suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Use syntax-procedure-alias-property with struct constructor procedures as well.

Browse Source 
This uses a new `racket/private/procedure-alias` module
which provides the relevant symbol via `protect-out`.
This commit is contained in:
Sam Tobin-Hochstadt 2013-01-14 12:33:46 -05:00
parent b6564980ab
commit 230172cf94
4 changed files with 41 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
collects/racket/private/define-struct.rkt
View File

@ -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)

12
collects/racket/private/kw.rkt
View File

@ -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)))

19
collects/racket/private/procedure-alias.rkt Normal file
View File

@ -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)))

3
collects/scribblings/reference/define-struct.scrbl
View File

@ -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