From 7a79b808a8d65e8f45ef137025c95846d2225edd Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 17 Jan 2010 07:07:06 +0000 Subject: [PATCH 01/12] Ported a lot of mzlib contracts to new properties. svn: r17699 original commit: 1f969b883113a646d9bbf3470df1755dfc3a708e --- collects/mzlib/contract.ss | 47 +-- collects/mzlib/private/contract-arr-checks.ss | 82 ++--- .../mzlib/private/contract-arr-obj-helpers.ss | 291 ++++++++---------- collects/mzlib/private/contract-arrow.ss | 138 ++++----- collects/mzlib/private/contract-object.ss | 39 +-- 5 files changed, 244 insertions(+), 353 deletions(-) diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index 64d02c4..3c6ef88 100644 --- a/collects/mzlib/contract.ss +++ b/collects/mzlib/contract.ss @@ -48,48 +48,11 @@ check-between/c string-len/c check-unary-between/c) - (rename-out [string-len/c string/len])) - -;; from contract-guts.ss - -(provide any - and/c - any/c - none/c - make-none/c - - guilty-party - contract-violation->string - - contract? - contract-name - contract-proc - - flat-contract? - flat-contract - flat-contract-predicate - flat-named-contract - - contract-first-order-passes? - - ;; below need docs - - make-proj-contract - - contract-stronger? - - coerce-contract - flat-contract/predicate? - - build-compound-type-name - raise-contract-error - - proj-prop proj-pred? proj-get - name-prop name-pred? name-get - stronger-prop stronger-pred? stronger-get - flat-prop flat-pred? flat-get - first-order-prop first-order-get - (rename-out [or/c union])) + (rename-out [or/c union]) + (rename-out [string-len/c string/len]) + (except-out (all-from-out scheme/contract/private/guts) + check-flat-contract + check-flat-named-contract)) ;; copied here because not provided by scheme/contract anymore diff --git a/collects/mzlib/private/contract-arr-checks.ss b/collects/mzlib/private/contract-arr-checks.ss index 547d814..5410d74 100644 --- a/collects/mzlib/private/contract-arr-checks.ss +++ b/collects/mzlib/private/contract-arr-checks.ss @@ -77,31 +77,21 @@ f))) -(define (check-pre-expr->pp/h val pre-expr src-info blame orig-str) +(define (check-pre-expr->pp/h val pre-expr blame) (unless pre-expr - (raise-contract-error val - src-info - blame - orig-str - "pre-condition expression failure"))) + (raise-blame-error blame val "pre-condition expression failure"))) -(define (check-post-expr->pp/h val post-expr src-info blame orig-str) +(define (check-post-expr->pp/h val post-expr blame) (unless post-expr - (raise-contract-error val - src-info - blame - orig-str - "post-condition expression failure"))) + (raise-blame-error blame val "post-condition expression failure"))) -(define (check-procedure val dom-length optionals mandatory-kwds optional-keywords src-info blame orig-str) +(define (check-procedure val dom-length optionals mandatory-kwds optional-keywords blame) (unless (and (procedure? val) (procedure-arity-includes?/optionals val dom-length optionals) (keywords-match mandatory-kwds optional-keywords val)) - (raise-contract-error - val - src-info + (raise-blame-error blame - orig-str + val "expected a procedure that accepts ~a arguments~a, given: ~e" dom-length (keyword-error-text mandatory-kwds) @@ -140,53 +130,37 @@ (and (procedure? val) (procedure-accepts-and-more? val arity))) -(define (check-procedure/kind val arity kind-of-thing src-info blame orig-str) +(define (check-procedure/kind val arity kind-of-thing blame) (unless (procedure? val) - (raise-contract-error val - src-info - blame - orig-str - "expected a procedure, got ~e" - val)) + (raise-blame-error blame val "expected a procedure, got ~e" val)) (unless (procedure-arity-includes? val arity) - (raise-contract-error val - src-info - blame - orig-str - "expected a ~a of arity ~a (not arity ~a), got ~e" - kind-of-thing - arity - (procedure-arity val) - val))) + (raise-blame-error blame + val + "expected a ~a of arity ~a (not arity ~a), got ~e" + kind-of-thing + arity + (procedure-arity val) + val))) -(define (check-procedure/more/kind val arity kind-of-thing src-info blame orig-str) +(define (check-procedure/more/kind val arity kind-of-thing blame) (unless (procedure? val) - (raise-contract-error val - src-info - blame - orig-str - "expected a procedure, got ~e" - val)) + (raise-blame-error blame val "expected a procedure, got ~e" val)) (unless (procedure-accepts-and-more? val arity) - (raise-contract-error val - src-info - blame - orig-str - "expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got ~e" - kind-of-thing - arity - (procedure-arity val) - val))) + (raise-blame-error blame + val + "expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got ~e" + kind-of-thing + arity + (procedure-arity val) + val))) -(define (check-procedure/more val dom-length mandatory-kwds optional-kwds src-info blame orig-str) +(define (check-procedure/more val dom-length mandatory-kwds optional-kwds blame) (unless (and (procedure? val) (procedure-accepts-and-more? val dom-length) (keywords-match mandatory-kwds optional-kwds val)) - (raise-contract-error - val - src-info + (raise-blame-error blame - orig-str + val "expected a procedure that accepts ~a arguments and and arbitrarily more~a, given: ~e" dom-length (keyword-error-text mandatory-kwds) diff --git a/collects/mzlib/private/contract-arr-obj-helpers.ss b/collects/mzlib/private/contract-arr-obj-helpers.ss index 9d4d980..4dd2791 100644 --- a/collects/mzlib/private/contract-arr-obj-helpers.ss +++ b/collects/mzlib/private/contract-arr-obj-helpers.ss @@ -19,9 +19,9 @@ (define (make-/proc method-proc? /h stx) (let-values ([(arguments-check build-proj check-val first-order-check wrapper) (/h method-proc? stx)]) - (let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id positive-position?))]) + (let ([outer-args (syntax (val blame name-id))]) (with-syntax ([inner-check (check-val outer-args)] - [(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + [(val blame name-id) outer-args] [(val-args body) (wrapper outer-args)]) (with-syntax ([inner-lambda (set-inferred-name-from @@ -37,11 +37,10 @@ (arguments-check outer-args (syntax/loc stx - (make-proj-contract - name-id - (lambda (pos-blame neg-blame src-info orig-str positive-position?) - proj-code) - first-order-check)))))))))) + (simple-contract + #:name name-id + #:projection (lambda (blame) proj-code) + #:first-order first-order-check)))))))))) (define (make-case->/proc method-proc? stx inferred-name-stx select/h) (syntax-case stx () @@ -55,9 +54,9 @@ [(_ cases ...) (let-values ([(arguments-check build-projs check-val first-order-check wrapper) (case->/h method-proc? stx (syntax->list (syntax (cases ...))) select/h)]) - (let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id positive-position?))]) + (let ([outer-args (syntax (val blame name-id))]) (with-syntax ([(inner-check ...) (check-val outer-args)] - [(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + [(val blame name-id) outer-args] [(body ...) (wrapper outer-args)]) (with-syntax ([inner-lambda (set-inferred-name-from @@ -73,11 +72,10 @@ (arguments-check outer-args (syntax/loc stx - (make-proj-contract - (apply build-compound-type-name 'case-> name-id) - (lambda (pos-blame neg-blame src-info orig-str positive-position?) - proj-code) - first-order-check)))))))))])) + (simple-contract + #:name (apply build-compound-type-name 'case-> name-id) + #:projection (lambda (blame) proj-code) + #:first-order first-order-check)))))))))])) (define (make-opt->/proc method-proc? stx select/h case-arr-stx arr-stx) (syntax-case stx (any) @@ -230,7 +228,7 @@ [(null? cases) (values (lambda (outer-args body) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [body body] [(name-ids ...) (reverse name-ids)]) (syntax @@ -249,10 +247,10 @@ (/h method-proc? (car cases))]) (values (lambda (outer-args x) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [new-id new-id]) (arguments-check - (syntax (val pos-blame neg-blame src-info orig-str new-id positive-position?)) + (syntax (val blame new-id)) (arguments-checks outer-args x)))) @@ -364,7 +362,7 @@ (values (lambda (outer-args body) (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + [(val blame name-id) outer-args]) (syntax (let ([dom-contract-x (coerce-contract '-> dom)] ...) (let ([dom-x (contract-proc dom-contract-x)] ...) @@ -373,19 +371,19 @@ ;; proj (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [inner-lambda inner-lambda]) (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))] ...) + (let ([dom-projection-x (dom-x (blame-swap blame))] ...) inner-lambda)))) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax - (check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str)))) + (check-procedure val dom-length 0 '() '() #|keywords|# blame)))) (syntax (check-procedure? dom-length)) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax ((arg-x ...) (val (dom-projection-x arg-x) ...))))))] @@ -399,14 +397,14 @@ (values (lambda (outer-args body) (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + [(val blame name-id) outer-args]) (syntax (let ([dom-contract-x (coerce-contract '-> dom)] ... [rng-contract-x (coerce-contract '-> rng)] ...) - (let ([dom-x (contract-proc dom-contract-x)] + (let ([dom-x (contract-projection dom-contract-x)] ... - [rng-x (contract-proc rng-contract-x)] + [rng-x (contract-projection rng-contract-x)] ...) (let ([name-id (build-compound-type-name @@ -417,22 +415,22 @@ ;; proj (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [inner-lambda inner-lambda]) (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))] + (let ([dom-projection-x (dom-x (blame-swap blame))] ... - [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str positive-position?)] ...) + [rng-projection-x (rng-x blame)] ...) inner-lambda)))) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax - (check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str)))) + (check-procedure val dom-length 0 '() '() #|keywords|# blame)))) (syntax (check-procedure? dom-length)) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax ((arg-x ...) (let-values ([(res-x ...) (val (dom-projection-x arg-x) ...)]) @@ -448,34 +446,34 @@ (values (lambda (outer-args body) (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + [(val blame name-id) outer-args]) (syntax (let ([dom-contract-x (coerce-contract '-> dom)] ... [rng-contract-x (coerce-contract '-> rng)]) - (let ([dom-x (contract-proc dom-contract-x)] + (let ([dom-x (contract-projection dom-contract-x)] ... - [rng-x (contract-proc rng-contract-x)]) + [rng-x (contract-projection rng-contract-x)]) (let ([name-id (build-compound-type-name '-> name-dom-contract-x ... rng-contract-x)]) body)))))) ;; proj (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [inner-lambda inner-lambda]) (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))] + (let ([dom-projection-x (dom-x (blame-swap blame))] ... - [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str positive-position?)]) + [rng-projection-x (rng-x blame)]) inner-lambda)))) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax - (check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str)))) + (check-procedure val dom-length 0 '() '() #|keywords|# blame)))) (syntax (check-procedure? dom-length)) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax ((arg-x ...) (let ([res-x (val (dom-projection-x arg-x) ...)]) @@ -509,7 +507,7 @@ [arity (length (syntax->list (syntax (dom ...))))]) (values (lambda (outer-args body) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [body body] [(name-dom-contract-x ...) (if method-proc? @@ -522,10 +520,10 @@ ... [dom-rest-contract-x (coerce-contract '->* rest)] [rng-contract-x (coerce-contract '->* rng)] ...) - (let ([dom-x (contract-proc dom-contract-x)] + (let ([dom-x (contract-projection dom-contract-x)] ... - [dom-rest-x (contract-proc dom-rest-contract-x)] - [rng-x (contract-proc rng-contract-x)] + [dom-rest-x (contract-projection dom-rest-contract-x)] + [rng-x (contract-projection rng-contract-x)] ...) (let ([name-id (build-compound-type-name @@ -536,22 +534,22 @@ body)))))) ;; proj (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [inner-lambda inner-lambda]) (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))] + (let ([dom-projection-x (dom-x (blame-swap blame))] ... - [dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str (not positive-position?))] - [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str positive-position?)] ...) + [dom-rest-projection-x (dom-rest-x (blame-swap blame))] + [rng-projection-x (rng-x blame)] ...) inner-lambda)))) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax - (check-procedure/more val dom-length '() '() #|keywords|# src-info pos-blame orig-str)))) + (check-procedure/more val dom-length '() '() #|keywords|# blame)))) (syntax (check-procedure/more? dom-length)) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax ((arg-x ... . arg-rest-x) (let-values ([(res-x ...) @@ -577,7 +575,7 @@ (values (lambda (outer-args body) (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + [(val blame name-id) outer-args] [(name-dom-contract-x ...) (if method-proc? (cdr @@ -588,9 +586,9 @@ (let ([dom-contract-x (coerce-contract '->* dom)] ... [dom-rest-contract-x (coerce-contract '->* rest)]) - (let ([dom-x (contract-proc dom-contract-x)] + (let ([dom-x (contract-projection dom-contract-x)] ... - [dom-rest-x (contract-proc dom-rest-contract-x)]) + [dom-rest-x (contract-projection dom-rest-contract-x)]) (let ([name-id (build-compound-type-name '->* (build-compound-type-name name-dom-contract-x ...) @@ -599,21 +597,21 @@ body)))))) ;; proj (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [inner-lambda inner-lambda]) (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))] + (let ([dom-projection-x (dom-x (blame-swap blame))] ... - [dom-projection-rest-x (dom-rest-x neg-blame pos-blame src-info orig-str (not positive-position?))]) + [dom-projection-rest-x (dom-rest-x (blame-swap blame))]) inner-lambda)))) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax - (check-procedure/more val dom-length '() '() #|keywords|# src-info pos-blame orig-str)))) + (check-procedure/more val dom-length '() '() #|keywords|# blame)))) (syntax (check-procedure/more? dom-length)) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax ((arg-x ... . arg-rest-x) (apply @@ -636,7 +634,7 @@ (values (lambda (outer-args body) (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + [(val blame name-id) outer-args] [(name-dom-contract-x ...) (if method-proc? (cdr @@ -645,7 +643,7 @@ (syntax (dom-contract-x ...)))]) (syntax (let ([dom-contract-x (coerce-contract '->d dom)] ...) - (let ([dom-x (contract-proc dom-contract-x)] + (let ([dom-x (contract-projection dom-contract-x)] ... [rng-x rng]) (check-rng-procedure '->d rng-x arity) @@ -654,31 +652,27 @@ ;; proj (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [inner-lambda inner-lambda]) (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))] ...) + (let ([dom-projection-x (dom-x (blame-swap blame))] ...) inner-lambda)))) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax - (check-procedure val arity 0 '() '() #|keywords|# src-info pos-blame orig-str)))) + (check-procedure val arity 0 '() '() #|keywords|# blame)))) (syntax (check-procedure? arity)) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax ((arg-x ...) (let ([arg-x (dom-projection-x arg-x)] ...) (let ([rng-contract (rng-x arg-x ...)]) - (((contract-proc (coerce-contract '->d rng-contract)) - pos-blame - neg-blame - src-info - orig-str - positive-position?) + (((contract-projection (coerce-contract '->d rng-contract)) + blame) (val arg-x ...))))))))))])) ;; ->d*/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) @@ -694,7 +688,7 @@ (values (lambda (outer-args body) (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + [(val blame name-id) outer-args] [(name-dom-contract-x ...) (if method-proc? (cdr @@ -703,7 +697,7 @@ (syntax (dom-contract-x ...)))]) (syntax (let ([dom-contract-x (coerce-contract '->d* dom)] ...) - (let ([dom-x (contract-proc dom-contract-x)] + (let ([dom-x (contract-projection dom-contract-x)] ... [rng-mk-x rng-mk]) (check-rng-procedure '->d* rng-mk-x dom-length) @@ -715,20 +709,20 @@ ;; proj (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [inner-lambda inner-lambda]) (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))] ...) + (let ([dom-projection-x (dom-x (blame-swap blame))] ...) inner-lambda)))) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax - (check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str)))) + (check-procedure val dom-length 0 '() '() #|keywords|# blame)))) (syntax (check-procedure? dom-length)) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax ((arg-x ...) (call-with-values @@ -742,12 +736,8 @@ (apply values (map (lambda (rng-contract result) - (((contract-proc (coerce-contract '->d* rng-contract)) - pos-blame - neg-blame - src-info - orig-str - positive-position?) + (((contract-projection (coerce-contract '->d* rng-contract)) + blame) result)) rng-contracts results))))))))))))] @@ -763,7 +753,7 @@ (values (lambda (outer-args body) (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + [(val blame name-id) outer-args] [(name-dom-contract-x ...) (if method-proc? (cdr @@ -774,9 +764,9 @@ (let ([dom-contract-x (coerce-contract '->d* dom)] ... [dom-rest-contract-x (coerce-contract '->d* rest)]) - (let ([dom-x (contract-proc dom-contract-x)] + (let ([dom-x (contract-projection dom-contract-x)] ... - [dom-rest-x (contract-proc dom-rest-contract-x)] + [dom-rest-x (contract-projection dom-rest-contract-x)] [rng-mk-x rng-mk]) (check-rng-procedure/more rng-mk-x arity) (let ([name-id (build-compound-type-name @@ -788,22 +778,22 @@ ;; proj (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [inner-lambda inner-lambda]) (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))] + (let ([dom-projection-x (dom-x (blame-swap blame))] ... - [dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str (not positive-position?))]) + [dom-rest-projection-x (dom-rest-x (blame-swap blame))]) inner-lambda)))) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax - (check-procedure/more val arity '() '() #|keywords|# src-info pos-blame orig-str)))) + (check-procedure/more val arity '() '() #|keywords|# blame)))) (syntax (check-procedure/more? arity)) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax ((arg-x ... . rest-arg-x) (call-with-values @@ -822,12 +812,8 @@ (apply values (map (lambda (rng-contract result) - (((contract-proc (coerce-contract '->d* rng-contract)) - pos-blame - neg-blame - src-info - orig-str - positive-position?) + (((contract-projection (coerce-contract '->d* rng-contract)) + blame) result)) rng-contracts results))))))))))))])) @@ -880,32 +866,31 @@ (values (lambda (outer-args body) (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + [(val blame name-id) outer-args]) (syntax (let ([name-id name-stx]) body)))) (lambda (outer-args inner-lambda) inner-lambda) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [kind-of-thing (if method-proc? 'method 'procedure)]) (syntax (begin - (check-procedure/kind val arity 'kind-of-thing src-info pos-blame orig-str))))) + (check-procedure/kind val arity 'kind-of-thing blame))))) (syntax (check-procedure? arity)) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax-case* (syntax result-stuff) (any values) module-or-top-identifier=? [(any) (syntax ((x ...) (begin - (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) - (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) - neg-blame pos-blame src-info orig-str - (not positive-position?))] + (check-pre-expr->pp/h val pre-expr blame) + (let ([dom-id ((contract-projection (coerce-contract 'stx-name dom)) + (blame-swap blame))] ...) (val (dom-id x) ...)))))] [((values (rng-ids rng-ctc) ...) post-expr) @@ -915,16 +900,14 @@ (syntax ((x ...) (begin - (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) - (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) - neg-blame pos-blame src-info orig-str - (not positive-position?))] + (check-pre-expr->pp/h val pre-expr (blame-swap blame)) + (let ([dom-id ((contract-projection (coerce-contract 'stx-name dom)) + (blame-swap blame))] ...) (let-values ([(rng-ids ...) (val (dom-id x) ...)]) - (check-post-expr->pp/h val post-expr src-info pos-blame orig-str) - (let ([rng-ids-x ((contract-proc (coerce-contract 'stx-name rng-ctc)) - pos-blame neg-blame src-info orig-str - positive-position?)] ...) + (check-post-expr->pp/h val post-expr blame) + (let ([rng-ids-x ((contract-projection (coerce-contract 'stx-name rng-ctc)) + blame)] ...) (values (rng-ids-x rng-ids) ...))))))))] [((values (rng-ids rng-ctc) ...) post-expr) (andmap identifier? (syntax->list (syntax (rng-ids ...)))) @@ -941,16 +924,14 @@ (syntax ((x ...) (begin - (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) - (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) - neg-blame pos-blame src-info orig-str - (not positive-position?))] + (check-pre-expr->pp/h val pre-expr (blame-swap blame)) + (let ([dom-id ((contract-projection (coerce-contract 'stx-name dom)) + (blame-swap blame))] ... - [rng-id ((contract-proc (coerce-contract 'stx-name rng)) - pos-blame neg-blame src-info orig-str - positive-position?)]) + [rng-id ((contract-projection (coerce-contract 'stx-name rng)) + blame)]) (let ([res-id (rng-id (val (dom-id x) ...))]) - (check-post-expr->pp/h val post-expr src-info pos-blame orig-str) + (check-post-expr->pp/h val post-expr blame) res-id)))))] [_ (raise-syntax-error name "unknown result specification" stx (syntax result-stuff))]))))))] @@ -1000,35 +981,33 @@ (values (lambda (outer-args body) (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + [(val blame name-id) outer-args]) (syntax (let ([name-id name-stx]) body)))) (lambda (outer-args inner-lambda) inner-lambda) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [kind-of-thing (if method-proc? 'method 'procedure)]) (syntax (begin - (check-procedure/more/kind val arity 'kind-of-thing src-info pos-blame orig-str))))) + (check-procedure/more/kind val arity 'kind-of-thing blame))))) (syntax (check-procedure/more? arity)) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax-case* (syntax result-stuff) (values any) module-or-top-identifier=? [(any) (syntax ((x ... . rest-x) (begin - (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) - (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) - neg-blame pos-blame src-info orig-str - (not positive-position?))] + (check-pre-expr->pp/h val pre-expr (blame-swap blame)) + (let ([dom-id ((contract-projection (coerce-contract 'stx-name dom)) + (blame-swap blame))] ... - [rest-id ((contract-proc (coerce-contract 'stx-name rest-dom)) - neg-blame pos-blame src-info orig-str - (not positive-position?))]) + [rest-id ((contract-projection (coerce-contract 'stx-name rest-dom)) + (blame-swap blame))]) (apply val (dom-id x) ... (rest-id rest-x))))))] [(any . x) (raise-syntax-error name "cannot have anything after any" stx (syntax result-stuff))] @@ -1039,19 +1018,16 @@ (syntax ((x ... . rest-x) (begin - (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) - (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) - neg-blame pos-blame src-info orig-str - (not positive-position?))] + (check-pre-expr->pp/h val pre-expr (blame-swap blame)) + (let ([dom-id ((contract-projection (coerce-contract 'stx-name dom)) + (blame-swap blame))] ... - [rest-id ((contract-proc (coerce-contract 'stx-name rest-dom)) - neg-blame pos-blame src-info orig-str - (not positive-position?))]) + [rest-id ((contract-projection (coerce-contract 'stx-name rest-dom)) + (blame-swap blame))]) (let-values ([(rng-ids ...) (apply val (dom-id x) ... (rest-id rest-x))]) - (check-post-expr->pp/h val post-expr src-info pos-blame orig-str) - (let ([rng-ids-x ((contract-proc (coerce-contract 'stx-name rng-ctc)) - pos-blame neg-blame src-info orig-str - positive-position?)] ...) + (check-post-expr->pp/h val post-expr blame) + (let ([rng-ids-x ((contract-projection (coerce-contract 'stx-name rng-ctc)) + blame)] ...) (values (rng-ids-x rng-ids) ...))))))))] [((values (rng-ids rng-ctc) ...) . whatever) (and (andmap identifier? (syntax->list (syntax (rng-ids ...)))) @@ -1073,19 +1049,16 @@ (syntax ((x ... . rest-x) (begin - (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) - (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) - neg-blame pos-blame src-info orig-str - (not positive-position?))] + (check-pre-expr->pp/h val pre-expr (blame-swap blame)) + (let ([dom-id ((contract-projection (coerce-contract 'stx-name dom)) + (blame-swap blame))] ... - [rest-id ((contract-proc (coerce-contract 'stx-name rest-dom)) - neg-blame pos-blame src-info orig-str - (not positive-position?))] - [rng-id ((contract-proc (coerce-contract 'stx-name rng)) - pos-blame neg-blame src-info orig-str - positive-position?)]) + [rest-id ((contract-projection (coerce-contract 'stx-name rest-dom)) + (blame-swap blame))] + [rng-id ((contract-projection (coerce-contract 'stx-name rng)) + blame)]) (let ([res-id (rng-id (apply val (dom-id x) ... (rest-id rest-x)))]) - (check-post-expr->pp/h val post-expr src-info pos-blame orig-str) + (check-post-expr->pp/h val post-expr blame) res-id)))))] [(rng res-id post-expr) (not (identifier? (syntax res-id))) diff --git a/collects/mzlib/private/contract-arrow.ss b/collects/mzlib/private/contract-arrow.ss index 757622b..0a9a658 100644 --- a/collects/mzlib/private/contract-arrow.ss +++ b/collects/mzlib/private/contract-arrow.ss @@ -30,21 +30,19 @@ [(p-app-x ...) (generate-temporaries #'(rngs ...))] [(res-x ...) (generate-temporaries #'(rngs ...))]) #'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...) - (let ([proj-x ((proj-get rngs-x) rngs-x)] ...) - (make-proj-contract + (let ([proj-x (contract-projection rngs-x)] ...) + (simple-contract + #:name (build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...) - (λ (pos-blame neg-blame src-info orig-str positive-position?) - (let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str positive-position?)] ...) + #:projection + (λ (blame) + (let ([p-app-x (proj-x blame)] ...) (λ (val) (if (procedure? val) (λ args (let-values ([(res-x ...) (apply val args)]) (values (p-app-x res-x) ...))) - (raise-contract-error val - src-info - pos-blame - orig-str - "expected a procedure"))))) + (raise-blame-error blame val "expected a procedure"))))) procedure?))))])) (define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func) @@ -64,64 +62,66 @@ ;; and it produces a wrapper-making function. (define-struct -> (rng-any? doms dom-rest rngs kwds quoted-kwds func) #:omit-define-syntaxes - #:property proj-prop - (λ (ctc) - (let* ([doms/c (map (λ (x) ((proj-get x) x)) - (if (->-dom-rest ctc) + #:property prop:contract + (build-contract-property + #:projection + (λ (ctc) + (let* ([doms/c (map contract-projection + (if (->-dom-rest ctc) (append (->-doms ctc) (list (->-dom-rest ctc))) (->-doms ctc)))] - [rngs/c (map (λ (x) ((proj-get x) x)) (->-rngs ctc))] - [kwds/c (map (λ (x) ((proj-get x) x)) (->-kwds ctc))] - [mandatory-keywords (->-quoted-kwds ctc)] - [func (->-func ctc)] - [dom-length (length (->-doms ctc))] - [has-rest? (and (->-dom-rest ctc) #t)]) - (lambda (pos-blame neg-blame src-info orig-str positive-position?) - (let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str (not positive-position?))) - doms/c)] - [partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str positive-position?)) - rngs/c)] - [partial-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str (not positive-position?))) - kwds/c)]) - (apply func - (λ (val) - (if has-rest? - (check-procedure/more val dom-length '() mandatory-keywords src-info pos-blame orig-str) - (check-procedure val dom-length 0 '() mandatory-keywords src-info pos-blame orig-str))) - (append partial-doms partial-ranges partial-kwds)))))) - - #:property name-prop - (λ (ctc) (single-arrow-name-maker - (->-doms ctc) - (->-dom-rest ctc) - (->-kwds ctc) - (->-quoted-kwds ctc) - (->-rng-any? ctc) - (->-rngs ctc))) - #:property first-order-prop - (λ (ctc) - (let ([l (length (->-doms ctc))]) - (if (->-dom-rest ctc) + [rngs/c (map contract-projection (->-rngs ctc))] + [kwds/c (map contract-projection (->-kwds ctc))] + [mandatory-keywords (->-quoted-kwds ctc)] + [func (->-func ctc)] + [dom-length (length (->-doms ctc))] + [has-rest? (and (->-dom-rest ctc) #t)]) + (lambda (blame) + (let ([partial-doms (map (λ (dom) (dom (blame-swap blame))) + doms/c)] + [partial-ranges (map (λ (rng) (rng blame)) + rngs/c)] + [partial-kwds (map (λ (kwd) (kwd (blame-swap blame))) + kwds/c)]) + (apply func + (λ (val) + (if has-rest? + (check-procedure/more val dom-length '() mandatory-keywords blame) + (check-procedure val dom-length 0 '() mandatory-keywords blame))) + (append partial-doms partial-ranges partial-kwds)))))) + + #:name + (λ (ctc) (single-arrow-name-maker + (->-doms ctc) + (->-dom-rest ctc) + (->-kwds ctc) + (->-quoted-kwds ctc) + (->-rng-any? ctc) + (->-rngs ctc))) + #:first-order + (λ (ctc) + (let ([l (length (->-doms ctc))]) + (if (->-dom-rest ctc) (λ (x) - (and (procedure? x) - (procedure-accepts-and-more? x l))) + (and (procedure? x) + (procedure-accepts-and-more? x l))) (λ (x) - (and (procedure? x) - (procedure-arity-includes? x l) - (no-mandatory-keywords? x)))))) - #:property stronger-prop - (λ (this that) - (and (->? that) - (= (length (->-doms that)) - (length (->-doms this))) - (andmap contract-stronger? - (->-doms that) - (->-doms this)) - (= (length (->-rngs that)) - (length (->-rngs this))) - (andmap contract-stronger? - (->-rngs this) - (->-rngs that))))) + (and (procedure? x) + (procedure-arity-includes? x l) + (no-mandatory-keywords? x)))))) + #:stronger + (λ (this that) + (and (->? that) + (= (length (->-doms that)) + (length (->-doms this))) + (andmap contract-stronger? + (->-doms that) + (->-doms this)) + (= (length (->-rngs that)) + (length (->-rngs this))) + (andmap contract-stronger? + (->-rngs this) + (->-rngs that)))))) (define (single-arrow-name-maker doms/c doms-rest kwds/c kwds rng-any? rngs) (cond @@ -455,16 +455,14 @@ (append partials-rngs partial) (append this-stronger-ribs stronger-ribs)))]))]) (values - (with-syntax ((pos (opt/info-pos opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info)) + (with-syntax ((blame (opt/info-blame opt/info)) ((dom-arg ...) dom-vars) ((rng-arg ...) rng-vars) ((next-dom ...) next-doms) (dom-len (length dom-vars)) ((next-rng ...) next-rngs)) (syntax (begin - (check-procedure val dom-len 0 '() '() #| keywords |# src-info pos orig-str) + (check-procedure val dom-len 0 '() '() #| keywords |# blame) (λ (dom-arg ...) (let-values ([(rng-arg ...) (val next-dom ...)]) (values next-rng ...)))))) @@ -505,14 +503,12 @@ (append partials-doms partial) (append this-stronger-ribs stronger-ribs)))]))]) (values - (with-syntax ((pos (opt/info-pos opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info)) + (with-syntax ((blame (opt/info-blame opt/info)) ((dom-arg ...) dom-vars) ((next-dom ...) next-doms) (dom-len (length dom-vars))) (syntax (begin - (check-procedure val dom-len 0 '() '() #|keywords|# src-info pos orig-str) + (check-procedure val dom-len 0 '() '() #|keywords|# blame) (λ (dom-arg ...) (val next-dom ...))))) lifts-doms diff --git a/collects/mzlib/private/contract-object.ss b/collects/mzlib/private/contract-object.ss index c0166dc..63c91ed 100644 --- a/collects/mzlib/private/contract-object.ss +++ b/collects/mzlib/private/contract-object.ss @@ -344,24 +344,24 @@ `(object-contract ,(build-compound-type-name 'method-name method-ctc-var) ... ,(build-compound-type-name 'field 'field-name field-ctc-var) ...) - (lambda (pos-blame neg-blame src-info orig-str positive-position?) - (let ([method/app-var (method-var pos-blame neg-blame src-info orig-str positive-position?)] + (lambda (blame) + (let ([method/app-var (method-var blame)] ... - [field/app-var (field-var pos-blame neg-blame src-info orig-str positive-position?)] + [field/app-var (field-var blame)] ...) (let ([field-names-list '(field-name ...)]) (lambda (val) - (check-object val src-info pos-blame orig-str) + (check-object val blame) (let ([val-mtd-names (interface->method-names (object-interface val))]) (void) - (check-method val 'method-name val-mtd-names src-info pos-blame orig-str) + (check-method val 'method-name val-mtd-names blame) ...) (unless (field-bound? field-name val) - (field-error val 'field-name src-info pos-blame orig-str)) ... + (field-error val 'field-name blame)) ... (let ([vtable (extract-vtable val)] [method-ht (extract-method-ht val)]) @@ -373,31 +373,16 @@ #f)))))))])))) -(define (check-object val src-info blame orig-str) +(define (check-object val blame) (unless (object? val) - (raise-contract-error val - src-info - blame - orig-str - "expected an object, got ~e" - val))) + (raise-blame-error blame val "expected an object, got ~e" val))) -(define (check-method val method-name val-mtd-names src-info blame orig-str) +(define (check-method val method-name val-mtd-names blame) (unless (memq method-name val-mtd-names) - (raise-contract-error val - src-info - blame - orig-str - "expected an object with method ~s" - method-name))) + (raise-blame-error blame val "expected an object with method ~s" method-name))) -(define (field-error val field-name src-info blame orig-str) - (raise-contract-error val - src-info - blame - orig-str - "expected an object with field ~s" - field-name)) +(define (field-error val field-name blame) + (raise-blame-error blame val "expected an object with field ~s" field-name)) (define (make-mixin-contract . %/<%>s) ((and/c (flat-contract class?) From f56868d873280fccab10d87f5a617f91c32157ff Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 17 Jan 2010 07:23:47 +0000 Subject: [PATCH 02/12] Typos and type errors in new property stuff. svn: r17700 original commit: bb7bd9de51f01b2620a8162da5de0bfffd645247 --- collects/mzlib/private/contract-arr-obj-helpers.ss | 2 +- collects/mzlib/private/contract-object.ss | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/mzlib/private/contract-arr-obj-helpers.ss b/collects/mzlib/private/contract-arr-obj-helpers.ss index 4dd2791..de1788c 100644 --- a/collects/mzlib/private/contract-arr-obj-helpers.ss +++ b/collects/mzlib/private/contract-arr-obj-helpers.ss @@ -365,7 +365,7 @@ [(val blame name-id) outer-args]) (syntax (let ([dom-contract-x (coerce-contract '-> dom)] ...) - (let ([dom-x (contract-proc dom-contract-x)] ...) + (let ([dom-x (contract-projection dom-contract-x)] ...) (let ([name-id (build-compound-type-name '-> name-dom-contract-x ... 'any)]) body)))))) diff --git a/collects/mzlib/private/contract-object.ss b/collects/mzlib/private/contract-object.ss index 63c91ed..c5018cb 100644 --- a/collects/mzlib/private/contract-object.ss +++ b/collects/mzlib/private/contract-object.ss @@ -331,9 +331,9 @@ ... [field-ctc-var (coerce-contract 'object-contract field-ctc-stx)] ...) - (let ([method-var (contract-proc method-ctc-var)] + (let ([method-var (contract-projection method-ctc-var)] ... - [field-var (contract-proc field-ctc-var)] + [field-var (contract-projection field-ctc-var)] ...) (let ([cls (make-wrapper-class 'wrapper-class '(method-name ...) From 62f745be71c4419401179e4e8961d95d5a90bf47 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Mon, 18 Jan 2010 18:26:02 +0000 Subject: [PATCH 03/12] Ported mzlib units to new contract system. svn: r17718 original commit: 7763a4079ad4db29c3c42d7278e779e6ff604f90 --- collects/mzlib/unit.ss | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 64a77d6..dec63d2 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -482,7 +482,7 @@ (if (pair? v/c) (contract (let-syntax #,renamings ctc-stx) (car v/c) (cdr v/c) (current-contract-region) - #,(id->contract-src-info var)) + (quote #,var) (quote-syntax #,var)) (error 'unit "contracted import ~a used before definition" (quote #,(syntax->datum var)))))))) (quasisyntax/loc (error-syntax) @@ -747,7 +747,8 @@ (contract #,ctc #,tmp (current-contract-region) 'cant-happen - #,(id->contract-src-info id)) + (quote #,id) + (quote-syntax #,id)) (set-box! #,export-loc (cons #,tmp (current-contract-region))))) (quasisyntax/loc defn-or-expr @@ -824,7 +825,7 @@ #`(let ([old-v/c (#,vref)]) (contract ctc-stx (car old-v/c) (cdr old-v/c) (current-contract-region) - #,(id->contract-src-info var))) + (quote #,var) (quote-syntax #,var))) #`(#,vref)) (current-contract-region))) (if ctc @@ -832,7 +833,7 @@ (let ([old-v/c (#,vref)]) (contract ctc-stx (car old-v/c) (cdr old-v/c) (current-contract-region) - #,(id->contract-src-info var)))) + (quote #,var) (quote-syntax #,var)))) vref))))) (car target-sig) (cadddr target-sig))) @@ -1303,7 +1304,7 @@ #`(let ([v/c (#,tb)]) (contract ctc-stx (car v/c) (cdr v/c) (current-contract-region) - #,(id->contract-src-info v)))) + (quote #,v) (quote-syntax #,v)))) #`(#,tb))) tbs (iota (length (car os))) @@ -1503,11 +1504,10 @@ #'name (syntax/loc stx ((import (import-tagged-sig-id [i.x i.c] ...) ...) - (export (export-tagged-sig-id [e.x e.c] ...) ...))))] - [src-info (id->contract-src-info #'name)]) + (export (export-tagged-sig-id [e.x e.c] ...) ...))))]) (values (syntax/loc stx - (contract unit-contract new-unit '(unit name) (current-contract-region) src-info)) + (contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-syntax name))) isigs esigs deps))))] [(ic:import-clause/contract ec:export-clause/contract . body) (build-unit/contract From 6e0495d778d695186d7d94035e3fe24500faf4b9 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 01:01:28 +0000 Subject: [PATCH 04/12] Ported more code to use new contract bindings. svn: r17727 original commit: 2bad47fd0fff59cde30406af4db42e6e65ffa899 --- collects/mzlib/private/contract-object.ss | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/collects/mzlib/private/contract-object.ss b/collects/mzlib/private/contract-object.ss index c5018cb..76d22c7 100644 --- a/collects/mzlib/private/contract-object.ss +++ b/collects/mzlib/private/contract-object.ss @@ -340,10 +340,12 @@ (list methods ...) '(field-name ...) #t)]) - (make-proj-contract + (simple-contract + #:name `(object-contract ,(build-compound-type-name 'method-name method-ctc-var) ... ,(build-compound-type-name 'field 'field-name field-ctc-var) ...) + #:projection (lambda (blame) (let ([method/app-var (method-var blame)] ... @@ -369,8 +371,7 @@ val (method/app-var (vector-ref vtable (hash-ref method-ht 'method-name))) ... (field/app-var (get-field field-name val)) ... - )))))) - #f)))))))])))) + )))))))))))))])))) (define (check-object val blame) From 974744419961f5f5fd0f38143507b7a2249b267e Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 03:42:45 +0000 Subject: [PATCH 05/12] Ported more code to new contract tools. svn: r17733 original commit: 722fae41a8e5e74a053336ab6e5bc32f3487870d --- collects/mzlib/private/contract-arrow.ss | 2 +- collects/mzlib/private/contract-define.ss | 14 +++++++++----- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/collects/mzlib/private/contract-arrow.ss b/collects/mzlib/private/contract-arrow.ss index 0a9a658..4eb6f11 100644 --- a/collects/mzlib/private/contract-arrow.ss +++ b/collects/mzlib/private/contract-arrow.ss @@ -33,7 +33,7 @@ (let ([proj-x (contract-projection rngs-x)] ...) (simple-contract #:name - (build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...) + (build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...) #:projection (λ (blame) (let ([p-app-x (proj-x blame)] ...) diff --git a/collects/mzlib/private/contract-define.ss b/collects/mzlib/private/contract-define.ss index 9bc54bd..df8215b 100644 --- a/collects/mzlib/private/contract-define.ss +++ b/collects/mzlib/private/contract-define.ss @@ -2,9 +2,11 @@ (provide define/contract) -(require (for-syntax scheme/base) +(require (for-syntax scheme/base + unstable/srcloc + (prefix-in a: scheme/contract/private/helpers)) (only-in scheme/contract contract) - (for-syntax (prefix-in a: scheme/contract/private/helpers))) + unstable/location) ;; First, we have the old define/contract implementation, which ;; is still used in mzlib/contract. @@ -12,7 +14,7 @@ (define-for-syntax (make-define/contract-transformer contract-id id) (make-set!-transformer (λ (stx) - (with-syntax ([neg-blame-str (a:build-src-loc-string stx)] + (with-syntax ([neg-blame-str (source-location->string stx)] [contract-id contract-id] [id id]) (syntax-case stx (set!) @@ -27,7 +29,8 @@ id (syntax->datum (quote-syntax f)) neg-blame-str - (quote-syntax f)) + (quote f) + (quote-srcloc f)) arg ...))] [ident @@ -37,7 +40,8 @@ id (syntax->datum (quote-syntax ident)) neg-blame-str - (quote-syntax ident)))]))))) + (quote ident) + (quote-srcloc ident)))]))))) ;; (define/contract id contract expr) ;; defines `id' with `contract'; initially binding From 76fba4d47e126041e0f8ea3983311a8038082312 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 04:57:33 +0000 Subject: [PATCH 06/12] Updated quote-syntax to quote-srcloc in mzlib unit contracts. svn: r17735 original commit: 5606c590bd78a12c057b62ef43e496a76b0581c5 --- collects/mzlib/unit.ss | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index dec63d2..2ada199 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -16,6 +16,7 @@ (require mzlib/etc scheme/contract/base scheme/stxparam + unstable/location "private/unit-contract.ss" "private/unit-keywords.ss" "private/unit-runtime.ss" @@ -482,7 +483,7 @@ (if (pair? v/c) (contract (let-syntax #,renamings ctc-stx) (car v/c) (cdr v/c) (current-contract-region) - (quote #,var) (quote-syntax #,var)) + (quote #,var) (quote-srcloc #,var)) (error 'unit "contracted import ~a used before definition" (quote #,(syntax->datum var)))))))) (quasisyntax/loc (error-syntax) @@ -748,7 +749,7 @@ (current-contract-region) 'cant-happen (quote #,id) - (quote-syntax #,id)) + (quote-srcloc #,id)) (set-box! #,export-loc (cons #,tmp (current-contract-region))))) (quasisyntax/loc defn-or-expr @@ -825,7 +826,7 @@ #`(let ([old-v/c (#,vref)]) (contract ctc-stx (car old-v/c) (cdr old-v/c) (current-contract-region) - (quote #,var) (quote-syntax #,var))) + (quote #,var) (quote-srcloc #,var))) #`(#,vref)) (current-contract-region))) (if ctc @@ -833,7 +834,7 @@ (let ([old-v/c (#,vref)]) (contract ctc-stx (car old-v/c) (cdr old-v/c) (current-contract-region) - (quote #,var) (quote-syntax #,var)))) + (quote #,var) (quote-srcloc #,var)))) vref))))) (car target-sig) (cadddr target-sig))) @@ -1304,7 +1305,7 @@ #`(let ([v/c (#,tb)]) (contract ctc-stx (car v/c) (cdr v/c) (current-contract-region) - (quote #,v) (quote-syntax #,v)))) + (quote #,v) (quote-srcloc #,v)))) #`(#,tb))) tbs (iota (length (car os))) @@ -1507,7 +1508,7 @@ (export (export-tagged-sig-id [e.x e.c] ...) ...))))]) (values (syntax/loc stx - (contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-syntax name))) + (contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-srcloc name))) isigs esigs deps))))] [(ic:import-clause/contract ec:export-clause/contract . body) (build-unit/contract From ff9748dd993809a2ae6159a6127c1e2356c22638 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 06:29:43 +0000 Subject: [PATCH 07/12] Fixed missing keyword to simple-contract. svn: r17740 original commit: 2633965c91cf9e94c11b2343d66a633bb2d5270f --- collects/mzlib/private/contract-arrow.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mzlib/private/contract-arrow.ss b/collects/mzlib/private/contract-arrow.ss index 4eb6f11..a0e84f2 100644 --- a/collects/mzlib/private/contract-arrow.ss +++ b/collects/mzlib/private/contract-arrow.ss @@ -43,7 +43,7 @@ (let-values ([(res-x ...) (apply val args)]) (values (p-app-x res-x) ...))) (raise-blame-error blame val "expected a procedure"))))) - procedure?))))])) + #:first-order procedure?))))])) (define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func) (let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)] From d9e5df35edd0d5c4e81344b1c464b7ea20ff6018 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 07:14:17 +0000 Subject: [PATCH 08/12] Fixed blame detection regexp. svn: r17742 original commit: 35a716d5d36b4995c025d3e46089e3dea7a09dc8 --- collects/tests/mzscheme/contract-mzlib-test.ss | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss index 2e22f41..fa7a913 100644 --- a/collects/tests/mzscheme/contract-mzlib-test.ss +++ b/collects/tests/mzscheme/contract-mzlib-test.ss @@ -78,13 +78,9 @@ of the contract library does not change over time. (define (test/spec-failed name expression blame) (let () (define (has-proper-blame? msg) - (equal? - blame - (cond - [(regexp-match #rx"(^| )(.*) broke" msg) - => - (λ (x) (caddr x))] - [else (format "no blame in error message: \"~a\"" msg)]))) + (regexp-match? + (string-append "(^| )" (regexp-quote blame) " broke") + msg)) (printf "testing: ~s\n" name) (contract-eval `(,thunk-error-test @@ -5127,7 +5123,11 @@ so that propagation occurs. (and (exn? x) (regexp-match #rx"expected field name to be b, but found string?" (exn-message x))))) - (contract-eval `(,test 'pos guilty-party (with-handlers ((void values)) (contract not #t 'pos 'neg)))) + (contract-eval + `(,test + 'pos + (compose blame-guilty exn:fail:contract:blame-object) + (with-handlers ((void values)) (contract not #t 'pos 'neg)))) (report-errs) From 6e6139e8ae21cea8b26a150fce7b4a4270f10f61 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 09:24:48 +0000 Subject: [PATCH 09/12] Fixed a missing blame swap. svn: r17748 original commit: ad9968493ec76a2b3fc803f58b43f519c47d5c6f --- collects/mzlib/private/contract-arr-obj-helpers.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mzlib/private/contract-arr-obj-helpers.ss b/collects/mzlib/private/contract-arr-obj-helpers.ss index de1788c..ea6d71c 100644 --- a/collects/mzlib/private/contract-arr-obj-helpers.ss +++ b/collects/mzlib/private/contract-arr-obj-helpers.ss @@ -888,7 +888,7 @@ (syntax ((x ...) (begin - (check-pre-expr->pp/h val pre-expr blame) + (check-pre-expr->pp/h val pre-expr (blame-swap blame)) (let ([dom-id ((contract-projection (coerce-contract 'stx-name dom)) (blame-swap blame))] ...) From e600445407dbd4991aa7e30e19b95d9a77b21725 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 09:25:02 +0000 Subject: [PATCH 10/12] Fixed an expected contract message. svn: r17749 original commit: 934c775c2546157a2eae5e50d89466344fd7e19e --- collects/mzlib/private/contract-define.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mzlib/private/contract-define.ss b/collects/mzlib/private/contract-define.ss index df8215b..9cd106f 100644 --- a/collects/mzlib/private/contract-define.ss +++ b/collects/mzlib/private/contract-define.ss @@ -14,7 +14,7 @@ (define-for-syntax (make-define/contract-transformer contract-id id) (make-set!-transformer (λ (stx) - (with-syntax ([neg-blame-str (source-location->string stx)] + (with-syntax ([neg-blame-str (source-location->string stx "<>")] [contract-id contract-id] [id id]) (syntax-case stx (set!) From 02ce7aabdb2118b3f604431a45bf881bcf345a7d Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 23:25:07 +0000 Subject: [PATCH 11/12] Replaced uses of quote-srcloc with quote-syntax. svn: r17757 original commit: 7f58c26709c9a97623f50ec812727daa080b155b --- collects/mzlib/private/contract-define.ss | 7 +++---- collects/mzlib/unit.ss | 13 ++++++------- 2 files changed, 9 insertions(+), 11 deletions(-) diff --git a/collects/mzlib/private/contract-define.ss b/collects/mzlib/private/contract-define.ss index 9cd106f..cf76531 100644 --- a/collects/mzlib/private/contract-define.ss +++ b/collects/mzlib/private/contract-define.ss @@ -5,8 +5,7 @@ (require (for-syntax scheme/base unstable/srcloc (prefix-in a: scheme/contract/private/helpers)) - (only-in scheme/contract contract) - unstable/location) + (only-in scheme/contract contract)) ;; First, we have the old define/contract implementation, which ;; is still used in mzlib/contract. @@ -30,7 +29,7 @@ (syntax->datum (quote-syntax f)) neg-blame-str (quote f) - (quote-srcloc f)) + (quote-syntax f)) arg ...))] [ident @@ -41,7 +40,7 @@ (syntax->datum (quote-syntax ident)) neg-blame-str (quote ident) - (quote-srcloc ident)))]))))) + (quote-syntax ident)))]))))) ;; (define/contract id contract expr) ;; defines `id' with `contract'; initially binding diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 2ada199..dec63d2 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -16,7 +16,6 @@ (require mzlib/etc scheme/contract/base scheme/stxparam - unstable/location "private/unit-contract.ss" "private/unit-keywords.ss" "private/unit-runtime.ss" @@ -483,7 +482,7 @@ (if (pair? v/c) (contract (let-syntax #,renamings ctc-stx) (car v/c) (cdr v/c) (current-contract-region) - (quote #,var) (quote-srcloc #,var)) + (quote #,var) (quote-syntax #,var)) (error 'unit "contracted import ~a used before definition" (quote #,(syntax->datum var)))))))) (quasisyntax/loc (error-syntax) @@ -749,7 +748,7 @@ (current-contract-region) 'cant-happen (quote #,id) - (quote-srcloc #,id)) + (quote-syntax #,id)) (set-box! #,export-loc (cons #,tmp (current-contract-region))))) (quasisyntax/loc defn-or-expr @@ -826,7 +825,7 @@ #`(let ([old-v/c (#,vref)]) (contract ctc-stx (car old-v/c) (cdr old-v/c) (current-contract-region) - (quote #,var) (quote-srcloc #,var))) + (quote #,var) (quote-syntax #,var))) #`(#,vref)) (current-contract-region))) (if ctc @@ -834,7 +833,7 @@ (let ([old-v/c (#,vref)]) (contract ctc-stx (car old-v/c) (cdr old-v/c) (current-contract-region) - (quote #,var) (quote-srcloc #,var)))) + (quote #,var) (quote-syntax #,var)))) vref))))) (car target-sig) (cadddr target-sig))) @@ -1305,7 +1304,7 @@ #`(let ([v/c (#,tb)]) (contract ctc-stx (car v/c) (cdr v/c) (current-contract-region) - (quote #,v) (quote-srcloc #,v)))) + (quote #,v) (quote-syntax #,v)))) #`(#,tb))) tbs (iota (length (car os))) @@ -1508,7 +1507,7 @@ (export (export-tagged-sig-id [e.x e.c] ...) ...))))]) (values (syntax/loc stx - (contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-srcloc name))) + (contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-syntax name))) isigs esigs deps))))] [(ic:import-clause/contract ec:export-clause/contract . body) (build-unit/contract From ae2dbe30b119b20b0eb9befd0876450f228fd455 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sat, 23 Jan 2010 18:31:10 +0000 Subject: [PATCH 12/12] Replaced #%variable-reference with quote-module-path for unit contract blame. svn: r17781 original commit: d00e3432d960ea24ea6b25f34bbedd2002ba4041 --- collects/mzlib/unit.ss | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index dec63d2..d13d748 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -16,6 +16,7 @@ (require mzlib/etc scheme/contract/base scheme/stxparam + unstable/location "private/unit-contract.ss" "private/unit-keywords.ss" "private/unit-runtime.ss" @@ -1294,7 +1295,7 @@ (((wrap-code ...) ...) (map (λ (os ov tbs) (define rename-bindings - (get-member-bindings def-table os #'(#%variable-reference))) + (get-member-bindings def-table os #'(quote-module-path))) (map (λ (tb i v c) (if c (with-syntax ([ctc-stx