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

Allow the structure name to be used as a constructor.

Browse Source 
Push to 5.0.
This commit is contained in:
Stevie Strickland 2010-05-21 17:13:19 -04:00
parent c4f67b3e74
commit 77b4106c84
2 changed files with 34 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
collects/racket/contract/regions.rkt
View File

@ -94,6 +94,20 @@
#:freevars ([fv.var fv.ctc] ...) #:freevars ([fv.var fv.ctc] ...)
(define name body-expr)))))])) (define name body-expr)))))]))
(begin-for-syntax
(define-struct contract-struct-info (si cons)
#:omit-define-syntaxes
#:property prop:struct-info (λ (s) ((contract-struct-info-si s)))
#:property prop:procedure (λ (s stx)
(with-syntax ([orig ((contract-struct-info-cons s))])
(syntax-case stx ()
[(_ arg ...)
(datum->syntax stx
(syntax-e (syntax (orig arg ...)))
stx
stx)]
[_ #'orig])))))
(define-syntax (define-struct/contract stx) (define-syntax (define-struct/contract stx)
(define-struct field-info (stx ctc [mutable? #:mutable] auto?)) (define-struct field-info (stx ctc [mutable? #:mutable] auto?))
(define-struct s-info (auto-value-stx transparent? def-stxs? def-vals?)) (define-struct s-info (auto-value-stx transparent? def-stxs? def-vals?))
@ -371,7 +385,7 @@
[(s-info-def-vals? sinfo) [(s-info-def-vals? sinfo)
(list (list
#`(define-syntax struct-name #`(define-syntax struct-name
(make-struct-info (make-contract-struct-info
(λ () (λ ()
(list #,(quoter #'struct:) (list #,(quoter #'struct:)
#,(quoter #'maker) #,(quoter #'maker)
@ -380,7 +394,8 @@
(list #,@(map quoter super-refs))) (list #,@(map quoter super-refs)))
(list* #,@(map quoter (syntax->list #'(mut ...))) (list* #,@(map quoter (syntax->list #'(mut ...)))
(list #,@(map quoter super-muts))) (list #,@(map quoter super-muts)))
#,(quoter #'super))))))] #,(quoter #'super)))
(λ () #,(quoter #'maker)))))]
[else [else
(list (list
#'(define-syntax struct-name #'(define-syntax struct-name

17
collects/tests/racket/contract-test.rktl
View File

@ -2877,6 +2877,23 @@
[(struct point [dx dy]) (list dx dy)] [(struct point [dx dy]) (list dx dy)]
[v (box v)])) [v (box v)]))
(list 1 2 'red)) (list 1 2 'red))
(test/spec-passed
'define-struct/contract25
'(let ()
(define-struct/contract point
([x number?] [y number?])
#:transparent)
(point 1 2)))
(test/spec-failed
'define-struct/contract26
'(let ()
(define-struct/contract point
([x number?] [y number?])
#:transparent)
(point 1 #t))
"top-level")
; ;
; ;
; ;