artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Refactor quasiquote.

Browse source 
* module/mes/quasiquote.mes (quasiquote): Refactor.
* tests/quasiquote.test: Add tests.
This commit is contained in:
Jan Nieuwenhuizen 2016-12-22 12:11:55 +01:00
parent 6854627391
commit ea7c0aac86
2 changed files with 58 additions and 20 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

46
module/mes/quasiquote.mes
View file

@ -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))

32
tests/quasiquote.test
View file

@ -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)