From 0037734cfa069deb1ca20ae95b59b6a4d25dc714 Mon Sep 17 00:00:00 2001 From: James Cash Date: Sat, 23 Aug 2008 23:18:42 -0400 Subject: [PATCH 1/5] Reinstating failing test --- extra/lisp/lisp-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index 7458926799..e539221eaf 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -87,8 +87,8 @@ 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 ] with-interactive-vocabs From be4e6138610704cb08f73e7edd7612f13f7d5fc5 Mon Sep 17 00:00:00 2001 From: James Cash Date: Wed, 3 Sep 2008 10:21:27 -0400 Subject: [PATCH 2/5] Working on adding a " "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 diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 22bcd6905b..995e4004d5 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -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 ; @@ -147,3 +149,27 @@ 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 + + "define" "lisp" "defun" define-primitive + + "(lambda (&rest xs) xs)" lisp-string>factor "list" lisp-define + "(defmacro if (pred tr fl) (list (quote cond) (list pred tr) (list (quote #t) fl)))" lisp-eval + ; From 1faba13945c4b547f81a0ba1c4f085a79db3490a Mon Sep 17 00:00:00 2001 From: James Cash Date: Mon, 8 Sep 2008 23:28:16 -0400 Subject: [PATCH 3/5] Adding more tests to extra/lisp --- extra/lisp/lisp-tests.factor | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index 6c6396255a..20f6420056 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -64,4 +64,24 @@ IN: lisp.test "((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 From b24a7ee3c42e4ed9a6b46e54cc8fdeb3706157f1 Mon Sep 17 00:00:00 2001 From: James Cash Date: Mon, 8 Sep 2008 23:37:38 -0400 Subject: [PATCH 4/5] Fixing bugs in extra/lisp, adding --- extra/lisp/lisp.factor | 30 +++++++++++++++++++----------- 1 file changed, 19 insertions(+), 11 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 995e4004d5..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 ; @@ -121,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 ; @@ -135,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 ; @@ -150,7 +149,7 @@ 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 ( -- ) +: define-lisp-builtins ( -- ) init-env f "#f" lisp-define @@ -168,8 +167,17 @@ M: no-such-var summary drop "No such variable" ; "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 + "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 From c25abc5d00a7fa952c7c5875cb9efd592b713625 Mon Sep 17 00:00:00 2001 From: James Cash Date: Mon, 8 Sep 2008 23:37:55 -0400 Subject: [PATCH 5/5] Adding tests for --- extra/lisp/lisp-tests.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index 20f6420056..48f6419d30 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -76,12 +76,12 @@ IN: lisp.test "((lambda (&rest xs) xs) 1 2 3 4)" lisp-eval cons>seq ] unit-test -! { 10 } [ -! -! ] unit-test + { 10 } [ + + ] unit-test -! { 4 } [ -! -! ] unit-test + { 4 } [ + + ] unit-test ] with-interactive-vocabs