Finished draft macro implementation

[scheme.forth.jl.git] / scheme.4th

diff --git a/scheme.4th b/scheme.4th
index 136c8a8..12c07d2 100644 (file)
--- a/scheme.4th
+++ b/scheme.4th
@@ -37,7 +37,7 @@ make-type fileport-type
 : istype? ( obj type -- obj bool )
     over = ;
 
-\ ------ List-structured memory ------ {{{
+\ ---- List-structured memory ---- {{{
 
 10000 constant scheme-memsize
 
@@ -268,14 +268,15 @@ objvar symbol-table
     does> dup @ swap 1+ @
 ;
 
-create-symbol quote     quote-symbol
-create-symbol define    define-symbol
-create-symbol set!      set!-symbol
-create-symbol ok        ok-symbol
-create-symbol if        if-symbol
-create-symbol lambda    lambda-symbol
-create-symbol λ         λ-symbol
-create-symbol begin     begin-symbol
+create-symbol quote         quote-symbol
+create-symbol define        define-symbol
+create-symbol define-macro  define-macro-symbol
+create-symbol set!          set!-symbol
+create-symbol ok            ok-symbol
+create-symbol if            if-symbol
+create-symbol lambda        lambda-symbol
+create-symbol λ             λ-symbol
+create-symbol begin         begin-symbol
 
 \ }}}
 
@@ -391,12 +392,67 @@ objvar env
 
 hide env
 
+: make-procedure ( params body env -- proc )
+    nil
+    cons cons cons
+    drop compound-proc-type
+;
+
 objvar global-env
 nil nil nil extend-env
 global-env obj!
 
 \ }}}
 
+\ ---- Macros ---- {{{
+
+objvar macro-table
+
+( Look up macro in macro table. Returns nil if
+  no macro is found. )
+: lookup-macro ( name_symbol -- proc )
+    macro-table obj@
+
+    begin
+        nil? false =
+    while
+        2over 2over
+        car car objeq? if
+            2swap 2drop
+            car cdr
+            exit
+        then
+    repeat
+;
+
+: make-macro ( name_symbol params body env -- )
+    make-procedure
+
+    2swap ( proc name_symbol )
+
+    macro-table obj@
+
+    begin
+        nil? false =
+    while
+        2over 2over ( proc name table name table )
+        car car objeq? if
+            2swap 2drop ( proc table )
+            car ( proc entry )
+            set-cdr!
+            exit
+        then
+    repeat
+
+    2drop
+
+    2swap cons
+    macro-table obj@ cons
+    macro-table obj!
+;
+
+\ }}}
+
 \ ---- Read ---- {{{
 
 variable parse-idx
@@ -970,6 +1026,34 @@ parse-idx-stack parse-idx-sp !
     ok-symbol
 ;
 
+: macro-definition? ( obj -- obj bool )
+    define-macro-symbol tagged-list? ;
+
+: macro-definition-name ( exp -- mname )
+    cdr car car ;
+
+: macro-definition-params ( exp -- params )
+    cdr car cdr ;
+
+: macro-definition-body ( exp -- body )
+    cdr cdr ;
+
+objvar env
+: eval-define-macro ( obj env -- res )
+    env obj!
+
+    2dup macro-definition-name 2swap ( name obj )
+    2dup macro-definition-params 2swap ( name params obj )
+    macro-definition-body ( name params body )
+
+    env obj@ ( name params body env )
+
+    make-macro
+
+    ok-symbol
+;
+hide env
+
 : if? ( obj -- obj bool )
     if-symbol tagged-list? ;
 
@@ -1007,12 +1091,6 @@ parse-idx-stack parse-idx-sp !
 : lambda-body ( obj -- body )
     cdr cdr ;
 
-: make-procedure ( params body env -- proc )
-    nil
-    cons cons cons
-    drop compound-proc-type
-;
-
 : begin? ( obj -- obj bool )
     begin-symbol tagged-list? ;
 
@@ -1045,7 +1123,7 @@ parse-idx-stack parse-idx-sp !
     2drop car 2swap ( finalexp env )
 ;
 
-: application? ( obj -- obj bool)
+: application? ( obj -- obj bool )
     pair-type istype? ;
 
 : operator ( obj -- operator )
@@ -1084,16 +1162,40 @@ parse-idx-stack parse-idx-sp !
 : procedure-env ( proc -- body )
     drop pair-type cdr cdr car ;
 
-: apply ( proc args )
+( Ensure terminating symbol arg name is handled
+  specially to allow for variadic procedures. )
+: flatten-proc-args ( argvals argnames -- argvals' argnames' )
+    nil? if exit then
+
+    symbol-type istype? if
+        nil cons
+        2swap
+        nil cons
+        2swap
+        exit
+    then
+
+    2over cdr 2over cdr
+    recurse ( argvals argnames argvals'' argnames'' )
+    2rot car 2swap cons  ( argvals argvals'' argnames' )
+    2rot car 2rot cons ( argnames' argvals' )
+    2swap
+;
+
+: apply ( proc argvals )
         2swap dup case
             primitive-proc-type of
                 drop execute
             endof
 
             compound-proc-type of
-                2dup procedure-body ( args proc body )
-                -2rot 2dup procedure-params ( body args proc params )
-                -2rot procedure-env ( body params args procenv )
+                2dup procedure-body ( argvals proc body )
+                -2rot 2dup procedure-params ( body argvals proc argnames )
+                -2rot procedure-env ( body argnames argvals procenv )
+
+                -2rot 2swap
+                flatten-proc-args
+                2swap 2rot
 
                 extend-env ( body env )
 
@@ -1136,6 +1238,11 @@ parse-idx-stack parse-idx-sp !
         exit
     then
 
+    macro-definition? if
+        2swap eval-define-macro
+        exit
+    then
+
     if? if
         2over 2over
         if-predicate
@@ -1165,12 +1272,30 @@ parse-idx-stack parse-idx-sp !
     then
 
     application? if
-        2over 2over
-        operator 2swap eval
-        -2rot
-        operands 2swap list-of-vals
 
-        apply
+        2over 2over ( env exp env exp )
+        operator 2dup ( env exp env opname opname )
+
+        lookup-macro 2dup nil objeq? if
+            \ Regular function application
+
+            2drop ( env exp env opname )
+
+            2swap eval ( env exp proc )
+            -2rot ( proc env exp )
+            operands 2swap ( proc operands env )
+            list-of-vals ( proc argvals )
+
+            apply
+        else
+            \ Macro function evaluation
+
+            ( env exp env opname mproc )
+            2swap 2drop -2rot 2drop  ( env mproc exp )
+            apply 2swap ( expanded-exp env )
+
+            ['] eval goto-deferred
+        then
         exit
     then
 
@@ -1357,6 +1482,7 @@ variable gc-stack-depth
     gc-unmark
 
     symbol-table obj@ gc-mark-obj
+    macro-table obj@ gc-mark-obj
     global-env obj@ gc-mark-obj
 
     depth gc-stack-depth @ do