From c69687d234b01bb642ff71cbfccf6eb326cf8cb2 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Wed, 12 Feb 2014 22:31:17 +0900
Subject: [PATCH] quasiquote is now safe for nesting

---
 piclib/built-in.scm | 63 +++++++++++++++++++++++++++++++++------------
 1 file changed, 47 insertions(+), 16 deletions(-)

diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index af6e6357..5f5e4ae8 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -120,24 +120,55 @@
                        (r 'it)
                        (cons (r 'or) (cdr exprs))))))))))
 
+  (define (quasiquote? form compare?)
+    (and (pair? form) (compare? (car form) 'quasiquote)))
+
+  (define (unquote? form compare?)
+    (and (pair? form) (compare? (car form) 'unquote)))
+
+  (define (unquote-splicing? form compare?)
+    (and (pair? form) (pair? (car form)) (compare? (car (car form)) 'unquote-splicing)))
+
   (define-syntax quasiquote
-    (er-macro-transformer
-     (lambda (expr r compare?)
-       (let ((x (cadr expr)))
+    (ir-macro-transformer
+     (lambda (form inject compare)
+
+       (define (qq depth expr)
          (cond
-          ((symbol? x) (list (r 'quote) x))
-          ((pair? x) (cond
-                      ((compare? (r 'unquote) (car x))
-                       (cadr x))
-                      ((and (pair? (car x))
-                            (compare? (r 'unquote-splicing) (caar x)))
-                       (list (r 'append) (cadar x)
-                             (list (r 'quasiquote) (cdr x))))
-                      (#t
-                       (list (r 'cons)
-                             (list (r 'quasiquote) (car x))
-                             (list (r 'quasiquote) (cdr x))))))
-          (#t x))))))
+          ;; unquote
+          ((unquote? expr compare)
+           (if (= depth 1)
+               (car (cdr expr))
+               (list 'list
+                     (list 'quote (inject 'unquote))
+                     (qq (- depth 1) (car (cdr expr))))))
+          ;; unquote-splicing
+          ((unquote-splicing? expr compare)
+           (if (= depth 1)
+               (list 'append
+                     (car (cdr (car expr)))
+                     (qq depth (cdr expr)))
+               (list 'cons
+                     (list 'list
+                           (list 'quote (inject 'unquote-splicing))
+                           (qq (- depth 1) (car (cdr (car expr)))))
+                     (qq depth (cdr expr)))))
+          ;; quasiquote
+          ((quasiquote? expr compare)
+           (list 'list
+                 (list 'quote (inject 'quasiquote))
+                 (qq (+ depth 1) (car (cdr expr)))))
+          ;; list
+          ((pair? expr)
+           (list 'cons
+                 (qq depth (car expr))
+                 (qq depth (cdr expr))))
+          ;; simple datum
+          (else
+           (list 'quote expr))))
+
+       (let ((x (cadr form)))
+         (qq 1 x)))))
 
   #;
   (define-syntax let*