diff --git a/extra/advice/advice-docs.factor b/extra/advice/advice-docs.factor new file mode 100644 index 0000000000..2b33378b99 --- /dev/null +++ b/extra/advice/advice-docs.factor @@ -0,0 +1,22 @@ +IN: advice +USING: help.markup help.syntax tools.annotations words ; + +HELP: make-advised +{ $values { "word" "a word to annotate in preparation of advising" } } +{ $description "Prepares a word for being advised. This is done by: " + { $list + { "Annotating it to call the appropriate words before, around, and after the original body " } + { "Adding " { $snippet "before" } ", " { $snippet "around" } ", and " { $snippet "after" } " properties, which will contain the advice" } + { "Adding an " { $snippet "advised" } "property, which can later be used to determine if a given word is defined (see " { $link advised? } ")" } + } +} +{ $see-also advised? annotate } ; + +HELP: advised? +{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet word } " is advised" } } +{ $description "Determines whether or not the given word has any advice on it." } ; + +ARTICLE: "advice" "Advice" +"Advice is a simple way of adding additition functionality to words by adding 'hooks' to a word, which can act before, after, or around the calling of the word." ; + +ABOUT: "advice" \ No newline at end of file diff --git a/extra/advice/advice-tests.factor b/extra/advice/advice-tests.factor new file mode 100644 index 0000000000..17b60c8fb1 --- /dev/null +++ b/extra/advice/advice-tests.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2008 James Cash +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences math tools.test advice parser namespaces ; +IN: advice.tests + +[ +: foo "foo" ; +\ foo make-advised + + { "bar" "foo" } [ + [ "bar" ] "barify" \ foo advise-before + foo ] unit-test + + { "bar" "foo" "baz" } [ + [ "baz" ] "bazify" \ foo advise-after + foo ] unit-test + + { "foo" "baz" } [ + "barify" \ foo before remove-advice + foo ] unit-test + +: bar ( a -- b ) 1+ ; +\ bar make-advised + + { 11 } [ + [ 2 * ] "double" \ bar advise-before + 5 bar + ] unit-test + + { 11/3 } [ + [ 3 / ] "third" \ bar advise-after + 5 bar + ] unit-test + + { -2 } [ + [ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around + 5 bar + ] unit-test + + ] with-scope \ No newline at end of file diff --git a/extra/advice/advice.factor b/extra/advice/advice.factor new file mode 100644 index 0000000000..6a7d46f935 --- /dev/null +++ b/extra/advice/advice.factor @@ -0,0 +1,49 @@ +! Copyright (C) 2008 James Cash +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences symbols fry words assocs tools.annotations coroutines ; +IN: advice + +SYMBOLS: before after around advised ; + + + +: advise-before ( quot name word -- ) + before advise ; + +: advise-after ( quot name word -- ) + after advise ; + +: advise-around ( quot name word -- ) + [ \ coterminate suffix ] 2dip + around advise ; + +: get-advice ( word type -- seq ) + word-prop values ; + +: call-before ( word -- ) + before get-advice [ call ] each ; + +: call-after ( word -- ) + after get-advice [ call ] each ; + +: call-around ( main word -- ) + around get-advice [ cocreate ] map tuck + [ [ coresume ] each ] [ call ] [ reverse [ coresume ] each ] tri* ; + +: remove-advice ( name word loc -- ) + word-prop delete-at ; + +: ad-do-it ( input -- result ) + coyield ; + +: advised? ( word -- ? ) + advised word-prop ; + +: make-advised ( word -- ) + [ dup [ over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ] + [ { before after around } [ H{ } clone swap set-word-prop ] with each ] + [ t advised set-word-prop ] tri ; + \ No newline at end of file diff --git a/extra/advice/authors.txt b/extra/advice/authors.txt new file mode 100644 index 0000000000..4b7af4aac0 --- /dev/null +++ b/extra/advice/authors.txt @@ -0,0 +1 @@ +James Cash diff --git a/extra/advice/summary.txt b/extra/advice/summary.txt new file mode 100644 index 0000000000..a6f9c06526 --- /dev/null +++ b/extra/advice/summary.txt @@ -0,0 +1 @@ +Implmentation of advice/aspects diff --git a/extra/advice/tags.txt b/extra/advice/tags.txt new file mode 100644 index 0000000000..a87b65d938 --- /dev/null +++ b/extra/advice/tags.txt @@ -0,0 +1,3 @@ +advice +aspect +annotations diff --git a/extra/lisp/lisp-docs.factor b/extra/lisp/lisp-docs.factor index 149f22864e..c970a1e0b7 100644 --- a/extra/lisp/lisp-docs.factor +++ b/extra/lisp/lisp-docs.factor @@ -1,5 +1,12 @@ IN: lisp USING: help.markup help.syntax ; +HELP: into factor quotations and calls it" } +{ $see-also lisp-string>factor } ; + +HELP: lisp-string>factor +{ $values { "str" "a string of lisp code" } { "quot" "the quotation the lisp compiles into" } } +{ $description "Turns a string of lisp into a factor quotation" } ; ARTICLE: "lisp" "Lisp in Factor" "This is a simple implementation of a Lisp dialect, which somewhat resembles Scheme." $nl diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index 48f6419d30..5f849c4416 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -84,4 +84,11 @@ IN: lisp.test ] unit-test + { { 3 3 4 } } [ + cons>seq + ] unit-test + ] with-interactive-vocabs diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index e60529caab..4a933501e8 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -64,14 +64,9 @@ PRIVATE> : macro-expand ( cons -- quot ) uncons [ list>seq >quotation ] [ lookup-macro ] bi* call call ; - - : expand-macros ( cons -- cons ) - dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ; - + dup list? [ [ expand-macros ] lmap dup car lisp-macro? [ macro-expand expand-macros ] when ] when ; + : convert-begin ( cons -- quot ) cdr [ convert-form ] [ ] lmap-as [ 1 tail* ] [ but-last ] bi [ '[ { } _ with-datastack drop ] ] map prepend '[ _ [ call ] each ] ; @@ -169,15 +164,15 @@ M: no-such-var summary drop "No such variable" ; "set" "lisp" "define-lisp-var" define-primitive - "(lambda (&rest xs) xs)" lisp-string>factor first "list" lisp-define - "(defmacro setq (var val) (list (quote set) (list (quote quote) var) val))" lisp-eval + "(set 'list (lambda (&rest xs) xs))" lisp-eval + "(defmacro setq (var val) (list 'set (list 'quote var) val))" lisp-eval <" (defmacro defun (name vars &rest body) - (list (quote setq) name (list (quote lambda) vars body))) "> lisp-eval + (list 'setq name (cons 'lambda (cons vars body)))) "> lisp-eval - "(defmacro if (pred tr fl) (list (quote cond) (list pred tr) (list (quote #t) fl)))" lisp-eval + "(defmacro if (pred tr fl) (list 'cond (list pred tr) (list (quote #t) fl)))" lisp-eval ; : " parse-multiline-string define-lisp-builtins - lisp-string>factor parsed \ call parsed ; parsing + "LISP>" parse-multiline-string "(begin " prepend ")" append define-lisp-builtins + lisp-string>factor parsed \ call parsed ; parsing \ No newline at end of file diff --git a/extra/lisp/parser/parser-tests.factor b/extra/lisp/parser/parser-tests.factor index d722390f9a..911a8d3440 100644 --- a/extra/lisp/parser/parser-tests.factor +++ b/extra/lisp/parser/parser-tests.factor @@ -65,4 +65,16 @@ IN: lisp.parser.tests } } [ "(1 (3 4) 2)" lisp-expr +] unit-test + +{ { T{ lisp-symbol { name "quote" } } { 1 2 3 } } } [ + "'(1 2 3)" lisp-expr cons>seq +] unit-test + +{ { T{ lisp-symbol f "quote" } T{ lisp-symbol f "foo" } } } [ + "'foo" lisp-expr cons>seq +] unit-test + +{ { 1 2 { T{ lisp-symbol { name "quote" } } { 3 4 } } 5 } } [ + "(1 2 '(3 4) 5)" lisp-expr cons>seq ] unit-test \ No newline at end of file diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor index 72344fd0dc..50f58692d5 100644 --- a/extra/lisp/parser/parser.factor +++ b/extra/lisp/parser/parser.factor @@ -35,5 +35,7 @@ atom = number | identifier | string s-expression = LPAREN (list-item)* RPAREN => [[ second seq>cons ]] -list-item = _ ( atom | s-expression ) _ => [[ second ]] -;EBNF +list-item = _ ( atom | s-expression | quoted ) _ => [[ second ]] +quoted = squote list-item => [[ second nil cons "quote" swap cons ]] +expr = list-item +;EBNF \ No newline at end of file diff --git a/work/README.txt b/work/README.txt deleted file mode 100644 index fd1af07408..0000000000 --- a/work/README.txt +++ /dev/null @@ -1 +0,0 @@ -The 'work' directory is for your own personal vocabularies.