mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 03:30:27 +02:00
Code Activity

unquote and unquote-splicing can split multiple expressions

Browse source 
* module/ice-9/psyntax.scm (quasiquote): Import new definition from
  upstream psyntax, to allow unquote and unquote-splicing to take
  multiple arguments.
  (unquote, unquote-splicing): Adapt to not require a particular syntax
  form.

* module/ice-9/psyntax-pp.scm: Regenerated.
This commit is contained in:
Andy Wingo 2011-02-08 21:38:57 +01:00
parent 8a302b9f78
commit 0f550375be
2 changed files with 2585 additions and 1332 deletions
Download patch file Download diff file Expand all files Collapse all files

3740
module/ice-9/psyntax-pp.scm
View file

File diff suppressed because it is too large Load diff

177
module/ice-9/psyntax.scm
View file

@ -2657,66 +2657,109 @@
(begin c ... (doloop step ...)))))))))))
(define-syntax quasiquote
(letrec
((quasicons
(lambda (x y)
(with-syntax ((x x) (y y))
(syntax-case #'y (quote list)
((quote dy)
(syntax-case #'x (quote)
((quote dx) #'(quote (dx . dy)))
(_ (if (null? #'dy)
#'(list x)
#'(cons x y)))))
((list . stuff) #'(list x . stuff))
(else #'(cons x y))))))
(quasiappend
(lambda (x y)
(with-syntax ((x x) (y y))
(syntax-case #'y (quote)
((quote ()) #'x)
(_ #'(append x y))))))
(quasivector
(lambda (x)
(with-syntax ((x x))
(syntax-case #'x (quote list)
((quote (x ...)) #'(quote #(x ...)))
((list x ...) #'(vector x ...))
(_ #'(list->vector x))))))
(quasi
(lambda (p lev)
(syntax-case p (unquote unquote-splicing quasiquote)
((unquote p)
(if (= lev 0)
#'p
(quasicons #'(quote unquote)
(quasi #'(p) (- lev 1)))))
((unquote . args)
(= lev 0)
(syntax-violation 'unquote
"unquote takes exactly one argument"
p #'(unquote . args)))
(((unquote-splicing p) . q)
(if (= lev 0)
(quasiappend #'p (quasi #'q lev))
(quasicons (quasicons #'(quote unquote-splicing)
(quasi #'(p) (- lev 1)))
(quasi #'q lev))))
(((unquote-splicing . args) . q)
(= lev 0)
(syntax-violation 'unquote-splicing
"unquote-splicing takes exactly one argument"
p #'(unquote-splicing . args)))
((quasiquote p)
(quasicons #'(quote quasiquote)
(quasi #'(p) (+ lev 1))))
((p . q)
(quasicons (quasi #'p lev) (quasi #'q lev)))
(#(x ...) (quasivector (quasi #'(x ...) lev)))
(p #'(quote p))))))
(let ()
(define (quasi p lev)
(syntax-case p (unquote quasiquote)
((unquote p)
(if (= lev 0)
#'("value" p)
(quasicons #'("quote" unquote) (quasi #'(p) (- lev 1)))))
((quasiquote p) (quasicons #'("quote" quasiquote) (quasi #'(p) (+ lev 1))))
((p . q)
(syntax-case #'p (unquote unquote-splicing)
((unquote p ...)
(if (= lev 0)
(quasilist* #'(("value" p) ...) (quasi #'q lev))
(quasicons
(quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))
(quasi #'q lev))))
((unquote-splicing p ...)
(if (= lev 0)
(quasiappend #'(("value" p) ...) (quasi #'q lev))
(quasicons
(quasicons #'("quote" unquote-splicing) (quasi #'(p ...) (- lev 1)))
(quasi #'q lev))))
(_ (quasicons (quasi #'p lev) (quasi #'q lev)))))
(#(x ...) (quasivector (vquasi #'(x ...) lev)))
(p #'("quote" p))))
(define (vquasi p lev)
(syntax-case p ()
((p . q)
(syntax-case #'p (unquote unquote-splicing)
((unquote p ...)
(if (= lev 0)
(quasilist* #'(("value" p) ...) (vquasi #'q lev))
(quasicons
(quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))
(vquasi #'q lev))))
((unquote-splicing p ...)
(if (= lev 0)
(quasiappend #'(("value" p) ...) (vquasi #'q lev))
(quasicons
(quasicons
#'("quote" unquote-splicing)
(quasi #'(p ...) (- lev 1)))
(vquasi #'q lev))))
(_ (quasicons (quasi #'p lev) (vquasi #'q lev)))))
(() #'("quote" ()))))
(define (quasicons x y)
(with-syntax ((x x) (y y))
(syntax-case #'y ()
(("quote" dy)
(syntax-case #'x ()
(("quote" dx) #'("quote" (dx . dy)))
(_ (if (null? #'dy) #'("list" x) #'("list*" x y)))))
(("list" . stuff) #'("list" x . stuff))
(("list*" . stuff) #'("list*" x . stuff))
(_ #'("list*" x y)))))
(define (quasiappend x y)
(syntax-case y ()
(("quote" ())
(cond
((null? x) #'("quote" ()))
((null? (cdr x)) (car x))
(else (with-syntax (((p ...) x)) #'("append" p ...)))))
(_
(cond
((null? x) y)
(else (with-syntax (((p ...) x) (y y)) #'("append" p ... y)))))))
(define (quasilist* x y)
(let f ((x x))
(if (null? x)
y
(quasicons (car x) (f (cdr x))))))
(define (quasivector x)
(syntax-case x ()
(("quote" (x ...)) #'("quote" #(x ...)))
(_
(let f ((y x) (k (lambda (ls) #`("vector" #,@ls))))
(syntax-case y ()
(("quote" (y ...)) (k #'(("quote" y) ...)))
(("list" y ...) (k #'(y ...)))
(("list*" y ... z) (f #'z (lambda (ls) (k (append #'(y ...) ls)))))
(else #`("list->vector" #,x)))))))
(define (emit x)
(syntax-case x ()
(("quote" x) #''x)
(("list" x ...) #`(list #,@(map emit #'(x ...))))
;; could emit list* for 3+ arguments if implementation supports
;; list*
(("list*" x ... y)
(let f ((x* #'(x ...)))
(if (null? x*)
(emit #'y)
#`(cons #,(emit (car x*)) #,(f (cdr x*))))))
(("append" x ...) #`(append #,@(map emit #'(x ...))))
(("vector" x ...) #`(vector #,@(map emit #'(x ...))))
(("list->vector" x) #`(list->vector #,(emit #'x)))
(("value" x) #'x)))
(lambda (x)
(syntax-case x ()
((_ e) (quasi #'e 0))))))
(syntax-case x ()
;; convert to intermediate language, combining introduced (but
;; not unquoted source) quote expressions where possible and
;; choosing optimal construction code otherwise, then emit
;; Scheme code corresponding to the intermediate language forms.
((_ e) (emit (quasi #'e 0)))))))
(define-syntax include
(lambda (x)
@ -2752,19 +2795,15 @@
(define-syntax unquote
(lambda (x)
(syntax-case x ()
((_ e)
(syntax-violation 'unquote
"expression not valid outside of quasiquote"
x)))))
(syntax-violation 'unquote
"expression not valid outside of quasiquote"
x)))
(define-syntax unquote-splicing
(lambda (x)
(syntax-case x ()
((_ e)
(syntax-violation 'unquote-splicing
"expression not valid outside of quasiquote"
x)))))
(syntax-violation 'unquote-splicing
"expression not valid outside of quasiquote"
x)))
(define-syntax case
(lambda (x)