From: Tim Vaughan <tgvaughan@gmail.com>
Date: Thu, 27 Oct 2016 21:25:21 +0000 (+1300)
Subject: Added lookup-macro and make-macro.
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=a966a509dd23259423e21c55d973403b88b86ea4;p=scheme.forth.jl.git

Added lookup-macro and make-macro.
---

diff --git a/scheme.4th b/scheme.4th
index 5a049d4..7ac6355 100644
--- a/scheme.4th
+++ b/scheme.4th
@@ -392,12 +392,67 @@ objvar env
 
 hide env
 
+: make-procedure ( params body env -- proc )
+    nil
+    cons cons cons
+    drop compound-proc-type
+;
+
 objvar global-env
 nil nil nil extend-env
 global-env obj!
 
 \ }}}
 
+\ ---- Macros ---- {{{
+
+objvar macro-table
+
+: lookup-macro ( name_symbol -- proc? bool )
+    macro-table obj@
+
+    begin
+        nil? false =
+    while
+        2over 2over
+        car car objeq? if
+            2swap 2drop
+            car cdr
+            true exit
+        then
+    repeat
+
+    2drop false
+;
+
+: make-macro ( name_symbol params body env -- )
+    make-procedure
+
+    2swap ( proc name_symbol )
+
+    macro-table obj@
+
+    begin
+        nil? false =
+    while
+        2over 2over ( proc name table name table )
+        car car objeq? if
+            2swap 2drop ( proc table )
+            car ( proc entry )
+            set-cdr!
+            exit
+        then
+    repeat
+
+    2drop
+
+    2swap cons
+    macro-table obj@ cons
+    macro-table obj!
+;
+
+\ }}}
+
 \ ---- Read ---- {{{
 
 variable parse-idx
@@ -1011,12 +1066,6 @@ parse-idx-stack parse-idx-sp !
 : lambda-body ( obj -- body )
     cdr cdr ;
 
-: make-procedure ( params body env -- proc )
-    nil
-    cons cons cons
-    drop compound-proc-type
-;
-
 : begin? ( obj -- obj bool )
     begin-symbol tagged-list? ;
 
@@ -1405,6 +1454,7 @@ variable gc-stack-depth
     gc-unmark
 
     symbol-table obj@ gc-mark-obj
+    macro-table obj@ gc-mark-obj
     global-env obj@ gc-mark-obj
 
     depth gc-stack-depth @ do