Implemented read-level portion of quasiquote forms.

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

diff --git a/scheme.4th b/scheme.4th
index 9b940e7..fc307d7 100644 (file)
--- a/scheme.4th
+++ b/scheme.4th
@@ -262,15 +262,18 @@ objvar symbol-table
     does> dup @ swap 1+ @
 ;
 
-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
+create-symbol quote             quote-symbol
+create-symbol quasiquote        quasiquote-symbol
+create-symbol unquote           unquote-symbol
+create-symbol unquote-splicing  unquote-splicing-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
 
 \ }}}
 
@@ -966,6 +969,21 @@ parse-idx-stack parse-idx-sp !
         quote-symbol recurse nil cons cons exit
     then
 
+    nextchar [char] ` = if
+        inc-parse-idx
+        quasiquote-symbol recurse nil cons cons exit
+    then
+
+    nextchar [char] , = if
+        inc-parse-idx
+        nextchar [char] @ = if
+            inc-parse-idx
+            unquote-splicing-symbol recurse nil cons cons exit
+        else
+            unquote-symbol recurse nil cons cons exit
+        then
+    then
+
     eof? if
         EOF character-type
         inc-parse-idx
@@ -1022,19 +1040,34 @@ parse-idx-stack parse-idx-sp !
 : make-lambda ( params body -- lambda-exp )
     lambda-symbol -2rot cons cons ;
 
-: definition-var ( obj -- var )
-    cdr car
-    symbol-type istype? false = if car then
+( Handles iterative expansion of defines in
+  terms of nested lambdas. Most Schemes only
+  handle one iteration of expansion! )
+: definition-var-val ( obj -- var val )
+
+    cdr 2dup cdr 2swap car ( val var )
+
+    begin
+        symbol-type istype? false =
+    while
+        2dup cdr 2swap car ( val formals var' )
+        -2rot 2swap ( var' formals val )
+        make-lambda nil cons ( var' val' )
+        2swap ( val' var' )
+    repeat
+
+    2swap car
 ;
 
-: definition-val ( obj -- val )
-    2dup cdr car symbol-type istype? if
-        2drop
-        cdr cdr car
-    else
-        cdr 2swap cdr cdr
-        make-lambda
-    then
+: eval-definition ( obj env -- res )
+    2dup 2rot ( env env obj )
+    definition-var-val ( env env var val )
+    2rot eval  ( env var val )
+
+    2rot ( var val env )
+    define-var
+
+    ok-symbol
 ;
 
 : assignment? ( obj -- obj bool )
@@ -1046,20 +1079,6 @@ parse-idx-stack parse-idx-sp !
 : assignment-val ( obj -- val )
     cdr cdr car ;
 
-: eval-definition ( obj env -- res )
-    2swap 
-    2over 2over ( env obj env obj )
-    definition-val 2swap ( env obj valexp env )
-    eval  ( env obj val )
-    
-    2swap definition-var 2swap ( env var val )
-
-    2rot ( var val env )
-    define-var
-
-    ok-symbol
-;
-    
 : eval-assignment ( obj env -- res )
     2swap 
     2over 2over ( env obj env obj )
@@ -1213,7 +1232,15 @@ hide env
 ( Ensure terminating symbol arg name is handled
   specially to allow for variadic procedures. )
 : flatten-proc-args ( argvals argnames -- argvals' argnames' )
-    nil? if exit then
+    nil? if
+        2over nil? false = if
+            bold fg red ." Too many arguments supplied to compound method. Aborting." reset-term cr
+            abort
+        else
+            2drop
+        then
+        exit
+    then
 
     symbol-type istype? if
         nil cons
@@ -1223,21 +1250,22 @@ hide env
         exit
     then
 
-    2over cdr 2over cdr
+    2over
+    nil? if
+        bold fg red ." Too few arguments supplied to compound method. Aborting." reset-term cr
+        abort
+    else
+        cdr
+    then
+
+    2over cdr
+
     recurse ( argvals argnames argvals'' argnames'' )
     2rot car 2swap cons  ( argvals argvals'' argnames' )
     2rot car 2rot cons ( argnames' argvals' )
     2swap
 ;
 
-:noname
-    \ Dummy apply procedure
-    \ Should never actually run!
-    ." Error: Dummy apply procedure executed!" cr
-; dup make-primitive apply
-objvar dummy-apply-proc
-primitive-proc-type dummy-apply-proc obj!
-
 : apply ( proc argvals -- result )
         2swap dup case
             primitive-proc-type of
@@ -1351,45 +1379,24 @@ primitive-proc-type dummy-apply-proc obj!
             ( env exp env opname mproc )
             2swap 2drop -2rot 2drop cdr ( env mproc body )
 
-            2dup print cr
             macro-expand
-            2dup print cr
 
             2swap
             ['] eval goto-deferred
-        then
-
-       \ Regular function application
-
-        2drop ( env exp env opname )
-
-        2swap eval ( env exp proc )
-
-        2dup dummy-apply-proc obj@ objeq? if
-            2drop ( env exp )
-            cdr 2over 2over car ( env expbody env real-opname )
-            2swap eval ( env expbody proc )
+        else
+           \ Regular function application
 
-            2swap cdr
-            nil? false = if car then ( env proc real-operand )
+            2drop ( env exp env opname )
 
-            2rot eval ( proc argvals )
+            2swap eval ( env exp proc )
 
-            pair-type istype? false = if
-                bold fg red ." Error: apply requires a list of operand arguments." cr
-                reset-term abort
-            then
+            -2rot ( proc env exp )
+            operands 2swap ( proc operands env )
+            list-of-vals ( proc argvals )
 
             apply
             exit
-        then 
-
-        -2rot ( proc env exp )
-        operands 2swap ( proc operands env )
-        list-of-vals ( proc argvals )
-
-        apply
-        exit
+        then
     then
 
     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr