mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-11 22:31:12 +02:00
psyntax: Generate identifiers in a deterministic fashion.
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
Ludovic Courtès
parent
54b43451ef
commit
458ae248ab
5 changed files with 106 additions and 47 deletions
|
|
@ -1,6 +1,6 @@
|
|||
;;; -*- 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
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -384,6 +384,13 @@ If there is no handler at all, Guile prints an error and then exits."
|
|||
(define (module-ref module sym)
|
||||
(let ((v (module-variable module 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)
|
||||
#f)
|
||||
|
||||
|
|
@ -2021,7 +2028,8 @@ VALUE."
|
|||
submodules
|
||||
submodule-binder
|
||||
public-interface
|
||||
filename)))
|
||||
filename
|
||||
next-unique-id)))
|
||||
|
||||
|
||||
;; make-module &opt size uses binder
|
||||
|
|
@ -2049,7 +2057,7 @@ VALUE."
|
|||
(make-hash-table %default-import-size)
|
||||
'()
|
||||
(make-weak-key-hash-table 31) #f
|
||||
(make-hash-table 7) #f #f #f))
|
||||
(make-hash-table 7) #f #f #f 0))
|
||||
|
||||
|
||||
|
||||
|
|
@ -2656,6 +2664,11 @@ VALUE."
|
|||
(let ((m (make-module 0)))
|
||||
(set-module-obarray! m (%get-pre-modules-obarray))
|
||||
(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))
|
||||
|
||||
;; The root interface is a module that uses the same obarray as the
|
||||
|
|
@ -2684,6 +2697,11 @@ VALUE."
|
|||
the-root-module
|
||||
(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
|
||||
;; to move their real definition here because that would be unnatural.
|
||||
;;
|
||||
|
|
@ -2714,6 +2732,21 @@ 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) most-positive-fixnum))
|
||||
"-"
|
||||
(->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)))
|
||||
|
|
@ -3013,7 +3046,7 @@ VALUE."
|
|||
#:warning "Failed to autoload ~a in ~a:\n" sym name))))
|
||||
(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) #f #f #f)))
|
||||
(make-hash-table 0) #f #f #f 0)))
|
||||
|
||||
(define (module-autoload! module . args)
|
||||
"Have @var{module} automatically load the module named @var{name} when one
|
||||
|
|
|
|||
|
|
@ -310,9 +310,7 @@
|
|||
(syntax-object-expression x)
|
||||
(join-marks (car w) (car (syntax-object-wrap x))))
|
||||
(values x (car w)))))
|
||||
(gen-label
|
||||
(lambda ()
|
||||
(string-append "l-" (session-id) (symbol->string (gensym "-")))))
|
||||
(gen-label (lambda () (symbol->string (module-gensym "l"))))
|
||||
(gen-labels
|
||||
(lambda (ls)
|
||||
(if (null? ls) '() (cons (gen-label) (gen-labels (cdr ls))))))
|
||||
|
|
@ -960,7 +958,7 @@
|
|||
((transformer-environment (lambda (k) (k e r w s rib mod))))
|
||||
(rebuild-macro-output
|
||||
(p (source-wrap e (anti-mark w) s mod))
|
||||
(gensym (string-append "m-" (session-id) "-")))))))
|
||||
(module-gensym "m"))))))
|
||||
(expand-body
|
||||
(lambda (body outer-form r w mod)
|
||||
(let* ((r (cons '("placeholder" placeholder) r))
|
||||
|
|
@ -1472,7 +1470,8 @@
|
|||
s
|
||||
mod
|
||||
get-formals
|
||||
(map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
|
||||
(map (lambda (tmp-bde397a-a85 tmp-bde397a-a84 tmp-bde397a-a83)
|
||||
(cons tmp-bde397a-a83 (cons tmp-bde397a-a84 tmp-bde397a-a85)))
|
||||
e2*
|
||||
e1*
|
||||
args*)))
|
||||
|
|
@ -1504,7 +1503,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 '(())))
|
||||
|
|
@ -1766,7 +1765,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-bde397a-c50 tmp-bde397a-c4f tmp-bde397a-c4e)
|
||||
(cons tmp-bde397a-c4e (cons tmp-bde397a-c4f tmp-bde397a-c50)))
|
||||
e2
|
||||
e1
|
||||
args)))
|
||||
|
|
@ -1778,7 +1778,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-bde397a-c66 tmp-bde397a-c65 tmp-bde397a-c64)
|
||||
(cons tmp-bde397a-c64 (cons tmp-bde397a-c65 tmp-bde397a-c66)))
|
||||
e2
|
||||
e1
|
||||
args)))
|
||||
|
|
@ -1801,7 +1802,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-bde397a-c86 tmp-bde397a-c85 tmp-bde397a-c84)
|
||||
(cons tmp-bde397a-c84 (cons tmp-bde397a-c85 tmp-bde397a-c86)))
|
||||
e2
|
||||
e1
|
||||
args)))
|
||||
|
|
@ -1813,7 +1815,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-bde397a-c9c tmp-bde397a-c9b tmp-bde397a-c9a)
|
||||
(cons tmp-bde397a-c9a (cons tmp-bde397a-c9b tmp-bde397a-c9c)))
|
||||
e2
|
||||
e1
|
||||
args)))
|
||||
|
|
@ -2329,7 +2332,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))
|
||||
|
|
@ -2699,7 +2702,8 @@
|
|||
#f
|
||||
k
|
||||
'()
|
||||
(map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
|
||||
(map (lambda (tmp-bde397a-10fd tmp-bde397a-10fc tmp-bde397a-10fb)
|
||||
(list (cons tmp-bde397a-10fb tmp-bde397a-10fc) tmp-bde397a-10fd))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
|
|
@ -2715,7 +2719,8 @@
|
|||
#f
|
||||
k
|
||||
(list docstring)
|
||||
(map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
|
||||
(map (lambda (tmp-bde397a-2 tmp-bde397a-1 tmp-bde397a)
|
||||
(list (cons tmp-bde397a tmp-bde397a-1) tmp-bde397a-2))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
|
|
@ -2730,7 +2735,8 @@
|
|||
dots
|
||||
k
|
||||
'()
|
||||
(map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
|
||||
(map (lambda (tmp-bde397a-112f tmp-bde397a-112e tmp-bde397a-112d)
|
||||
(list (cons tmp-bde397a-112d tmp-bde397a-112e) tmp-bde397a-112f))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
|
|
@ -2746,7 +2752,8 @@
|
|||
dots
|
||||
k
|
||||
(list docstring)
|
||||
(map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
|
||||
(map (lambda (tmp-bde397a-114e tmp-bde397a-114d tmp-bde397a-114c)
|
||||
(list (cons tmp-bde397a-114c tmp-bde397a-114d) tmp-bde397a-114e))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
|
|
@ -2865,7 +2872,9 @@
|
|||
(apply (lambda (p)
|
||||
(if (= lev 0)
|
||||
(quasilist*
|
||||
(map (lambda (tmp) (list "value" tmp)) p)
|
||||
(map (lambda (tmp-bde397a-11b3)
|
||||
(list "value" tmp-bde397a-11b3))
|
||||
p)
|
||||
(quasi q lev))
|
||||
(quasicons
|
||||
(quasicons
|
||||
|
|
@ -2883,7 +2892,9 @@
|
|||
(apply (lambda (p)
|
||||
(if (= lev 0)
|
||||
(quasiappend
|
||||
(map (lambda (tmp) (list "value" tmp)) p)
|
||||
(map (lambda (tmp-bde397a-11b8)
|
||||
(list "value" tmp-bde397a-11b8))
|
||||
p)
|
||||
(quasi q lev))
|
||||
(quasicons
|
||||
(quasicons
|
||||
|
|
@ -2916,7 +2927,9 @@
|
|||
(if tmp
|
||||
(apply (lambda (p)
|
||||
(if (= lev 0)
|
||||
(quasilist* (map (lambda (tmp) (list "value" tmp)) p) (vquasi q lev))
|
||||
(quasilist*
|
||||
(map (lambda (tmp-bde397a-11ce) (list "value" tmp-bde397a-11ce)) p)
|
||||
(vquasi q lev))
|
||||
(quasicons
|
||||
(quasicons
|
||||
'("quote" #(syntax-object unquote ((top)) (hygiene guile)))
|
||||
|
|
@ -2932,7 +2945,7 @@
|
|||
(apply (lambda (p)
|
||||
(if (= lev 0)
|
||||
(quasiappend
|
||||
(map (lambda (tmp) (list "value" tmp)) p)
|
||||
(map (lambda (tmp-bde397a-11d3) (list "value" tmp-bde397a-11d3)) p)
|
||||
(vquasi q lev))
|
||||
(quasicons
|
||||
(quasicons
|
||||
|
|
@ -3020,7 +3033,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-bde397a-121c) (cons "vector" t-bde397a-121c)) tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
"source expression failed to match any pattern"
|
||||
|
|
@ -3028,7 +3041,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-bde397a) (list "quote" tmp-bde397a)) y)))
|
||||
tmp-1)
|
||||
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
|
||||
(if tmp-1
|
||||
|
|
@ -3037,7 +3051,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-bde397a tmp)) (list "list->vector" t-bde397a)))))))))))))))))
|
||||
(emit (lambda (x)
|
||||
(let ((tmp x))
|
||||
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
|
||||
|
|
@ -3050,7 +3065,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-bde397a)
|
||||
(cons '#(syntax-object list ((top)) (hygiene guile)) t-bde397a))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3066,8 +3082,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-bde397a-125a t-bde397a)
|
||||
(list '#(syntax-object cons ((top)) (hygiene guile))
|
||||
t-bde397a-125a
|
||||
t-bde397a))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3080,8 +3098,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-bde397a)
|
||||
(cons '#(syntax-object append ((top)) (hygiene guile))
|
||||
t-bde397a))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3094,8 +3113,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-bde397a)
|
||||
(cons '#(syntax-object vector ((top)) (hygiene guile))
|
||||
t-bde397a))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3106,8 +3126,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-bde397a-127e tmp))
|
||||
(list '#(syntax-object list->vector ((top)) (hygiene guile))
|
||||
t-bde397a-127e))))
|
||||
tmp-1)
|
||||
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
|
||||
(if tmp-1
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
@ -642,7 +643,7 @@
|
|||
;; labels must be comparable with "eq?", have read-write invariance,
|
||||
;; and distinct from symbols.
|
||||
(define (gen-label)
|
||||
(string-append "l-" (session-id) (symbol->string (gensym "-"))))
|
||||
(symbol->string (module-gensym "l")))
|
||||
|
||||
(define gen-labels
|
||||
(lambda (ls)
|
||||
|
|
@ -671,7 +672,7 @@
|
|||
(cons 'shift (wrap-subst w)))))
|
||||
|
||||
(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
|
||||
;; internal definitions, in which the ribcages are built incrementally
|
||||
|
|
@ -2591,7 +2592,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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue