mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 14:21:10 +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)
;; 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>)*)
@ -567,18 +567,6 @@
(cons a (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
(lambda (type sym val)
(put-global-definition-hook sym type val)))
@ -738,6 +726,20 @@
(same-marks? (cdr x) (cdr y))))))
(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)
(define-syntax-rule (first e)
;; Rely on Guile's multiple-values truncation.
@ -786,6 +788,43 @@
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)
;; 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.
(current-module))
(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,
;; and if so, compare their bindings, that they are either
;; bound to the same variable, or both unbound and have
@ -814,11 +856,11 @@
(eq? bi (id-module-binding j))
(and (not (id-module-binding j))
(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
;; bound to the same thing.
(and (eq? ni nj)
(not (eq? nj (id-sym-name j))))))))
(equal? ni nj))))))
;; 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
@ -1096,17 +1138,19 @@
(lambda (e r w s rib mod for-car?)
(cond
((symbol? e)
(let* ((n (id-var-name e w))
(b (lookup n r mod))
(type (binding-type b)))
(call-with-values (lambda () (resolve-identifier e w r mod))
(lambda (type value mod* name)
(case type
((global) (values type n e w s mod))
((macro)
(if for-car?
(values type (binding-value b) e w s mod)
(syntax-type (chi-macro (binding-value b) e r w s rib mod)
(values type value e w s mod)
(syntax-type (chi-macro value e r w s rib mod)
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)
(let ((first (car e)))
(call-with-values
@ -1757,34 +1801,35 @@
(global-extend 'local-syntax 'letrec-syntax #t)
(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)
(syntax-case e ()
((_ ((var val) ...) e1 e2 ...)
(valid-bound-ids? #'(var ...))
(let ((names (map (lambda (x) (id-var-name x w)) #'(var ...))))
(for-each
(lambda (id n)
(case (binding-type (lookup n r mod))
(let ((names
(map (lambda (x)
(call-with-values
(lambda () (resolve-identifier x w r mod))
(lambda (type value mod name)
(case type
((displaced-lexical)
(syntax-violation 'fluid-let-syntax
"identifier out of context"
e
(source-wrap id w s mod)))))
#'(var ...)
names)
(chi-body
#'(e1 e2 ...)
(source-wrap e w s mod)
(extend-env
names
(source-wrap x w s mod)))
(else name)))))
#'(var ...)))
(bindings
(let ((trans-r (macros-only-env r)))
(map (lambda (x)
(make-binding 'macro
(eval-local-transformer (chi x trans-r w mod)
mod)))
#'(val ...)))
r)
(make-binding
'macro
(eval-local-transformer (chi x trans-r w mod) mod)))
#'(val ...)))))
(chi-body #'(e1 e2 ...)
(source-wrap e w s mod)
(extend-env names bindings r)
w
mod)))
(_ (syntax-violation 'fluid-let-syntax "bad syntax"
@ -1797,24 +1842,25 @@
(_ (syntax-violation 'quote "bad syntax"
(source-wrap e w s mod))))))
(global-extend 'core 'syntax
(global-extend
'core 'syntax
(let ()
(define gen-syntax
(lambda (src e r maps ellipsis? mod)
(if (id? e)
(let ((label (id-var-name e empty-wrap)))
;; Mod does not matter, we are looking to see if
;; the id is lexical syntax.
(let ((b (lookup label r mod)))
(if (eq? (binding-type b) 'syntax)
(call-with-values (lambda ()
(resolve-identifier e empty-wrap r mod))
(lambda (type value mod name)
(case type
((syntax)
(call-with-values
(lambda ()
(let ((var.lev (binding-value b)))
(gen-ref src (car var.lev) (cdr var.lev) maps)))
(lambda (var maps) (values `(ref ,var) maps)))
(lambda () (gen-ref src (car value) (cdr value) maps))
(lambda (var maps)
(values `(ref ,var) maps))))
(else
(if (ellipsis? e)
(syntax-violation 'syntax "misplaced ellipsis" src)
(values `(quote ,e) maps)))))
(values `(quote ,e) maps))))))
(syntax-case e ()
((dots e)
(ellipsis? #'dots)
@ -2090,39 +2136,34 @@
(_ (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)
(syntax-case e ()
((_ id val)
(id? #'id)
(let ((n (id-var-name #'id w))
;; Lookup id in its module
(id-mod (if (syntax-object? #'id)
(syntax-object-module #'id)
mod)))
(let ((b (lookup n r id-mod)))
(case (binding-type b)
(call-with-values
(lambda () (resolve-identifier #'id w r mod))
(lambda (type value id-mod name)
(case type
((lexical)
(build-lexical-assignment s
(syntax->datum #'id)
(binding-value b)
(build-lexical-assignment s (syntax->datum #'id) value
(chi #'val r w mod)))
((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)
(let ((p (binding-value b)))
(if (procedure-property p 'variable-transformer)
(if (procedure-property value 'variable-transformer)
;; As syntax-type does, call chi-macro with
;; 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"
(wrap e w mod)
(wrap #'id w id-mod)))))
(wrap #'id w id-mod))))
((displaced-lexical)
(syntax-violation 'set! "identifier out of context"
(wrap #'id w mod)))
(else (syntax-violation 'set! "bad set!"
(source-wrap e w s mod)))))))
(else
(syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))))
((_ (head tail ...) val)
(call-with-values
(lambda () (syntax-type #'head r empty-wrap no-source #f mod #t))