From b078cbc0ef449663b6d468321d59289bf95b3bbd Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 8 Jan 2016 11:02:05 -0500 Subject: [PATCH] Add define-rename-transformer-parameter and friends --- pkgs/base/info.rkt | 2 +- .../scribblings/reference/stx-param.scrbl | 28 +++++++++++++ .../scribblings/reference/stx-trans.scrbl | 10 +++-- .../scribblings/reference/syntax.scrbl | 4 +- .../tests/racket/stxparam.rktl | 18 ++++++++ racket/collects/racket/private/stxparam.rkt | 32 +++++++++++---- .../collects/racket/private/stxparamkey.rkt | 41 ++++++++++++++++--- racket/collects/racket/stxparam.rkt | 33 ++++++++++----- racket/src/racket/src/schvers.h | 4 +- 9 files changed, 139 insertions(+), 33 deletions(-) diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index f0155438f0..3212dd1af8 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -12,7 +12,7 @@ (define collection 'multi) -(define version "6.3.0.13") +(define version "6.3.0.14") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/pkgs/racket-doc/scribblings/reference/stx-param.scrbl b/pkgs/racket-doc/scribblings/reference/stx-param.scrbl index d6ae7ab106..047e00384b 100644 --- a/pkgs/racket-doc/scribblings/reference/stx-param.scrbl +++ b/pkgs/racket-doc/scribblings/reference/stx-param.scrbl @@ -79,6 +79,34 @@ the target's value. (if t then else)))])) ]} +@defform[(define-rename-transformer-parameter id expr)]{ + +Binds @racket[id] as syntax to a @tech{syntax parameter} that must +be bound to a @racket[make-rename-transformer] result and, unlike +@racket[define-syntax-parameter], @racket[syntax-local-value] of +@racket[id] @emph{does} produce the target's value, including inside +of @racket[syntax-parameterize]. + +@examples[#:eval the-eval #:escape UNSYNTAX + (define-syntax (test stx) + (syntax-case stx () + [(_ t) + #`#,(syntax-local-value #'t)])) + (define-syntax one 1) + (define-syntax two 2) + (define-syntax-parameter not-num + (make-rename-transformer #'one)) + (test not-num) + + (define-rename-transformer-parameter num + (make-rename-transformer #'one)) + (test num) + (syntax-parameterize ([num (make-rename-transformer #'two)]) + (test num)) +] + +@history[#:added "6.3.0.14"]} + @; ---------------------------------------------------------------------- @section{Syntax Parameter Inspection} diff --git a/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl b/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl index ae05333533..6e9de282cf 100644 --- a/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl +++ b/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl @@ -198,10 +198,12 @@ 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. -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. +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. The returned identifier +should probably have the @racket['not-free-identifier=?] syntax +property. 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") diff --git a/pkgs/racket-doc/scribblings/reference/syntax.scrbl b/pkgs/racket-doc/scribblings/reference/syntax.scrbl index 9e2a88413b..fde18939ba 100644 --- a/pkgs/racket-doc/scribblings/reference/syntax.scrbl +++ b/pkgs/racket-doc/scribblings/reference/syntax.scrbl @@ -2926,8 +2926,8 @@ Similar to @racket[quote], but produces a @tech{syntax object} that preserves the @tech{lexical information} and source-location information attached to @racket[datum] at expansion time. -When @racket[#:local] is specified, than all @tech{scopes} in the -syntax object's @tech{lexical information} is preserved. When +When @racket[#:local] is specified, then all @tech{scopes} in the +syntax object's @tech{lexical information} are preserved. When @racket[#:local] is omitted, then the @tech{scope sets} within @racket[datum] are pruned to omit the @tech{scope} for any binding form that appears between the @racket[quote-syntax] form and the diff --git a/pkgs/racket-test-core/tests/racket/stxparam.rktl b/pkgs/racket-test-core/tests/racket/stxparam.rktl index 317614f3b8..b8daa79546 100644 --- a/pkgs/racket-test-core/tests/racket/stxparam.rktl +++ b/pkgs/racket-test-core/tests/racket/stxparam.rktl @@ -132,5 +132,23 @@ ;; ---------------------------------------- +(let () + (define-syntax (slv stx) + (syntax-case stx () + [(_ t) + #`#,(syntax-local-value #'t)])) + (define-syntax one 1) + (define-syntax two 2) + (define-rename-transformer-parameter num + (make-rename-transformer #'one)) + (test #t = (slv num) 1) + (syntax-parameterize ([num (make-rename-transformer #'two)]) + (test #t = (slv num) 2)) + (splicing-syntax-parameterize ([num (make-rename-transformer #'two)]) + (define too (slv num))) + (test #t = too 2)) + +;; ---------------------------------------- + (report-errs) diff --git a/racket/collects/racket/private/stxparam.rkt b/racket/collects/racket/private/stxparam.rkt index f9af1c8e9b..6fed01c96e 100644 --- a/racket/collects/racket/private/stxparam.rkt +++ b/racket/collects/racket/private/stxparam.rkt @@ -12,7 +12,7 @@ (syntax-case stx () [(_ ([id val] ...) body ...) (let ([ids (syntax->list #'(id ...))]) - (with-syntax ([(gen-id ...) + (with-syntax ([((gen-id must-be-renamer?) ...) (map (lambda (id) (unless (identifier? id) (raise-syntax-error @@ -20,19 +20,29 @@ "not an identifier" stx id)) - (let* ([rt (syntax-local-value id (lambda () #f))] - [sp (if (set!-transformer? rt) - (set!-transformer-procedure rt) - rt)]) + (let*-values + ;; If it is a rename-transformer-parameter, then + ;; we need to get the parameter and not what it + ;; points to, otherwise, we can keep going. + ([(rt* rt-target) + (syntax-local-value/immediate id (lambda () #f))] + [(rt) (if (syntax-parameter? rt*) + rt* + (or rt-target rt*))] + [(sp) (if (set!-transformer? rt) + (set!-transformer-procedure rt) + rt)]) (unless (syntax-parameter? sp) (raise-syntax-error #f "not bound as a syntax parameter" stx id)) - (syntax-local-get-shadower - (syntax-local-introduce (syntax-parameter-target sp)) - #t))) + (list + (syntax-local-get-shadower + (syntax-local-introduce (syntax-parameter-target sp)) + #t) + (rename-transformer-parameter? sp)))) ids)]) (let ([dup (check-duplicate-identifier ids)]) (when dup @@ -52,6 +62,10 @@ (list ids) #'())]) (syntax/loc stx - (let-syntaxes ([(gen-id) (convert-renamer val)] ...) + (let-syntaxes ([(gen-id) + (convert-renamer + (if must-be-renamer? (quote-syntax val) #f) + val)] + ...) orig ... body ...)))))]))) diff --git a/racket/collects/racket/private/stxparamkey.rkt b/racket/collects/racket/private/stxparamkey.rkt index 14884d6443..8a597dfbfe 100644 --- a/racket/collects/racket/private/stxparamkey.rkt +++ b/racket/collects/racket/private/stxparamkey.rkt @@ -4,10 +4,34 @@ "stxcase.rkt" "stxloc.rkt" "with-stx.rkt") (-define-struct wrapped-renamer (renamer)) - (-define-struct parameter-binding (val param)) + + (define-values (struct:parameter-binding make-parameter-binding parameter-binding? parameter-binding-ref parameter-binding-set!) + (make-struct-type 'parameter-binding #f 2 0 #f null (current-inspector) #f '(0 1))) + (define parameter-binding-val (make-struct-field-accessor parameter-binding-ref 0)) + (define parameter-binding-param (make-struct-field-accessor parameter-binding-ref 1)) + + (define (parameter-binding-rt-target pbr) + (rename-transformer-target (wrapped-renamer-renamer (parameter-binding-val pbr)))) + (define-values (struct:parameter-binding-rt make-parameter-binding-rt parameter-binding-rt? parameter-binding-rt-ref parameter-binding-rt-set!) + (make-struct-type 'parameter-binding-rt struct:parameter-binding 0 0 #f (list (cons prop:rename-transformer parameter-binding-rt-target)) (current-inspector) #f)) + (define-values (struct:syntax-parameter make-syntax-parameter syntax-parameter? syntax-parameter-ref syntax-parameter-set!) - (make-struct-type 'syntax-parameter #f 2 0 #f null (current-inspector) 0)) + (make-struct-type 'syntax-parameter #f 2 0 #f null (current-inspector) 0 '(0 1))) + + (define (rename-transformer-parameter-target rtp) + (define t (syntax-parameter-target rtp)) + ;; XXX (syntax-transforming?) is not always true when the + ;; prop:rename-transformer procedure is evaluated. I think this is + ;; because it used to test rename-transformer? + (define lt + (if (syntax-transforming?) + (syntax-local-get-shadower t #t) + t)) + (syntax-property lt 'not-free-identifier=? #t)) + + (define-values (struct:rename-transformer-parameter make-rename-transformer-parameter rename-transformer-parameter? rename-transformer-parameter-ref rename-transformer-parameter-set!) + (make-struct-type 'rename-transformer-parameter struct:syntax-parameter 0 0 #f (list (cons prop:rename-transformer rename-transformer-parameter-target)) (current-inspector) #f)) (define (syntax-parameter-target sp) (syntax-parameter-ref sp 1)) @@ -36,12 +60,17 @@ (let ([v (target-value target)]) (parameter-binding-param v))) - (define (convert-renamer v) - (make-parameter-binding + (define (convert-renamer must-be-renamer?-stx v) + (when must-be-renamer?-stx + (unless (rename-transformer? v) + (raise-syntax-error #f "rename-transformer-parameter must be bound to rename-transformer" must-be-renamer?-stx))) + ((if must-be-renamer?-stx + make-parameter-binding-rt + make-parameter-binding) (if (rename-transformer? v) (make-wrapped-renamer v) v) - ;; comile-time parameter needed for `splicing-syntax-parameterize': + ;; compile-time parameter needed for `splicing-syntax-parameterize': (make-parameter #f))) (define (apply-transformer v stx set!-stx) @@ -84,6 +113,8 @@ apply-transformer syntax-parameter? make-syntax-parameter + rename-transformer-parameter? + make-rename-transformer-parameter syntax-parameter-target syntax-parameter-target-value syntax-parameter-target-parameter)) diff --git a/racket/collects/racket/stxparam.rkt b/racket/collects/racket/stxparam.rkt index ab198b4f06..cf3c561a07 100644 --- a/racket/collects/racket/stxparam.rkt +++ b/racket/collects/racket/stxparam.rkt @@ -10,6 +10,7 @@ "private/stxloc.rkt" "private/stxparamkey.rkt")) (#%provide define-syntax-parameter + define-rename-transformer-parameter syntax-parameterize (for-syntax syntax-parameter-value make-parameter-rename-transformer)) @@ -18,16 +19,28 @@ (syntax-case stx () [(_ id init-val) (with-syntax ([gen-id (car (generate-temporaries (list #'id)))]) - #'(begin - (define-syntax gen-id (convert-renamer init-val)) - (define-syntax id - (let ([gen-id #'gen-id]) - (make-set!-transformer - (make-syntax-parameter - (lambda (stx) - (let ([v (syntax-parameter-target-value gen-id)]) - (apply-transformer v stx #'set!))) - gen-id))))))])) + #'(begin + (define-syntax gen-id (convert-renamer #f init-val)) + (define-syntax id + (let ([gen-id #'gen-id]) + (make-set!-transformer + (make-syntax-parameter + (lambda (stx) + (let ([v (syntax-parameter-target-value gen-id)]) + (apply-transformer v stx #'set!))) + gen-id))))))])) + + (define-syntax (define-rename-transformer-parameter stx) + (syntax-case stx () + [(_ id init-val) + (with-syntax ([gen-id (car (generate-temporaries (list #'id)))]) + #'(begin + (define-syntax gen-id (convert-renamer #'init-val init-val)) + (define-syntax id + (let ([gen-id #'gen-id]) + (make-rename-transformer-parameter + #f + gen-id)))))])) (define-syntax (syntax-parameterize stx) (do-syntax-parameterize stx #'let-syntaxes #f #f))) diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 38ecd3f12b..c869cac2f3 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "6.3.0.13" +#define MZSCHEME_VERSION "6.3.0.14" #define MZSCHEME_VERSION_X 6 #define MZSCHEME_VERSION_Y 3 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 13 +#define MZSCHEME_VERSION_W 14 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)