diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index 7458926799..48f6419d30 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -5,29 +5,6 @@ quotations ; IN: lisp.test -: define-lisp-builtins ( -- ) - init-env - - f "#f" lisp-define - t "#t" lisp-define - - "+" "math" "+" define-primitive - "-" "math" "-" define-primitive - "<" "math" "<" define-primitive - ">" "math" ">" define-primitive - - "cons" "lists" "cons" define-primitive - "car" "lists" "car" define-primitive - "cdr" "lists" "cdr" define-primitive - "append" "lists" "lappend" define-primitive - "nil" "lists" "nil" define-primitive - "nil?" "lists" "nil?" define-primitive - - "define" "lisp" "defun" define-primitive - - "(lambda (&rest xs) xs)" lisp-string>factor "list" lisp-define - ; - [ define-lisp-builtins @@ -75,10 +52,6 @@ IN: lisp.test "(begin (+ 5 6) (+ 1 4))" lisp-eval ] unit-test - { T{ lisp-symbol f "if" } } [ - "(defmacro if (pred tr fl) (list (quote cond) (list pred tr) (list (quote #t) fl)))" lisp-eval - ] unit-test - { t } [ T{ lisp-symbol f "if" } lisp-macro? ] unit-test @@ -87,8 +60,28 @@ IN: lisp.test "(if #t 1 2)" lisp-eval ] unit-test -! { 3 } [ -! "((lambda (x) (if x (+ 1 2) (- 3 5))) #t)" lisp-eval -! ] unit-test + { 3 } [ + "((lambda (x) (if x (+ 1 2) (- 3 5))) #t)" lisp-eval + ] unit-test + + { { 5 4 3 } } [ + "((lambda (x &rest xs) (cons x xs)) 5 4 3)" lisp-eval cons>seq + ] unit-test + + { { 5 } } [ + "((lambda (x &rest xs) (cons x xs)) 5)" lisp-eval cons>seq + ] unit-test + + { { 1 2 3 4 } } [ + "((lambda (&rest xs) xs) 1 2 3 4)" lisp-eval cons>seq + ] unit-test + + { 10 } [ + + ] unit-test + + { 4 } [ + + ] unit-test ] with-interactive-vocabs diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 22bcd6905b..e004af8655 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -3,7 +3,7 @@ USING: kernel peg sequences arrays strings combinators.lib namespaces combinators math locals locals.private locals.backend accessors vectors syntax lisp.parser assocs parser sequences.lib words -quotations fry lists summary combinators.short-circuit continuations ; +quotations fry lists summary combinators.short-circuit continuations multiline ; IN: lisp DEFER: convert-form @@ -46,7 +46,7 @@ DEFER: define-lisp-macro : rest-lambda ( body vars -- quot ) "&rest" swap [ remove ] [ index ] 2bi [ localize-lambda lambda-rewrite call ] dip - swap '[ , cut '[ @ , seq>list ] call , call call ] ; + swap '[ , cut '[ @ , seq>list ] call , call call ] 1quotation ; : normal-lambda ( body vars -- quot ) localize-lambda lambda-rewrite '[ @ compose call call ] 1quotation ; @@ -59,18 +59,20 @@ PRIVATE> cadr 1quotation ; : convert-defmacro ( cons -- quot ) - cdr [ car ] keep [ convert-lambda ] [ car name>> ] bi define-lisp-macro 1quotation ; + cdr [ convert-lambda ] [ car name>> ] bi define-lisp-macro [ ] ; : macro-expand ( cons -- quot ) uncons [ list>seq >quotation ] [ lookup-macro ] bi* call call ; - -: (expand-macros) ( cons -- cons ) + + + +: expand-macros ( cons -- cons ) dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ; - -: convert-begin ( cons -- quot ) + +: convert-begin ( cons -- quot ) cdr [ convert-form ] [ ] lmap-as [ 1 tail* ] [ but-last ] bi [ '[ { } , with-datastack drop ] ] map prepend '[ , [ call ] each ] ; @@ -86,7 +88,7 @@ PRIVATE> : convert-list-form ( cons -- quot ) dup car - { + { { [ dup lisp-symbol? ] [ form-dispatch ] } [ drop convert-general-form ] } cond ; @@ -119,9 +121,9 @@ M: no-such-var summary drop "No such variable" ; : lisp-define ( quot name -- ) lisp-env get set-at ; - -: defun ( name quot -- name ) - over name>> lisp-define ; + +: define-lisp-var ( lisp-symbol body -- ) + swap name>> lisp-define ; : lisp-get ( name -- word ) lisp-env get at ; @@ -133,8 +135,7 @@ M: no-such-var summary drop "No such variable" ; dup lisp-symbol? [ name>> lisp-env get key? ] [ drop f ] if ; : funcall ( quot sym -- * ) - [ 1array [ call ] with-datastack >quotation ] dip - dup lisp-symbol? [ lookup-var ] when curry call ; inline + [ 1array [ call ] with-datastack >quotation ] dip curry call ; inline : define-primitive ( name vocab word -- ) swap lookup 1quotation '[ , compose call ] swap lisp-define ; @@ -147,3 +148,36 @@ M: no-such-var summary drop "No such variable" ; : lisp-macro? ( car -- ? ) dup lisp-symbol? [ name>> macro-env get key? ] [ drop f ] if ; + +: define-lisp-builtins ( -- ) + init-env + + f "#f" lisp-define + t "#t" lisp-define + + "+" "math" "+" define-primitive + "-" "math" "-" define-primitive + "<" "math" "<" define-primitive + ">" "math" ">" define-primitive + + "cons" "lists" "cons" define-primitive + "car" "lists" "car" define-primitive + "cdr" "lists" "cdr" define-primitive + "append" "lists" "lappend" define-primitive + "nil" "lists" "nil" define-primitive + "nil?" "lists" "nil?" define-primitive + + "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 + + <" (defmacro defun (name vars &rest body) + (list (quote setq) name (list (quote lambda) vars body))) "> lisp-eval + + "(defmacro if (pred tr fl) (list (quote cond) (list pred tr) (list (quote #t) fl)))" lisp-eval + ; + +: " parse-multiline-string define-lisp-builtins + lisp-string>factor parsed \ call parsed ; parsing \ No newline at end of file