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

fixed bug in provide/contract

Browse Source 
svn: r411
This commit is contained in:
Robby Findler 2005-07-21 00:22:36 +00:00
parent 5ebead55e1
commit b01290c3ef
2 changed files with 51 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
collects/mzlib/private/contract.ss
View File

@ -379,42 +379,40 @@ add struct contracts for immutable structs?
#f)]
[(field-contracts ...) field-contracts]
[(field-contract-ids ...) field-contract-ids])
(with-syntax ([struct-code
(with-syntax ([id-rename (a:mangle-id provide-stx
"provide/contract-struct-expandsion-info-id"
struct-name)]
[struct-name struct-name]
[struct:struct-name struct:struct-name]
;[(selector-id ...) selector-ids]
;[(mutator-id ...) mutator-ids]
;[predicate-id predicate-id]
;[constructor-id constructor-id]
[super-id (if (boolean? super-id)
super-id
(with-syntax ([super-id super-id])
(syntax #'super-id)))])
(syntax (begin
#;
(provide struct-name)
(provide (rename id-rename struct-name))
(define-syntax id-rename
(list-immutable #'struct:struct-name
#'constructor-new-name
#'predicate-new-name
(list-immutable #'selector-new-names ...)
(list-immutable #'mutator-new-names ...)
super-id)))))]
[struct:struct-name struct:struct-name])
(syntax/loc stx
(begin
struct-code
(define field-contract-ids field-contracts) ...
selector-codes ...
mutator-codes ...
predicate-code
constructor-code
(provide struct:struct-name)))))))
(with-syntax ([(rev-selector-new-names ...) (reverse (syntax->list (syntax (selector-new-names ...))))]
[(rev-mutator-new-names ...) (reverse (syntax->list (syntax (mutator-new-names ...))))])
(with-syntax ([struct-code
(with-syntax ([id-rename (a:mangle-id provide-stx
"provide/contract-struct-expandsion-info-id"
struct-name)]
[struct-name struct-name]
[struct:struct-name struct:struct-name]
[super-id (if (boolean? super-id)
super-id
(with-syntax ([super-id super-id])
(syntax #'super-id)))])
(syntax (begin
#;
(provide struct-name)
(provide (rename id-rename struct-name))
(define-syntax id-rename
(list-immutable #'struct:struct-name
#'constructor-new-name
#'predicate-new-name
(list-immutable #'rev-selector-new-names ...)
(list-immutable #'rev-mutator-new-names ...)
super-id)))))]
[struct:struct-name struct:struct-name])
(syntax/loc stx
(begin
struct-code
(define field-contract-ids field-contracts) ...
selector-codes ...
mutator-codes ...
predicate-code
constructor-code
(provide struct:struct-name))))))))
;; map/count : (X Y int -> Z) (listof X) (listof Y) -> (listof Z)
(define (map/count f l1 l2)

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

@ -1483,9 +1483,24 @@
'(parameterize ([current-namespace (make-namespace)])
(eval '(module m mzscheme
(require (lib "contract.ss"))
(define-struct (exn2 exn) ())
(provide/contract (struct (exn2 exn) ((message any/c) (continuation-marks any/c))))))
(define-struct (exn2 exn) ())
(provide/contract (struct (exn2 exn) ((message any/c) (continuation-marks any/c))))))
(eval '(require m))))
(test/spec-passed/result
'provide/contract13
'(parameterize ([current-namespace (make-namespace)])
(eval '(module common-msg-structs mzscheme
(require (lib "contract.ss" "mzlib"))
(define-struct register (name type) (make-inspector))
(provide/contract (struct register ([name any/c] [type any/c])))))
(eval '(require common-msg-structs))
(eval '(require (lib "plt-match.ss")))
(eval '(match (make-register 1 2)
[(struct register (name type))
(list name type)])))
(list 1 2))
;