From a9e0195cd866692844586002f1614ff74a79426a Mon Sep 17 00:00:00 2001
From: Tim Vaughan <tgvaughan@gmail.com>
Date: Tue, 1 Nov 2016 21:35:16 +1300
Subject: [PATCH] Simplified iterative define expansion.

---
 scheme-primitives.4th |  8 +++----
 scheme.4th            | 55 ++++++++++++++++++-------------------------
 2 files changed, 27 insertions(+), 36 deletions(-)

diff --git a/scheme-primitives.4th b/scheme-primitives.4th
index e5a7dba..97c098f 100644
--- a/scheme-primitives.4th
+++ b/scheme-primitives.4th
@@ -358,7 +358,7 @@ defer display
 :noname ( args -- none )
     2dup 1 ensure-arg-count
 
-    car print cr
+    car print
 
     none
 ; make-primitive write
@@ -388,7 +388,7 @@ defer display
     2dup 1 ensure-arg-count
     car string-type ensure-arg-type
 
-    (printstring) cr
+    (printstring)
 
     none
 ; make-primitive display-string
@@ -397,7 +397,7 @@ defer display
     2dup 1 ensure-arg-count
     car character-type ensure-arg-type
 
-    displaychar cr
+    displaychar
 
     none
 ; make-primitive display-character
@@ -406,7 +406,7 @@ defer display
     2dup 1 ensure-arg-count
     car
 
-    display cr
+    display
 
     none
 ; make-primitive display
diff --git a/scheme.4th b/scheme.4th
index 3728257..57ee1e6 100644
--- a/scheme.4th
+++ b/scheme.4th
@@ -1022,43 +1022,25 @@ parse-idx-stack parse-idx-sp !
 : make-lambda ( params body -- lambda-exp )
     lambda-symbol -2rot cons cons ;
 
-( Handles recursive expansion of defines in
+( Handles iterative expansion of defines in
   terms of nested lambdas. Most Schemes only
-  handle one level of expansion! )
-: (definition-var-val) ( val var -- val' var' )
-    symbol-type istype? if 2swap car 2swap exit then
+  handle one iteration of expansion! )
+: definition-var-val ( obj -- var val )
 
-    2dup cdr 2swap car
-    symbol-type istype? if
-        2swap ( body procname procargs )
-        2rot ( procname procargs body )
-        make-lambda ( procname lambda-exp )
-        2swap
-        exit
-    then
+    cdr 2dup cdr 2swap car ( val var )
 
-    ( body procargs nextval )
-    -2rot 2swap ( nextval procargs body )
-    make-lambda nil cons ( nextval lambda-exp )
-    2swap ( lambda-exp nextval )
-    recurse
-;
+    begin
+        symbol-type istype? false =
+    while
+        2dup cdr 2swap car ( val formals var' )
+        -2rot 2swap ( var' formals val )
+        make-lambda nil cons ( var' val' )
+        2swap ( val' var' )
+    repeat
 
-: definition-var-val ( obj -- var val )
-    cdr 2dup cdr 2swap car
-    (definition-var-val)
-    2swap
+    2swap car
 ;
 
-: assignment? ( obj -- obj bool )
-    set!-symbol tagged-list? ;
-
-: assignment-var ( obj -- var )
-    cdr car ;
-    
-: assignment-val ( obj -- val )
-    cdr cdr car ;
-
 : eval-definition ( obj env -- res )
     2dup 2rot ( env env obj )
     definition-var-val ( env env var val )
@@ -1069,7 +1051,16 @@ parse-idx-stack parse-idx-sp !
 
     ok-symbol
 ;
+
+: assignment? ( obj -- obj bool )
+    set!-symbol tagged-list? ;
+
+: assignment-var ( obj -- var )
+    cdr car ;
     
+: assignment-val ( obj -- val )
+    cdr cdr car ;
+
 : eval-assignment ( obj env -- res )
     2swap 
     2over 2over ( env obj env obj )
@@ -1639,7 +1630,7 @@ variable gc-stack-depth
 
     include scheme-primitives.4th
 
-    s" scheme-library.scm" load 2drop
+    \ s" scheme-library.scm" load 2drop
     
 \ }}}
 
-- 
2.20.1