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

fixed bugs dealing with super structs in provide/contract and fixed (newly exposed) bugs in mrflow

Browse Source 
svn: r391
This commit is contained in:
Robby Findler 2005-07-18 13:06:30 +00:00
parent 758d2cbd29
commit 4b0e802fe4
8 changed files with 95 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/mrflow/assoc-set-exn.ss
View File

@ -6,6 +6,7 @@
(provide
(struct exn:assoc-set:key-not-found (assoc-set key))
(struct exn:assoc-set:duplicate-key (assoc-set key))
exn:assoc-set
exn:assoc-set?
raise-key-not-found-exn
raise-duplicate-key-exn

10
collects/mrflow/assoc-set-hash.ss
View File

@ -20,8 +20,14 @@
(provide/contract
(exn:assoc-set? (any/c . -> . boolean?))
(struct exn:assoc-set:key-not-found ((assoc-set assoc-set?) (key any/c)))
(struct exn:assoc-set:duplicate-key ((assoc-set assoc-set?) (key any/c)))
(struct (exn:assoc-set:key-not-found exn:assoc-set) ((message (and/c string? immutable?))
(continuation-mark-set continuation-mark-set?)
(assoc-set assoc-set?)
(key any/c)))
(struct (exn:assoc-set:duplicate-key exn:assoc-set) ((message (and/c string? immutable?))
(continuation-mark-set continuation-mark-set?)
(assoc-set assoc-set?)
(key any/c)))
(assoc-set-make (() ((symbols 'equal)) . opt-> . assoc-set?))
(assoc-set-reset (assoc-set? . -> . assoc-set?))
(assoc-set? (any/c . -> . boolean?))

10
collects/mrflow/assoc-set-list.ss
View File

@ -22,8 +22,14 @@
(provide/contract
(exn:assoc-set? (any/c . -> . boolean?))
(struct exn:assoc-set:key-not-found ((assoc-set assoc-set?) (key any/c)))
(struct exn:assoc-set:duplicate-key ((assoc-set assoc-set?) (key any/c)))
(struct (exn:assoc-set:key-not-found exn:assoc-set) ((message (and/c string? immutable?))
(continuation-mark-set continuation-mark-set?)
(assoc-set assoc-set?)
(key any/c)))
(struct (exn:assoc-set:duplicate-key exn:assoc-set) ((message (and/c string? immutable?))
(continuation-mark-set continuation-mark-set?)
(assoc-set assoc-set?)
(key any/c)))
(assoc-set-make (() ((symbols 'equal)) . opt-> . assoc-set?))
(assoc-set-reset (assoc-set? . -> . assoc-set?))
(assoc-set? (any/c . -> . boolean?))

1
collects/mrflow/set-exn.ss
View File

@ -5,6 +5,7 @@
(module set-exn mzscheme
(provide
exn:set
exn:set?
(struct exn:set:value-not-found (set value))
(struct exn:set:duplicate-value (set value))

10
collects/mrflow/set-hash.ss
View File

@ -19,8 +19,14 @@
(provide/contract
(exn:set? (any/c . -> . boolean?))
(struct exn:set:value-not-found ((set set?) (value any/c)))
(struct exn:set:duplicate-value ((set set?) (value any/c)))
(struct (exn:set:value-not-found exn:set) ((message (and/c string? immutable?))
(continuation-mark-set continuation-mark-set?)
(set set?)
(value any/c)))
(struct (exn:set:duplicate-value exn:set) ((message (and/c string? immutable?))
(continuation-mark-set continuation-mark-set?)
(set set?)
(value any/c)))
(set-make (() ((symbols 'equal)) . opt-> . set?))
(set-reset (set? . -> . set?))
(set? (any/c . -> . boolean?))

10
collects/mrflow/set-list.ss
View File

@ -22,8 +22,14 @@
(provide/contract
(exn:set? (any/c . -> . boolean?))
(struct exn:set:value-not-found ((set set?) (value any/c)))
(struct exn:set:duplicate-value ((set set?) (value any/c)))
(struct (exn:set:value-not-found exn:set) ((message (and/c string? immutable?))
(continuation-mark-set continuation-mark-set?)
(set set?)
(value any/c)))
(struct (exn:set:duplicate-value exn:set) ((message (and/c string? immutable?))
(continuation-mark-set continuation-mark-set?)
(set set?)
(value any/c)))
(set-make (() ((symbols 'equal)) . opt-> . set?))
(set-reset (set? . -> . set?))
(set? (any/c . -> . boolean?))

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

@ -265,7 +265,7 @@ add struct contracts for immutable structs?
[selector-ids (reverse (list-ref struct-info 3))]
[mutator-ids (reverse (list-ref struct-info 4))]
[parent-struct-count (let ([parent-info (extract-parent-struct-info struct-name-position)])
(and parent-info
(and parent-info
(let ([fields (cadddr parent-info)])
(cond
[(null? fields) 0]
@ -291,16 +291,50 @@ add struct contracts for immutable structs?
(symbol->string (syntax-e struct-name)))))])
(let ([unknown-info
(λ (what)
(lambda (what names)
(raise-syntax-error
'provide/contract
(format "cannot determine ~a" what)
(format "cannot determine ~a, found ~s" what names)
provide-stx
struct-name))])
(unless constructor-id (unknown-info "constructor"))
(unless predicate-id (unknown-info "predicate"))
(unless (andmap values selector-ids) (unknown-info "selectors"))
(unless (andmap values mutator-ids) (unknown-info "mutators")))
struct-name))]
[is-id-ok?
(lambda (id i)
(if (or (not parent-struct-count)
(parent-struct-count . <= . i))
id
#t))])
(unless constructor-id (unknown-info "constructor" constructor-id))
(unless predicate-id (unknown-info "predicate" predicate-id))
(unless (andmap/count is-id-ok? selector-ids)
(unknown-info "selectors"
(map (lambda (x) (if (syntax? x)
(syntax-object->datum x)
x))
selector-ids)))
(unless (andmap/count is-id-ok? mutator-ids)
(unknown-info "mutators"
(map (lambda (x) (if (syntax? x)
(syntax-object->datum x)
x))
mutator-ids))))
(unless (equal? (length selector-ids)
(length field-contract-ids))
(raise-syntax-error 'provide/contract
(format "found ~a fields in struct, but ~a contracts"
(length selector-ids)
(length field-contract-ids))
provide-stx
struct-name))
(unless (equal? (length mutator-ids)
(length field-contract-ids))
(raise-syntax-error 'provide/contract
(format "found ~a fields in struct, but ~a contracts"
(length mutator-ids)
(length field-contract-ids))
provide-stx
struct-name))
(with-syntax ([((selector-codes selector-new-names) ...)
(filter
@ -395,6 +429,16 @@ add struct contracts for immutable structs?
(cdr l2)
(+ i 1)))])))
;; andmap/count : (X Y int -> Z) (listof X) (listof Y) -> (listof Z)
(define (andmap/count f l1)
(let loop ([l1 l1]
[i 0])
(cond
[(null? l1) #t]
[else (and (f (car l1) i)
(loop (cdr l1)
(+ i 1)))])))
;; extract-parent-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...))
(define (extract-parent-struct-info stx)
(syntax-case stx ()

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

@ -1478,6 +1478,15 @@
(eval '(require n)))
'n)
(test/spec-passed
'provide/contract12
'(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))))))
(eval '(require m))))
;
;