From 33bb5e906086e4e0c0951d840916f8fa4bef602c Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Mon, 7 Sep 2015 20:25:34 -0400 Subject: [PATCH] Make prop:rename-transformer accept a procedure Allows the choice of target identifier to be delayed until expansion time, rather than fixed at the point of the transformer definition. --- .../scribblings/reference/stx-trans.scrbl | 35 +++++++- pkgs/racket-test-core/tests/racket/stx.rktl | 82 +++++++++++++++++++ racket/src/racket/src/struct.c | 22 ++++- 3 files changed, 133 insertions(+), 6 deletions(-) diff --git a/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl b/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl index 44278cc3a9..7548b0d335 100644 --- a/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl +++ b/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl @@ -181,8 +181,9 @@ A @tech{structure type property} to identify structure types that act as @tech{rename transformers} like the ones created by @racket[make-rename-transformer]. -The property value must be an exact integer or an identifier -@tech{syntax object}. In the former case, the integer designates a +The property value must be an exact integer, an identifier +@tech{syntax object}, or a procedure that takes one argument. +In the former case, the integer designates a field within the structure that should contain an identifier; the integer must be between @racket[0] (inclusive) and the number of non-automatic fields in the structure type (exclusive, not counting @@ -194,7 +195,35 @@ target for renaming, just like the first argument to @racket[make-rename-transformer]. If the property value is an integer, the target identifier is extracted from the structure instance; if the field value is not an identifier, then an identifier @racketidfont{?} -with an empty context is used, instead.} +with an empty context is used, instead. + +If the property value is a procedure that takes one argument, then the procedure +is called to obtain the identifier that the rename transformer will use +as a target identifier. If the procedure returns any value that is not +an identifier, the @racket[exn:fail:contract] exception is raised. + +@examples[#:eval stx-eval #:escape UNSYNTAX + (code:comment "Example of a procedure argument for prop:rename-transformer") + (define-syntax slv-1 'first-transformer-binding) + (define-syntax slv-2 'second-transformer-binding) + (begin-for-syntax + (struct slv-cooperator (redirect-to-first?) + #:property prop:rename-transformer + (λ (inst) + (if (slv-cooperator-redirect-to-first? inst) + #'slv-1 + #'slv-2)))) + (define-syntax (slv-lookup stx) + (syntax-case stx () + [(_ id) + #`(quote #,(syntax-local-value #'id))])) + (define-syntax slv-inst-1 (slv-cooperator #t)) + (define-syntax slv-inst-2 (slv-cooperator #f)) + (slv-lookup slv-inst-1) + (slv-lookup slv-inst-2) +] + +@history[#:changed "6.3" "the property now accepts a procedure of one argument."]} @defproc[(local-expand [stx any/c] diff --git a/pkgs/racket-test-core/tests/racket/stx.rktl b/pkgs/racket-test-core/tests/racket/stx.rktl index 7a5abe1e3c..93bef70763 100644 --- a/pkgs/racket-test-core/tests/racket/stx.rktl +++ b/pkgs/racket-test-core/tests/racket/stx.rktl @@ -2105,6 +2105,88 @@ (check stx #f) (check #f a-stx)) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Test prop:rename-transformer with procedure content + +(begin-for-syntax + (struct slv-struct-1 (id) + #:property prop:rename-transformer + (λ (o) (slv-struct-1-id o))) + + (struct slv-struct-2 (t1? t1 t2) + #:property prop:rename-transformer + (λ (o) + (if (slv-struct-2-t1? o) + (slv-struct-2-t1 o) + (slv-struct-2-t2 o)))) + + (struct slv-struct-bad () + #:property prop:rename-transformer + (λ (o) 'not-an-identifier))) + +(let () + (define-syntax target-1 't1) + (define-syntax target-2 't2) + + (define-syntax (m stx) + (syntax-case stx () + [(_ id) + #`(quote #,(syntax-local-value #'id) )])) + + (define-syntax (m2 stx) + (syntax-case stx () + [(_ id) + (let-values ([(x y) (syntax-local-value/immediate #'id)]) + #`(list (quote #,(if (rename-transformer? x) 'rename-transformer x)) + (quote #,(and y (syntax-e y)))))])) + + (define-syntax s1 (slv-struct-1 #'target-1)) + (define-syntax s2 (slv-struct-1 #'target-2)) + (define-syntax s3 (make-rename-transformer #'target-2)) + (define-syntax s4 (slv-struct-1 #'s3)) + (define-syntax s5 (slv-struct-2 #t #'target-1 #'target-2)) + (define-syntax s6 (slv-struct-2 #f #'target-1 #'target-2)) + (define-syntax s7 (slv-struct-2 #t #'s3 #'target-2)) + (define-syntax s8 (slv-struct-2 #f #'s3 #'target-2)) + (define-syntax s9 (make-rename-transformer #'s8)) + + (test 't1 values (m s1)) + (test '(rename-transformer target-1) values (m2 s1)) + (test 't2 values (m s2)) + (test '(rename-transformer target-2) values (m2 s2)) + (test 't2 values (m s4)) + (test '(rename-transformer s3) values (m2 s4)) + (test 't1 values (m s5)) + (test '(rename-transformer target-1) values (m2 s5)) + (test 't2 values (m s6)) + (test '(rename-transformer target-2) values (m2 s6)) + (test 't2 values (m s7)) + (test '(rename-transformer s3) values (m2 s7)) + (test 't2 values (m s8)) + (test '(rename-transformer target-2) values (m2 s8)) + (test 't2 values (m s9)) + (test '(rename-transformer s8) values (m2 s9)) + + (define target-3 't3) + (define target-4 't4) + (define-syntax r1 (slv-struct-1 #'target-3)) + (define-syntax r2 (slv-struct-1 #'target-4)) + (define-syntax r3 (slv-struct-2 #t #'target-3 #'target-4)) + (define-syntax r4 (slv-struct-2 #f #'target-3 #'target-4)) + (test 't3 values r1) + (test 't4 values r2) + (test 't3 values r3) + (test 't4 values r4) + + (err/rt-test + (let () + (struct foo () #:property prop:rename-transformer (λ (x y) 3)) + (void)) + exn:fail:contract?) + (err/rt-test + (eval #'(let () (define-syntax s-bad (slv-struct-bad)) (m s-bad))) + exn:fail:contract?)) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/racket/src/racket/src/struct.c b/racket/src/racket/src/struct.c index 6fa00b254f..353885cbc1 100644 --- a/racket/src/racket/src/struct.c +++ b/racket/src/racket/src/struct.c @@ -1882,14 +1882,30 @@ int scheme_is_binding_rename_transformer(Scheme_Object *o) static int is_stx_id(Scheme_Object *o) { return (SCHEME_STXP(o) && SCHEME_SYMBOLP(SCHEME_STX_VAL(o))); } +static int is_stx_id_or_proc_1(Scheme_Object *o) { return (is_stx_id(o) || is_proc_1(o)); } + Scheme_Object *scheme_rename_transformer_id(Scheme_Object *o) { + Scheme_Object *a[1]; + if (SAME_TYPE(SCHEME_TYPE(o), scheme_id_macro_type)) return SCHEME_PTR1_VAL(o); if (SCHEME_CHAPERONE_STRUCTP(o)) { Scheme_Object *v; v = scheme_struct_type_property_ref(rename_transformer_property, o); - if (SCHEME_INTP(v)) { + if (SCHEME_PROCP(v)) { + a[0] = o; + /* apply a continuation barrier here to prevent a capture in + * the property access */ + v = scheme_apply(v, 1, a); + if (!is_stx_id(v)) { + scheme_contract_error("prop:rename-transformer", + "contract violation for given value", + "expected", 0, "identifier?", + "given", 1, v, + NULL); + } + } else if (SCHEME_INTP(v)) { v = scheme_struct_ref(o, SCHEME_INT_VAL(v)); if (!is_stx_id(v)) { v = scheme_datum_to_syntax(scheme_intern_symbol("?"), scheme_false, scheme_false, 0, 0); @@ -1903,8 +1919,8 @@ Scheme_Object *scheme_rename_transformer_id(Scheme_Object *o) static Scheme_Object *check_rename_transformer_property_value_ok(int argc, Scheme_Object *argv[]) { return check_indirect_property_value_ok("guard-for-prop:rename-transformer", - is_stx_id, 0, - "(or/c exact-nonnegative-integer? identifier?)", + is_stx_id_or_proc_1, 0, + "(or/c exact-nonnegative-integer? identifier? (-> any/c identifier?))", argc, argv); }