Merge git://factorcode.org/git/jamesnvc into new_lisp

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 } [
+    { 3 } [
-!         "((lambda (x) (if x (+ 1 2) (- 3 5))) #t)" lisp-eval
+        "((lambda (x) (if x (+ 1 2) (- 3 5))) #t)" lisp-eval
-!     ] unit-test
+    ] 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 } [
+        <LISP (begin (+ 1 2) (+ 9 1)) LISP>
+    ] unit-test
+    
+    { 4 } [
+        <LISP ((lambda (x y) (if x (+ 1 y) (+ 2 y))) #t 3) LISP>
+    ] unit-test
     
 ] with-interactive-vocabs

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> 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> lambda-rewrite '[ @ compose call call ] 1quotation ;
@@ -59,13 +59,15 @@ 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 ;
 
+<PRIVATE
 : (expand-macros) ( cons -- cons )
     [ dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ] lmap ;
+PRIVATE>
 
 : expand-macros ( cons -- cons )
     dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ;
@@ -120,8 +122,8 @@ M: no-such-var summary drop "No such variable" ;
 : lisp-define ( quot name -- )
     lisp-env get set-at ;
     
-: defun ( name quot -- name )
+: define-lisp-var ( lisp-symbol body --  )
-    over name>> lisp-define ;
+    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
+    [ 1array [ call ] with-datastack >quotation ] dip curry call ; inline
-    dup lisp-symbol? [ lookup-var ] when 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
+   ;
+
+: <LISP 
+    "LISP>" parse-multiline-string define-lisp-builtins
+    lisp-string>factor parsed \ call parsed ; parsing