Simplified apply.

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

diff --git a/scheme.4th b/scheme.4th
index 8c5b159..d6b3621 100644 (file)
--- a/scheme.4th
+++ b/scheme.4th
@@ -239,7 +239,7 @@ objvar symbol-table
 ;
 
 
-: cstr>charlist ( addr n -- symbol-obj )
+: cstr>charlist ( addr n -- charlist )
     dup 0= if
         2drop nil
     else
@@ -256,13 +256,7 @@ objvar symbol-table
     count
 
     cstr>charlist
-    drop symbol-type
-
-    2dup
-
-    symbol-table obj@
-    cons
-    symbol-table obj!
+    charlist>symbol
 
     create swap , ,
     does> dup @ swap 1+ @
@@ -402,6 +396,54 @@ objvar global-env
 nil nil nil extend-env
 global-env obj!
 
+\ }}}
+
+\ ---- Primitives ---- {{{
+
+: make-primitive ( cfa -- )
+    bl word
+    count
+
+    \ 2dup ." Defining primitive " type ." ..." cr
+
+    cstr>charlist
+    charlist>symbol
+  
+    rot primitive-proc-type ( var prim )
+    global-env obj@ define-var
+;
+
+: arg-count-error
+            bold fg red ." Incorrect argument count." reset-term cr
+            abort
+;
+
+: ensure-arg-count ( args n -- )
+    dup 0= if
+        drop nil objeq? false = if
+            arg-count-error
+        then
+    else
+        -rot nil? if
+            arg-count-error
+        then
+        
+        cdr rot 1- recurse
+    then
+;
+
+: arg-type-error
+            bold fg red ." Incorrect argument type." reset-term cr
+            abort
+;
+
+: ensure-arg-type ( arg type -- arg )
+    istype? false = if
+        arg-type-error
+    then
+;
+
+
 \ }}}
 
 \ ---- Macros ---- {{{
@@ -1188,10 +1230,10 @@ hide env
     2swap
 ;
 
-: apply ( proc argvals )
+: apply ( proc argvals -- result )
         2swap dup case
             primitive-proc-type of
-                drop execute
+                drop execute     
             endof
 
             compound-proc-type of
@@ -1210,11 +1252,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
 
@@ -1280,31 +1335,34 @@ hide env
     application? if
 
         2over 2over ( env exp env exp )
-        operator 2dup ( env exp env opname opname )
+        operator ( env exp env opname )
+
+        2dup lookup-macro nil? false = if
+             \ Macro function evaluation
+
+            ( env exp env opname mproc )
+            2swap 2drop -2rot 2drop cdr ( env mproc body )
+
+            2dup print cr
+            macro-expand
+            2dup print cr
 
-        lookup-macro nil? if
-            \ Regular function application
+            2swap
+            ['] eval goto-deferred
+        else
+           \ 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
-
-            ." Macro eval"
-
-            ( env exp env opname mproc )
-            2swap 2drop -2rot 2drop cdr ( env mproc body )
-
-            \ TODO: evaluate macro procedure on expression body
-            ." ABORTED: Macros not yet fully implemented!" abort
+            exit
         then
-        exit
     then
 
     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
@@ -1507,61 +1565,6 @@ variable gc-stack-depth
 
 \ }}}
 
-\ ---- Primitives ---- {{{
-
-: make-primitive ( cfa -- )
-    bl word
-    count
-
-    \ 2dup ." Defining primitive " type ." ..." cr
-
-    cstr>charlist
-    drop symbol-type
-    
-    2dup
-
-    symbol-table obj@
-    cons
-    symbol-table obj!
-
-    rot primitive-proc-type ( var prim )
-    global-env obj@ define-var
-;
-
-: arg-count-error
-            bold fg red ." Incorrect argument count." reset-term cr
-            abort
-;
-
-: ensure-arg-count ( args n -- )
-    dup 0= if
-        drop nil objeq? false = if
-            arg-count-error
-        then
-    else
-        -rot nil? if
-            arg-count-error
-        then
-        
-        cdr rot 1- recurse
-    then
-;
-
-: arg-type-error
-            bold fg red ." Incorrect argument type." reset-term cr
-            abort
-;
-
-: ensure-arg-type ( arg type -- arg )
-    istype? false = if
-        arg-type-error
-    then
-;
-
-include scheme-primitives.4th
-
-\ }}}
-
 \ ---- Loading files ---- {{{
 
 : charlist>cstr ( charlist addr -- n )
@@ -1603,15 +1606,14 @@ include scheme-primitives.4th
     again
 ;
 
-:noname ( args -- finalResult )
-    2dup 1 ensure-arg-count
-    car string-type ensure-arg-type
+\ }}}
+
+\ ---- Standard Library ---- {{{
 
-    drop pair-type
-    pad charlist>cstr
-    pad swap load
-; make-primitive load
+    include scheme-primitives.4th
 
+    s" scheme-library.scm" load 2drop
+    
 \ }}}
 
 \ ---- REPL ----