mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-28 16:00:22 +02:00
Code Activity

resolve-identifier for toplevel definitions resolves by module

Browse source 
* module/ice-9/psyntax.scm (id-var-name): For mapping identifiers to
  toplevel definitions, also compare against the module.
  (resolve-identifier): Pass the module to id-var-name when looking up
  identifiers.
  (free-id=?): Adapt to id-var-name change.
  (chi-top-sequence): When adding a mapping from the given identifier
  to a toplevel definition, make the name be a pair.
This commit is contained in:
Andy Wingo 2011-11-07 09:55:57 +01:00
parent 1ce645567d
commit 47e9919d22
1 changed files with 63 additions and 33 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -738,55 +738,76 @@
;; reference to a top-level definition created during a previous
;; macroexpansion.
;;
;; For lexical variables, finding a label simply amounts to
;; looking for an entry with the same symbolic name and the same
;; marks. Finding a toplevel definition is the same, except we
;; also have to compare modules, hence the `mod' parameter.
;; Instead of adding a separate entry in the ribcage for modules,
;; which wouldn't be used for lexicals, we arrange for the entry
;; for the name entry to be a pair with the module in its car, and
;; the name itself in the cdr. So if the name that we find is a
;; pair, we have to check modules.
;;
;; The identifer may be passed in wrapped or unwrapped. In any
;; case, this routine returns either a symbol, a syntax object, or
;; a string label.
;;
(lambda (id w)
(lambda (id w mod)
(define-syntax-rule (first e)
;; Rely on Guile's multiple-values truncation.
e)
(define search
(lambda (sym subst marks)
(lambda (sym subst marks mod)
(if (null? subst)
(values #f marks)
(let ((fst (car subst)))
(if (eq? fst 'shift)
(search sym (cdr subst) (cdr marks))
(search sym (cdr subst) (cdr marks) mod)
(let ((symnames (ribcage-symnames fst)))
(if (vector? symnames)
(search-vector-rib sym subst marks symnames fst)
(search-list-rib sym subst marks symnames fst))))))))
(search-vector-rib sym subst marks symnames fst mod)
(search-list-rib sym subst marks symnames fst mod))))))))
(define search-list-rib
(lambda (sym subst marks symnames ribcage)
(lambda (sym subst marks symnames ribcage mod)
(let f ((symnames symnames) (i 0))
(cond
((null? symnames) (search sym (cdr subst) marks))
((null? symnames) (search sym (cdr subst) marks mod))
((and (eq? (car symnames) sym)
(same-marks? marks (list-ref (ribcage-marks ribcage) i)))
(values (list-ref (ribcage-labels ribcage) i) marks))
(let ((n (list-ref (ribcage-labels ribcage) i)))
(if (pair? n)
(if (equal? mod (car n))
(values (cdr n) marks)
(f (cdr symnames) (fx+ i 1)))
(values n marks))))
(else (f (cdr symnames) (fx+ i 1)))))))
(define search-vector-rib
(lambda (sym subst marks symnames ribcage)
(lambda (sym subst marks symnames ribcage mod)
(let ((n (vector-length symnames)))
(let f ((i 0))
(cond
((fx= i n) (search sym (cdr subst) marks))
((fx= i n) (search sym (cdr subst) marks mod))
((and (eq? (vector-ref symnames i) sym)
(same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
(values (vector-ref (ribcage-labels ribcage) i) marks))
(let ((n (vector-ref (ribcage-labels ribcage) i)))
(if (pair? n)
(if (equal? mod (car n))
(values (cdr n) marks)
(f (fx+ i 1)))
(values n marks))))
(else (f (fx+ i 1))))))))
(cond
((symbol? id)
(or (first (search id (wrap-subst w) (wrap-marks w))) id))
(or (first (search id (wrap-subst w) (wrap-marks w) mod)) id))
((syntax-object? id)
(let ((id (syntax-object-expression id))
(w1 (syntax-object-wrap id)))
(w1 (syntax-object-wrap id))
(mod (syntax-object-module id)))
(let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
(call-with-values (lambda () (search id (wrap-subst w) marks))
(call-with-values (lambda () (search id (wrap-subst w) marks mod))
(lambda (new-id marks)
(or new-id
(first (search id (wrap-subst w1) marks))
(first (search id (wrap-subst w1) marks mod))
id))))))
(else (syntax-violation 'id-var-name "invalid id" id)))))
@ -811,7 +832,7 @@
(or (assq-ref r label)
(make-binding 'displaced-lexical)))))
(values (binding-type b) (binding-value b) mod)))
(let ((n (id-var-name id w)))
(let ((n (id-var-name id w mod)))
(cond
((syntax-object? n)
;; Recursing allows syntax-parameterize to override
@ -833,18 +854,19 @@
(define free-id=?
(lambda (i j)
(let ((ni (id-var-name i empty-wrap))
(nj (id-var-name j empty-wrap)))
(define (id-module-binding id)
(let ((mod (and (syntax-object? id) (syntax-object-module id))))
(module-variable
(if mod
;; The normal case.
(resolve-module (cdr mod))
;; Either modules have not been booted, or we have a
;; raw symbol coming in, which is possible.
(current-module))
(id-sym-name id))))
(let* ((mi (and (syntax-object? i) (syntax-object-module i)))
(mj (and (syntax-object? j) (syntax-object-module j)))
(ni (id-var-name i empty-wrap mi))
(nj (id-var-name j empty-wrap mj)))
(define (id-module-binding id mod)
(module-variable
(if mod
;; The normal case.
(resolve-module (cdr mod))
;; Either modules have not been booted, or we have a
;; raw symbol coming in, which is possible.
(current-module))
(id-sym-name id)))
(cond
((syntax-object? ni) (free-id=? ni j))
((syntax-object? nj) (free-id=? i nj))
@ -854,12 +876,12 @@
;; bound to the same variable, or both unbound and have
;; the same name.
(and (eq? nj (id-sym-name j))
(let ((bi (id-module-binding i)))
(let ((bi (id-module-binding i mi)))
(if bi
(eq? bi (id-module-binding j))
(and (not (id-module-binding j))
(eq? bi (id-module-binding j mj))
(and (not (id-module-binding j mj))
(eq? ni nj))))
(eq? (id-module-binding i) (id-module-binding j))))
(eq? (id-module-binding i mi) (id-module-binding j mj))))
(else
;; Otherwise `i' is bound, so check that `j' is bound, and
;; bound to the same thing.
@ -960,7 +982,15 @@
(w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
(define (record-definition! id var)
(let ((mod (cons 'hygiene (module-name (current-module)))))
(extend-ribcage! ribcage id (wrap var top-wrap mod))))
;; Ribcages map symbol+marks to names, mostly for
;; resolving lexicals. Here to add a mapping for toplevel
;; definitions we also need to match the module. So, we
;; put it in the name instead, and make id-var-name handle
;; the special case of names that are pairs. See the
;; comments in id-var-name for more.
(extend-ribcage! ribcage id
(cons (syntax-object-module id)
(wrap var top-wrap mod)))))
(define (parse body r w s m esew mod)
(let lp ((body body) (exps '()))
(if (null? body)