conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

quasiquote is now safe for nesting

This commit is contained in:
Yuichi Nishiwaki 2014-02-12 22:31:17 +09:00
parent 234c573bb6
commit c69687d234
1 changed files with 47 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
piclib/built-in.scm
View File

@ -120,24 +120,55 @@
(r 'it) (r 'it)
(cons (r 'or) (cdr exprs)))))))))) (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 (define-syntax quasiquote
(er-macro-transformer (ir-macro-transformer
(lambda (expr r compare?) (lambda (form inject compare)
(let ((x (cadr expr)))
(define (qq depth expr)
(cond (cond
((symbol? x) (list (r 'quote) x)) ;; unquote
((pair? x) (cond ((unquote? expr compare)
((compare? (r 'unquote) (car x)) (if (= depth 1)
(cadr x)) (car (cdr expr))
((and (pair? (car x)) (list 'list
(compare? (r 'unquote-splicing) (caar x))) (list 'quote (inject 'unquote))
(list (r 'append) (cadar x) (qq (- depth 1) (car (cdr expr))))))
(list (r 'quasiquote) (cdr x)))) ;; unquote-splicing
(#t ((unquote-splicing? expr compare)
(list (r 'cons) (if (= depth 1)
(list (r 'quasiquote) (car x)) (list 'append
(list (r 'quasiquote) (cdr x)))))) (car (cdr (car expr)))
(#t x)))))) (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* (define-syntax let*