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

fixed define-contract-struct so that it defines (via define-syntax) the struct name, following the define-struct covention

Browse Source 
svn: r6664
This commit is contained in:
Robby Findler 2007-06-14 21:14:14 +00:00
parent 9cec27f49b
commit ea5b3493f3
2 changed files with 26 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/mzlib/private/contract-ds.ss
View File

@ -58,7 +58,7 @@ it around flattened out.
#f
#t
stx)]
[struct:-name (list-ref struct-names 0)]
[struct:-name/val (list-ref struct-names 0)]
[struct-maker/val (list-ref struct-names 1)]
[predicate/val (list-ref struct-names 2)]
[selectors/val (cdddr struct-names)]
@ -72,6 +72,7 @@ it around flattened out.
[struct/dc struct/dc-name/val]
[field-count field-count/val]
[(selectors ...) selectors/val]
[struct:-name struct:-name/val]
[struct-maker struct-maker/val]
[predicate predicate/val]
[contract-name (add-suffix "-contract")]
@ -94,6 +95,13 @@ it around flattened out.
(values))))
(list))
(define-syntax name (list-immutable #'struct:-name
#'struct-maker
#'predicate
(list-immutable #'selectors ...)
(list-immutable #,@(map (λ (x) #f) (syntax->list #'(selectors ...))))
#t))
(define (evaluate-attrs stct contract/info)
(when (wrap-parent-get stct 0) ;; test to make sure this even has attributes
(let* ([any-unknown? #f]

19
collects/tests/mzscheme/contract-test.ss
View File

@ -3399,13 +3399,28 @@
(contract-eval '(define-contract-struct couple (hd tl)))
(test/spec-passed
'd-c-s-match1
'(begin
(eval '(module d-c-s-match1 mzscheme
(require (lib "contract.ss")
(lib "match.ss"))
(define-contract-struct foo (bar baz))
(match (make-foo #t #f)
[($ foo bar baz) #t]
[_ #f])))
(eval '(require d-c-s-match1))))
(test/pos-blame 'd-c-s1
'(begin
(eval '(module m mzscheme
(eval '(module d-c-s1 mzscheme
(require (lib "contract.ss"))
(define-contract-struct couple (hd tl))
(contract (couple/c any/c any/c) 1 'pos 'neg)))
(eval '(require m))))
(eval '(require d-c-s1))))
(test/spec-passed 'd-c-s2
'(contract (couple/c any/c any/c) (make-couple 1 2) 'pos 'neg))