X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=scheme.4th;h=5a049d4fe930fcff80ebd21f404f5be70dea251d;hb=35821ce20b4614368e7983ccc1132a74e5f9eacb;hp=7c1a31606045a96f092d71327a86c91ddea1e440;hpb=167e0b9dcc4de39b9479abcfcc80cc039023e1a7;p=scheme.forth.jl.git

diff --git a/scheme.4th b/scheme.4th
index 7c1a316..5a049d4 100644
--- a/scheme.4th
+++ b/scheme.4th
@@ -28,6 +28,7 @@ make-type boolean-type
 make-type character-type
 make-type string-type
 make-type nil-type
+make-type none-type
 make-type pair-type
 make-type symbol-type
 make-type primitive-proc-type
@@ -36,7 +37,7 @@ make-type fileport-type
 : istype? ( obj type -- obj bool )
     over = ;
 
-\ ------ List-structured memory ------ {{{
+\ ---- List-structured memory ---- {{{
 
 10000 constant scheme-memsize
 
@@ -112,6 +113,9 @@ variable nextfree
 : nil 0 nil-type ;
 : nil? nil-type istype? ;
 
+: none 0 none-type ;
+: none? none-type istype? ;
+
 : objvar create nil swap , , ;
 
 : value@ ( objvar -- val ) @ ;
@@ -264,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
 
 \ }}}
 
@@ -886,6 +891,7 @@ parse-idx-stack parse-idx-sp !
     character-type istype? if true exit then
     string-type istype? if true exit then
     nil-type istype? if true exit then
+    none-type istype? if true exit then
 
     false
 ;
@@ -965,6 +971,9 @@ parse-idx-stack parse-idx-sp !
     ok-symbol
 ;
 
+: macro-definition? ( obj -- obj bool )
+    define-macro-symbol tagged-list? ;
+
 : if? ( obj -- obj bool )
     if-symbol tagged-list? ;
 
@@ -1022,7 +1031,10 @@ parse-idx-stack parse-idx-sp !
     2swap ( env explist )
 
     \ Abort on empty list
-    2dup nil objeq? if 2swap exit then
+    2dup nil objeq? if
+        2drop none
+        2swap exit
+    then
 
     begin
         2dup cdr ( env explist nextexplist )
@@ -1037,7 +1049,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 )
@@ -1076,16 +1088,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 )
 
@@ -1128,6 +1164,11 @@ parse-idx-stack parse-idx-sp !
         exit
     then
 
+    macro-definition? if
+        2swap eval-define-macro
+        exit
+    then
+
     if? if
         2over 2over
         if-predicate
@@ -1151,16 +1192,33 @@ parse-idx-stack parse-idx-sp !
     then
 
     begin? if
-        \ TODO
+        begin-actions 2swap
+        eval-sequence
+        ['] eval goto-deferred
     then
 
     application? if
+
         2over 2over
-        operator 2swap eval
-        -2rot
-        operands 2swap list-of-vals
+        operator
+
+        find-macro-proc nil objeq? if
+            \ Regular function application
+
+            2swap eval
+            -2rot
+            operands 2swap list-of-vals
 
-        apply
+            apply
+        else
+            \ Macro function evaluation
+
+            2swap 2drop 2swap ( env mproc exp )
+
+            apply 2swap ( expanded-exp env )
+
+            ['] eval goto-deferred
+        then
         exit
     then
 
@@ -1238,6 +1296,9 @@ parse-idx-stack parse-idx-sp !
 : printcomp ( primobj -- )
     2drop ." <compound procedure>" ;
 
+: printnone ( noneobj -- )
+    2drop ." Unspecified return value" ;
+
 :noname ( obj -- )
     fixnum-type istype? if printfixnum exit then
     realnum-type istype? if printrealnum exit then
@@ -1249,6 +1310,7 @@ parse-idx-stack parse-idx-sp !
     pair-type istype? if ." (" printpair ." )" exit then
     primitive-proc-type istype? if printprim exit then
     compound-proc-type istype? if printcomp exit then
+    none-type istype? if printnone exit then
 
     bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
     abort