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: Clean up lexical gensym creation

Browse source 
* module/ice-9/psyntax.scm (gen-lexical): Add a nice comment.  Rename
from build-lexical-var, and remove unused src argument.
(gen-var, generate-temporaries): Use gen-lexical.
* module/ice-9/psyntax-pp.scm: Regenerate.
This commit is contained in:
Andy Wingo 2024-11-14 14:34:20 +01:00
parent bb7154fb80
commit ebbb10c92d
2 changed files with 75 additions and 69 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -141,6 +141,7 @@
(begin (begin
(for-each maybe-name-value! ids val-exps) (for-each maybe-name-value! ids val-exps)
(make-letrec src in-order? ids vars val-exps body-exp))))) (make-letrec src in-order? ids vars val-exps body-exp)))))
(gen-lexical (lambda (id) (module-gensym (symbol->string id))))
(datum-sourcev (datum-sourcev
(lambda (datum) (lambda (datum)
(let ((props (source-properties datum))) (let ((props (source-properties datum)))
@ -796,11 +797,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-e02 transformer-environment) (let* ((t-680b775fb37a463-df9 transformer-environment)
(t-680b775fb37a463-e03 (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-dfa (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-e02 t-680b775fb37a463-df9
t-680b775fb37a463-e03 t-680b775fb37a463-dfa
(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)
@ -1330,11 +1331,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-1 (map (lambda (tmp-680b775fb37a463-2
tmp-680b775fb37a463 tmp-680b775fb37a463-1
tmp-680b775fb37a463-107f) tmp-680b775fb37a463)
(cons tmp-680b775fb37a463-107f (cons tmp-680b775fb37a463
(cons tmp-680b775fb37a463 tmp-680b775fb37a463-1))) (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
e2* e2*
e1* e1*
args*))) args*)))
@ -1356,8 +1357,7 @@
((pair? x) (cons (strip (car x)) (strip (cdr x)))) ((pair? x) (cons (strip (car x)) (strip (cdr x))))
((vector? x) (list->vector (strip (vector->list x)))) ((vector? x) (list->vector (strip (vector->list x))))
(else x))))) (else x)))))
(gen-var (gen-var (lambda (id) (let ((id (if (syntax? id) (syntax-expression id) id))) (gen-lexical id))))
(lambda (id) (let ((id (if (syntax? id) (syntax-expression id) id))) (module-gensym (symbol->string id)))))
(lambda-var-list (lambda-var-list
(lambda (vars) (lambda (vars)
(let lvl ((vars vars) (ls '()) (w '(()))) (let lvl ((vars vars) (ls '()) (w '(())))
@ -1603,8 +1603,8 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-6c3 tmp-680b775fb37a463-6c2 tmp-680b775fb37a463-6c1) (map (lambda (tmp-680b775fb37a463-6b8 tmp-680b775fb37a463-6b7 tmp-680b775fb37a463-6b6)
(cons tmp-680b775fb37a463-6c1 (cons tmp-680b775fb37a463-6c2 tmp-680b775fb37a463-6c3))) (cons tmp-680b775fb37a463-6b6 (cons tmp-680b775fb37a463-6b7 tmp-680b775fb37a463-6b8)))
e2 e2
e1 e1
args))) args)))
@ -1614,9 +1614,9 @@
(apply (lambda (docstring args e1 e2) (apply (lambda (docstring args e1 e2)
(build-it (build-it
(list (cons 'documentation (syntax->datum docstring))) (list (cons 'documentation (syntax->datum docstring)))
(map (lambda (tmp-680b775fb37a463-6d9 tmp-680b775fb37a463-6d8 tmp-680b775fb37a463-6d7) (map (lambda (tmp-680b775fb37a463-6ce tmp-680b775fb37a463-6cd tmp-680b775fb37a463-6cc)
(cons tmp-680b775fb37a463-6d7 (cons tmp-680b775fb37a463-6cc
(cons tmp-680b775fb37a463-6d8 tmp-680b775fb37a463-6d9))) (cons tmp-680b775fb37a463-6cd tmp-680b775fb37a463-6ce)))
e2 e2
e1 e1
args))) args)))
@ -1636,8 +1636,8 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-68d tmp-680b775fb37a463-68c tmp-680b775fb37a463-68b) (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(cons tmp-680b775fb37a463-68b (cons tmp-680b775fb37a463-68c tmp-680b775fb37a463-68d))) (cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
e2 e2
e1 e1
args))) args)))
@ -1647,9 +1647,8 @@
(apply (lambda (docstring args e1 e2) (apply (lambda (docstring args e1 e2)
(build-it (build-it
(list (cons 'documentation (syntax->datum docstring))) (list (cons 'documentation (syntax->datum docstring)))
(map (lambda (tmp-680b775fb37a463-6a3 tmp-680b775fb37a463-6a2 tmp-680b775fb37a463-6a1) (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(cons tmp-680b775fb37a463-6a1 (cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
(cons tmp-680b775fb37a463-6a2 tmp-680b775fb37a463-6a3)))
e2 e2
e1 e1
args))) args)))
@ -2112,7 +2111,7 @@
(lambda (ls) (lambda (ls)
(let ((x ls)) (if (not (list? x)) (syntax-violation 'generate-temporaries "invalid argument" x))) (let ((x ls)) (if (not (list? x)) (syntax-violation 'generate-temporaries "invalid argument" x)))
(let ((mod (cons 'hygiene (module-name (current-module))))) (let ((mod (cons 'hygiene (module-name (current-module)))))
(map (lambda (x) (wrap (module-gensym "t") '((top)) mod)) ls)))) (map (lambda (x) (wrap (gen-var 't) '((top)) mod)) ls))))
(set! free-identifier=? (set! free-identifier=?
(lambda (x y) (lambda (x y)
(let ((x x)) (if (not (nonsymbol-id? x)) (syntax-violation 'free-identifier=? "invalid argument" x))) (let ((x x)) (if (not (nonsymbol-id? x)) (syntax-violation 'free-identifier=? "invalid argument" x)))
@ -2430,9 +2429,8 @@
#f #f
k k
'() '()
(map (lambda (tmp-680b775fb37a463-11a1 tmp-680b775fb37a463-11a0 tmp-680b775fb37a463-119f) (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(list (cons tmp-680b775fb37a463-119f tmp-680b775fb37a463-11a0) (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-2))
tmp-680b775fb37a463-11a1))
template template
pattern pattern
keyword))) keyword)))
@ -2447,11 +2445,11 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-11ba (map (lambda (tmp-680b775fb37a463-11b0
tmp-680b775fb37a463-11b9 tmp-680b775fb37a463-11af
tmp-680b775fb37a463-11b8) tmp-680b775fb37a463-11ae)
(list (cons tmp-680b775fb37a463-11b8 tmp-680b775fb37a463-11b9) (list (cons tmp-680b775fb37a463-11ae tmp-680b775fb37a463-11af)
tmp-680b775fb37a463-11ba)) tmp-680b775fb37a463-11b0))
template template
pattern pattern
keyword))) keyword)))
@ -2463,11 +2461,11 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-11d3 (map (lambda (tmp-680b775fb37a463-11c9
tmp-680b775fb37a463-11d2 tmp-680b775fb37a463-11c8
tmp-680b775fb37a463-11d1) tmp-680b775fb37a463-11c7)
(list (cons tmp-680b775fb37a463-11d1 tmp-680b775fb37a463-11d2) (list (cons tmp-680b775fb37a463-11c7 tmp-680b775fb37a463-11c8)
tmp-680b775fb37a463-11d3)) tmp-680b775fb37a463-11c9))
template template
pattern pattern
keyword))) keyword)))
@ -2483,11 +2481,11 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-11f2 (map (lambda (tmp-680b775fb37a463-11e8
tmp-680b775fb37a463-11f1 tmp-680b775fb37a463-11e7
tmp-680b775fb37a463-11f0) tmp-680b775fb37a463-11e6)
(list (cons tmp-680b775fb37a463-11f0 tmp-680b775fb37a463-11f1) (list (cons tmp-680b775fb37a463-11e6 tmp-680b775fb37a463-11e7)
tmp-680b775fb37a463-11f2)) tmp-680b775fb37a463-11e8))
template template
pattern pattern
keyword))) keyword)))
@ -2615,9 +2613,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-12a2) (map (lambda (tmp-680b775fb37a463)
(list "value" (list "value" tmp-680b775fb37a463))
tmp-680b775fb37a463-12a2))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -2643,9 +2640,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-12a7) (map (lambda (tmp-680b775fb37a463-129d)
(list "value" (list "value"
tmp-680b775fb37a463-12a7)) tmp-680b775fb37a463-129d))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -2681,8 +2678,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-12bd) (map (lambda (tmp-680b775fb37a463-12b3)
(list "value" tmp-680b775fb37a463-12bd)) (list "value" tmp-680b775fb37a463-12b3))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -2702,8 +2699,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-12c2) (map (lambda (tmp-680b775fb37a463-12b8)
(list "value" tmp-680b775fb37a463-12c2)) (list "value" tmp-680b775fb37a463-12b8))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -2785,8 +2782,7 @@
(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-130b) (apply (lambda (t-680b775fb37a463) (cons "vector" t-680b775fb37a463))
(cons "vector" t-680b775fb37a463-130b))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2796,7 +2792,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) (list "quote" tmp-680b775fb37a463)) (k (map (lambda (tmp-680b775fb37a463-130d)
(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))))
@ -2807,8 +2804,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 tmp)) (let ((t-680b775fb37a463-131c tmp))
(list "list->vector" t-680b775fb37a463))))))))))))))))) (list "list->vector" t-680b775fb37a463-131c)))))))))))))))))
(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))))
@ -2820,9 +2817,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) (apply (lambda (t-680b775fb37a463-132b)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463)) t-680b775fb37a463-132b))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2838,13 +2835,14 @@
(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-1 t-680b775fb37a463) (apply (lambda (t-680b775fb37a463-133f
t-680b775fb37a463-133e)
(list (make-syntax (list (make-syntax
'cons 'cons
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-1 t-680b775fb37a463-133f
t-680b775fb37a463)) t-680b775fb37a463-133e))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2857,12 +2855,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-134b)
(cons (make-syntax (cons (make-syntax
'append 'append
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463)) t-680b775fb37a463-134b))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2891,12 +2889,12 @@
(if tmp-1 (if tmp-1
(apply (lambda (x) (apply (lambda (x)
(let ((tmp (emit x))) (let ((tmp (emit x)))
(let ((t-680b775fb37a463-136d tmp)) (let ((t-680b775fb37a463 tmp))
(list (make-syntax (list (make-syntax
'list->vector 'list->vector
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-136d)))) t-680b775fb37a463))))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
(if tmp-1 (if tmp-1

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

@ -352,9 +352,17 @@
(make-letrec src in-order? ids vars val-exps body-exp))))) (make-letrec src in-order? ids vars val-exps body-exp)))))
(define-syntax-rule (build-lexical-var src id) (define (gen-lexical id)
;; Use a per-module counter instead of the global counter of ;; Generate a unique symbol for a lexical variable. These need to
;; 'gensym' so that the generated identifier is reproducible. ;; be symbols as they are embedded in Tree-IL. Lexicals from
;; different separately compiled modules can coexist, for example
;; if a macro defined in module A is used in a separately-compiled
;; module B, so they do need to be unique. However we assume that
;; generally a module corresponds to a compilation unit, so there
;; is no need to be unique across separately-compiled instances of
;; the same module, and that therefore we can use a deterministic
;; per-module counter instead of the global counter of 'gensym' so
;; that the generated identifier is reproducible.
(module-gensym (symbol->string id))) (module-gensym (symbol->string id)))
(define-syntax no-source (identifier-syntax #f)) (define-syntax no-source (identifier-syntax #f))
@ -414,7 +422,7 @@
;; (ellipsis . <identifier>) custom ellipsis ;; (ellipsis . <identifier>) custom ellipsis
;; (displaced-lexical) displaced lexicals ;; (displaced-lexical) displaced lexicals
;; <level> ::= <non-negative integer> ;; <level> ::= <non-negative integer>
;; <var> ::= variable returned by build-lexical-var ;; <var> ::= symbol returned by gen-lexical
;; a macro is a user-defined syntactic-form. a core is a ;; a macro is a user-defined syntactic-form. a core is a
;; system-defined syntactic form. begin, define, define-syntax, ;; system-defined syntactic form. begin, define, define-syntax,
@ -1965,7 +1973,7 @@
(define gen-var (define gen-var
(lambda (id) (lambda (id)
(let ((id (if (syntax? id) (syntax-expression id) id))) (let ((id (if (syntax? id) (syntax-expression id) id)))
(build-lexical-var no-source id)))) (gen-lexical id))))
;; appears to return a reversed list ;; appears to return a reversed list
(define lambda-var-list (define lambda-var-list
@ -2747,7 +2755,7 @@
(arg-check list? ls 'generate-temporaries) (arg-check list? ls 'generate-temporaries)
(let ((mod (cons 'hygiene (module-name (current-module))))) (let ((mod (cons 'hygiene (module-name (current-module)))))
(map (lambda (x) (map (lambda (x)
(wrap (module-gensym "t") top-wrap mod)) (wrap (gen-var 't) top-wrap mod))
ls)))) ls))))
(set! free-identifier=? (set! free-identifier=?