diff --git a/collects/racket/private/define-struct.rkt b/collects/racket/private/define-struct.rkt index 5c93db6d71..676cd74f1d 100644 --- a/collects/racket/private/define-struct.rkt +++ b/collects/racket/private/define-struct.rkt @@ -4,6 +4,7 @@ (module define-struct '#%kernel (#%require "small-scheme.rkt" "define.rkt" "../stxparam.rkt" (for-syntax '#%kernel "define.rkt" + "procedure-alias.rkt" "stx.rkt" "stxcase-scheme.rkt" "small-scheme.rkt" "stxloc.rkt" "qqstx.rkt" "struct-info.rkt")) @@ -57,12 +58,21 @@ (datum->syntax orig (syntax-e orig) stx orig)) (syntax-case stx () [(self arg ...) (datum->syntax stx - (cons (syntax-property (transfer-srcloc orig #'self) - 'constructor-for - (syntax-local-introduce #'self)) - (syntax-e (syntax (arg ...)))) + (cons + (syntax-property + (syntax-property (transfer-srcloc orig #'self) + 'constructor-for + (syntax-local-introduce #'self)) + alias-of (syntax-local-introduce #'self)) + (syntax-e (syntax (arg ...)))) stx stx)] + [self (identifier? #'self) + (syntax-property + (syntax-property (transfer-srcloc orig #'self) + 'constructor-for + (syntax-local-introduce #'self)) + alias-of (syntax-local-introduce #'self))] [_ (transfer-srcloc orig stx)])) (define-values-for-syntax (make-self-ctor-struct-info) diff --git a/collects/racket/private/kw.rkt b/collects/racket/private/kw.rkt index 3a1f68b189..23dbc9d9dd 100644 --- a/collects/racket/private/kw.rkt +++ b/collects/racket/private/kw.rkt @@ -3,6 +3,7 @@ "small-scheme.rkt" "more-scheme.rkt" (for-syntax '#%kernel + "procedure-alias.rkt" "stx.rkt" "small-scheme.rkt" "stxcase-scheme.rkt" @@ -972,14 +973,11 @@ (define-for-syntax kw-expander-impl (make-struct-field-accessor kw-expander-ref 1 'impl)) (define-for-syntax kw-expander-proc (make-struct-field-accessor kw-expander-ref 2 'proc)) - (define-for-syntax kw-alias-of (gensym 'alias-of)) (define-for-syntax kw-converted-arguments-variant-of (gensym 'converted-arguments-variant-of)) - (define-for-syntax (syntax-procedure-alias-property stx) - (unless (syntax? stx) (raise-argument-error 'syntax-procedure-alias "syntax?" stx)) - (syntax-property stx kw-alias-of)) (define-for-syntax (syntax-procedure-converted-arguments-property stx) - (unless (syntax? stx) (raise-argument-error 'syntax-procedure-converted-arguments "syntax?" stx)) + (unless (syntax? stx) + (raise-argument-error 'syntax-procedure-converted-arguments "syntax?" stx)) (syntax-property stx kw-converted-arguments-variant-of)) (define-for-syntax (make-keyword-syntax get-ids n-req n-opt rest? req-kws all-kws) @@ -1015,7 +1013,7 @@ (cons (syntax-taint (syntax-local-introduce #'self)) (syntax-taint (syntax-local-introduce impl-id))))] [wrap-id/prop - (syntax-property wrap-id kw-alias-of + (syntax-property wrap-id alias-of (cons (syntax-taint (syntax-local-introduce #'self)) (syntax-taint (syntax-local-introduce wrap-id))))]) (if (free-identifier=? #'new-app (datum->syntax stx '#%app)) @@ -1124,7 +1122,7 @@ orig)))) (datum->syntax stx (cons wrap-id/prop #'(arg ...)) stx stx)))] [self - (syntax-property wrap-id kw-alias-of (cons (syntax-taint (syntax-local-introduce #'self)) + (syntax-property wrap-id alias-of (cons (syntax-taint (syntax-local-introduce #'self)) (syntax-taint (syntax-local-introduce wrap-id))))])) (lambda () (define-values (impl-id wrap-id) (get-ids)) impl-id) (lambda () (define-values (impl-id wrap-id) (get-ids)) wrap-id))) diff --git a/collects/racket/private/procedure-alias.rkt b/collects/racket/private/procedure-alias.rkt new file mode 100644 index 0000000000..f0d0560a31 --- /dev/null +++ b/collects/racket/private/procedure-alias.rkt @@ -0,0 +1,19 @@ +(module procedure-alias '#%kernel + (#%require "define.rkt" + "small-scheme.rkt" + "more-scheme.rkt" + (for-syntax '#%kernel + "stx.rkt" + "small-scheme.rkt" + "stxcase-scheme.rkt" + "name.rkt" + "norm-define.rkt" + "qqstx.rkt" + "sort.rkt")) + + (#%provide syntax-procedure-alias-property (protect alias-of)) + (define alias-of (gensym 'alias-of)) + (define (syntax-procedure-alias-property stx) + (unless (syntax? stx) + (raise-argument-error 'syntax-procedure-alias "syntax?" stx)) + (syntax-property stx alias-of))) diff --git a/collects/scribblings/reference/define-struct.scrbl b/collects/scribblings/reference/define-struct.scrbl index 0f355d49b9..cbad3788f3 100644 --- a/collects/scribblings/reference/define-struct.scrbl +++ b/collects/scribblings/reference/define-struct.scrbl @@ -66,6 +66,9 @@ to @math{4+2n} names: inaccessible identifier that is bound to the constructor procedure; the expanded identifier has a @racket['constructor-for] property whose value is an identifier + that is @racket[free-identifier=?] to @racket[id] as well as + a syntax property accessible via + @racket[syntax-procedure-alias-property] with an identifier that is @racket[free-identifier=?] to @racket[id].} @item{@racket[id]@racketidfont{?}, a @deftech{predicate} procedure