;;; -*- 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
(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)
submodules
submodule-binder
public-interface
- filename)))
+ filename
+ next-unique-id)))
;; make-module &opt size uses binder
(make-hash-table)
'()
(make-weak-key-hash-table 31) #f
- (make-hash-table 7) #f #f #f))
+ (make-hash-table 7) #f #f #f 0))
\f
(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
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.
;;
(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)))
#: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
(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))))))
(source-wrap e w (cdr w) mod)
x))
(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*
- t-1
- t
+ t-680b775fb37a463-7fe
+ t-680b775fb37a463-7ff
(lambda ()
(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))
s
mod
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*
e1*
args*)))
(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 '(())))
(apply (lambda (args e1 e2)
(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
e1
args)))
(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-680b775fb37a463-cd2
+ tmp-680b775fb37a463-cd1
+ tmp-680b775fb37a463-cd0)
+ (cons tmp-680b775fb37a463-cd0
+ (cons tmp-680b775fb37a463-cd1 tmp-680b775fb37a463-cd2)))
e2
e1
args)))
(apply (lambda (args e1 e2)
(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
e1
args)))
(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-680b775fb37a463-d08
+ tmp-680b775fb37a463-d07
+ tmp-680b775fb37a463-d06)
+ (cons tmp-680b775fb37a463-d06
+ (cons tmp-680b775fb37a463-d07 tmp-680b775fb37a463-d08)))
e2
e1
args)))
(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))
#f
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
pattern
keyword)))
#f
k
(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
pattern
keyword)))
dots
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
pattern
keyword)))
dots
k
(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
pattern
keyword)))
(apply (lambda (p)
(if (= lev 0)
(quasilist*
- (map (lambda (tmp) (list "value" tmp)) p)
+ (map (lambda (tmp-680b775fb37a463)
+ (list "value" tmp-680b775fb37a463))
+ p)
(quasi q lev))
(quasicons
(quasicons
(apply (lambda (p)
(if (= lev 0)
(quasiappend
- (map (lambda (tmp) (list "value" tmp)) p)
+ (map (lambda (tmp-680b775fb37a463)
+ (list "value" tmp-680b775fb37a463))
+ p)
(quasi q lev))
(quasicons
(quasicons
(if tmp
(apply (lambda (p)
(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
'("quote" #(syntax-object unquote ((top)) (hygiene guile)))
(apply (lambda (p)
(if (= lev 0)
(quasiappend
- (map (lambda (tmp) (list "value" tmp)) p)
+ (map (lambda (tmp-680b775fb37a463) (list "value" tmp-680b775fb37a463))
+ p)
(vquasi q lev))
(quasicons
(quasicons
(let ((tmp-1 ls))
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp
- (apply (lambda (t) (cons "vector" t)) tmp)
+ (apply (lambda (t-680b775fb37a463-127d)
+ (cons "vector" t-680b775fb37a463-127d))
+ tmp)
(syntax-violation
#f
"source expression failed to match any pattern"
(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-680b775fb37a463) (list "quote" tmp-680b775fb37a463))
+ y)))
tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
(if tmp-1
(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-680b775fb37a463 tmp))
+ (list "list->vector" t-680b775fb37a463)))))))))))))))))
(emit (lambda (x)
(let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
(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-680b775fb37a463-12a7)
+ (cons '#(syntax-object list ((top)) (hygiene guile))
+ t-680b775fb37a463-12a7))
tmp)
(syntax-violation
#f
(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-680b775fb37a463-12bb t-680b775fb37a463-12ba)
+ (list '#(syntax-object cons ((top)) (hygiene guile))
+ t-680b775fb37a463-12bb
+ t-680b775fb37a463-12ba))
tmp)
(syntax-violation
#f
(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-680b775fb37a463-12c7)
+ (cons '#(syntax-object append ((top)) (hygiene guile))
+ t-680b775fb37a463-12c7))
tmp)
(syntax-violation
#f
(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-680b775fb37a463-12d3)
+ (cons '#(syntax-object vector ((top)) (hygiene guile))
+ t-680b775fb37a463-12d3))
tmp)
(syntax-violation
#f
(if tmp-1
(apply (lambda (x)
(let ((tmp (emit x)))
- (let ((t tmp))
- (list '#(syntax-object list->vector ((top)) (hygiene guile)) t))))
+ (let ((t-680b775fb37a463-12df tmp))
+ (list '#(syntax-object list->vector ((top)) (hygiene guile))
+ t-680b775fb37a463-12df))))
tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
(if tmp-1
;;;; -*-scheme-*-
;;;;
;;;; 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
;;;; modify it under the terms of the GNU Lesser General Public
(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))
;; 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)
(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
(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)
projects / platform / upstream / guile.git / commitdiff