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

Ensure that (syntax ()) results in ()

Browse source 
* module/ice-9/psyntax.scm: Add a special case for ().  There are
already special cases for pairs, vectors, etc; the issue is that with
read-syntax, the () might be come into psyntax as an annotated syntax
object, which here we would want to strip, to preserve the invariant to
psyntax users that all lists are unwrapped.
This commit is contained in:
Andy Wingo 2021-02-25 09:33:15 +01:00
parent 9ade45097c
commit 0cc7991855
2 changed files with 40 additions and 34 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -990,11 +990,11 @@
(source-wrap e w (cdr w) mod) (source-wrap e w (cdr w) mod)
x)) x))
(else (decorate-source x s)))))) (else (decorate-source x s))))))
(let* ((t-680b775fb37a463-db3 transformer-environment) (let* ((t-680b775fb37a463-db4 transformer-environment)
(t-680b775fb37a463-db4 (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-db5 (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-db3
t-680b775fb37a463-db4 t-680b775fb37a463-db4
t-680b775fb37a463-db5
(lambda () (lambda ()
(rebuild-macro-output (rebuild-macro-output
(p (source-wrap e (anti-mark w) s mod)) (p (source-wrap e (anti-mark w) s mod))
@ -1727,14 +1727,17 @@
(lambda () (gen-syntax src y r maps ellipsis? mod)) (lambda () (gen-syntax src y r maps ellipsis? mod))
(lambda (y maps) (values (gen-cons x y) maps)))))) (lambda (y maps) (values (gen-cons x y) maps))))))
tmp-1) tmp-1)
(let ((tmp ($sc-dispatch tmp '#(vector (any . each-any))))) (let ((tmp-1 ($sc-dispatch tmp '#(vector (any . each-any)))))
(if tmp (if tmp-1
(apply (lambda (e1 e2) (apply (lambda (e1 e2)
(call-with-values (call-with-values
(lambda () (gen-syntax src (cons e1 e2) r maps ellipsis? mod)) (lambda () (gen-syntax src (cons e1 e2) r maps ellipsis? mod))
(lambda (e maps) (values (gen-vector e) maps)))) (lambda (e maps) (values (gen-vector e) maps))))
tmp) tmp-1)
(values (list 'quote e) maps)))))))))))) (let ((tmp ($sc-dispatch tmp '())))
(if tmp
(apply (lambda () (values ''() maps)) tmp)
(values (list 'quote e) maps))))))))))))))
(gen-ref (gen-ref
(lambda (src var level maps) (lambda (src var level maps)
(cond ((= level 0) (values var maps)) (cond ((= level 0) (values var maps))
@ -2859,9 +2862,9 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-115f) (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(list (cons tmp-680b775fb37a463-115f tmp-680b775fb37a463) (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
tmp-680b775fb37a463-1)) tmp-680b775fb37a463-2))
template template
pattern pattern
keyword))) keyword)))
@ -2876,9 +2879,11 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-117a tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-117b
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-117a
tmp-680b775fb37a463-117a)) tmp-680b775fb37a463)
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-117a)
tmp-680b775fb37a463-117b))
template template
pattern pattern
keyword))) keyword)))
@ -2894,9 +2899,9 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-119a tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
tmp-680b775fb37a463-2)) tmp-680b775fb37a463-119a))
template template
pattern pattern
keyword))) keyword)))
@ -3044,8 +3049,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-124a)
(list "value" tmp-680b775fb37a463)) (list "value" tmp-680b775fb37a463-124a))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3068,8 +3073,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-124e) (map (lambda (tmp-680b775fb37a463-124f)
(list "value" tmp-680b775fb37a463-124e)) (list "value" tmp-680b775fb37a463-124f))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3122,8 +3127,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-126a)
(list "value" tmp-680b775fb37a463)) (list "value" tmp-680b775fb37a463-126a))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3213,8 +3218,8 @@
(let ((tmp-1 ls)) (let ((tmp-1 ls))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-12b2) (apply (lambda (t-680b775fb37a463-12b3)
(cons "vector" t-680b775fb37a463-12b2)) (cons "vector" t-680b775fb37a463-12b3))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3224,8 +3229,8 @@
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
(if tmp-1 (if tmp-1
(apply (lambda (y) (apply (lambda (y)
(k (map (lambda (tmp-680b775fb37a463-12be) (k (map (lambda (tmp-680b775fb37a463-12bf)
(list "quote" tmp-680b775fb37a463-12be)) (list "quote" tmp-680b775fb37a463-12bf))
y))) y)))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
@ -3236,8 +3241,8 @@
(apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1) (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
(let ((else tmp)) (let ((else tmp))
(let ((tmp x)) (let ((tmp x))
(let ((t-680b775fb37a463-12cd tmp)) (let ((t-680b775fb37a463-12ce tmp))
(list "list->vector" t-680b775fb37a463-12cd))))))))))))))))) (list "list->vector" t-680b775fb37a463-12ce)))))))))))))))))
(emit (lambda (x) (emit (lambda (x)
(let ((tmp x)) (let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
@ -3250,9 +3255,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-12dc) (apply (lambda (t-680b775fb37a463-12dd)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463-12dc)) t-680b775fb37a463-12dd))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3268,10 +3273,10 @@
(let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
(let ((tmp ($sc-dispatch tmp-1 '(any any)))) (let ((tmp ($sc-dispatch tmp-1 '(any any))))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-12f0 t-680b775fb37a463-12ef) (apply (lambda (t-680b775fb37a463-12f1 t-680b775fb37a463-12f0)
(list (make-syntax 'cons '((top)) '(hygiene guile)) (list (make-syntax 'cons '((top)) '(hygiene guile))
t-680b775fb37a463-12f0 t-680b775fb37a463-12f1
t-680b775fb37a463-12ef)) t-680b775fb37a463-12f0))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3284,9 +3289,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-12fc) (apply (lambda (t-680b775fb37a463-12fd)
(cons (make-syntax 'append '((top)) '(hygiene guile)) (cons (make-syntax 'append '((top)) '(hygiene guile))
t-680b775fb37a463-12fc)) t-680b775fb37a463-12fd))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f

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

@ -2142,6 +2142,7 @@
(lambda () (lambda ()
(gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod)) (gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod))
(lambda (e maps) (values (gen-vector e) maps)))) (lambda (e maps) (values (gen-vector e) maps))))
(() (values '(quote ()) maps))
(_ (values `(quote ,e) maps)))))) (_ (values `(quote ,e) maps))))))
(define gen-ref (define gen-ref