From 6cb6a8d3e4449a1cf70ac4cbb0b88cf2c38d6434 Mon Sep 17 00:00:00 2001
From: Tim Vaughan <tgvaughan@gmail.com>
Date: Wed, 28 Jun 2017 08:47:49 +1200
Subject: [PATCH] Replaced old eval with "expand analyze evaluate-eproc"

Compound procedures still not working.
---
 src/scheme-primitives.4th |  14 ++---
 src/scheme.4th            | 122 +++-----------------------------------
 2 files changed, 16 insertions(+), 120 deletions(-)

diff --git a/src/scheme-primitives.4th b/src/scheme-primitives.4th
index f38fd93..183efec 100644
--- a/src/scheme-primitives.4th
+++ b/src/scheme-primitives.4th
@@ -592,13 +592,13 @@ defer display
 
 \ ==== Evaluation ==== {{{
 
-:noname ( args -- result )
-    2dup car 2swap cdr
-
-    nil? false = if car then ( proc argvals )
-    
-    apply
-; make-primitive apply 
+\ :noname ( args -- result )
+\     2dup car 2swap cdr
+\ 
+\     nil? false = if car then ( proc argvals )
+\     
+\     apply
+\ ; make-primitive apply 
 
 \ }}}
 
diff --git a/src/scheme.4th b/src/scheme.4th
index e5ac9cd..a32ee45 100644
--- a/src/scheme.4th
+++ b/src/scheme.4th
@@ -1529,113 +1529,6 @@ hide env
     2swap
 ;
 
-: apply ( proc argvals -- result )
-        2swap dup case
-            primitive-proc-type of
-                drop execute     
-            endof
-
-            compound-proc-type of
-                2dup procedure-body ( argvals proc body )
-                -2rot 2dup procedure-params ( body argvals proc argnames )
-                -2rot procedure-env ( body argnames argvals procenv )
-
-                -2rot 2swap
-                flatten-proc-args
-                2swap 2rot
-
-                extend-env ( body env )
-
-                eval-sequence
-
-                R> drop ['] eval goto-deferred  \ Tail call optimization
-            endof
-
-            except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw
-        endcase
-;
-
-:noname ( obj env -- result )
-    2swap
-
-    \ --- DEBUG ---
-    ( 
-      fg yellow ." Evaluating: " bold 2dup print reset-term
-      space fg green ." PS: " bold depth . reset-term
-      space fg blue  ." RS: " bold RSP@ RSP0 - . reset-term cr
-    )
-
-    self-evaluating? if
-        2swap 2drop
-        exit
-    then
-
-    quote? if
-        quote-body
-        2swap 2drop
-        exit
-    then
-
-    variable? if
-        2swap lookup-var
-        exit
-    then
-
-    definition? if
-        2swap eval-definition
-        exit
-    then
-
-    assignment? if
-        2swap eval-assignment
-        exit
-    then
-
-    macro-definition? if
-        2swap eval-define-macro
-        exit
-    then
-
-    if? if
-        2over 2over
-        if-predicate
-        2swap eval 
-
-        true? if
-            if-consequent
-        else
-            if-alternative
-        then
-
-        2swap
-        ['] eval goto-deferred
-    then
-
-    lambda? if
-        2dup lambda-parameters
-        2swap lambda-body
-        2rot make-procedure
-        exit
-    then
-
-    application? if
-
-        2over 2over ( env exp env exp )
-        operator ( env exp env opname )
-
-        2swap eval ( env exp proc )
-
-        -2rot ( proc env exp )
-        operands 2swap ( proc operands env )
-        list-of-vals ( proc argvals )
-
-        apply
-        exit
-    then
-
-    except-message: ." tried to evaluate object with unknown type." recoverable-exception throw
-; is eval
-
 \ }}}
 
 \ ---- Analyze ----
@@ -1658,8 +1551,6 @@ hide env
     \ Final element of eproc list is primitive procedure
     drop \ dump type signifier
 
-    .s cr \ DEBUG
-
     goto \ jump straight to primitive procedure (executor)
 ;
 
@@ -1876,6 +1767,11 @@ hide env
         exit
     then
 
+\    macro-definition? if
+\        analyze-macro-definition
+\        exit
+\    then
+
     assignment? if
         analyze-assignment
         exit
@@ -2021,6 +1917,10 @@ hide env
 
 \ }}}
 
+:noname ( exp env -- res )
+    2swap expand analyze 2swap evaluate-eproc
+; is eval
+
 \ ---- Print ---- {{{
 
 : printfixnum ( fixnum -- ) drop 0 .R ;
@@ -2245,8 +2145,6 @@ variable gc-stack-depth
 
         2swap 2drop ( port obj )
 
-        expand
-
         global-env obj@ eval ( port res )
     again
 ;
@@ -2275,8 +2173,6 @@ variable gc-stack-depth
         true exit
     then
 
-    expand
-
     global-env obj@ eval
 
     fg cyan ." ; " print reset-term
-- 
2.20.1