From af8e47216da60326dec6e0fb6e666bf36ac134a6 Mon Sep 17 00:00:00 2001
From: Tim Vaughan <tgvaughan@gmail.com>
Date: Sat, 5 Nov 2016 14:05:17 +1300
Subject: [PATCH] Working on quasiquote.

---
 scheme-primitives.4th |  5 +++-
 scheme.4th            | 69 +++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 73 insertions(+), 1 deletion(-)

diff --git a/scheme-primitives.4th b/scheme-primitives.4th
index fdb28d3..86fbbd9 100644
--- a/scheme-primitives.4th
+++ b/scheme-primitives.4th
@@ -352,7 +352,10 @@ hide relcfa
     pad swap load
 ; make-primitive load
 
-' read make-primitive read
+:noname ( args -- obj )
+    0 ensure-arg-count
+    read
+; make-primitive read
 
 defer display
 :noname ( args -- none )
diff --git a/scheme.4th b/scheme.4th
index bacd8e0..5d3b778 100644
--- a/scheme.4th
+++ b/scheme.4th
@@ -1060,6 +1060,70 @@ parse-idx-stack parse-idx-sp !
 : quote-body ( quote-obj -- quote-body-obj )
     cadr ;
 
+: quasiquote? ( obj -- obj bool )
+    quasiquote-symbol tagged-list? ;
+
+: unquote? ( obj -- obj bool )
+    unquote-symbol tagged-list?
+;
+
+: eval-unquote ( env obj -- res )
+    cdr ( env args )
+
+    nil? if
+        recoverable-exception throw" no arguments to unquote."
+    then
+
+    2dup cdr
+    nil? false = if
+        recoverable-exception throw" too many arguments to unquote."
+    then
+
+    2drop car 2swap eval
+;
+
+: (eval-quasiquote) ( env obj -- res )
+    nil? if
+        2swap 2drop exit
+    then
+
+    2over 2over car ( env obj env obj-car )
+
+    unquote? if
+        eval-unquote
+    else
+        2swap 2drop
+    then
+
+    -2rot cdr ( caritem env cdr )
+    recurse ( caritem cdritems )
+    cons
+;
+
+: eval-quasiquote ( obj env -- res )
+    2swap cdr ( env args )
+
+    nil? if
+        recoverable-exception throw" no arguments to quasiquote."
+    then
+
+    2dup cdr ( env args args-cdr )
+    nil? false = if
+        recoverable-exception throw" too many arguments to quasiquote."
+    then
+
+    2drop car ( env arg )
+
+    unquote? if
+        eval-unquote exit
+    then
+
+    pair-type istype? if
+        (eval-quasiquote) exit
+    then
+
+    2swap 2drop ;
+
 : variable? ( obj -- obj bool )
     symbol-type istype? ;
 
@@ -1346,6 +1410,11 @@ hide env
         exit
     then
 
+    quasiquote? if
+        2swap eval-quasiquote
+        exit
+    then
+
     variable? if
         2swap lookup-var
         exit
-- 
2.20.1