Added testing code back in.

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

diff --git a/scheme.4th b/scheme.4th
index 12c07d2..f96fec9 100644 (file)
--- a/scheme.4th
+++ b/scheme.4th
@@ -180,7 +180,7 @@ console-i/o-port obj@ current-input-port obj!
 objvar symbol-table
 
 : duplicate-charlist ( charlist -- copy )
-    2dup nil objeq? false = if
+    nil? false = if
         2dup car 2swap cdr recurse cons
     then ;
 
@@ -336,7 +336,7 @@ objvar vals
 : get-vars-vals ( var env -- vars? vals? bool )
 
     begin
-        2dup nil objeq? false =
+        nil? false =
     while
         2over 2over first-frame
         get-vars-vals-frame if
@@ -422,7 +422,11 @@ objvar macro-table
             car cdr
             exit
         then
+
+        cdr
     repeat
+
+    2swap 2drop
 ;
 
 : make-macro ( name_symbol params body env -- )
@@ -442,6 +446,8 @@ objvar macro-table
             set-cdr!
             exit
         then
+
+        cdr
     repeat
 
     2drop
@@ -1065,7 +1071,7 @@ hide env
 
 : if-alternative ( ifobj -- alt|false )
     cdr cdr cdr
-    2dup nil objeq? if
+    nil? if
         2drop false
     else
         car
@@ -1105,14 +1111,14 @@ hide env
     2swap ( env explist )
 
     \ Abort on empty list
-    2dup nil objeq? if
+    nil? if
         2drop none
         2swap exit
     then
 
     begin
         2dup cdr ( env explist nextexplist )
-        2dup nil objeq? false =
+        nil? false =
     while
         -2rot car 2over ( nextexplist env exp env )
         eval
@@ -1182,7 +1188,7 @@ hide env
     2swap
 ;
 
-: apply ( proc argvals )
+: apply ( proc argvals -- result )
         2swap dup case
             primitive-proc-type of
                 drop execute
@@ -1204,11 +1210,24 @@ hide env
                 R> drop ['] eval goto-deferred  \ Tail call optimization
             endof
 
-            bold fg red ." Object not applicable. Aboring." reset-term cr
+            bold fg red ." Object not applicable. Aborting." reset-term cr
             abort
         endcase
 ;
 
+: macro-expand ( proc expbody -- result )
+    2swap
+    2dup procedure-body ( expbody proc procbody )
+    -2rot 2dup procedure-params ( procbody expbody proc argnames )
+    -2rot procedure-env ( procbody argnames expbody procenv )
+    
+    -2rot 2swap
+    flatten-proc-args
+    2swap 2rot
+
+    extend-env eval-sequence eval
+;
+
 :noname ( obj env -- result )
     2swap
 
@@ -1276,7 +1295,7 @@ hide env
         2over 2over ( env exp env exp )
         operator 2dup ( env exp env opname opname )
 
-        lookup-macro 2dup nil objeq? if
+        lookup-macro nil? if
             \ Regular function application
 
             2drop ( env exp env opname )
@@ -1291,9 +1310,13 @@ hide env
             \ Macro function evaluation
 
             ( env exp env opname mproc )
-            2swap 2drop -2rot 2drop  ( env mproc exp )
-            apply 2swap ( expanded-exp env )
+            2swap 2drop -2rot 2drop cdr ( env mproc body )
 
+            2dup print cr
+            macro-expand
+            2dup print cr
+
+            2swap
             ['] eval goto-deferred
         then
         exit
@@ -1499,6 +1522,49 @@ variable gc-stack-depth
 
 \ }}}
 
+\ ---- Loading files ---- {{{
+
+: charlist>cstr ( charlist addr -- n )
+
+    dup 2swap ( origaddr addr charlist )
+
+    begin 
+        nil? false =
+    while
+        2dup cdr 2swap car 
+        drop ( origaddr addr charlist char )
+        -rot 2swap ( origaddr charlist addr char )
+        over !
+        1+ -rot ( origaddr nextaddr charlist )
+    repeat
+
+    2drop ( origaddr finaladdr ) 
+    swap -
+;
+
+: load ( addr n -- finalResult )
+    open-input-file
+
+    empty-parse-str
+
+    ok-symbol ( port res )
+
+    begin
+        2over read-port ( port res obj )
+
+        2dup EOF character-type objeq? if
+            2drop 2swap close-port
+            exit
+        then
+
+        2swap 2drop ( port obj )
+
+        global-env obj@ eval ( port res )
+    again
+;
+
+\ }}}
+
 \ ---- Primitives ---- {{{
 
 : make-primitive ( cfa -- )
@@ -1531,7 +1597,7 @@ variable gc-stack-depth
             arg-count-error
         then
     else
-        -rot 2dup nil objeq? if
+        -rot nil? if
             arg-count-error
         then
         
@@ -1554,58 +1620,6 @@ include scheme-primitives.4th
 
 \ }}}
 
-\ ---- Loading files ---- {{{
-
-: charlist>cstr ( charlist addr -- n )
-
-    dup 2swap ( origaddr addr charlist )
-
-    begin 
-        2dup nil objeq? false =
-    while
-        2dup cdr 2swap car 
-        drop ( origaddr addr charlist char )
-        -rot 2swap ( origaddr charlist addr char )
-        over !
-        1+ -rot ( origaddr nextaddr charlist )
-    repeat
-
-    2drop ( origaddr finaladdr ) 
-    swap -
-;
-
-: load ( addr n -- finalResult )
-    open-input-file
-
-    empty-parse-str
-
-    ok-symbol ( port res )
-
-    begin
-        2over read-port ( port res obj )
-
-        2dup EOF character-type objeq? if
-            2drop 2swap close-port
-            exit
-        then
-
-        2swap 2drop ( port obj )
-
-        global-env obj@ eval ( port res )
-    again
-;
-
-:noname ( args -- finalResult )
-    2dup 1 ensure-arg-count
-    car string-type ensure-arg-type
-
-    drop pair-type
-    pad charlist>cstr
-    pad swap load
-; make-primitive load
-
-\ }}}
-
 \ ---- REPL ----
 
 : repl