From 7a6c6a6727ea3407db9392e4f3c065fed304485f Mon Sep 17 00:00:00 2001
From: Justin Ethier <justin.ethier@gmail.com>
Date: Wed, 19 Aug 2015 22:03:12 -0400
Subject: [PATCH] Move quasiquote to scheme/base

---
 scheme/base.sld               | 33 +++++++++++++++++++++++++++++++++
 scheme/cyclone/transforms.sld | 31 -------------------------------
 scheme/eval.sld               |  7 -------
 3 files changed, 33 insertions(+), 38 deletions(-)

diff --git a/scheme/base.sld b/scheme/base.sld
index 8b3043ee..5df6a762 100644
--- a/scheme/base.sld
+++ b/scheme/base.sld
@@ -82,6 +82,7 @@
     features
     and
     or
+    quasiquote
   )
   (begin
     ;; Features implemented by this Scheme
@@ -105,6 +106,38 @@
                        (list (rename 'if) (rename 'tmp)
                              (rename 'tmp)
                              (cons (rename 'or) (cddr expr)))))))))
+    (define-syntax quasiquote
+      (er-macro-transformer
+        ;; Based on the quasiquote macro from Chibi scheme
+        (lambda (expr rename compare)
+          (define (qq x d)
+            (cond
+             ((pair? x)
+              (cond
+               ((compare (rename 'unquote) (car x))
+                (if (<= d 0)
+                    (cadr x)
+                    (list (rename 'list) (list (rename 'quote) 'unquote)
+                          (qq (cadr x) (- d 1)))))
+               ((compare (rename 'unquote-splicing) (car x))
+                (if (<= d 0)
+                    (list (rename 'cons) (qq (car x) d) (qq (cdr x) d))
+                    (list (rename 'list) (list (rename 'quote) 'unquote-splicing)
+                          (qq (cadr x) (- d 1)))))
+               ((compare (rename 'quasiquote) (car x))
+                (list (rename 'list) (list (rename 'quote) 'quasiquote)
+                      (qq (cadr x) (+ d 1))))
+               ((and (<= d 0) (pair? (car x))
+                     (compare (rename 'unquote-splicing) (caar x)))
+                (if (null? (cdr x))
+                    (cadr (car x))
+                    (list (rename 'append) (cadr (car x)) (qq (cdr x) d))))
+               (else
+                (list (rename 'cons) (qq (car x) d) (qq (cdr x) d)))))
+             ((vector? x) (list (rename 'list->vector) (qq (vector->list x) d)))
+             ((if (symbol? x) #t (null? x)) (list (rename 'quote) x))
+             (else x)))
+          (qq (cadr expr) 0))))
 
     ;; TODO: The whitespace characters are space, tab, line feed, form feed (not in parser yet), and carriage return.
     (define call-with-current-continuation call/cc)
diff --git a/scheme/cyclone/transforms.sld b/scheme/cyclone/transforms.sld
index 46b07545..35cd96ea 100644
--- a/scheme/cyclone/transforms.sld
+++ b/scheme/cyclone/transforms.sld
@@ -255,37 +255,6 @@
                      `(,(rename 'begin) ,@(cdar ls))))
                 ((check (caar ls)) `(,(rename 'begin) ,@(cdar ls)))
                 (else (expand (cdr ls)))))))
-    (cons 'quasiquote
-      ;; Based on the quasiquote macro from Chibi scheme
-      (lambda (expr rename compare)
-        (define (qq x d)
-          (cond
-           ((pair? x)
-            (cond
-             ((compare (rename 'unquote) (car x))
-              (if (<= d 0)
-                  (cadr x)
-                  (list (rename 'list) (list (rename 'quote) 'unquote)
-                        (qq (cadr x) (- d 1)))))
-             ((compare (rename 'unquote-splicing) (car x))
-              (if (<= d 0)
-                  (list (rename 'cons) (qq (car x) d) (qq (cdr x) d))
-                  (list (rename 'list) (list (rename 'quote) 'unquote-splicing)
-                        (qq (cadr x) (- d 1)))))
-             ((compare (rename 'quasiquote) (car x))
-              (list (rename 'list) (list (rename 'quote) 'quasiquote)
-                    (qq (cadr x) (+ d 1))))
-             ((and (<= d 0) (pair? (car x))
-                   (compare (rename 'unquote-splicing) (caar x)))
-              (if (null? (cdr x))
-                  (cadr (car x))
-                  (list (rename 'append) (cadr (car x)) (qq (cdr x) d))))
-             (else
-              (list (rename 'cons) (qq (car x) d) (qq (cdr x) d)))))
-           ((vector? x) (list (rename 'list->vector) (qq (vector->list x) d)))
-           ((if (symbol? x) #t (null? x)) (list (rename 'quote) x))
-           (else x)))
-        (qq (cadr expr) 0)))
   ))
 
 
diff --git a/scheme/eval.sld b/scheme/eval.sld
index 1092f63b..e439629d 100644
--- a/scheme/eval.sld
+++ b/scheme/eval.sld
@@ -62,9 +62,6 @@
 (define (quoted? exp)
   (tagged-list? 'quote exp))
 
-(define (quasiquoted? exp)
-  (tagged-list? 'quasiquote exp))
-
 (define (assignment? exp)
   (tagged-list? 'set! exp))
 (define (assignment-variable exp) (cadr exp))
@@ -403,7 +400,6 @@
   (cond ((self-evaluating? exp) 
          (analyze-self-evaluating exp))
         ((quoted? exp) (analyze-quoted exp))
-        ((quasiquoted? exp) (analyze-quasiquoted exp))
         ((variable? exp) (analyze-variable exp))
         ((assignment? exp) (analyze-assignment exp env))
         ((definition? exp) (analyze-definition exp env))
@@ -442,9 +438,6 @@
   (let ((qval (cadr exp)))
     (lambda (env) qval)))
 
-(define (analyze-quasiquoted exp)
-  (error "quasiquote not supported yet by eval"))
-
 (define (analyze-variable exp)
   (lambda (env) (lookup-variable-value exp env)))