From b33493ea8eaca177145026f20a6233ddfedb0572 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 20 Jan 2005 05:05:05 +0000 Subject: [PATCH] . original commit: 28e8d7d337f009adcb92d142d6f92140379d506d --- collects/mzlib/contract.ss | 80 +++++++++++++++++++++-- collects/tests/mzscheme/contract-test.ss | 82 +++++++++++++++++++++++- 2 files changed, 156 insertions(+), 6 deletions(-) diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index f63b3c5..3127811 100644 --- a/collects/mzlib/contract.ss +++ b/collects/mzlib/contract.ss @@ -1231,10 +1231,14 @@ add struct contracts for immutable structs? [(field-var ...) (generate-temporaries flds)] [(field/app-var ...) (generate-temporaries flds)]) (syntax - (let ([method-ctc-var method-ctc-stx] ... - [field-ctc-var (coerce-contract object-contract field-ctc-stx)] ...) - (let ([method-var (contract-proc method-ctc-var)] ... - [field-var (contract-proc field-ctc-var)] ...) + (let ([method-ctc-var method-ctc-stx] + ... + [field-ctc-var (coerce-contract object-contract field-ctc-stx)] + ...) + (let ([method-var (contract-proc method-ctc-var)] + ... + [field-var (contract-proc field-ctc-var)] + ...) (make-contract `(object-contract ,(build-compound-type-name 'method-name method-ctc-var) ... @@ -2432,6 +2436,8 @@ add struct contracts for immutable structs? vectorof vector-immutableof vector/c vector-immutable/c cons-immutable/c cons/c list-immutable/c list/c box-immutable/c box/c + promise/c + struct/c mixin-contract make-mixin-contract syntax/c) @@ -2964,6 +2970,72 @@ add struct contracts for immutable structs? (and (syntax? val) (pred (syntax-e val))))))) + (define promise/c + (lambda (ctc-in) + (let* ([ctc (coerce-contract promise/c ctc-in)] + [ctc-proc (contract-proc ctc)]) + (make-contract + (build-compound-type-name 'promise/c ctc) + (lambda (pos neg src-info orig-str) + (let ([p-app (ctc-proc pos neg src-info orig-str)]) + (lambda (val) + (unless (promise? val) + (raise-contract-error + src-info + pos + neg + orig-str + "expected , given: ~e" + val)) + (delay (p-app (force val)))))))))) + + (define-syntax (struct/c stx) + (syntax-case stx () + [(_ struct-name args ...) + (and (identifier? (syntax struct-name)) + (syntax-local-value (syntax struct-name) (lambda () #f))) + (with-syntax ([(ctc-x ...) (generate-temporaries (syntax (args ...)))] + [(ctc-proc-x ...) (generate-temporaries (syntax (args ...)))] + [(ctc-app-x ...) (generate-temporaries (syntax (args ...)))] + [(type-desc-id + constructor-id + predicate-id + (selector-id ...) + (mutator-id ...) + super-id) + (syntax-local-value (syntax struct-name))]) + (syntax + (let ([ctc-x (coerce-contract struct/c args)] ...) + + (unless predicate-id + (error 'struct/c "could not determine predicate for ~s" 'struct-name)) + (unless (and selector-id ...) + (error 'struct/c "could not determine selectors for ~s" 'struct-name)) + + (unless (flat-contract? ctc-x) + (error 'struct/c "expected flat contracts as arguments, got ~e" ctc-x)) + ... + + (let ([ctc-proc-x (contract-proc ctc-x)] ...) + (make-contract + (build-compound-type-name 'struct/c 'struct-name ctc-x ...) + (lambda (pos neg src-info orig-str) + (let ([ctc-app-x (ctc-proc-x pos neg src-info orig-str)] ...) + (lambda (val) + (unless (predicate-id val) + (raise-contract-error + src-info + pos + neg + orig-str + "expected <~a>, given: ~e" + 'struct-name + val)) + (ctc-app-x (selector-id val)) ... + val))))))))] + [(_ struct-name anything ...) + (raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))])) + (define (flat-contract/predicate? pred) (or (flat-contract? pred) (and (procedure? pred) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index a36f9f4..00fabb6 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -2395,6 +2395,79 @@ 'neg) 1)) + (test/pos-blame + 'promise/c1 + '(force (contract (promise/c boolean?) + (delay 1) + 'pos + 'neg))) + + (test/spec-passed + 'promise/c2 + '(force (contract (promise/c boolean?) + (delay #t) + 'pos + 'neg))) + + (test/spec-passed/result + 'promise/c3 + '(let ([x 0]) + (contract (promise/c any/c) + (delay (set! x (+ x 1))) + 'pos + 'neg) + x) + 0) + + (test/spec-passed/result + 'promise/c4 + '(let ([x 0]) + (force (contract (promise/c any/c) + (delay (set! x (+ x 1))) + 'pos + 'neg)) + x) + 1) + + (test/spec-passed/result + 'promise/c5 + '(let ([x 0]) + (let ([p (contract (promise/c any/c) + (delay (set! x (+ x 1))) + 'pos + 'neg)]) + (force p) + (force p)) + x) + 1) + + (test/spec-passed + 'struct/c1 + '(let () + (define-struct s (a)) + (contract (struct/c s integer?) + (make-s 1) + 'pos + 'neg))) + + (test/pos-blame + 'struct/c2 + '(let () + (define-struct s (a)) + (contract (struct/c s integer?) + (make-s #f) + 'pos + 'neg))) + + (test/pos-blame + 'struct/c3 + '(let () + (define-struct s (a)) + (contract (struct/c s integer?) + 1 + 'pos + 'neg))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; ;; Flat Contract Tests ;; @@ -2640,7 +2713,8 @@ (object-contract (m (-> integer? any)))) (test-name '(object-contract (m (-> integer? (values integer? integer?)))) (object-contract (m (-> integer? (values integer? integer?))))) - (test-name '(object-contract (m (case-> (-> integer? integer? integer?) (-> integer? (values integer? integer?))))) + (test-name '(object-contract (m (case-> (-> integer? integer? integer?) + (-> integer? (values integer? integer?))))) (object-contract (m (case-> (-> integer? integer? integer?) (-> integer? (values integer? integer?)))))) @@ -2669,6 +2743,10 @@ (object-contract (m (->r ((x number?) (y boolean?) (z pair?)) number?)))) (test-name '(object-contract (m (->r ((x ...) (y ...) (z ...)) rest-x ... ...))) (object-contract (m (->r ((x number?) (y boolean?) (z pair?)) rest-x any/c number?)))) - + (test-name '(promise/c any/c) (promise/c any/c)) + (test-name '(struct/c st integer?) + (let () + (define-struct st (a)) + (struct/c st integer?))) )) (report-errs)