Merged macro quasiquote into analyze.

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

diff --git a/src/scheme.4th b/src/scheme.4th
index 7a1a1dc..e5ac9cd 100644 (file)
--- a/src/scheme.4th
+++ b/src/scheme.4th
@@ -1315,95 +1315,6 @@ parse-idx-stack parse-idx-sp !
 : quote-body ( quote-obj -- quote-body-obj )
     cdr car ;
 
-: quasiquote? ( obj -- obj bool )
-    quasiquote-symbol tagged-list? ;
-
-: unquote? ( obj -- obj bool )
-    unquote-symbol tagged-list? ;
-
-: unquote-splicing? ( obj -- obj bool )
-    unquote-splicing-symbol tagged-list? ;
-
-: eval-unquote ( env obj -- res )
-    cdr ( env args )
-
-    nil? if
-        except-message: ." no arguments to unquote." recoverable-exception throw
-    then
-
-    2dup cdr
-    nil? false = if
-        except-message: ." too many arguments to unquote." recoverable-exception throw
-    then
-
-    2drop car 2swap eval
-;
-
-( Create a new list from elements of l1 consed on to l2 )
-: join-lists ( l2 l1 -- l3 )
-    nil? if 2drop exit then
-
-    2dup car
-    -2rot cdr
-    recurse cons
-;
-
-defer eval-quasiquote-item
-: eval-quasiquote-pair ( env obj -- res )
-    2over 2over ( env obj env obj )
-
-    cdr eval-quasiquote-item
-
-    -2rot car ( cdritem env objcar )
-
-    unquote-splicing? if
-        eval-unquote ( cdritems caritem )
-
-        2swap nil? if
-            2drop
-        else
-            2swap join-lists
-        then
-    else
-        eval-quasiquote-item ( cdritems caritem )
-        2swap cons
-    then
-
-;
-
-:noname ( env obj )
-    nil? if
-        2swap 2drop exit
-    then
-
-    unquote? if
-        eval-unquote exit
-    then
-
-    pair-type istype? if
-        eval-quasiquote-pair exit
-    then
-
-    2swap 2drop
-; is eval-quasiquote-item
-
-: eval-quasiquote ( obj env -- res )
-    2swap cdr ( env args )
-
-    nil? if
-        except-message: ." no arguments to quasiquote." recoverable-exception throw
-    then
-
-    2dup cdr ( env args args-cdr )
-    nil? false = if
-        except-message: ." too many arguments to quasiquote." recoverable-exception throw
-    then
-
-    2drop car ( env arg )
-
-    eval-quasiquote-item
-;
-
 : variable? ( obj -- obj bool )
     symbol-type istype? ;
 
@@ -1665,11 +1576,6 @@ hide env
         exit
     then
 
-    quasiquote? if
-        2swap eval-quasiquote
-        exit
-    then
-
     variable? if
         2swap lookup-var
         exit
@@ -1737,7 +1643,7 @@ hide env
 : evaluate-eproc ( eproc env --- res )
 
     >R >R
-    
+
     begin
         nil? invert
     while
@@ -1747,10 +1653,13 @@ hide env
     
     2drop \ get rid of null
 
-    R> R>
+    R> R> 2swap
 
     \ Final element of eproc list is primitive procedure
     drop \ dump type signifier
+
+    .s cr \ DEBUG
+
     goto \ jump straight to primitive procedure (executor)
 ;
 
@@ -1896,22 +1805,27 @@ hide env
 ;
 
 : evaluate-operand-eprocs ( env aprocs -- vals )
-    nil? invert if
-        2over 2over car evaluate-eproc ( env aprocs thisres )
-        -rot cdr recurse
+    nil? if
+        2swap 2drop
+    else
+        2over 2over car 2swap evaluate-eproc ( env aprocs thisval )
+        -2rot cdr recurse ( thisval restvals )
+        cons
+    then
 ;
 
 : application-executor ( operator-proc arg-procs env -- res )
     2rot 2over ( aprocs env fproc env )
     evaluate-eproc ( aprocs env proc )
-    2swap -2rot 2over 2swap ( proc env env aprocs )
-    evaluate-operand-eprocs ( proc env vals )
-    
-    2rot ( env vals proc )
+
+    -2rot 2swap ( proc env aprocs )
+    evaluate-operand-eprocs ( proc vals )
+
+    2swap ( vals proc )
     
     dup case
         primitive-proc-type of
-            2rot 2drop execute
+            drop execute
         endof
 
         compound-proc-type of
@@ -1936,7 +1850,7 @@ hide env
     2dup operator analyze
     2swap operands operand-eproc-list
 
-    ['] application-executor
+    ['] application-executor primitive-proc-type
     nil cons cons cons
 ;
 
@@ -1977,6 +1891,14 @@ hide env
         exit
     then
 
+    application? if
+        analyze-application
+        exit
+    then
+
+    
+    except-message: ." tried to analyze unknown expression type." recoverable-exception throw
+
 ; is analyze
 
 
@@ -2014,33 +1936,6 @@ hide env
     R> drop ['] expand goto-deferred
 ;
 
-: expand-quasiquote-item ( exp -- result )
-    nil? if exit then
-
-    unquote? if
-        unquote-symbol 2swap cdr car expand nil cons cons
-        exit
-    then
-
-    unquote-splicing? if
-        unquote-splicing-symbol 2swap cdr car expand nil cons cons
-        exit
-    then
-    
-    pair-type istype? if
-        2dup car recurse
-        2swap cdr recurse
-        cons
-    then
-;
-
-: expand-quasiquote ( exp -- result )
-    quasiquote-symbol 2swap cdr
-
-    expand-quasiquote-item
-
-    cons ;
-
 : expand-definition ( exp -- result )
     define-symbol 2swap
 
@@ -2110,8 +2005,6 @@ hide env
 
     quote? if exit then
 
-    quasiquote? if expand-quasiquote exit then
-
     definition? if expand-definition exit then
 
     assignment? if expand-assignment exit then