diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 8ef7e5f..5d0e727 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -390,6 +390,7 @@ If there is no handler at all, Guile prints an error and then exits." (let ((i next-id)) (set! next-id (+ i 1)) i)))) +(define module-gensym gensym) (define (resolve-module . args) #f) @@ -2731,6 +2732,20 @@ VALUE." (nested-define-module! (resolve-module '() #f) name mod) (accessor mod)))))) +(define* (module-gensym #:optional (id " mg") (m (current-module))) + "Return a fresh symbol in the context of module M, based on ID (a +string or symbol). As long as M is a valid module, this procedure is +deterministic." + (define (->string number) + (number->string number 16)) + + (if m + (string->symbol + (string-append id "-" + (->string (hash (module-name m) 10000)) "-" + (->string (module-generate-unique-id! m)))) + (gensym id))) + (define (make-modules-in module name) (or (nested-ref-module module name) (let ((m (make-module 31))) @@ -4322,7 +4337,6 @@ when none is available, reading FILE-NAME with READER." syntax-locally-bound-identifiers syntax-session-id))) - ;;; Place the user in the guile-user module. diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index c81b69e..e46951d 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1483,7 +1483,8 @@ s mod get-formals - (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) + (map (lambda (tmp-c0a-a89 tmp-c0a-a88 tmp-c0a-a87) + (cons tmp-c0a-a87 (cons tmp-c0a-a88 tmp-c0a-a89))) e2* e1* args*))) @@ -1515,7 +1516,7 @@ (gen-var (lambda (id) (let ((id (if (syntax-object? id) (syntax-object-expression id) id))) - (gensym (string-append (symbol->string id) "-"))))) + (module-gensym (symbol->string id))))) (lambda-var-list (lambda (vars) (let lvl ((vars vars) (ls '()) (w '(()))) @@ -1777,7 +1778,8 @@ (apply (lambda (args e1 e2) (build-it '() - (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) + (map (lambda (tmp-c0a-c54 tmp-c0a-c53 tmp-c0a-c52) + (cons tmp-c0a-c52 (cons tmp-c0a-c53 tmp-c0a-c54))) e2 e1 args))) @@ -1789,7 +1791,8 @@ (apply (lambda (docstring args e1 e2) (build-it (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) + (map (lambda (tmp-c0a-c6a tmp-c0a-c69 tmp-c0a-c68) + (cons tmp-c0a-c68 (cons tmp-c0a-c69 tmp-c0a-c6a))) e2 e1 args))) @@ -1812,7 +1815,8 @@ (apply (lambda (args e1 e2) (build-it '() - (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) + (map (lambda (tmp-c0a-c8a tmp-c0a-c89 tmp-c0a-c88) + (cons tmp-c0a-c88 (cons tmp-c0a-c89 tmp-c0a-c8a))) e2 e1 args))) @@ -1824,7 +1828,8 @@ (apply (lambda (docstring args e1 e2) (build-it (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) + (map (lambda (tmp-c0a-ca0 tmp-c0a-c9f tmp-c0a-c9e) + (cons tmp-c0a-c9e (cons tmp-c0a-c9f tmp-c0a-ca0))) e2 e1 args))) @@ -2340,7 +2345,7 @@ (if (not (list? x)) (syntax-violation 'generate-temporaries "invalid argument" x))) (let ((mod (cons 'hygiene (module-name (current-module))))) - (map (lambda (x) (wrap (gensym "t-") '((top)) mod)) ls)))) + (map (lambda (x) (wrap (module-gensym "t-") '((top)) mod)) ls)))) (set! free-identifier=? (lambda (x y) (let ((x x)) @@ -2710,7 +2715,8 @@ #f k '() - (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2)) + (map (lambda (tmp-c0a-1 tmp-c0a tmp-c0a-10ff) + (list (cons tmp-c0a-10ff tmp-c0a) tmp-c0a-1)) template pattern keyword))) @@ -2726,7 +2732,8 @@ #f k (list docstring) - (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2)) + (map (lambda (tmp-c0a-111a tmp-c0a-1 tmp-c0a) + (list (cons tmp-c0a tmp-c0a-1) tmp-c0a-111a)) template pattern keyword))) @@ -2741,7 +2748,8 @@ dots k '() - (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2)) + (map (lambda (tmp-c0a-2 tmp-c0a-1 tmp-c0a) + (list (cons tmp-c0a tmp-c0a-1) tmp-c0a-2)) template pattern keyword))) @@ -2757,7 +2765,8 @@ dots k (list docstring) - (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2)) + (map (lambda (tmp-c0a-2 tmp-c0a-1 tmp-c0a) + (list (cons tmp-c0a tmp-c0a-1) tmp-c0a-2)) template pattern keyword))) @@ -2876,7 +2885,7 @@ (apply (lambda (p) (if (= lev 0) (quasilist* - (map (lambda (tmp) (list "value" tmp)) p) + (map (lambda (tmp-c0a-11b7) (list "value" tmp-c0a-11b7)) p) (quasi q lev)) (quasicons (quasicons @@ -2894,7 +2903,8 @@ (apply (lambda (p) (if (= lev 0) (quasiappend - (map (lambda (tmp) (list "value" tmp)) p) + (map (lambda (tmp-c0a-11bc) (list "value" tmp-c0a-11bc)) + p) (quasi q lev)) (quasicons (quasicons @@ -2927,7 +2937,9 @@ (if tmp (apply (lambda (p) (if (= lev 0) - (quasilist* (map (lambda (tmp) (list "value" tmp)) p) (vquasi q lev)) + (quasilist* + (map (lambda (tmp-c0a-11d2) (list "value" tmp-c0a-11d2)) p) + (vquasi q lev)) (quasicons (quasicons '("quote" #(syntax-object unquote ((top)) (hygiene guile))) @@ -2943,7 +2955,7 @@ (apply (lambda (p) (if (= lev 0) (quasiappend - (map (lambda (tmp) (list "value" tmp)) p) + (map (lambda (tmp-c0a-11d7) (list "value" tmp-c0a-11d7)) p) (vquasi q lev)) (quasicons (quasicons @@ -3031,7 +3043,7 @@ (let ((tmp-1 ls)) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t) (cons "vector" t)) tmp) + (apply (lambda (t--c0a) (cons "vector" t--c0a)) tmp) (syntax-violation #f "source expression failed to match any pattern" @@ -3039,7 +3051,8 @@ (let ((tmp y)) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) (if tmp-1 - (apply (lambda (y) (k (map (lambda (tmp) (list "quote" tmp)) y))) + (apply (lambda (y) + (k (map (lambda (tmp-c0a-122c) (list "quote" tmp-c0a-122c)) y))) tmp-1) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) (if tmp-1 @@ -3048,7 +3061,8 @@ (if tmp-1 (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1) (let ((else tmp)) - (let ((tmp x)) (let ((t tmp)) (list "list->vector" t))))))))))))))))) + (let ((tmp x)) + (let ((t--c0a-123b tmp)) (list "list->vector" t--c0a-123b))))))))))))))))) (emit (lambda (x) (let ((tmp x)) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) @@ -3061,7 +3075,8 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t) (cons '#(syntax-object list ((top)) (hygiene guile)) t)) + (apply (lambda (t--c0a-124a) + (cons '#(syntax-object list ((top)) (hygiene guile)) t--c0a-124a)) tmp) (syntax-violation #f @@ -3077,8 +3092,10 @@ (let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp ($sc-dispatch tmp-1 '(any any)))) (if tmp - (apply (lambda (t-1 t) - (list '#(syntax-object cons ((top)) (hygiene guile)) t-1 t)) + (apply (lambda (t--c0a-125e t--c0a-125d) + (list '#(syntax-object cons ((top)) (hygiene guile)) + t--c0a-125e + t--c0a-125d)) tmp) (syntax-violation #f @@ -3091,8 +3108,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t) - (cons '#(syntax-object append ((top)) (hygiene guile)) t)) + (apply (lambda (t--c0a-126a) + (cons '#(syntax-object append ((top)) (hygiene guile)) + t--c0a-126a)) tmp) (syntax-violation #f @@ -3105,8 +3123,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t) - (cons '#(syntax-object vector ((top)) (hygiene guile)) t)) + (apply (lambda (t--c0a) + (cons '#(syntax-object vector ((top)) (hygiene guile)) + t--c0a)) tmp) (syntax-violation #f @@ -3117,8 +3136,9 @@ (if tmp-1 (apply (lambda (x) (let ((tmp (emit x))) - (let ((t tmp)) - (list '#(syntax-object list->vector ((top)) (hygiene guile)) t)))) + (let ((t--c0a tmp)) + (list '#(syntax-object list->vector ((top)) (hygiene guile)) + t--c0a)))) 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 7d12469..13e15be 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -1,7 +1,7 @@ ;;;; -*-scheme-*- ;;;; ;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010, 2011, -;;;; 2012, 2013 Free Software Foundation, Inc. +;;;; 2012, 2013, 2016 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -460,9 +460,10 @@ (make-letrec src in-order? ids vars val-exps body-exp))))) - ;; FIXME: use a faster gensym (define-syntax-rule (build-lexical-var src id) - (gensym (string-append (symbol->string id) "-"))) + ;; Use a per-module counter instead of the global counter of + ;; 'gensym' so that the generated identifier is reproducible. + (module-gensym (symbol->string id))) (define-structure (syntax-object expression wrap module)) @@ -2598,7 +2599,9 @@ (lambda (ls) (arg-check list? ls 'generate-temporaries) (let ((mod (cons 'hygiene (module-name (current-module))))) - (map (lambda (x) (wrap (gensym "t-") top-wrap mod)) ls)))) + (map (lambda (x) + (wrap (module-gensym "t-") top-wrap mod)) + ls)))) (set! free-identifier=? (lambda (x y) diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm index 60c87e3..23d37a8 100644 --- a/module/language/tree-il/fix-letrec.scm +++ b/module/language/tree-il/fix-letrec.scm @@ -1,6 +1,6 @@ ;;; transformation of letrec into simpler forms -;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2009, 2010, 2011, 2012, 2016 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -267,7 +267,9 @@ ;; bindings, in a `let' to indicate that order doesn't ;; matter, and bind to their variables. (list - (let ((tmps (map (lambda (x) (gensym)) c))) + (let ((tmps (map (lambda (x) + (module-gensym "fixlr")) + c))) (make-let #f (map cadr c) tmps (map caddr c) (make-sequence diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm index 249961d..d280869 100644 --- a/module/system/base/syntax.scm +++ b/module/system/base/syntax.scm @@ -1,6 +1,6 @@ ;;; Guile VM specific syntaxes and utilities -;; Copyright (C) 2001, 2009 Free Software Foundation, Inc +;; Copyright (C) 2001, 2009, 2016 Free Software Foundation, Inc ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -72,7 +72,7 @@ '() (cons (car slots) (lp (cdr slots)))))) (opts (list-tail slots (length reqs))) - (tail (gensym))) + (tail (module-gensym "defrec"))) `(define (,(symbol-append 'make- stem) ,@reqs . ,tail) (let ,(map (lambda (o) `(,(car o) (cond ((null? ,tail) ,(cadr o)) @@ -243,8 +243,8 @@ ;; code looks good. (define-macro (transform-record type-and-common record . clauses) - (let ((r (gensym)) - (rtd (gensym)) + (let ((r (module-gensym "rec")) + (rtd (module-gensym "rtd")) (type-stem (trim-brackets (car type-and-common)))) (define (make-stem s) (symbol-append type-stem '- s))