mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 03:30:27 +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
70cfabd7e8
commit
84a740d86a
5 changed files with 143 additions and 50 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
|
||||
|
|
@ -373,6 +373,13 @@ If returning early, return the return value of F."
|
|||
(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)
|
||||
|
||||
|
|
@ -1982,7 +1989,8 @@ name extensions listed in %load-extensions."
|
|||
submodules
|
||||
submodule-binder
|
||||
public-interface
|
||||
filename)))
|
||||
filename
|
||||
next-unique-id)))
|
||||
|
||||
|
||||
;; make-module &opt size uses binder
|
||||
|
|
@ -2005,7 +2013,7 @@ initial uses list, or binding procedure."
|
|||
(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))
|
||||
|
||||
|
||||
|
||||
|
|
@ -2542,6 +2550,11 @@ interfaces are added to the inports list."
|
|||
(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
|
||||
|
|
@ -2570,6 +2583,11 @@ interfaces are added to the inports list."
|
|||
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.
|
||||
;;
|
||||
|
|
@ -2600,6 +2618,21 @@ interfaces are added to the inports list."
|
|||
(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)))
|
||||
|
|
@ -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))))
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -295,9 +295,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))))))
|
||||
|
|
@ -994,14 +992,15 @@
|
|||
(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))
|
||||
|
|
@ -1532,7 +1531,11 @@
|
|||
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*)))
|
||||
|
|
@ -1564,7 +1567,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 '(())))
|
||||
|
|
@ -1832,7 +1835,11 @@
|
|||
(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)))
|
||||
|
|
@ -1844,7 +1851,11 @@
|
|||
(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)))
|
||||
|
|
@ -1867,7 +1878,11 @@
|
|||
(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)))
|
||||
|
|
@ -1879,7 +1894,11 @@
|
|||
(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)))
|
||||
|
|
@ -2387,7 +2406,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))
|
||||
|
|
@ -2787,7 +2806,11 @@
|
|||
#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)))
|
||||
|
|
@ -2803,7 +2826,9 @@
|
|||
#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)))
|
||||
|
|
@ -2818,7 +2843,11 @@
|
|||
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)))
|
||||
|
|
@ -2834,7 +2863,11 @@
|
|||
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)))
|
||||
|
|
@ -2974,7 +3007,9 @@
|
|||
(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
|
||||
|
|
@ -2992,7 +3027,9 @@
|
|||
(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
|
||||
|
|
@ -3025,7 +3062,11 @@
|
|||
(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)))
|
||||
|
|
@ -3041,7 +3082,8 @@
|
|||
(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
|
||||
|
|
@ -3129,7 +3171,9 @@
|
|||
(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"
|
||||
|
|
@ -3137,7 +3181,9 @@
|
|||
(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
|
||||
|
|
@ -3146,7 +3192,9 @@
|
|||
(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))))
|
||||
|
|
@ -3159,7 +3207,9 @@
|
|||
(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
|
||||
|
|
@ -3175,8 +3225,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-680b775fb37a463-12bb t-680b775fb37a463-12ba)
|
||||
(list '#(syntax-object cons ((top)) (hygiene guile))
|
||||
t-680b775fb37a463-12bb
|
||||
t-680b775fb37a463-12ba))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3189,8 +3241,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-680b775fb37a463-12c7)
|
||||
(cons '#(syntax-object append ((top)) (hygiene guile))
|
||||
t-680b775fb37a463-12c7))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3203,8 +3256,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-680b775fb37a463-12d3)
|
||||
(cons '#(syntax-object vector ((top)) (hygiene guile))
|
||||
t-680b775fb37a463-12d3))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3215,8 +3269,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-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
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
;;;; -*-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
|
||||
|
|
@ -461,9 +461,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))
|
||||
|
||||
|
|
@ -632,7 +633,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)
|
||||
|
|
@ -661,7 +662,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
|
||||
|
|
@ -2717,7 +2718,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, 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
|
||||
;;;; 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
|
||||
;; 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)
|
||||
(list->seq
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
@ -215,8 +215,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