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

psyntax: Remove useless gen-label invocations

Browse source 
* module/ice-9/psyntax.scm (expand-top-sequence): Remove needless
gen-label uses, and replace one use with gen-lexical (which is what is
needed).
* module/ice-9/psyntax-pp.scm: Regenerate.
This commit is contained in:
Andy Wingo 2024-11-14 15:08:40 +01:00
parent ebbb10c92d
commit 70e2616975
2 changed files with 46 additions and 50 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -456,7 +456,6 @@
(cond (cond
((memv key '(define-form)) ((memv key '(define-form))
(let* ((id (wrap value w mod)) (let* ((id (wrap value w mod))
(label (gen-label))
(var (if (macro-introduced-identifier? id) (var (if (macro-introduced-identifier? id)
(fresh-derived-name id x) (fresh-derived-name id x)
(syntax-expression id)))) (syntax-expression id))))
@ -476,7 +475,6 @@
(build-global-definition s mod var (expand e r w mod))))))))) (build-global-definition s mod var (expand e r w mod)))))))))
((memv key '(define-syntax-form define-syntax-parameter-form)) ((memv key '(define-syntax-form define-syntax-parameter-form))
(let* ((id (wrap value w mod)) (let* ((id (wrap value w mod))
(label (gen-label))
(var (if (macro-introduced-identifier? id) (var (if (macro-introduced-identifier? id)
(fresh-derived-name id x) (fresh-derived-name id x)
(syntax-expression id)))) (syntax-expression id))))
@ -797,11 +795,11 @@
(source-wrap e w (cdr w) mod) (source-wrap e w (cdr w) mod)
x)) x))
(else (decorate-source x)))))) (else (decorate-source x))))))
(let* ((t-680b775fb37a463-df9 transformer-environment) (let* ((t-680b775fb37a463-df5 transformer-environment)
(t-680b775fb37a463-dfa (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-df6 (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-df9 t-680b775fb37a463-df5
t-680b775fb37a463-dfa t-680b775fb37a463-df6
(lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (module-gensym "m")))))))) (lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (module-gensym "m"))))))))
(expand-body (expand-body
(lambda (body outer-form r w mod) (lambda (body outer-form r w mod)
@ -832,7 +830,7 @@
((not (car var-ids)) ((not (car var-ids))
(lp (cdr var-ids) (cdr vars) (cdr vals) (make-seq src ((car vals)) tail))) (lp (cdr var-ids) (cdr vars) (cdr vals) (make-seq src ((car vals)) tail)))
(else (let ((var-ids (map (lambda (id) (if id (syntax->datum id) '_)) (reverse var-ids))) (else (let ((var-ids (map (lambda (id) (if id (syntax->datum id) '_)) (reverse var-ids)))
(vars (map (lambda (var) (or var (gen-label))) (reverse vars))) (vars (map (lambda (var) (or var (gen-lexical '_))) (reverse vars)))
(vals (map (lambda (expand-expr id) (vals (map (lambda (expand-expr id)
(if id (expand-expr) (make-seq src (expand-expr) (build-void src)))) (if id (expand-expr) (make-seq src (expand-expr) (build-void src))))
(reverse vals) (reverse vals)
@ -2429,8 +2427,8 @@
#f #f
k k
'() '()
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463 tmp-680b775fb37a463-118f tmp-680b775fb37a463-118e)
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-2)) (list (cons tmp-680b775fb37a463-118e tmp-680b775fb37a463-118f) tmp-680b775fb37a463))
template template
pattern pattern
keyword))) keyword)))
@ -2445,11 +2443,11 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-11b0 (map (lambda (tmp-680b775fb37a463-11a9
tmp-680b775fb37a463-11af tmp-680b775fb37a463-11a8
tmp-680b775fb37a463-11ae) tmp-680b775fb37a463-11a7)
(list (cons tmp-680b775fb37a463-11ae tmp-680b775fb37a463-11af) (list (cons tmp-680b775fb37a463-11a7 tmp-680b775fb37a463-11a8)
tmp-680b775fb37a463-11b0)) tmp-680b775fb37a463-11a9))
template template
pattern pattern
keyword))) keyword)))
@ -2461,11 +2459,11 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-11c9 (map (lambda (tmp-680b775fb37a463-11c2
tmp-680b775fb37a463-11c8 tmp-680b775fb37a463-11c1
tmp-680b775fb37a463-11c7) tmp-680b775fb37a463-11c0)
(list (cons tmp-680b775fb37a463-11c7 tmp-680b775fb37a463-11c8) (list (cons tmp-680b775fb37a463-11c0 tmp-680b775fb37a463-11c1)
tmp-680b775fb37a463-11c9)) tmp-680b775fb37a463-11c2))
template template
pattern pattern
keyword))) keyword)))
@ -2481,11 +2479,11 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-11e8 (map (lambda (tmp-680b775fb37a463-11e1
tmp-680b775fb37a463-11e7 tmp-680b775fb37a463-11e0
tmp-680b775fb37a463-11e6) tmp-680b775fb37a463-11df)
(list (cons tmp-680b775fb37a463-11e6 tmp-680b775fb37a463-11e7) (list (cons tmp-680b775fb37a463-11df tmp-680b775fb37a463-11e0)
tmp-680b775fb37a463-11e8)) tmp-680b775fb37a463-11e1))
template template
pattern pattern
keyword))) keyword)))
@ -2613,8 +2611,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-128e)
(list "value" tmp-680b775fb37a463)) (list "value"
tmp-680b775fb37a463-128e))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -2640,9 +2639,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-129d) (map (lambda (tmp-680b775fb37a463)
(list "value" (list "value"
tmp-680b775fb37a463-129d)) tmp-680b775fb37a463))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -2678,8 +2677,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-12b3) (map (lambda (tmp-680b775fb37a463-12a9)
(list "value" tmp-680b775fb37a463-12b3)) (list "value" tmp-680b775fb37a463-12a9))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -2699,8 +2698,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-12b8) (map (lambda (tmp-680b775fb37a463-12ae)
(list "value" tmp-680b775fb37a463-12b8)) (list "value" tmp-680b775fb37a463-12ae))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -2782,7 +2781,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) (cons "vector" t-680b775fb37a463)) (apply (lambda (t-680b775fb37a463-12f7)
(cons "vector" t-680b775fb37a463-12f7))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2792,8 +2792,7 @@
(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-130d) (k (map (lambda (tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463))
(list "quote" tmp-680b775fb37a463-130d))
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))))
@ -2804,8 +2803,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-131c tmp)) (let ((t-680b775fb37a463 tmp))
(list "list->vector" t-680b775fb37a463-131c))))))))))))))))) (list "list->vector" t-680b775fb37a463)))))))))))))))))
(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))))
@ -2817,9 +2816,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-132b) (apply (lambda (t-680b775fb37a463)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463-132b)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2835,14 +2834,13 @@
(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-133f (apply (lambda (t-680b775fb37a463-1 t-680b775fb37a463)
t-680b775fb37a463-133e)
(list (make-syntax (list (make-syntax
'cons 'cons
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-133f t-680b775fb37a463-1
t-680b775fb37a463-133e)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2855,12 +2853,12 @@
(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-134b) (apply (lambda (t-680b775fb37a463)
(cons (make-syntax (cons (make-syntax
'append 'append
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-134b)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2873,12 +2871,12 @@
(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) (apply (lambda (t-680b775fb37a463-134d)
(cons (make-syntax (cons (make-syntax
'vector 'vector
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463)) t-680b775fb37a463-134d))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f

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

@ -1077,7 +1077,6 @@
(case type (case type
((define-form) ((define-form)
(let* ((id (wrap value w mod)) (let* ((id (wrap value w mod))
(label (gen-label))
(var (if (macro-introduced-identifier? id) (var (if (macro-introduced-identifier? id)
(fresh-derived-name id x) (fresh-derived-name id x)
(syntax-expression id)))) (syntax-expression id))))
@ -1100,7 +1099,6 @@
(build-global-definition s mod var (expand e r w mod))))))))) (build-global-definition s mod var (expand e r w mod)))))))))
((define-syntax-form define-syntax-parameter-form) ((define-syntax-form define-syntax-parameter-form)
(let* ((id (wrap value w mod)) (let* ((id (wrap value w mod))
(label (gen-label))
(var (if (macro-introduced-identifier? id) (var (if (macro-introduced-identifier? id)
(fresh-derived-name id x) (fresh-derived-name id x)
(syntax-expression id)))) (syntax-expression id))))
@ -1586,7 +1584,7 @@
(let ((var-ids (map (lambda (id) (let ((var-ids (map (lambda (id)
(if id (syntax->datum id) '_)) (if id (syntax->datum id) '_))
(reverse var-ids))) (reverse var-ids)))
(vars (map (lambda (var) (or var (gen-label))) (vars (map (lambda (var) (or var (gen-lexical '_)))
(reverse vars))) (reverse vars)))
(vals (map (lambda (expand-expr id) (vals (map (lambda (expand-expr id)
(if id (if id