From: Tim Vaughan <tgvaughan@gmail.com>
Date: Mon, 12 Jun 2017 07:23:07 +0000 (+1200)
Subject: Added macro expansion skeleton.
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=6a04a1527adf7d707b0340f43d5392df9a8ecd72;p=scheme.forth.jl.git

Added macro expansion skeleton.
---

diff --git a/src/scheme.4th b/src/scheme.4th
index bb65be2..1068229 100644
--- a/src/scheme.4th
+++ b/src/scheme.4th
@@ -1656,20 +1656,6 @@ hide env
         endcase
 ;
 
-( Simply evaluates the given procedure with expbody as its argument. )
-: 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
 
@@ -1764,6 +1750,44 @@ hide env
 
 \ }}}
 
+\ ---- Macro Expansion ---- {{{
+
+( Simply evaluates the given procedure with expbody as its argument. )
+: macro-eval ( 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 ( exp -- result )
+
+    quasiquote? if expand-quasiquote exit then
+
+    definition? if expand-definition exit then
+
+    assignment? if expand-assignment exit then
+
+    macro-definition? if expand-define-macro exit then
+
+    if? if expand-if exit then
+
+    lambda? if expand-lambda exit then
+
+    begin? if expand-sequence exit then
+
+    application? if expand-apply exit then
+
+; is expand
+
+\ }}}
+
 \ ---- Print ---- {{{
 
 : printfixnum ( fixnum -- ) drop 0 .R ;
@@ -1988,6 +2012,8 @@ variable gc-stack-depth
 
         2swap 2drop ( port obj )
 
+        expand
+
         global-env obj@ eval ( port res )
     again
 ;
@@ -2016,6 +2042,8 @@ variable gc-stack-depth
         true exit
     then
 
+    expand
+
     global-env obj@ eval
 
     fg cyan ." ; " print reset-term