mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 19:50:24 +02:00
Code Activity

psyntax: Generate identifiers in a deterministic fashion.

Browse source 
Fixes <http://bugs.gnu.org/20272>.

* module/ice-9/boot-9.scm (module-generate-unique-id!)
(module-gensym): New procedures.
(module): Add 'next-unique-id' field.
(the-root-module): Inherit 'next-unique-id' value from early stub.
(make-module, make-autoload-interface): Adjust calls to
module-constructor.
* module/ice-9/psyntax.scm (gen-label, new-mark): Generate unique
identifiers from the module name and the per-module unique-id.
(build-lexical-var, generate-temporaries): Use
'module-gensym' instead of 'gensym'.
* module/ice-9/psyntax-pp.scm: Regenerate.
* module/language/tree-il/fix-letrec.scm (fix-letrec!): Use
'module-gensym' instead of 'gensym'.
* module/system/base/syntax.scm (define-record): Likewise.
(transform-record): Likewise.

Co-authored-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
Mark H Weaver 2016-02-12 11:19:38 -05:00 • committed by Ludovic Courtès
parent 70cfabd7e8
commit 84a740d86a
5 changed files with 143 additions and 50 deletions
Download patch file Download diff file Expand all files Collapse all files

41
module/ice-9/boot-9.scm
View file

@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*- ;;; -*- mode: scheme; coding: utf-8; -*-
;;;; Copyright (C) 1995-2014 Free Software Foundation, Inc. ;;;; Copyright (C) 1995-2014, 2016 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -373,6 +373,13 @@ If returning early, return the return value of F."
(define (module-ref module sym) (define (module-ref module sym)
(let ((v (module-variable module sym))) (let ((v (module-variable module sym)))
(if v (variable-ref v) (error "badness!" (pk module) (pk sym))))) (if v (variable-ref v) (error "badness!" (pk module) (pk sym)))))
(define module-generate-unique-id!
(let ((next-id 0))
(lambda (m)
(let ((i next-id))
(set! next-id (+ i 1))
i))))
(define module-gensym gensym)
(define (resolve-module . args) (define (resolve-module . args)
#f) #f)
@ -1982,7 +1989,8 @@ name extensions listed in %load-extensions."
submodules submodules
submodule-binder submodule-binder
public-interface public-interface
filename))) filename
next-unique-id)))
;; make-module &opt size uses binder ;; make-module &opt size uses binder
@ -2005,7 +2013,7 @@ initial uses list, or binding procedure."
(make-hash-table) (make-hash-table)
'() '()
(make-weak-key-hash-table 31) #f (make-weak-key-hash-table 31) #f
(make-hash-table 7) #f #f #f)) (make-hash-table 7) #f #f #f 0))
@ -2542,6 +2550,11 @@ interfaces are added to the inports list."
(let ((m (make-module 0))) (let ((m (make-module 0)))
(set-module-obarray! m (%get-pre-modules-obarray)) (set-module-obarray! m (%get-pre-modules-obarray))
(set-module-name! m '(guile)) (set-module-name! m '(guile))
;; Inherit next-unique-id from preliminary stub of
;; %module-get-next-unique-id! defined above.
(set-module-next-unique-id! m (module-generate-unique-id! #f))
m)) m))
;; The root interface is a module that uses the same obarray as the ;; The root interface is a module that uses the same obarray as the
@ -2570,6 +2583,11 @@ interfaces are added to the inports list."
the-root-module the-root-module
(error "unexpected module to resolve during module boot" name))) (error "unexpected module to resolve during module boot" name)))
(define (module-generate-unique-id! m)
(let ((i (module-next-unique-id m)))
(set-module-next-unique-id! m (+ i 1))
i))
;; Cheat. These bindings are needed by modules.c, but we don't want ;; Cheat. These bindings are needed by modules.c, but we don't want
;; to move their real definition here because that would be unnatural. ;; to move their real definition here because that would be unnatural.
;; ;;
@ -2600,6 +2618,21 @@ interfaces are added to the inports list."
(nested-define-module! (resolve-module '() #f) name mod) (nested-define-module! (resolve-module '() #f) name mod)
(accessor 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) most-positive-fixnum))
"-"
(->string (module-generate-unique-id! m))))
(gensym id)))
(define (make-modules-in module name) (define (make-modules-in module name)
(or (nested-ref-module module name) (or (nested-ref-module module name)
(let ((m (make-module 31))) (let ((m (make-module 31)))
@ -2891,7 +2924,7 @@ error if selected binding does not exist in the used module."
#:warning "Failed to autoload ~a in ~a:\n" sym name)))) #:warning "Failed to autoload ~a in ~a:\n" sym name))))
(module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f (module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f
(make-hash-table 0) '() (make-weak-value-hash-table 31) #f (make-hash-table 0) '() (make-weak-value-hash-table 31) #f
(make-hash-table 0) #f #f #f))) (make-hash-table 0) #f #f #f 0)))
(define (module-autoload! module . args) (define (module-autoload! module . args)
"Have @var{module} automatically load the module named @var{name} when one "Have @var{module} automatically load the module named @var{name} when one

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

@ -295,9 +295,7 @@
(syntax-object-expression x) (syntax-object-expression x)
(join-marks (car w) (car (syntax-object-wrap x)))) (join-marks (car w) (car (syntax-object-wrap x))))
(values x (car w))))) (values x (car w)))))
(gen-label (gen-label (lambda () (symbol->string (module-gensym "l"))))
(lambda ()
(string-append "l-" (session-id) (symbol->string (gensym "-")))))
(gen-labels (gen-labels
(lambda (ls) (lambda (ls)
(if (null? ls) '() (cons (gen-label) (gen-labels (cdr ls)))))) (if (null? ls) '() (cons (gen-label) (gen-labels (cdr ls))))))
@ -994,14 +992,15 @@
(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-1 transformer-environment) (t (lambda (k) (k e r w s rib mod)))) (let* ((t-680b775fb37a463-7fe transformer-environment)
(t-680b775fb37a463-7ff (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-1 t-680b775fb37a463-7fe
t t-680b775fb37a463-7ff
(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))
(gensym (string-append "m-" (session-id) "-"))))))))) (module-gensym "m"))))))))
(expand-body (expand-body
(lambda (body outer-form r w mod) (lambda (body outer-form r w mod)
(let* ((r (cons '("placeholder" placeholder) r)) (let* ((r (cons '("placeholder" placeholder) r))
@ -1532,7 +1531,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) (map (lambda (tmp-680b775fb37a463-aef
tmp-680b775fb37a463-aee
tmp-680b775fb37a463-aed)
(cons tmp-680b775fb37a463-aed
(cons tmp-680b775fb37a463-aee tmp-680b775fb37a463-aef)))
e2* e2*
e1* e1*
args*))) args*)))
@ -1564,7 +1567,7 @@
(gen-var (gen-var
(lambda (id) (lambda (id)
(let ((id (if (syntax-object? id) (syntax-object-expression id) 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-var-list
(lambda (vars) (lambda (vars)
(let lvl ((vars vars) (ls '()) (w '(()))) (let lvl ((vars vars) (ls '()) (w '(())))
@ -1832,7 +1835,11 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) (map (lambda (tmp-680b775fb37a463-cbc
tmp-680b775fb37a463-cbb
tmp-680b775fb37a463-cba)
(cons tmp-680b775fb37a463-cba
(cons tmp-680b775fb37a463-cbb tmp-680b775fb37a463-cbc)))
e2 e2
e1 e1
args))) args)))
@ -1844,7 +1851,11 @@
(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-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) (map (lambda (tmp-680b775fb37a463-cd2
tmp-680b775fb37a463-cd1
tmp-680b775fb37a463-cd0)
(cons tmp-680b775fb37a463-cd0
(cons tmp-680b775fb37a463-cd1 tmp-680b775fb37a463-cd2)))
e2 e2
e1 e1
args))) args)))
@ -1867,7 +1878,11 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) (map (lambda (tmp-680b775fb37a463-cf2
tmp-680b775fb37a463-cf1
tmp-680b775fb37a463-cf0)
(cons tmp-680b775fb37a463-cf0
(cons tmp-680b775fb37a463-cf1 tmp-680b775fb37a463-cf2)))
e2 e2
e1 e1
args))) args)))
@ -1879,7 +1894,11 @@
(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-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) (map (lambda (tmp-680b775fb37a463-d08
tmp-680b775fb37a463-d07
tmp-680b775fb37a463-d06)
(cons tmp-680b775fb37a463-d06
(cons tmp-680b775fb37a463-d07 tmp-680b775fb37a463-d08)))
e2 e2
e1 e1
args))) args)))
@ -2387,7 +2406,7 @@
(if (not (list? x)) (if (not (list? x))
(syntax-violation 'generate-temporaries "invalid argument" 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 (gensym "t-") '((top)) mod)) ls)))) (map (lambda (x) (wrap (module-gensym "t") '((top)) mod)) ls))))
(set! free-identifier=? (set! free-identifier=?
(lambda (x y) (lambda (x y)
(let ((x x)) (let ((x x))
@ -2787,7 +2806,11 @@
#f #f
k k
'() '()
(map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2)) (map (lambda (tmp-680b775fb37a463-115b
tmp-680b775fb37a463-115a
tmp-680b775fb37a463)
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-115a)
tmp-680b775fb37a463-115b))
template template
pattern pattern
keyword))) keyword)))
@ -2803,7 +2826,9 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2)) (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
tmp-680b775fb37a463-2))
template template
pattern pattern
keyword))) keyword)))
@ -2818,7 +2843,11 @@
dots dots
k k
'() '()
(map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2)) (map (lambda (tmp-680b775fb37a463-118d
tmp-680b775fb37a463-118c
tmp-680b775fb37a463-118b)
(list (cons tmp-680b775fb37a463-118b tmp-680b775fb37a463-118c)
tmp-680b775fb37a463-118d))
template template
pattern pattern
keyword))) keyword)))
@ -2834,7 +2863,11 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2)) (map (lambda (tmp-680b775fb37a463-11ac
tmp-680b775fb37a463-11ab
tmp-680b775fb37a463-11aa)
(list (cons tmp-680b775fb37a463-11aa tmp-680b775fb37a463-11ab)
tmp-680b775fb37a463-11ac))
template template
pattern pattern
keyword))) keyword)))
@ -2974,7 +3007,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp) (list "value" tmp)) p) (map (lambda (tmp-680b775fb37a463)
(list "value" tmp-680b775fb37a463))
p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
(quasicons (quasicons
@ -2992,7 +3027,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp) (list "value" tmp)) p) (map (lambda (tmp-680b775fb37a463)
(list "value" tmp-680b775fb37a463))
p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
(quasicons (quasicons
@ -3025,7 +3062,11 @@
(if tmp (if tmp
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (map (lambda (tmp) (list "value" tmp)) p) (vquasi q lev)) (quasilist*
(map (lambda (tmp-680b775fb37a463-122f)
(list "value" tmp-680b775fb37a463-122f))
p)
(vquasi q lev))
(quasicons (quasicons
(quasicons (quasicons
'("quote" #(syntax-object unquote ((top)) (hygiene guile))) '("quote" #(syntax-object unquote ((top)) (hygiene guile)))
@ -3041,7 +3082,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp) (list "value" tmp)) p) (map (lambda (tmp-680b775fb37a463) (list "value" tmp-680b775fb37a463))
p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
(quasicons (quasicons
@ -3129,7 +3171,9 @@
(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) (cons "vector" t)) tmp) (apply (lambda (t-680b775fb37a463-127d)
(cons "vector" t-680b775fb37a463-127d))
tmp)
(syntax-violation (syntax-violation
#f #f
"source expression failed to match any pattern" "source expression failed to match any pattern"
@ -3137,7 +3181,9 @@
(let ((tmp y)) (let ((tmp y))
(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) (k (map (lambda (tmp) (list "quote" tmp)) y))) (apply (lambda (y)
(k (map (lambda (tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463))
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))))
(if tmp-1 (if tmp-1
@ -3146,7 +3192,9 @@
(if tmp-1 (if tmp-1
(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 ((t tmp)) (list "list->vector" t))))))))))))))))) (let ((tmp x))
(let ((t-680b775fb37a463 tmp))
(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))))
@ -3159,7 +3207,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) (cons '#(syntax-object list ((top)) (hygiene guile)) t)) (apply (lambda (t-680b775fb37a463-12a7)
(cons '#(syntax-object list ((top)) (hygiene guile))
t-680b775fb37a463-12a7))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3175,8 +3225,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-1 t) (apply (lambda (t-680b775fb37a463-12bb t-680b775fb37a463-12ba)
(list '#(syntax-object cons ((top)) (hygiene guile)) t-1 t)) (list '#(syntax-object cons ((top)) (hygiene guile))
t-680b775fb37a463-12bb
t-680b775fb37a463-12ba))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3189,8 +3241,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) (apply (lambda (t-680b775fb37a463-12c7)
(cons '#(syntax-object append ((top)) (hygiene guile)) t)) (cons '#(syntax-object append ((top)) (hygiene guile))
t-680b775fb37a463-12c7))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3203,8 +3256,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) (apply (lambda (t-680b775fb37a463-12d3)
(cons '#(syntax-object vector ((top)) (hygiene guile)) t)) (cons '#(syntax-object vector ((top)) (hygiene guile))
t-680b775fb37a463-12d3))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3215,8 +3269,9 @@
(if tmp-1 (if tmp-1
(apply (lambda (x) (apply (lambda (x)
(let ((tmp (emit x))) (let ((tmp (emit x)))
(let ((t tmp)) (let ((t-680b775fb37a463-12df tmp))
(list '#(syntax-object list->vector ((top)) (hygiene guile)) t)))) (list '#(syntax-object list->vector ((top)) (hygiene guile))
t-680b775fb37a463-12df))))
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

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

@ -1,7 +1,7 @@
;;;; -*-scheme-*- ;;;; -*-scheme-*-
;;;; ;;;;
;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010, 2011, ;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010, 2011,
;;;; 2012, 2013, 2015 Free Software Foundation, Inc. ;;;; 2012, 2013, 2015, 2016 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -461,9 +461,10 @@
(make-letrec src in-order? ids vars val-exps body-exp))))) (make-letrec src in-order? ids vars val-exps body-exp)))))
;; FIXME: use a faster gensym
(define-syntax-rule (build-lexical-var src id) (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)) (define-structure (syntax-object expression wrap module))
@ -632,7 +633,7 @@
;; labels must be comparable with "eq?", have read-write invariance, ;; labels must be comparable with "eq?", have read-write invariance,
;; and distinct from symbols. ;; and distinct from symbols.
(define (gen-label) (define (gen-label)
(string-append "l-" (session-id) (symbol->string (gensym "-")))) (symbol->string (module-gensym "l")))
(define gen-labels (define gen-labels
(lambda (ls) (lambda (ls)
@ -661,7 +662,7 @@
(cons 'shift (wrap-subst w))))) (cons 'shift (wrap-subst w)))))
(define-syntax-rule (new-mark) (define-syntax-rule (new-mark)
(gensym (string-append "m-" (session-id) "-"))) (module-gensym "m"))
;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for ;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
;; internal definitions, in which the ribcages are built incrementally ;; internal definitions, in which the ribcages are built incrementally
@ -2717,7 +2718,9 @@
(lambda (ls) (lambda (ls)
(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) (wrap (gensym "t-") top-wrap mod)) ls)))) (map (lambda (x)
(wrap (module-gensym "t") top-wrap mod))
ls))))
(set! free-identifier=? (set! free-identifier=?
(lambda (x y) (lambda (x y)

6
module/language/tree-il/fix-letrec.scm
View file

@ -1,6 +1,6 @@
;;; transformation of letrec into simpler forms ;;; transformation of letrec into simpler forms
;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. ;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2016 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -272,7 +272,9 @@
;; bindings, in a `let' to indicate that order doesn't ;; bindings, in a `let' to indicate that order doesn't
;; matter, and bind to their variables. ;; matter, and bind to their variables.
(list (list
(let ((tmps (map (lambda (x) (gensym)) c))) (let ((tmps (map (lambda (x)
(module-gensym "fixlr"))
c)))
(make-let (make-let
#f (map cadr c) tmps (map caddr c) #f (map cadr c) tmps (map caddr c)
(list->seq (list->seq

8
module/system/base/syntax.scm
View file

@ -1,6 +1,6 @@
;;; Guile VM specific syntaxes and utilities ;;; 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 ;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public ;;; modify it under the terms of the GNU Lesser General Public
@ -72,7 +72,7 @@
'() '()
(cons (car slots) (lp (cdr slots)))))) (cons (car slots) (lp (cdr slots))))))
(opts (list-tail slots (length reqs))) (opts (list-tail slots (length reqs)))
(tail (gensym))) (tail (module-gensym "defrec")))
`(define (,(symbol-append 'make- stem) ,@reqs . ,tail) `(define (,(symbol-append 'make- stem) ,@reqs . ,tail)
(let ,(map (lambda (o) (let ,(map (lambda (o)
`(,(car o) (cond ((null? ,tail) ,(cadr o)) `(,(car o) (cond ((null? ,tail) ,(cadr o))
@ -215,8 +215,8 @@
;; code looks good. ;; code looks good.
(define-macro (transform-record type-and-common record . clauses) (define-macro (transform-record type-and-common record . clauses)
(let ((r (gensym)) (let ((r (module-gensym "rec"))
(rtd (gensym)) (rtd (module-gensym "rtd"))
(type-stem (trim-brackets (car type-and-common)))) (type-stem (trim-brackets (car type-and-common))))
(define (make-stem s) (define (make-stem s)
(symbol-append type-stem '- s)) (symbol-append type-stem '- s))