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

605
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,22 +842,25 @@
;; 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
;; `i' is not lexically bound. Assert that `j' is free, ((syntax-object? ni) (free-id=? ni j))
;; and if so, compare their bindings, that they are either ((syntax-object? nj) (free-id=? i nj))
;; bound to the same variable, or both unbound and have ((symbol? ni)
;; the same name. ;; `i' is not lexically bound. Assert that `j' is free,
(and (eq? nj (id-sym-name j)) ;; and if so, compare their bindings, that they are either
(let ((bi (id-module-binding i))) ;; bound to the same variable, or both unbound and have
(if bi ;; the same name.
(eq? bi (id-module-binding j)) (and (eq? nj (id-sym-name j))
(and (not (id-module-binding j)) (let ((bi (id-module-binding i)))
(eq? ni nj)))) (if bi
(eq? (id-module-binding i) (id-module-binding j))) (eq? bi (id-module-binding j))
;; Otherwise `i' is bound, so check that `j' is bound, and (and (not (id-module-binding j))
;; bound to the same thing. (eq? ni nj))))
(and (eq? ni nj) (eq? (id-module-binding i) (id-module-binding j))))
(not (eq? nj (id-sym-name j)))))))) (else
;; Otherwise `i' is bound, so check that `j' is bound, and
;; bound to the same thing.
(equal? ni nj))))))
;; 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 ((macro)
((global) (values type n e w s mod)) (if for-car?
((macro) (values type value e w s mod)
(if for-car? (syntax-type (chi-macro value e r w s rib mod)
(values type (binding-value b) e w s mod) r empty-wrap s rib mod #f)))
(syntax-type (chi-macro (binding-value b) e r w s rib mod) ((global)
r empty-wrap s rib mod #f))) ;; Toplevel definitions may resolve to bindings with
(else (values type (binding-value b) e w s mod))))) ;; 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,38 +1801,39 @@
(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
(lambda (e r w s mod) 'core 'fluid-let-syntax
(syntax-case e () (lambda (e r w s mod)
((_ ((var val) ...) e1 e2 ...) (syntax-case e ()
(valid-bound-ids? #'(var ...)) ((_ ((var val) ...) e1 e2 ...)
(let ((names (map (lambda (x) (id-var-name x w)) #'(var ...)))) (valid-bound-ids? #'(var ...))
(for-each (let ((names
(lambda (id n) (map (lambda (x)
(case (binding-type (lookup n r mod)) (call-with-values
((displaced-lexical) (lambda () (resolve-identifier x w r mod))
(syntax-violation 'fluid-let-syntax (lambda (type value mod name)
"identifier out of context" (case type
e ((displaced-lexical)
(source-wrap id w s mod))))) (syntax-violation 'fluid-let-syntax
#'(var ...) "identifier out of context"
names) e
(chi-body (source-wrap x w s mod)))
#'(e1 e2 ...) (else name)))))
(source-wrap e w s mod) #'(var ...)))
(extend-env (bindings
names (let ((trans-r (macros-only-env r)))
(let ((trans-r (macros-only-env r))) (map (lambda (x)
(map (lambda (x) (make-binding
(make-binding 'macro 'macro
(eval-local-transformer (chi x trans-r w mod) (eval-local-transformer (chi x trans-r w mod) mod)))
mod))) #'(val ...)))))
#'(val ...))) (chi-body #'(e1 e2 ...)
r) (source-wrap e w s mod)
w (extend-env names bindings r)
mod))) w
(_ (syntax-violation 'fluid-let-syntax "bad syntax" mod)))
(source-wrap e w s mod)))))) (_ (syntax-violation 'fluid-let-syntax "bad syntax"
(source-wrap e w s mod))))))
(global-extend 'core 'quote (global-extend 'core 'quote
(lambda (e r w s mod) (lambda (e r w s mod)
@ -1797,165 +1842,166 @@
(_ (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
(let () 'core 'syntax
(define gen-syntax (let ()
(lambda (src e r maps ellipsis? mod) (define gen-syntax
(if (id? e) (lambda (src e r maps ellipsis? mod)
(let ((label (id-var-name e empty-wrap))) (if (id? e)
;; Mod does not matter, we are looking to see if (call-with-values (lambda ()
;; the id is lexical syntax. (resolve-identifier e empty-wrap r mod))
(let ((b (lookup label r mod))) (lambda (type value mod name)
(if (eq? (binding-type b) 'syntax) (case type
(call-with-values ((syntax)
(lambda () (call-with-values
(let ((var.lev (binding-value b))) (lambda () (gen-ref src (car value) (cdr value) maps))
(gen-ref src (car var.lev) (cdr var.lev) maps))) (lambda (var maps)
(lambda (var maps) (values `(ref ,var) maps))) (values `(ref ,var) maps))))
(if (ellipsis? e) (else
(syntax-violation 'syntax "misplaced ellipsis" src) (if (ellipsis? e)
(values `(quote ,e) maps))))) (syntax-violation 'syntax "misplaced ellipsis" src)
(syntax-case e () (values `(quote ,e) maps))))))
((dots e) (syntax-case e ()
(ellipsis? #'dots) ((dots e)
(gen-syntax src #'e r maps (lambda (x) #f) mod)) (ellipsis? #'dots)
((x dots . y) (gen-syntax src #'e r maps (lambda (x) #f) mod))
;; this could be about a dozen lines of code, except that we ((x dots . y)
;; choose to handle #'(x ... ...) forms ;; this could be about a dozen lines of code, except that we
(ellipsis? #'dots) ;; choose to handle #'(x ... ...) forms
(let f ((y #'y) (ellipsis? #'dots)
(k (lambda (maps) (let f ((y #'y)
(call-with-values (k (lambda (maps)
(lambda () (call-with-values
(gen-syntax src #'x r (lambda ()
(cons '() maps) ellipsis? mod)) (gen-syntax src #'x r
(lambda (x maps) (cons '() maps) ellipsis? mod))
(if (null? (car maps)) (lambda (x maps)
(syntax-violation 'syntax "extra ellipsis" (if (null? (car maps))
src) (syntax-violation 'syntax "extra ellipsis"
(values (gen-map x (car maps)) src)
(cdr maps)))))))) (values (gen-map x (car maps))
(syntax-case y () (cdr maps))))))))
((dots . y) (syntax-case y ()
(ellipsis? #'dots) ((dots . y)
(f #'y (ellipsis? #'dots)
(lambda (maps) (f #'y
(call-with-values (lambda (maps)
(lambda () (k (cons '() maps)))
(lambda (x maps)
(if (null? (car maps))
(syntax-violation 'syntax "extra ellipsis" src)
(values (gen-mappend x (car maps))
(cdr maps))))))))
(_ (call-with-values
(lambda () (gen-syntax src y r maps ellipsis? mod))
(lambda (y maps)
(call-with-values
(lambda () (k maps))
(lambda (x maps)
(values (gen-append x y) maps)))))))))
((x . y)
(call-with-values
(lambda () (gen-syntax src #'x r maps ellipsis? mod))
(lambda (x maps)
(call-with-values
(lambda () (gen-syntax src #'y r maps ellipsis? mod))
(lambda (y maps) (values (gen-cons x y) maps))))))
(#(e1 e2 ...)
(call-with-values
(lambda ()
(gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod))
(lambda (e maps) (values (gen-vector e) maps))))
(_ (values `(quote ,e) maps))))))
(define gen-ref
(lambda (src var level maps)
(if (fx= level 0)
(values var maps)
(if (null? maps)
(syntax-violation 'syntax "missing ellipsis" src)
(call-with-values
(lambda () (gen-ref src var (fx- level 1) (cdr maps)))
(lambda (outer-var outer-maps)
(let ((b (assq outer-var (car maps))))
(if b
(values (cdr b) maps)
(let ((inner-var (gen-var 'tmp)))
(values inner-var
(cons (cons (cons outer-var inner-var)
(car maps))
outer-maps)))))))))))
(define gen-mappend
(lambda (e map-env)
`(apply (primitive append) ,(gen-map e map-env))))
(define gen-map
(lambda (e map-env)
(let ((formals (map cdr map-env))
(actuals (map (lambda (x) `(ref ,(car x))) map-env)))
(cond
((eq? (car e) 'ref)
;; identity map equivalence:
;; (map (lambda (x) x) y) == y
(car actuals))
((and-map
(lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
(cdr e))
;; eta map equivalence:
;; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
`(map (primitive ,(car e))
,@(map (let ((r (map cons formals actuals)))
(lambda (x) (cdr (assq (cadr x) r))))
(cdr e))))
(else `(map (lambda ,formals ,e) ,@actuals))))))
(define gen-cons
(lambda (x y)
(case (car y)
((quote)
(if (eq? (car x) 'quote)
`(quote (,(cadr x) . ,(cadr y)))
(if (eq? (cadr y) '())
`(list ,x)
`(cons ,x ,y))))
((list) `(list ,x ,@(cdr y)))
(else `(cons ,x ,y)))))
(define gen-append
(lambda (x y)
(if (equal? y '(quote ()))
x
`(append ,x ,y))))
(define gen-vector
(lambda (x)
(cond
((eq? (car x) 'list) `(vector ,@(cdr x)))
((eq? (car x) 'quote) `(quote #(,@(cadr x))))
(else `(list->vector ,x)))))
(define regen
(lambda (x)
(case (car x)
((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
((primitive) (build-primref no-source (cadr x)))
((quote) (build-data no-source (cadr x)))
((lambda)
(if (list? (cadr x))
(build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x)))
(error "how did we get here" x)))
(else (build-primcall no-source (car x) (map regen (cdr x)))))))
(lambda (e r w s mod)
(let ((e (source-wrap e w s mod)))
(syntax-case e ()
((_ x)
(call-with-values (call-with-values
(lambda () (gen-syntax e #'x r '() ellipsis? mod)) (lambda () (k (cons '() maps)))
(lambda (e maps) (regen e)))) (lambda (x maps)
(_ (syntax-violation 'syntax "bad `syntax' form" e))))))) (if (null? (car maps))
(syntax-violation 'syntax "extra ellipsis" src)
(values (gen-mappend x (car maps))
(cdr maps))))))))
(_ (call-with-values
(lambda () (gen-syntax src y r maps ellipsis? mod))
(lambda (y maps)
(call-with-values
(lambda () (k maps))
(lambda (x maps)
(values (gen-append x y) maps)))))))))
((x . y)
(call-with-values
(lambda () (gen-syntax src #'x r maps ellipsis? mod))
(lambda (x maps)
(call-with-values
(lambda () (gen-syntax src #'y r maps ellipsis? mod))
(lambda (y maps) (values (gen-cons x y) maps))))))
(#(e1 e2 ...)
(call-with-values
(lambda ()
(gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod))
(lambda (e maps) (values (gen-vector e) maps))))
(_ (values `(quote ,e) maps))))))
(define gen-ref
(lambda (src var level maps)
(if (fx= level 0)
(values var maps)
(if (null? maps)
(syntax-violation 'syntax "missing ellipsis" src)
(call-with-values
(lambda () (gen-ref src var (fx- level 1) (cdr maps)))
(lambda (outer-var outer-maps)
(let ((b (assq outer-var (car maps))))
(if b
(values (cdr b) maps)
(let ((inner-var (gen-var 'tmp)))
(values inner-var
(cons (cons (cons outer-var inner-var)
(car maps))
outer-maps)))))))))))
(define gen-mappend
(lambda (e map-env)
`(apply (primitive append) ,(gen-map e map-env))))
(define gen-map
(lambda (e map-env)
(let ((formals (map cdr map-env))
(actuals (map (lambda (x) `(ref ,(car x))) map-env)))
(cond
((eq? (car e) 'ref)
;; identity map equivalence:
;; (map (lambda (x) x) y) == y
(car actuals))
((and-map
(lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
(cdr e))
;; eta map equivalence:
;; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
`(map (primitive ,(car e))
,@(map (let ((r (map cons formals actuals)))
(lambda (x) (cdr (assq (cadr x) r))))
(cdr e))))
(else `(map (lambda ,formals ,e) ,@actuals))))))
(define gen-cons
(lambda (x y)
(case (car y)
((quote)
(if (eq? (car x) 'quote)
`(quote (,(cadr x) . ,(cadr y)))
(if (eq? (cadr y) '())
`(list ,x)
`(cons ,x ,y))))
((list) `(list ,x ,@(cdr y)))
(else `(cons ,x ,y)))))
(define gen-append
(lambda (x y)
(if (equal? y '(quote ()))
x
`(append ,x ,y))))
(define gen-vector
(lambda (x)
(cond
((eq? (car x) 'list) `(vector ,@(cdr x)))
((eq? (car x) 'quote) `(quote #(,@(cadr x))))
(else `(list->vector ,x)))))
(define regen
(lambda (x)
(case (car x)
((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
((primitive) (build-primref no-source (cadr x)))
((quote) (build-data no-source (cadr x)))
((lambda)
(if (list? (cadr x))
(build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x)))
(error "how did we get here" x)))
(else (build-primcall no-source (car x) (map regen (cdr x)))))))
(lambda (e r w s mod)
(let ((e (source-wrap e w s mod)))
(syntax-case e ()
((_ x)
(call-with-values
(lambda () (gen-syntax e #'x r '() ellipsis? mod))
(lambda (e maps) (regen e))))
(_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
(global-extend 'core 'lambda (global-extend 'core 'lambda
(lambda (e r w s mod) (lambda (e r w s mod)
@ -2090,58 +2136,53 @@
(_ (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
(lambda (e r w s mod) 'core 'set!
(syntax-case e () (lambda (e r w s mod)
((_ id val) (syntax-case e ()
(id? #'id) ((_ id val)
(let ((n (id-var-name #'id w)) (id? #'id)
;; Lookup id in its module (call-with-values
(id-mod (if (syntax-object? #'id) (lambda () (resolve-identifier #'id w r mod))
(syntax-object-module #'id) (lambda (type value id-mod name)
mod))) (case type
(let ((b (lookup n r id-mod))) ((lexical)
(case (binding-type b) (build-lexical-assignment s (syntax->datum #'id) value
((lexical) (chi #'val r w mod)))
(build-lexical-assignment s ((global)
(syntax->datum #'id) (build-global-assignment s name (chi #'val r w mod) id-mod))
(binding-value b) ((macro)
(chi #'val r w mod))) (if (procedure-property value 'variable-transformer)
((global) ;; As syntax-type does, call chi-macro with
(build-global-assignment s n (chi #'val r w mod) id-mod)) ;; the mod of the expression. Hmm.
((macro) (chi (chi-macro value e r w s #f mod) r empty-wrap mod)
(let ((p (binding-value b))) (syntax-violation 'set! "not a variable transformer"
(if (procedure-property p 'variable-transformer) (wrap e w mod)
;; As syntax-type does, call chi-macro with (wrap #'id w id-mod))))
;; the mod of the expression. Hmm. ((displaced-lexical)
(chi (chi-macro p e r w s #f mod) r empty-wrap mod) (syntax-violation 'set! "identifier out of context"
(syntax-violation 'set! "not a variable transformer" (wrap #'id w mod)))
(wrap e w mod) (else
(wrap #'id w id-mod))))) (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))))
((displaced-lexical) ((_ (head tail ...) val)
(syntax-violation 'set! "identifier out of context" (call-with-values
(wrap #'id w mod))) (lambda () (syntax-type #'head r empty-wrap no-source #f mod #t))
(else (syntax-violation 'set! "bad set!" (lambda (type value ee ww ss modmod)
(source-wrap e w s mod))))))) (case type
((_ (head tail ...) val) ((module-ref)
(call-with-values (let ((val (chi #'val r w mod)))
(lambda () (syntax-type #'head r empty-wrap no-source #f mod #t)) (call-with-values (lambda () (value #'(head tail ...) r w))
(lambda (type value ee ww ss modmod) (lambda (e r w s* mod)
(case type (syntax-case e ()
((module-ref) (e (id? #'e)
(let ((val (chi #'val r w mod))) (build-global-assignment s (syntax->datum #'e)
(call-with-values (lambda () (value #'(head tail ...) r w)) val mod)))))))
(lambda (e r w s* mod) (else
(syntax-case e () (build-call s
(e (id? #'e) (chi #'(setter head) r w mod)
(build-global-assignment s (syntax->datum #'e) (map (lambda (e) (chi e r w mod))
val mod))))))) #'(tail ... val))))))))
(else (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
(build-call s
(chi #'(setter head) r w mod)
(map (lambda (e) (chi e r w mod))
#'(tail ... val))))))))
(_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
(global-extend 'module-ref '@ (global-extend 'module-ref '@
(lambda (e r w) (lambda (e r w)