From: Tim Vaughan <tgvaughan@gmail.com>
Date: Tue, 1 Nov 2016 07:54:36 +0000 (+1300)
Subject: Simplified apply.
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=scheme.forth.jl.git;a=commitdiff_plain;h=61f902750c854d52bc37a5903e07b7e84f7081c4

Simplified apply.
---

diff --git a/scheme-primitives.4th b/scheme-primitives.4th
index 89e379e..e5a7dba 100644
--- a/scheme-primitives.4th
+++ b/scheme-primitives.4th
@@ -418,3 +418,13 @@ defer display
 
     none
 ; make-primitive newline
+
+( ==== Evaluation ==== )
+
+:noname ( args -- result )
+    2dup car 2swap cdr
+
+    nil? false = if car then ( proc argvals )
+    
+    apply
+; make-primitive apply 
diff --git a/scheme.4th b/scheme.4th
index 9b940e7..d6b3621 100644
--- a/scheme.4th
+++ b/scheme.4th
@@ -1230,14 +1230,6 @@ hide env
     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
@@ -1357,39 +1349,20 @@ primitive-proc-type dummy-apply-proc obj!
 
             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