From 4b0e802fe44083d923e34734d773b545246e1ee4 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 18 Jul 2005 13:06:30 +0000 Subject: [PATCH] fixed bugs dealing with super structs in provide/contract and fixed (newly exposed) bugs in mrflow svn: r391 --- collects/mrflow/assoc-set-exn.ss | 1 + collects/mrflow/assoc-set-hash.ss | 10 +++- collects/mrflow/assoc-set-list.ss | 10 +++- collects/mrflow/set-exn.ss | 1 + collects/mrflow/set-hash.ss | 10 +++- collects/mrflow/set-list.ss | 10 +++- collects/mzlib/private/contract.ss | 60 ++++++++++++++++++++---- collects/tests/mzscheme/contract-test.ss | 9 ++++ 8 files changed, 95 insertions(+), 16 deletions(-) diff --git a/collects/mrflow/assoc-set-exn.ss b/collects/mrflow/assoc-set-exn.ss index 99332bcce7..99ded81e80 100644 --- a/collects/mrflow/assoc-set-exn.ss +++ b/collects/mrflow/assoc-set-exn.ss @@ -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 diff --git a/collects/mrflow/assoc-set-hash.ss b/collects/mrflow/assoc-set-hash.ss index 3a51681d3d..fbafda956a 100644 --- a/collects/mrflow/assoc-set-hash.ss +++ b/collects/mrflow/assoc-set-hash.ss @@ -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?)) diff --git a/collects/mrflow/assoc-set-list.ss b/collects/mrflow/assoc-set-list.ss index b7d9f50de5..85c5bf162c 100644 --- a/collects/mrflow/assoc-set-list.ss +++ b/collects/mrflow/assoc-set-list.ss @@ -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?)) diff --git a/collects/mrflow/set-exn.ss b/collects/mrflow/set-exn.ss index d85304f213..e4f9fcf33f 100644 --- a/collects/mrflow/set-exn.ss +++ b/collects/mrflow/set-exn.ss @@ -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)) diff --git a/collects/mrflow/set-hash.ss b/collects/mrflow/set-hash.ss index 36c32c4ba3..40cca6b57c 100644 --- a/collects/mrflow/set-hash.ss +++ b/collects/mrflow/set-hash.ss @@ -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?)) diff --git a/collects/mrflow/set-list.ss b/collects/mrflow/set-list.ss index fd45a5c3ef..fe010ba465 100644 --- a/collects/mrflow/set-list.ss +++ b/collects/mrflow/set-list.ss @@ -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?)) diff --git a/collects/mzlib/private/contract.ss b/collects/mzlib/private/contract.ss index 365af906fe..d90601a008 100644 --- a/collects/mzlib/private/contract.ss +++ b/collects/mzlib/private/contract.ss @@ -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 @@ -394,6 +428,16 @@ add struct contracts for immutable structs? (loop (cdr l1) (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) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 993b30772c..e61e259860 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -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)))) + ; ;