mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 23:00:22 +02:00
Code Activity

psyntax: resolve-identifier refactor

Browse source 
* module/ice-9/psyntax.scm (id-var-name): Add a nice long comment.
  (lookup): Remove, as it is no longer used.
  (resolve-identifier): New helper, replaces most uses of id-var-name
  then `lookup'.
  (syntax-type, syntax, set!, fluid-let-syntax): Adapt to use
  resolve-identifier.
  (free-id=?): Adapt to id-var-name returning syntax objects.
This commit is contained in:
Andy Wingo 2011-11-04 18:50:38 +01:00
parent 45f584674a
commit c070de6345
1 changed files with 323 additions and 282 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -486,7 +486,7 @@
;; global (assumed global variable) and displaced-lexical (see below) ;; global (assumed global variable) and displaced-lexical (see below)
;; do not show up in any environment; instead, they are fabricated by ;; do not show up in any environment; instead, they are fabricated by
;; lookup when it finds no other bindings. ;; resolve-identifier when it finds no other bindings.
;; <environment> ::= ((<label> . <binding>)*) ;; <environment> ::= ((<label> . <binding>)*)
@ -567,18 +567,6 @@
(cons a (macros-only-env (cdr r))) (cons a (macros-only-env (cdr r)))
(macros-only-env (cdr r))))))) (macros-only-env (cdr r)))))))
(define lookup
;; x may be a label or a symbol
;; although symbols are usually global, we check the environment first
;; anyway because a temporary binding may have been established by
;; fluid-let-syntax
(lambda (x r mod)
(cond
((assq x r) => cdr)
((symbol? x)
(or (get-global-definition-hook x mod) (make-binding 'global)))
(else (make-binding 'displaced-lexical)))))
(define global-extend (define global-extend
(lambda (type sym val) (lambda (type sym val)
(put-global-definition-hook sym type val))) (put-global-definition-hook sym type val)))
@ -738,6 +726,20 @@
(same-marks? (cdr x) (cdr y)))))) (same-marks? (cdr x) (cdr y))))))
(define id-var-name (define id-var-name
;; Syntax objects use wraps to associate names with marked
;; identifiers. This function returns the name corresponding to
;; the given identifier and wrap, or the original identifier if no
;; corresponding name was found.
;;
;; The name may be a string created by gen-label, indicating a
;; lexical binding, or another syntax object, indicating a
;; reference to a top-level definition created during a previous
;; macroexpansion.
;;
;; 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)
(define-syntax-rule (first e) (define-syntax-rule (first e)
;; Rely on Guile's multiple-values truncation. ;; Rely on Guile's multiple-values truncation.
@ -786,6 +788,43 @@
id)))))) id))))))
(else (syntax-violation 'id-var-name "invalid id" id))))) (else (syntax-violation 'id-var-name "invalid id" id)))))
;; Returns four values: binding type, binding value, the module (for
;; resolving toplevel vars), and the name (for possible overriding
;; by fluid-let-syntax).
(define (resolve-identifier id w r mod)
(define (resolve-global var mod)
;; `var' is probably a global, but we check the environment
;; first anyway because a temporary binding may have been
;; established by `fluid-let-syntax'. FIXME: overriding a
;; toplevel via fluid-let-syntax using just a symbolic name
;; (without a module) does not make sense.
(let ((b (or (assq-ref r var)
(get-global-definition-hook var mod)
(make-binding 'global))))
(if (eq? 'global (binding-type b))
(values 'global var mod var)
(values (binding-type b) (binding-value b) mod var))))
(define (resolve-lexical label mod)
(let ((b (or (assq-ref r label)
(make-binding 'displaced-lexical))))
(values (binding-type b) (binding-value b) mod label)))
(let ((n (id-var-name id w)))
(cond
((syntax-object? n)
;; Recursing allows fluid-let-syntax to override
;; macro-introduced bindings, I think.
(resolve-identifier n w r mod))
((symbol? n)
(resolve-global n (if (syntax-object? id)
(syntax-object-module id)
mod)))
((string? n)
(resolve-lexical n (if (syntax-object? id)
(syntax-object-module id)
mod)))
(else
(error "unexpected id-var-name" id w n)))))
;; free-id=? must be passed fully wrapped ids since (free-id=? x y) ;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not. ;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
@ -803,7 +842,10 @@
;; raw symbol coming in, which is possible. ;; raw symbol coming in, which is possible.
(current-module)) (current-module))
(id-sym-name id)))) (id-sym-name id))))
(if (eq? ni (id-sym-name i)) (cond
((syntax-object? ni) (free-id=? ni j))
((syntax-object? nj) (free-id=? i nj))
((symbol? ni)
;; `i' is not lexically bound. Assert that `j' is free, ;; `i' is not lexically bound. Assert that `j' is free,
;; and if so, compare their bindings, that they are either ;; and if so, compare their bindings, that they are either
;; bound to the same variable, or both unbound and have ;; bound to the same variable, or both unbound and have
@ -814,11 +856,11 @@
(eq? bi (id-module-binding j)) (eq? bi (id-module-binding j))
(and (not (id-module-binding j)) (and (not (id-module-binding j))
(eq? ni nj)))) (eq? ni nj))))
(eq? (id-module-binding i) (id-module-binding j))) (eq? (id-module-binding i) (id-module-binding j))))
(else
;; Otherwise `i' is bound, so check that `j' is bound, and ;; Otherwise `i' is bound, so check that `j' is bound, and
;; bound to the same thing. ;; bound to the same thing.
(and (eq? ni nj) (equal? ni nj))))))
(not (eq? nj (id-sym-name j))))))))
;; bound-id=? may be passed unwrapped (or partially wrapped) ids as ;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
;; long as the missing portion of the wrap is common to both of the ids ;; long as the missing portion of the wrap is common to both of the ids
@ -1096,17 +1138,19 @@
(lambda (e r w s rib mod for-car?) (lambda (e r w s rib mod for-car?)
(cond (cond
((symbol? e) ((symbol? e)
(let* ((n (id-var-name e w)) (call-with-values (lambda () (resolve-identifier e w r mod))
(b (lookup n r mod)) (lambda (type value mod* name)
(type (binding-type b)))
(case type (case type
((global) (values type n e w s mod))
((macro) ((macro)
(if for-car? (if for-car?
(values type (binding-value b) e w s mod) (values type value e w s mod)
(syntax-type (chi-macro (binding-value b) e r w s rib mod) (syntax-type (chi-macro value e r w s rib mod)
r empty-wrap s rib mod #f))) r empty-wrap s rib mod #f)))
(else (values type (binding-value b) e w s mod))))) ((global)
;; Toplevel definitions may resolve to bindings with
;; different names or in different modules.
(values type value value w s mod*))
(else (values type value e w s mod))))))
((pair? e) ((pair? e)
(let ((first (car e))) (let ((first (car e)))
(call-with-values (call-with-values
@ -1757,34 +1801,35 @@
(global-extend 'local-syntax 'letrec-syntax #t) (global-extend 'local-syntax 'letrec-syntax #t)
(global-extend 'local-syntax 'let-syntax #f) (global-extend 'local-syntax 'let-syntax #f)
(global-extend 'core 'fluid-let-syntax (global-extend
'core 'fluid-let-syntax
(lambda (e r w s mod) (lambda (e r w s mod)
(syntax-case e () (syntax-case e ()
((_ ((var val) ...) e1 e2 ...) ((_ ((var val) ...) e1 e2 ...)
(valid-bound-ids? #'(var ...)) (valid-bound-ids? #'(var ...))
(let ((names (map (lambda (x) (id-var-name x w)) #'(var ...)))) (let ((names
(for-each (map (lambda (x)
(lambda (id n) (call-with-values
(case (binding-type (lookup n r mod)) (lambda () (resolve-identifier x w r mod))
(lambda (type value mod name)
(case type
((displaced-lexical) ((displaced-lexical)
(syntax-violation 'fluid-let-syntax (syntax-violation 'fluid-let-syntax
"identifier out of context" "identifier out of context"
e e
(source-wrap id w s mod))))) (source-wrap x w s mod)))
#'(var ...) (else name)))))
names) #'(var ...)))
(chi-body (bindings
#'(e1 e2 ...)
(source-wrap e w s mod)
(extend-env
names
(let ((trans-r (macros-only-env r))) (let ((trans-r (macros-only-env r)))
(map (lambda (x) (map (lambda (x)
(make-binding 'macro (make-binding
(eval-local-transformer (chi x trans-r w mod) 'macro
mod))) (eval-local-transformer (chi x trans-r w mod) mod)))
#'(val ...))) #'(val ...)))))
r) (chi-body #'(e1 e2 ...)
(source-wrap e w s mod)
(extend-env names bindings r)
w w
mod))) mod)))
(_ (syntax-violation 'fluid-let-syntax "bad syntax" (_ (syntax-violation 'fluid-let-syntax "bad syntax"
@ -1797,24 +1842,25 @@
(_ (syntax-violation 'quote "bad syntax" (_ (syntax-violation 'quote "bad syntax"
(source-wrap e w s mod)))))) (source-wrap e w s mod))))))
(global-extend 'core 'syntax (global-extend
'core 'syntax
(let () (let ()
(define gen-syntax (define gen-syntax
(lambda (src e r maps ellipsis? mod) (lambda (src e r maps ellipsis? mod)
(if (id? e) (if (id? e)
(let ((label (id-var-name e empty-wrap))) (call-with-values (lambda ()
;; Mod does not matter, we are looking to see if (resolve-identifier e empty-wrap r mod))
;; the id is lexical syntax. (lambda (type value mod name)
(let ((b (lookup label r mod))) (case type
(if (eq? (binding-type b) 'syntax) ((syntax)
(call-with-values (call-with-values
(lambda () (lambda () (gen-ref src (car value) (cdr value) maps))
(let ((var.lev (binding-value b))) (lambda (var maps)
(gen-ref src (car var.lev) (cdr var.lev) maps))) (values `(ref ,var) maps))))
(lambda (var maps) (values `(ref ,var) maps))) (else
(if (ellipsis? e) (if (ellipsis? e)
(syntax-violation 'syntax "misplaced ellipsis" src) (syntax-violation 'syntax "misplaced ellipsis" src)
(values `(quote ,e) maps))))) (values `(quote ,e) maps))))))
(syntax-case e () (syntax-case e ()
((dots e) ((dots e)
(ellipsis? #'dots) (ellipsis? #'dots)
@ -2090,39 +2136,34 @@
(_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod)))))) (_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
(global-extend 'core 'set! (global-extend
'core 'set!
(lambda (e r w s mod) (lambda (e r w s mod)
(syntax-case e () (syntax-case e ()
((_ id val) ((_ id val)
(id? #'id) (id? #'id)
(let ((n (id-var-name #'id w)) (call-with-values
;; Lookup id in its module (lambda () (resolve-identifier #'id w r mod))
(id-mod (if (syntax-object? #'id) (lambda (type value id-mod name)
(syntax-object-module #'id) (case type
mod)))
(let ((b (lookup n r id-mod)))
(case (binding-type b)
((lexical) ((lexical)
(build-lexical-assignment s (build-lexical-assignment s (syntax->datum #'id) value
(syntax->datum #'id)
(binding-value b)
(chi #'val r w mod))) (chi #'val r w mod)))
((global) ((global)
(build-global-assignment s n (chi #'val r w mod) id-mod)) (build-global-assignment s name (chi #'val r w mod) id-mod))
((macro) ((macro)
(let ((p (binding-value b))) (if (procedure-property value 'variable-transformer)
(if (procedure-property p 'variable-transformer)
;; As syntax-type does, call chi-macro with ;; As syntax-type does, call chi-macro with
;; the mod of the expression. Hmm. ;; the mod of the expression. Hmm.
(chi (chi-macro p e r w s #f mod) r empty-wrap mod) (chi (chi-macro value e r w s #f mod) r empty-wrap mod)
(syntax-violation 'set! "not a variable transformer" (syntax-violation 'set! "not a variable transformer"
(wrap e w mod) (wrap e w mod)
(wrap #'id w id-mod))))) (wrap #'id w id-mod))))
((displaced-lexical) ((displaced-lexical)
(syntax-violation 'set! "identifier out of context" (syntax-violation 'set! "identifier out of context"
(wrap #'id w mod))) (wrap #'id w mod)))
(else (syntax-violation 'set! "bad set!" (else
(source-wrap e w s mod))))))) (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))))
((_ (head tail ...) val) ((_ (head tail ...) val)
(call-with-values (call-with-values
(lambda () (syntax-type #'head r empty-wrap no-source #f mod #t)) (lambda () (syntax-type #'head r empty-wrap no-source #f mod #t))