diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index bd90b37b4..d32429733 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -141,6 +141,7 @@ (begin (for-each maybe-name-value! ids val-exps) (make-letrec src in-order? ids vars val-exps body-exp))))) + (gen-lexical (lambda (id) (module-gensym (symbol->string id)))) (datum-sourcev (lambda (datum) (let ((props (source-properties datum))) @@ -796,11 +797,11 @@ (source-wrap e w (cdr w) mod) x)) (else (decorate-source x)))))) - (let* ((t-680b775fb37a463-e02 transformer-environment) - (t-680b775fb37a463-e03 (lambda (k) (k e r w s rib mod)))) + (let* ((t-680b775fb37a463-df9 transformer-environment) + (t-680b775fb37a463-dfa (lambda (k) (k e r w s rib mod)))) (with-fluid* - t-680b775fb37a463-e02 - t-680b775fb37a463-e03 + t-680b775fb37a463-df9 + t-680b775fb37a463-dfa (lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (module-gensym "m")))))))) (expand-body (lambda (body outer-form r w mod) @@ -1330,11 +1331,11 @@ s mod get-formals - (map (lambda (tmp-680b775fb37a463-1 - tmp-680b775fb37a463 - tmp-680b775fb37a463-107f) - (cons tmp-680b775fb37a463-107f - (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1))) + (map (lambda (tmp-680b775fb37a463-2 + tmp-680b775fb37a463-1 + tmp-680b775fb37a463) + (cons tmp-680b775fb37a463 + (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) e2* e1* args*))) @@ -1356,8 +1357,7 @@ ((pair? x) (cons (strip (car x)) (strip (cdr x)))) ((vector? x) (list->vector (strip (vector->list x)))) (else x))))) - (gen-var - (lambda (id) (let ((id (if (syntax? id) (syntax-expression id) id))) (module-gensym (symbol->string id))))) + (gen-var (lambda (id) (let ((id (if (syntax? id) (syntax-expression id) id))) (gen-lexical id)))) (lambda-var-list (lambda (vars) (let lvl ((vars vars) (ls '()) (w '(()))) @@ -1603,8 +1603,8 @@ (apply (lambda (args e1 e2) (build-it '() - (map (lambda (tmp-680b775fb37a463-6c3 tmp-680b775fb37a463-6c2 tmp-680b775fb37a463-6c1) - (cons tmp-680b775fb37a463-6c1 (cons tmp-680b775fb37a463-6c2 tmp-680b775fb37a463-6c3))) + (map (lambda (tmp-680b775fb37a463-6b8 tmp-680b775fb37a463-6b7 tmp-680b775fb37a463-6b6) + (cons tmp-680b775fb37a463-6b6 (cons tmp-680b775fb37a463-6b7 tmp-680b775fb37a463-6b8))) e2 e1 args))) @@ -1614,9 +1614,9 @@ (apply (lambda (docstring args e1 e2) (build-it (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-680b775fb37a463-6d9 tmp-680b775fb37a463-6d8 tmp-680b775fb37a463-6d7) - (cons tmp-680b775fb37a463-6d7 - (cons tmp-680b775fb37a463-6d8 tmp-680b775fb37a463-6d9))) + (map (lambda (tmp-680b775fb37a463-6ce tmp-680b775fb37a463-6cd tmp-680b775fb37a463-6cc) + (cons tmp-680b775fb37a463-6cc + (cons tmp-680b775fb37a463-6cd tmp-680b775fb37a463-6ce))) e2 e1 args))) @@ -1636,8 +1636,8 @@ (apply (lambda (args e1 e2) (build-it '() - (map (lambda (tmp-680b775fb37a463-68d tmp-680b775fb37a463-68c tmp-680b775fb37a463-68b) - (cons tmp-680b775fb37a463-68b (cons tmp-680b775fb37a463-68c tmp-680b775fb37a463-68d))) + (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) + (cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) e2 e1 args))) @@ -1647,9 +1647,8 @@ (apply (lambda (docstring args e1 e2) (build-it (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-680b775fb37a463-6a3 tmp-680b775fb37a463-6a2 tmp-680b775fb37a463-6a1) - (cons tmp-680b775fb37a463-6a1 - (cons tmp-680b775fb37a463-6a2 tmp-680b775fb37a463-6a3))) + (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) + (cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) e2 e1 args))) @@ -2112,7 +2111,7 @@ (lambda (ls) (let ((x ls)) (if (not (list? x)) (syntax-violation 'generate-temporaries "invalid argument" x))) (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=? (lambda (x y) (let ((x x)) (if (not (nonsymbol-id? x)) (syntax-violation 'free-identifier=? "invalid argument" x))) @@ -2430,9 +2429,8 @@ #f k '() - (map (lambda (tmp-680b775fb37a463-11a1 tmp-680b775fb37a463-11a0 tmp-680b775fb37a463-119f) - (list (cons tmp-680b775fb37a463-119f tmp-680b775fb37a463-11a0) - tmp-680b775fb37a463-11a1)) + (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) + (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-2)) template pattern keyword))) @@ -2447,11 +2445,11 @@ #f k (list docstring) - (map (lambda (tmp-680b775fb37a463-11ba - tmp-680b775fb37a463-11b9 - tmp-680b775fb37a463-11b8) - (list (cons tmp-680b775fb37a463-11b8 tmp-680b775fb37a463-11b9) - tmp-680b775fb37a463-11ba)) + (map (lambda (tmp-680b775fb37a463-11b0 + tmp-680b775fb37a463-11af + tmp-680b775fb37a463-11ae) + (list (cons tmp-680b775fb37a463-11ae tmp-680b775fb37a463-11af) + tmp-680b775fb37a463-11b0)) template pattern keyword))) @@ -2463,11 +2461,11 @@ dots k '() - (map (lambda (tmp-680b775fb37a463-11d3 - tmp-680b775fb37a463-11d2 - tmp-680b775fb37a463-11d1) - (list (cons tmp-680b775fb37a463-11d1 tmp-680b775fb37a463-11d2) - tmp-680b775fb37a463-11d3)) + (map (lambda (tmp-680b775fb37a463-11c9 + tmp-680b775fb37a463-11c8 + tmp-680b775fb37a463-11c7) + (list (cons tmp-680b775fb37a463-11c7 tmp-680b775fb37a463-11c8) + tmp-680b775fb37a463-11c9)) template pattern keyword))) @@ -2483,11 +2481,11 @@ dots k (list docstring) - (map (lambda (tmp-680b775fb37a463-11f2 - tmp-680b775fb37a463-11f1 - tmp-680b775fb37a463-11f0) - (list (cons tmp-680b775fb37a463-11f0 tmp-680b775fb37a463-11f1) - tmp-680b775fb37a463-11f2)) + (map (lambda (tmp-680b775fb37a463-11e8 + tmp-680b775fb37a463-11e7 + tmp-680b775fb37a463-11e6) + (list (cons tmp-680b775fb37a463-11e6 tmp-680b775fb37a463-11e7) + tmp-680b775fb37a463-11e8)) template pattern keyword))) @@ -2615,9 +2613,8 @@ (apply (lambda (p) (if (= lev 0) (quasilist* - (map (lambda (tmp-680b775fb37a463-12a2) - (list "value" - tmp-680b775fb37a463-12a2)) + (map (lambda (tmp-680b775fb37a463) + (list "value" tmp-680b775fb37a463)) p) (quasi q lev)) (quasicons @@ -2643,9 +2640,9 @@ (apply (lambda (p) (if (= lev 0) (quasiappend - (map (lambda (tmp-680b775fb37a463-12a7) + (map (lambda (tmp-680b775fb37a463-129d) (list "value" - tmp-680b775fb37a463-12a7)) + tmp-680b775fb37a463-129d)) p) (quasi q lev)) (quasicons @@ -2681,8 +2678,8 @@ (apply (lambda (p) (if (= lev 0) (quasilist* - (map (lambda (tmp-680b775fb37a463-12bd) - (list "value" tmp-680b775fb37a463-12bd)) + (map (lambda (tmp-680b775fb37a463-12b3) + (list "value" tmp-680b775fb37a463-12b3)) p) (vquasi q lev)) (quasicons @@ -2702,8 +2699,8 @@ (apply (lambda (p) (if (= lev 0) (quasiappend - (map (lambda (tmp-680b775fb37a463-12c2) - (list "value" tmp-680b775fb37a463-12c2)) + (map (lambda (tmp-680b775fb37a463-12b8) + (list "value" tmp-680b775fb37a463-12b8)) p) (vquasi q lev)) (quasicons @@ -2785,8 +2782,7 @@ (let ((tmp-1 ls)) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-130b) - (cons "vector" t-680b775fb37a463-130b)) + (apply (lambda (t-680b775fb37a463) (cons "vector" t-680b775fb37a463)) tmp) (syntax-violation #f @@ -2796,7 +2792,8 @@ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) (if tmp-1 (apply (lambda (y) - (k (map (lambda (tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463)) + (k (map (lambda (tmp-680b775fb37a463-130d) + (list "quote" tmp-680b775fb37a463-130d)) y))) tmp-1) (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) (let ((else tmp)) (let ((tmp x)) - (let ((t-680b775fb37a463 tmp)) - (list "list->vector" t-680b775fb37a463))))))))))))))))) + (let ((t-680b775fb37a463-131c tmp)) + (list "list->vector" t-680b775fb37a463-131c))))))))))))))))) (emit (lambda (x) (let ((tmp x)) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) @@ -2820,9 +2817,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463) + (apply (lambda (t-680b775fb37a463-132b) (cons (make-syntax 'list '((top)) '(hygiene guile)) - t-680b775fb37a463)) + t-680b775fb37a463-132b)) tmp) (syntax-violation #f @@ -2838,13 +2835,14 @@ (let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp ($sc-dispatch tmp-1 '(any any)))) (if tmp - (apply (lambda (t-680b775fb37a463-1 t-680b775fb37a463) + (apply (lambda (t-680b775fb37a463-133f + t-680b775fb37a463-133e) (list (make-syntax 'cons '((top)) '(hygiene guile)) - t-680b775fb37a463-1 - t-680b775fb37a463)) + t-680b775fb37a463-133f + t-680b775fb37a463-133e)) tmp) (syntax-violation #f @@ -2857,12 +2855,12 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463) + (apply (lambda (t-680b775fb37a463-134b) (cons (make-syntax 'append '((top)) '(hygiene guile)) - t-680b775fb37a463)) + t-680b775fb37a463-134b)) tmp) (syntax-violation #f @@ -2891,12 +2889,12 @@ (if tmp-1 (apply (lambda (x) (let ((tmp (emit x))) - (let ((t-680b775fb37a463-136d tmp)) + (let ((t-680b775fb37a463 tmp)) (list (make-syntax 'list->vector '((top)) '(hygiene guile)) - t-680b775fb37a463-136d)))) + t-680b775fb37a463)))) tmp-1) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any)))) (if tmp-1 diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 7ca6bfafa..7ce94df2f 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -352,9 +352,17 @@ (make-letrec src in-order? ids vars val-exps body-exp))))) - (define-syntax-rule (build-lexical-var src id) - ;; Use a per-module counter instead of the global counter of - ;; 'gensym' so that the generated identifier is reproducible. + (define (gen-lexical id) + ;; Generate a unique symbol for a lexical variable. These need to + ;; 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))) (define-syntax no-source (identifier-syntax #f)) @@ -414,7 +422,7 @@ ;; (ellipsis . ) custom ellipsis ;; (displaced-lexical) displaced lexicals ;; ::= - ;; ::= variable returned by build-lexical-var + ;; ::= symbol returned by gen-lexical ;; a macro is a user-defined syntactic-form. a core is a ;; system-defined syntactic form. begin, define, define-syntax, @@ -1965,7 +1973,7 @@ (define gen-var (lambda (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 (define lambda-var-list @@ -2747,7 +2755,7 @@ (arg-check list? ls 'generate-temporaries) (let ((mod (cons 'hygiene (module-name (current-module))))) (map (lambda (x) - (wrap (module-gensym "t") top-wrap mod)) + (wrap (gen-var 't) top-wrap mod)) ls)))) (set! free-identifier=?