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

add #:reflection-name option to struct form

Browse Source
This commit is contained in:
Matthew Flatt 2010-08-18 15:47:11 -06:00
parent 4299b12d5b
commit dafb9de74c
2 changed files with 29 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -83,6 +83,11 @@
(raise-type-error name "inspector or #f" what))) (raise-type-error name "inspector or #f" what)))
what) what)
(define (check-reflection-name name what)
(unless (symbol? what)
(raise-type-error name "symbol" what))
what)
(define-syntax (define-struct* stx) (define-syntax (define-struct* stx)
(syntax-case stx () (syntax-case stx ()
[(_ . rest) [(_ . rest)
@ -203,6 +208,7 @@
(#:mutable . #f) (#:mutable . #f)
(#:guard . #f) (#:guard . #f)
(#:constructor-name . #f) (#:constructor-name . #f)
(#:reflection-name . #f)
(#:only-constructor? . #f) (#:only-constructor? . #f)
(#:omit-define-values . #f) (#:omit-define-values . #f)
(#:omit-define-syntaxes . #f))] (#:omit-define-syntaxes . #f))]
@ -272,6 +278,13 @@
'#:only-constructor? '#:only-constructor?
(eq? '#:constructor-name (syntax-e (car p)))) (eq? '#:constructor-name (syntax-e (car p))))
nongen?)] nongen?)]
[(eq? '#:reflection-name (syntax-e (car p)))
(check-exprs 1 p "expression")
(when (lookup config '#:reflection-name)
(bad "multiple" "#:reflection-name keys" (car p)))
(loop (cddr p)
(extend-config config '#:reflection-name (cadr p))
nongen?)]
[(eq? '#:prefab (syntax-e (car p))) [(eq? '#:prefab (syntax-e (car p)))
(when (lookup config '#:inspector) (when (lookup config '#:inspector)
(bad "multiple" insp-keys "s" (car p))) (bad "multiple" insp-keys "s" (car p)))
@ -364,7 +377,8 @@
(car field-stxes))] (car field-stxes))]
[else [else
(loop (cdr fields) (cdr field-stxes) #f)]))]) (loop (cdr fields) (cdr field-stxes) #f)]))])
(let*-values ([(inspector super-expr props auto-val guard ctor-name ctor-only? mutable? (let*-values ([(inspector super-expr props auto-val guard ctor-name ctor-only?
reflect-name-expr mutable?
omit-define-values? omit-define-syntaxes?) omit-define-values? omit-define-syntaxes?)
(let ([config (parse-props #'fm (syntax->list #'(prop ...)) super-id)]) (let ([config (parse-props #'fm (syntax->list #'(prop ...)) super-id)])
(values (lookup config '#:inspector) (values (lookup config '#:inspector)
@ -374,6 +388,7 @@
(lookup config '#:guard) (lookup config '#:guard)
(lookup config '#:constructor-name) (lookup config '#:constructor-name)
(lookup config '#:only-constructor?) (lookup config '#:only-constructor?)
(lookup config '#:reflection-name)
(lookup config '#:mutable) (lookup config '#:mutable)
(lookup config '#:omit-define-values) (lookup config '#:omit-define-values)
(lookup config '#:omit-define-syntaxes)))] (lookup config '#:omit-define-syntaxes)))]
@ -423,7 +438,10 @@
(and super-expr (and super-expr
#`(check-struct-type 'fm #,super-expr)))] #`(check-struct-type 'fm #,super-expr)))]
[prune (lambda (stx) (identifier-prune-lexical-context stx [prune (lambda (stx) (identifier-prune-lexical-context stx
(list (syntax-e stx) '#%top)))]) (list (syntax-e stx) '#%top)))]
[reflect-name-expr (if reflect-name-expr
(quasisyntax (check-reflection-name 'fm #,reflect-name-expr))
(quasisyntax '#,id))])
(let ([run-time-defns (let ([run-time-defns
(lambda () (lambda ()
(quasisyntax/loc stx (quasisyntax/loc stx
@ -438,7 +456,7 @@
[else (cons #`[(_ #,(field-id (car fields))) #'#,pos] [else (cons #`[(_ #,(field-id (car fields))) #'#,pos]
(loop (cdr fields) (add1 pos)))])) (loop (cdr fields) (add1 pos)))]))
[(_ name) (raise-syntax-error #f "no such field" stx #'name)]))]) [(_ name) (raise-syntax-error #f "no such field" stx #'name)]))])
(make-struct-type '#,id (make-struct-type #,reflect-name-expr
#,super-struct: #,super-struct:
#,(- (length fields) auto-count) #,(- (length fields) auto-count)
#,auto-count #,auto-count

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

@ -26,6 +26,7 @@
(code:line #:prefab) (code:line #:prefab)
(code:line #:constructor-name constructor-id) (code:line #:constructor-name constructor-id)
(code:line #:extra-constructor-name constructor-id) (code:line #:extra-constructor-name constructor-id)
(code:line #:reflection-name symbol-expr)
#:omit-define-syntaxes #:omit-define-syntaxes
#:omit-define-values] #:omit-define-values]
[field-option #:mutable [field-option #:mutable
@ -134,6 +135,13 @@ and it is not the same as @racket[id], then @racket[id] does not serve
as a constructor, and @racket[object-name] on the constructor produces as a constructor, and @racket[object-name] on the constructor produces
the symbolic form of @racket[constructor-id]. the symbolic form of @racket[constructor-id].
If @racket[#:reflection-name symbol-expr] is provided, then
@racket[symbol-expr] must produce a symbol that is used to identify
the structure type in reflective operations such as
@racket[struct-type-info]. It corresponds to the first argument of
@racket[make-struct-type]. Structure printing uses the reflective
name, as do the various procedures that are bound by @racket[struct].
If the @racket[#:omit-define-syntaxes] option is supplied, then If the @racket[#:omit-define-syntaxes] option is supplied, then
@racket[id] is not bound as a transformer. If the @racket[id] is not bound as a transformer. If the
@racket[#:omit-define-values] option is supplied, then none of the @racket[#:omit-define-values] option is supplied, then none of the