Macros almost working

extra/lisp/lisp.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel peg sequences arrays strings combinators.lib
 namespaces combinators math locals locals.private accessors
-vectors syntax lisp.parser assocs parser sequences.lib words quotations
-fry lists inspector ;
+vectors syntax lisp.parser assocs parser sequences.lib words
+quotations fry lists inspector ;
 IN: lisp
 
 DEFER: convert-form
@@ -11,15 +11,13 @@ DEFER: funcall
 DEFER: lookup-var
 DEFER: lisp-macro?
 DEFER: lookup-macro
-DEFER: macro-call
-
+DEFER: macro-expand
+DEFER: define-lisp-macro
+    
 ! Functions to convert s-exps to quotations
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 : convert-body ( cons -- quot )
     [ ] [ convert-form compose ] foldl ; inline
-  
-: convert-if ( cons -- quot )
-    cdr 3car [ convert-form ] tri@ '[ @ , , if ] ;
     
 : convert-begin ( cons -- quot )  
     cdr [ convert-form ] [ ] lmap-as '[ , [ funcall ] each ] ;
@@ -34,13 +32,11 @@ DEFER: macro-call
 ! words for convert-lambda  
 <PRIVATE  
 : localize-body ( assoc body -- assoc newbody )  
-    dupd [ dup lisp-symbol? [ tuck name>> swap at swap or ]
-                           [ dup cons? [ localize-body ] when nip ] if
-    ] with lmap>array ;
-    
+    [ lisp-symbol? ] pick '[ [ name>> , at ] [ ] bi or ] traverse ;
+
 : localize-lambda ( body vars -- newbody newvars )
     make-locals dup push-locals swap
-    [ swap localize-body seq>cons convert-form swap pop-locals ] dip swap ;
+    [ swap localize-body convert-form swap pop-locals ] dip swap ;
                    
 : split-lambda ( cons -- body-cons vars-seq )                   
     3car -rot nip [ name>> ] lmap>array ; inline
@@ -67,24 +63,24 @@ PRIVATE>
     [ { [ dup list? ] [ car dup lisp-symbol? ] [ name>> "unquote" equal? dup ] } && nip ]
     [ cadr ] traverse ;
     
-: form-dispatch ( lisp-symbol -- quot )
+: convert-defmacro ( cons -- quot )
+    cdr [ car ] keep [ convert-lambda ] [ car name>> ] bi define-lisp-macro 1quotation ;
+    
+: form-dispatch ( cons lisp-symbol -- quot )
     name>>
     { { "lambda" [ convert-lambda ] }
+      { "defmacro" [ convert-defmacro ] }
       { "quote" [ convert-quoted ] }
       { "unquote" [ convert-unquoted ] }
       { "quasiquote" [ convert-quasiquoted ] }
-      { "if" [ convert-if ] }
       { "begin" [ convert-begin ] }
       { "cond" [ convert-cond ] }
      [ drop convert-general-form ]
     } case ;
     
-: macro-expand ( cons -- quot )
-    uncons lookup-macro macro-call convert-form ;
-    
 : convert-list-form ( cons -- quot )  
     dup car
-    { { [ dup lisp-macro?  ] [ macro-expand ] }
+    { { [ dup lisp-macro?  ] [ drop macro-expand ] }
       { [ dup lisp-symbol? ] [ form-dispatch ] } 
      [ drop convert-general-form ]
     } cond ;
@@ -96,8 +92,17 @@ PRIVATE>
      [ 1quotation ]
     } cond ;
     
+: compile-form ( lisp-ast -- quot )
+    convert-form lambda-rewrite call ; inline
+    
+: macro-call ( lambda -- cons )
+    call ;
+    
+: macro-expand ( cons -- quot )
+    uncons lookup-macro macro-call compile-form ;
+    
 : lisp-string>factor ( str -- quot )
-    lisp-expr parse-result-ast convert-form lambda-rewrite call ;
+    lisp-expr parse-result-ast compile-form ;
     
 : lisp-eval ( str -- * )    
   lisp-string>factor call ;
@@ -105,7 +110,7 @@ PRIVATE>
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 SYMBOL: lisp-env
-ERROR: no-such-var var ;
+ERROR: no-such-var variable-name ;
     
 SYMBOL: macro-env
     
@@ -115,8 +120,8 @@ M: no-such-var summary drop "No such variable" ;
     H{ } clone lisp-env set
     H{ } clone macro-env set ;
 
-: lisp-define ( name quot -- )
-    swap lisp-env get set-at ;
+: lisp-define ( quot name -- )
+    lisp-env get set-at ;
     
 : lisp-get ( name -- word )
     dup lisp-env get at [ ] [ no-such-var ] ?if ;
@@ -128,10 +133,13 @@ M: no-such-var summary drop "No such variable" ;
     dup lisp-symbol?  [ lookup-var ] when call ; inline
     
 : define-primitive ( name vocab word -- )  
-    swap lookup 1quotation '[ , compose call ] lisp-define ;
+    swap lookup 1quotation '[ , compose call ] swap lisp-define ;
     
-: lookup-macro ( lisp-symbol -- macro )
+: lookup-macro ( lisp-symbol -- lambda )
     name>> macro-env get at ;
     
+: define-lisp-macro ( quot name -- )
+    macro-env get set-at ;
+    
 : lisp-macro? ( car -- ? )
     dup lisp-symbol? [ name>> macro-env get key? ] [ drop f ] if ;