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

syntax parameters implemented properly

Browse source 
* module/ice-9/psyntax.scm (resolve-identifier): Take an additional
  argument, indicating whether syntax parameters should be resolved or
  not.  Just return three values: the binding type and value, and the
  module for resolving toplevels.
  (chi-install-global): Take an extra arg, the type.  If we are defining
  a syntax parameter, construct a pair for the binding.
  (chi-body): Syntax parameters now use a per-parameter unique value (a
  pair) as a key in the expansion-time environment `r'.
  (syntax-parameterize): Don't allow parameterization of
  non-parameters.  This is an incompatible change, but it is for the
  better; you don't want to allow users to parameterize `lambda', after
  all.
This commit is contained in:
Andy Wingo 2011-11-05 15:36:02 +01:00
parent ea3ca4e4d0
commit 5b36d6034b
1 changed files with 60 additions and 42 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -493,6 +493,7 @@
;; identifier bindings include a type and a value ;; identifier bindings include a type and a value
;; <binding> ::= (macro . <procedure>) macros ;; <binding> ::= (macro . <procedure>) macros
;; (syntax-parameter . (<procedure>)) syntax parameters
;; (core . <procedure>) core forms ;; (core . <procedure>) core forms
;; (module-ref . <procedure>) @ or @@ ;; (module-ref . <procedure>) @ or @@
;; (begin) begin ;; (begin) begin
@ -564,7 +565,7 @@
(if (null? r) (if (null? r)
'() '()
(let ((a (car r))) (let ((a (car r)))
(if (eq? (cadr a) 'macro) (if (memq (cadr a) '(macro syntax-parameter))
(cons a (macros-only-env (cdr r))) (cons a (macros-only-env (cdr r)))
(macros-only-env (cdr r))))))) (macros-only-env (cdr r)))))))
@ -789,32 +790,33 @@
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 ;; Returns three values: binding type, binding value, the module (for
;; resolving toplevel vars), and the name (for possible overriding ;; resolving toplevel vars).
;; by syntax-parameterize). (define (resolve-identifier id w r mod resolve-syntax-parameters?)
(define (resolve-identifier id w r mod) (define (resolve-syntax-parameters b)
(if (and resolve-syntax-parameters?
(eq? (binding-type b) 'syntax-parameter))
(or (assq-ref r (binding-value b))
(make-binding 'macro (car (binding-value b))))
b))
(define (resolve-global var mod) (define (resolve-global var mod)
;; `var' is probably a global, but we check the environment (let ((b (resolve-syntax-parameters
;; first anyway because a temporary binding may have been (or (get-global-definition-hook var mod)
;; established by `syntax-parameterize'. FIXME: overriding a (make-binding 'global)))))
;; toplevel via syntax-parameterize using just a symbolic name (if (eq? (binding-type b) 'global)
;; (without a module) does not make sense. (values 'global var mod)
(let ((b (or (assq-ref r var) (values (binding-type b) (binding-value b) mod))))
(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) (define (resolve-lexical label mod)
(let ((b (or (assq-ref r label) (let ((b (resolve-syntax-parameters
(make-binding 'displaced-lexical)))) (or (assq-ref r label)
(values (binding-type b) (binding-value b) mod 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)))
(cond (cond
((syntax-object? n) ((syntax-object? n)
;; Recursing allows syntax-parameterize to override ;; Recursing allows syntax-parameterize to override
;; macro-introduced bindings, I think. ;; macro-introduced syntax parameters.
(resolve-identifier n w r mod)) (resolve-identifier n w r mod resolve-syntax-parameters?))
((symbol? n) ((symbol? n)
(resolve-global n (if (syntax-object? id) (resolve-global n (if (syntax-object? id)
(syntax-object-module id) (syntax-object-module id)
@ -992,23 +994,23 @@
((c) ((c)
(cond (cond
((memq 'compile esew) ((memq 'compile esew)
(let ((e (chi-install-global var (chi e r w mod)))) (let ((e (chi-install-global var type (chi e r w mod))))
(top-level-eval-hook e mod) (top-level-eval-hook e mod)
(if (memq 'load esew) (if (memq 'load esew)
(list (lambda () e)) (list (lambda () e))
'()))) '())))
((memq 'load esew) ((memq 'load esew)
(list (lambda () (list (lambda ()
(chi-install-global var (chi e r w mod))))) (chi-install-global var type (chi e r w mod)))))
(else '()))) (else '())))
((c&e) ((c&e)
(let ((e (chi-install-global var (chi e r w mod)))) (let ((e (chi-install-global var type (chi e r w mod))))
(top-level-eval-hook e mod) (top-level-eval-hook e mod)
(list (lambda () e)))) (list (lambda () e))))
(else (else
(if (memq 'eval esew) (if (memq 'eval esew)
(top-level-eval-hook (top-level-eval-hook
(chi-install-global var (chi e r w mod)) (chi-install-global var type (chi e r w mod))
mod)) mod))
'())))) '()))))
((begin-form) ((begin-form)
@ -1069,17 +1071,21 @@
(build-sequence s exps)))))) (build-sequence s exps))))))
(define chi-install-global (define chi-install-global
(lambda (name e) (lambda (name type e)
(build-global-definition (build-global-definition
no-source no-source
name name
(build-primcall (build-primcall
no-source no-source
'make-syntax-transformer 'make-syntax-transformer
(list (build-data no-source name) (if (eq? type 'define-syntax-parameter-form)
(build-data no-source 'macro) (list (build-data no-source name)
e))))) (build-data no-source 'syntax-parameter)
(build-primcall no-source 'list (list e)))
(list (build-data no-source name)
(build-data no-source 'macro)
e))))))
(define chi-when-list (define chi-when-list
(lambda (e when-list w) (lambda (e when-list w)
;; `when-list' is syntax'd version of list of situations. We ;; `when-list' is syntax'd version of list of situations. We
@ -1142,8 +1148,8 @@
(lambda (e r w s rib mod for-car?) (lambda (e r w s rib mod for-car?)
(cond (cond
((symbol? e) ((symbol? e)
(call-with-values (lambda () (resolve-identifier e w r mod)) (call-with-values (lambda () (resolve-identifier e w r mod #t))
(lambda (type value mod* name) (lambda (type value mod*)
(case type (case type
((macro) ((macro)
(if for-car? (if for-car?
@ -1438,7 +1444,11 @@
(parse (cdr body) (parse (cdr body)
(cons id ids) (cons label labels) (cons id ids) (cons label labels)
var-ids vars vals var-ids vars vals
(cons (make-binding 'macro (cons er (wrap e w mod))) (cons (make-binding
(if (eq? type 'define-syntax-parameter-form)
'syntax-parameter
'macro)
(cons er (wrap e w mod)))
bindings)))) bindings))))
((begin-form) ((begin-form)
(syntax-case e () (syntax-case e ()
@ -1473,7 +1483,7 @@
(let loop ((bs bindings) (er-cache #f) (r-cache #f)) (let loop ((bs bindings) (er-cache #f) (r-cache #f))
(if (not (null? bs)) (if (not (null? bs))
(let* ((b (car bs))) (let* ((b (car bs)))
(if (eq? (car b) 'macro) (if (memq (car b) '(macro syntax-parameter))
(let* ((er (cadr b)) (let* ((er (cadr b))
(r-cache (r-cache
(if (eq? er er-cache) (if (eq? er er-cache)
@ -1483,6 +1493,8 @@
(eval-local-transformer (eval-local-transformer
(chi (cddr b) r-cache empty-wrap mod) (chi (cddr b) r-cache empty-wrap mod)
mod)) mod))
(if (eq? (car b) 'syntax-parameter)
(set-cdr! b (list (cdr b))))
(loop (cdr bs) er r-cache)) (loop (cdr bs) er r-cache))
(loop (cdr bs) er-cache r-cache))))) (loop (cdr bs) er-cache r-cache)))))
(set-cdr! r (extend-env labels bindings (cdr r))) (set-cdr! r (extend-env labels bindings (cdr r)))
@ -1818,15 +1830,21 @@
(let ((names (let ((names
(map (lambda (x) (map (lambda (x)
(call-with-values (call-with-values
(lambda () (resolve-identifier x w r mod)) (lambda () (resolve-identifier x w r mod #f))
(lambda (type value mod name) (lambda (type value mod)
(case type (case type
((displaced-lexical) ((displaced-lexical)
(syntax-violation 'syntax-parameterize (syntax-violation 'syntax-parameterize
"identifier out of context" "identifier out of context"
e e
(source-wrap x w s mod))) (source-wrap x w s mod)))
(else name))))) ((syntax-parameter)
value)
(else
(syntax-violation 'syntax-parameterize
"invalid syntax parameter"
e
(source-wrap x w s mod)))))))
#'(var ...))) #'(var ...)))
(bindings (bindings
(let ((trans-r (macros-only-env r))) (let ((trans-r (macros-only-env r)))
@ -1857,8 +1875,8 @@
(lambda (src e r maps ellipsis? mod) (lambda (src e r maps ellipsis? mod)
(if (id? e) (if (id? e)
(call-with-values (lambda () (call-with-values (lambda ()
(resolve-identifier e empty-wrap r mod)) (resolve-identifier e empty-wrap r mod #f))
(lambda (type value mod name) (lambda (type value mod)
(case type (case type
((syntax) ((syntax)
(call-with-values (call-with-values
@ -2151,14 +2169,14 @@
((_ id val) ((_ id val)
(id? #'id) (id? #'id)
(call-with-values (call-with-values
(lambda () (resolve-identifier #'id w r mod)) (lambda () (resolve-identifier #'id w r mod #t))
(lambda (type value id-mod name) (lambda (type value id-mod)
(case type (case type
((lexical) ((lexical)
(build-lexical-assignment s (syntax->datum #'id) value (build-lexical-assignment s (syntax->datum #'id) value
(chi #'val r w mod))) (chi #'val r w mod)))
((global) ((global)
(build-global-assignment s name (chi #'val r w mod) id-mod)) (build-global-assignment s value (chi #'val r w mod) id-mod))
((macro) ((macro)
(if (procedure-property value 'variable-transformer) (if (procedure-property value 'variable-transformer)
;; As syntax-type does, call chi-macro with ;; As syntax-type does, call chi-macro with