From: Jan Nieuwenhuizen <janneke@gnu.org>
Date: Thu, 22 Dec 2016 11:11:55 +0000 (+0100)
Subject: Refactor quasiquote.
X-Git-Url: https://jxself.org/git/?p=mes.git;a=commitdiff_plain;h=ea7c0aac8644489094959e2fd11fddbd91fd2a0c

Refactor quasiquote.

* module/mes/quasiquote.mes (quasiquote): Refactor.
* tests/quasiquote.test: Add tests.
---

diff --git a/module/mes/quasiquote.mes b/module/mes/quasiquote.mes
index 05bf41b8..334f057e 100644
--- a/module/mes/quasiquote.mes
+++ b/module/mes/quasiquote.mes
@@ -29,25 +29,31 @@
 
 (define-macro (quasiquote x)
   (define (loop x)
-    (if (not (pair? x)) (cons 'quote (cons x '()))
-        (if (eq? (car x) 'quasiquote) (loop (loop (cadr x)))
-            (if (eq? (car x) 'unquote) (cadr x)
-                (if (and (pair? (car x)) (eq? (caar x) 'unquote-splicing))
-                    ((lambda (d)
-                       (list 'append (cadar x) d))
-                     (loop (cdr x)))
-                    ((lambda (a d)
-                       (if (pair? d)
-                           (if (eq? (car d) 'quote)
-                               (if (and (pair? a) (eq? (car a) 'quote))
-                                   (list 'quote (cons (cadr a) (cadr d)))
-                                   (if (null? (cadr d))
-                                       (list 'list a)
-                                       (list 'cons* a d)))
-                               (if (memq (car d) '(list cons*))
-                                   (cons (car d) (cons a (cdr d)))
+    (cond ((vector? x) (list 'list->vector (loop (vector->list x))))
+          ((not (pair? x)) (cons 'quote (cons x '())))
+          ;;((eq? (car x) 'quasiquote) (loop (loop (cadr x))))
+          ((eq? (car x) 'quasiquote) (loop (loop
+                                            (if (null? (cddr x)) (cadr x)
+                                                (cons 'list (cdr x))))))
+          ((eq? (car x) 'unquote) (if (null? (cddr x)) (cadr x)
+                                      (cons 'list (cdr x))))
+          ((and (pair? (car x)) (eq? (caar x) 'unquote-splicing))
+           ((lambda (d)
+              (if (null? (cddar x)) (list 'append (cadar x) d)
+                  (list 'quote (append (cdar x) d))))
+            (loop (cdr x))))
+          (else ((lambda (a d)
+                   (if (pair? d)
+                       (if (eq? (car d) 'quote)
+                           (if (and (pair? a) (eq? (car a) 'quote))
+                               (list 'quote (cons (cadr a) (cadr d)))
+                               (if (null? (cadr d))
+                                   (list 'list a)
                                    (list 'cons* a d)))
-                           (list 'cons* a d)))
-                     (loop (car x))
-                     (loop (cdr x))))))))
+                           (if (memq (car d) '(list cons*))
+                               (cons (car d) (cons a (cdr d)))
+                               (list 'cons* a d)))
+                       (list 'cons* a d)))
+                 (loop (car x))
+                 (loop (cdr x))))))
   (loop x))
diff --git a/tests/quasiquote.test b/tests/quasiquote.test
index 4d307f68..ac57511d 100755
--- a/tests/quasiquote.test
+++ b/tests/quasiquote.test
@@ -46,4 +46,36 @@ exit $?
 (pass-if "unquote-splicing 3" (sequal? `(1 ,@(list 2 3) 4) '(1 2 3 4)))
 (pass-if "unquote-splicing 4" (sequal? (let ((s-r '(2 3))) `(1 ,@s-r 4)) '(1 2 3 4)))
 
+;; From R6RS spec
+(pass-if-equal "qq 0" '(list 3 4)
+  `(list ,(+ 1 2) 4))
+(pass-if-equal "qq 1" '(list a (quote a))
+  (let ((name 'a))
+    `(list ,name ',name)) )
+(pass-if-equal "qq 2" '(a 3 4 5 6 b)
+  `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
+(pass-if-equal "qq 3" '((foo 7) . cons)
+  `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))
+(pass-if-equal "qq 4" '#(10 5 #t #t #f #f #f 8)
+  `#(10 5 ,(even? 4) ,@(map even? '(2 3 5 7)) 8))
+;; (pass-if-equal "qq 5" '(foo foo foo)
+;;   (let ((name 'foo))
+;;     `((unquote name name name))))
+;; (pass-if-equal "qq 6" '(foo foo foo)
+;;   (let ((name '(foo)))
+;;     `((unquote-splicing name name name))))
+;; (pass-if-equal "qq 7" '`(foo (unquote (append x y) (even? 9)))
+;;   (let ((q '((append x y) (even? 9))))
+;;     ``(foo ,,@q)))
+;; (pass-if-equal "qq 8" '(foo (2 3 4 5) #f)
+;;   (let ((x '(2 3))
+;;         (y '(4 5)))
+;;     `(foo (unquote (append x y) (even? 9)))))
+;; (pass-if-equal "qq 9" '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
+;;   `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
+;; (pass-if-equal "qq 10" '(a `(b ,x ,'y d) e)
+;;   (let ((name1 'x)
+;;         (name2 'y))
+;;     `(a `(b ,,name1 ,',name2 d) e)))
+
 (result 'report)