From 07a2ace9436a81e70ebdf2e3c6cedcc90f0684e1 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 25 Feb 2011 09:45:21 -0600 Subject: [PATCH] added the #:pre/name and #:post/name keywords to ->i --- .../racket/contract/private/arr-i-parse.rkt | 152 ++++++++++++------ collects/racket/contract/private/arr-i.rkt | 96 ++++++----- .../scribblings/reference/contracts.scrbl | 23 +-- collects/tests/racket/contract-test.rktl | 138 ++++++++++++---- 4 files changed, 282 insertions(+), 127 deletions(-) diff --git a/collects/racket/contract/private/arr-i-parse.rkt b/collects/racket/contract/private/arr-i-parse.rkt index 25b543b736..10efda5994 100644 --- a/collects/racket/contract/private/arr-i-parse.rkt +++ b/collects/racket/contract/private/arr-i-parse.rkt @@ -19,9 +19,9 @@ code does the parsing and validation of the syntax. ;; args : (listof arg?) ;; rst : (or/c #f arg/res?) -;; pre : (or/c pre/post? #f) +;; pre : (listof pre/post?) ;; ress : (or/c #f (listof eres?) (listof lres?)) -;; post : (or/c pre/post? #f) +;; post : (listof pre/post?) (struct istx (args rst pre ress post) #:transparent) ;; NOTE: the ress field may contain a mixture of eres and lres structs ;; but only temporarily; in that case, a syntax error @@ -46,7 +46,8 @@ code does the parsing and validation of the syntax. ;; vars : (listof identifier?) ;; exp : syntax[expr] -(struct pre/post (vars exp) #:transparent) +;; str : (or/c #f syntax[expr]) +(struct pre/post (vars str exp) #:transparent) (define (parse-->i stx) (if (identifier? stx) @@ -105,7 +106,7 @@ code does the parsing and validation of the syntax. (raise-syntax-error #f (if arg? "an argument cannot depend on a result" - "the #:pre condition cannot depend on a result") + "a #:pre or #:pre/name condition cannot depend on a result") stx arg-var))))) ;; no dups in the domains @@ -146,8 +147,8 @@ code does the parsing and validation of the syntax. (not-range-bound a-vars #t)))) ;; pre-condition variables are all bound, but not to a range variable - (when (istx-pre istx) - (let ([vars (pre/post-vars (istx-pre istx))]) + (for ([pre (in-list (istx-pre istx))]) + (let ([vars (pre/post-vars pre)]) (ensure-bound vars) (not-range-bound vars #f))) @@ -158,8 +159,8 @@ code does the parsing and validation of the syntax. (ensure-bound (arg/res-vars a-res))))) ;; post-condition variables are all bound - (when (istx-post istx) - (let ([vars (pre/post-vars (istx-post istx))]) + (for ([post (in-list (istx-post istx))]) + (let ([vars (pre/post-vars post)]) (ensure-bound vars))))) (define (ensure-no-cycles stx istx) @@ -328,6 +329,8 @@ code does the parsing and validation of the syntax. (values '() leftover)] [(dep-range #:post . stuff) (values '() leftover)] + [(dep-range #:post/name . stuff) + (values '() leftover)] [((opts ...) . rest) (values #'(opts ...) #'rest)] [_ (values '() leftover)])] @@ -358,48 +361,103 @@ code does the parsing and validation of the syntax. "expected something to follow #:rest" stx #'x)] [_ (values #f leftover)])] - [(pre-cond leftover) - (syntax-case leftover () - [(#:pre (id ...) pre-cond . pre-leftover) - (begin - (syntax-case #'pre-leftover () - [() (raise-syntax-error - #f - "expected #:pre to be followed by at least three subterms (a sequence of identifiers, the pre-condition and the range contract), but found only two" - stx - (car (syntax->list leftover)))] - [x (void)]) - (for-each (λ (x) (check-id stx x)) (syntax->list #'(id ...))) - (values (pre/post (syntax->list #'(id ...)) #'pre-cond) #'pre-leftover))] - [_ (values #f leftover)])] + [(pre-conds leftover) + (let loop ([leftover leftover] + [conditions '()]) + (syntax-case leftover () + [(#:pre (id ...) pre-cond . pre-leftover) + (begin + (syntax-case #'pre-leftover () + [() (raise-syntax-error + #f + "expected #:pre to be followed by at least three subterms (a sequence of identifiers, the pre-condition, and the range contract), but found only two" + stx + (car (syntax->list leftover)))] + [x (void)]) + (for-each (λ (x) (check-id stx x)) (syntax->list #'(id ...))) + (loop #'pre-leftover + (cons (pre/post (syntax->list #'(id ...)) #f #'pre-cond) conditions)))] + [(#:pre . rest) + (raise-syntax-error #f + "expected a sequence of identifiers and an expression to follow #:pre" + stx + (car (syntax->list leftover)))] + [(#:pre/name (id ...) str pre-cond . pre-leftover) + (begin + (syntax-case #'pre-leftover () + [() (raise-syntax-error + #f + "expected #:pre/name to be followed by at least four subterms (a sequence of identifiers, a name, the pre-condition, and the range contract), but found only three" + stx + (car (syntax->list leftover)))] + [x (void)]) + (for-each (λ (x) (check-id stx x)) (syntax->list #'(id ...))) + (unless (string? (syntax-e #'str)) + (raise-syntax-error + #f + "expected #:pre/name to have a string after the sequence of variables" + stx + #'str)) + (loop #'pre-leftover + (cons (pre/post (syntax->list #'(id ...)) (syntax-e #'str) #'pre-cond) conditions)))] + [(#:pre/name . rest) + (raise-syntax-error #f + "expected a sequence of identifiers, a string, and an expression to follow #:pre/name" + stx + (car (syntax->list leftover)))] + [_ (values (reverse conditions) leftover)]))] [(range leftover) - (syntax-case leftover () - [(range . leftover) - (not (keyword? (syntax-e #'range))) - (values #'range #'leftover)] - [(a . b) - (raise-syntax-error #f "expected a range expression" stx #'a)] - [() - (raise-syntax-error #f "expected a range expression, but found nothing" stx)])] - [(post-cond leftover) - (syntax-case leftover () - [(#:post (id ...) post-cond . leftover) - (begin - (for-each (λ (x) (check-id stx x)) (syntax->list #'(id ...))) - (syntax-case range (any) - [any (raise-syntax-error #f "cannot have a #:post with any as the range" stx #'post-cond)] - [_ (void)]) - (values (pre/post (syntax->list #'(id ...)) #'post-cond) #'leftover))] - [(#:post a b . stuff) - (begin - (raise-syntax-error #f "expected a sequence of variables to follow #:post" stx #'a))] - [(#:post a) - (begin - (raise-syntax-error #f "expected a sequence of variables and an expression to follow #:post" stx #'a))] - [_ (values #f leftover)])]) + (begin + (syntax-case leftover () + [(range . leftover) + (not (keyword? (syntax-e #'range))) + (values #'range #'leftover)] + [(a . b) + (raise-syntax-error #f "expected a range expression" stx #'a)] + [() + (raise-syntax-error #f "expected a range expression, but found nothing" stx)]))] + [(post-conds leftover) + (let loop ([leftover leftover] + [post-conds '()]) + (syntax-case leftover () + [(#:post (id ...) post-cond . leftover) + (begin + (for-each (λ (x) (check-id stx x)) (syntax->list #'(id ...))) + (syntax-case range (any) + [any (raise-syntax-error #f "cannot have a #:post with any as the range" stx #'post-cond)] + [_ (void)]) + (loop #'leftover + (cons (pre/post (syntax->list #'(id ...)) #f #'post-cond) post-conds)))] + [(#:post a b . stuff) + (begin + (raise-syntax-error #f "expected a sequence of variables to follow #:post" stx #'a))] + [(#:post a) + (begin + (raise-syntax-error #f "expected a sequence of variables and an expression to follow #:post" stx #'a))] + [(#:post/name (id ...) str post-cond . leftover) + (begin + (for-each (λ (x) (check-id stx x)) (syntax->list #'(id ...))) + (syntax-case range (any) + [any (raise-syntax-error #f "cannot have a #:post with any as the range" stx #'post-cond)] + [_ (void)]) + (unless (string? (syntax-e #'str)) + (raise-syntax-error #f + "expected the error message part of a #:post/name declaraction to be a string" + stx + #'str)) + (loop #'leftover + (cons (pre/post (syntax->list #'(id ...)) (syntax-e #'str) #'post-cond) post-conds)))] + [(#:post/name . stuff) + (begin + (raise-syntax-error #f "expected a sequence of variables, a string, and an expression to follow #:post/name" + stx + (car (syntax-e leftover))))] + + [_ + (values (reverse post-conds) leftover)]))]) (syntax-case leftover () [() - (values raw-mandatory-doms raw-optional-doms id/rest-id pre-cond range post-cond)] + (values raw-mandatory-doms raw-optional-doms id/rest-id pre-conds range post-conds)] [(a . b) (raise-syntax-error #f "bad syntax" stx #'a)] [_ diff --git a/collects/racket/contract/private/arr-i.rkt b/collects/racket/contract/private/arr-i.rkt index 4a1ee5e300..11d860e95f 100644 --- a/collects/racket/contract/private/arr-i.rkt +++ b/collects/racket/contract/private/arr-i.rkt @@ -111,9 +111,9 @@ (let* ([name-info (->i-name-info ctc)] [args-info (vector-ref name-info 0)] [rest-info (vector-ref name-info 1)] - [pre-info (vector-ref name-info 2)] + [pre-infos (vector-ref name-info 2)] [rng-info (vector-ref name-info 3)] - [post-info (vector-ref name-info 4)]) + [post-infos (vector-ref name-info 4)]) `(->i ,(arg/ress->spec args-info (->i-arg-ctcs ctc) (->i-arg-dep-ctcs ctc) @@ -130,9 +130,12 @@ [(nodep) `(#:rest [,(list-ref rest-info 1) ,(contract-name (car (reverse (->i-arg-ctcs ctc))))])] [(dep) `(#:rest [,(list-ref rest-info 1) ,(list-ref rest-info 2) ...])]) '()) - ,@(if pre-info - `(#:pre ,pre-info ...) - '()) + ,@(apply + append + (for/list ([pre-info pre-infos]) + (if (cadr pre-info) + `(#:pre/name ,@pre-info ...) + `(#:pre ,(car pre-info) ...)))) ,(cond [(not rng-info) 'any] @@ -146,9 +149,12 @@ `(values ,@infos)] [else (car infos)]))]) - ,@(if post-info - `(#:post ,post-info ...) - '())))) + ,@(apply + append + (for/list ([post-info post-infos]) + (if (cadr post-info) + `(#:post/name ,@post-info ...) + `(#:post ,(car post-info) ...))))))) #:first-order (λ (ctc) (let ([has-rest? (->i-rest? ctc)] @@ -331,33 +337,33 @@ (define-for-syntax (maybe-generate-temporary x) (and x (car (generate-temporaries (list x))))) -(define (check-pre bool val blame) +(define (check-pre bool val str blame) (unless bool - (raise-blame-error blame val "#:pre condition violation"))) + (raise-blame-error blame val (or str "#:pre condition violation")))) -(define (check-post bool val blame) +(define (check-post bool val str blame) (unless bool - (raise-blame-error blame val "#:post condition violation"))) + (raise-blame-error blame val (or str "#:post condition violation")))) (define-for-syntax (add-pre-cond an-istx arg/res-to-indy-var call-stx) - (cond - [(istx-pre an-istx) - #`(begin (check-pre (pre-proc #,@(map arg/res-to-indy-var (pre/post-vars (istx-pre an-istx)))) - val - swapped-blame) - #,call-stx)] - [else - call-stx])) + #`(begin #,@(for/list ([pre (in-list (istx-pre an-istx))] + [i (in-naturals)]) + (define id (string->symbol (format "pre-proc~a" i))) + #`(check-pre (#,id #,@(map arg/res-to-indy-var (pre/post-vars pre))) + val + #,(pre/post-str pre) + swapped-blame)) + #,call-stx)) (define-for-syntax (add-post-cond an-istx arg/res-to-indy-var call-stx) - (cond - [(istx-post an-istx) - #`(begin (check-post (post-proc #,@(map arg/res-to-indy-var (pre/post-vars (istx-post an-istx)))) - val - blame) - #,call-stx)] - [else - call-stx])) + #`(begin #,@(for/list ([post (in-list (istx-post an-istx))] + [i (in-naturals)]) + (define id (string->symbol (format "post-proc~a" i))) + #`(check-post (#,id #,@(map arg/res-to-indy-var (pre/post-vars post))) + val + #,(pre/post-str post) + blame)) + #,call-stx)) ;; add-wrapper-let : syntax ;; (listof arg/res) -- sorted version of the arg/res structs, ordered by evaluation order @@ -530,8 +536,12 @@ #`(λ (blame swapped-blame indy-dom-blame indy-rng-blame chk ctc ;; the pre- and post-condition procs - #,@(if (istx-pre an-istx) (list #'pre-proc) '()) - #,@(if (istx-post an-istx) (list #'post-proc) '()) + #,@(for/list ([pres (istx-pre an-istx)] + [i (in-naturals)]) + (string->symbol (format "pre-proc~a" i))) + #,@(for/list ([pres (istx-post an-istx)] + [i (in-naturals)]) + (string->symbol (format "post-proc~a" i))) ;; first the non-dependent arg projections #,@(filter values (map (λ (arg/res arg-proj-var) (and (not (arg/res-vars arg/res)) arg-proj-var)) @@ -617,8 +627,8 @@ (free-identifier-mapping-put! vars var #t))))) ;; pre-condition - (when (istx-pre an-istx) - (for ([var (in-list (pre/post-vars (istx-pre an-istx)))]) + (for ([pre (in-list (istx-pre an-istx))]) + (for ([var (in-list (pre/post-vars pre))]) (free-identifier-mapping-put! vars var #t))) ;; results @@ -629,8 +639,8 @@ (free-identifier-mapping-put! vars var #t))))) ;; post-condition - (when (istx-post an-istx) - (for ([var (in-list (pre/post-vars (istx-post an-istx)))]) + (for ([post (in-list (istx-post an-istx))]) + (for ([var (in-list (pre/post-vars post))]) (free-identifier-mapping-put! vars var #t))) vars)) @@ -742,12 +752,10 @@ #''()) #,(let ([func (λ (pre/post) #`(λ #,(pre/post-vars pre/post) #,(pre/post-exp pre/post)))]) - #`(list #,@(if (istx-pre an-istx) - (list (func (istx-pre an-istx))) - '()) - #,@(if (istx-post an-istx) - (list (func (istx-post an-istx))) - '()))) + #`(list #,@(for/list ([pre (in-list (istx-pre an-istx))]) + (func pre)) + #,@(for/list ([post (in-list (istx-post an-istx))]) + (func post)))) #,(length (filter values (map (λ (arg) (and (not (arg-kwd arg)) (not (arg-optional? arg)))) (istx-args an-istx)))) @@ -778,7 +786,9 @@ ,(map syntax-e (arg/res-vars (istx-rst an-istx)))) `(nodep ,(syntax-e (arg/res-var (istx-rst an-istx))))) #f) - #,(and (istx-pre an-istx) (map syntax-e (pre/post-vars (istx-pre an-istx)))) + #,(for/list ([pre (in-list (istx-pre an-istx))]) + (list (map syntax-e (pre/post-vars pre)) + (pre/post-str pre))) #,(and (istx-ress an-istx) (for/list ([a-res (in-list (istx-ress an-istx))]) `(,(if (arg/res-vars a-res) 'dep 'nodep) @@ -790,7 +800,9 @@ '()) #f #f))) - #,(and (istx-post an-istx) (map syntax-e (pre/post-vars (istx-post an-istx)))))) + #,(for/list ([post (in-list (istx-post an-istx))]) + (list (map syntax-e (pre/post-vars post)) + (pre/post-str post))))) 'racket/contract:contract (let () (define (find-kwd kwd) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 7caa081896..459b6882bd 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -600,13 +600,17 @@ symbols, and that return a symbol. [optional-dependent-dom id+ctc (code:line keyword id+ctc)] [dependent-rest (code:line) (code:line #:rest id+ctc)] - [pre-condition (code:line) (code:line #:pre (id ...) boolean-expr)] + [pre-condition (code:line) + (code:line #:pre (id ...) boolean-expr pre-condition) + (code:line #:pre/name (id ...) string boolean-expr pre-condition)] [dependent-range any id+ctc un+ctc (values id+ctc ...) (values un+ctc ...)] - [post-condition (code:line) (code:line #:post (id ...) boolean-expr)] + [post-condition (code:line) + (code:line #:post (id ...) boolean-expr post-condition) + (code:line #:post/name (id ...) string boolean-expr post-condition)] [id+ctc [id contract-expr] [id (id ...) contract-expr]] [un+ctc [_ contract-expr] @@ -623,7 +627,8 @@ The first sub-form of a @racket[->i] contract covers the mandatory and the second sub-form covers the optional arguments. Following that is an optional rest-args contract, and an optional pre-condition. The pre-condition is introduced with the @racket[#:pre] keyword followed by the list of names on -which it depends. +which it depends. If the @racket[#:pre/name] keyword is used, the string +supplied is used as part of the error message; similarly with @racket[#:post/name]. The @racket[dep-range] non-terminal specifies the possible result contracts. If it is @racket[any], then any value is allowed. Otherwise, the @@ -642,14 +647,14 @@ second argument (@scheme[y]) demands that it is greater than the first argument. The result contract promises a number that is greater than the sum of the two arguments. While the dependency specification for @scheme[y] signals that the argument contract depends on the value of the first -argument, the dependency list for @scheme[result] indicates that the +argument, the dependency sequence for @scheme[result] indicates that the contract depends on both argument values. @margin-note*{In general, an -empty list is (nearly) equivalent to not adding -a list at all except that the former is more expensive than the latter.} +empty sequence is (nearly) equivalent to not adding +a sequence at all except that the former is more expensive than the latter.} Since the contract for @racket[x] does not depend on anything else, it does -not come with any dependency list, not even @scheme[()]. +not come with any dependency sequence, not even @scheme[()]. -The contract expressions are not evaluated in +The contract expressions are not always evaluated in order. First, if there is no dependency for a given contract expression, the contract expression is evaluated at the time that the @racket[->i] expression is evaluated rather than the time when the function is called or @@ -664,7 +669,7 @@ argument, with its contract checked, is available for the other). When there is no dependency between two arguments (or the result and an argument), then the contract that appears earlier in the source text is evaluated first. -#; + Finally, if all of the identifier positions of the range contract are @racket[_]s (underscores), then the range contract expressions are evaluated when the function is called and the underscore is not bound diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index bc330f1499..cef80da9c6 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -2500,6 +2500,38 @@ '((contract (->i ([x number?]) #:pre () (= 1 2) any) (λ (x) 1) 'pos 'neg) 2)) + + (test/neg-blame + '->i35-b + '((contract (->i ([x number?]) #:pre () #t #:pre () (= 1 2) any) + (λ (x) 1) + 'pos 'neg) 2)) + + (test/neg-blame + '->i35-c + '((contract (->i ([x number?]) #:pre (x) (even? x) #:pre (x) (positive? x) any) + (λ (x) 1) + 'pos 'neg) 3)) + + (test/neg-blame + '->i35-d + '((contract (->i ([x number?]) #:pre (x) (even? x) #:pre (x) (positive? x) any) + (λ (x) 1) + 'pos 'neg) -2)) + + (test/neg-blame + '->i35-e + '((contract (->i ([x any/c]) #:pre (x) (pair? x) #:pre (x) (car x) any) + (λ (x) 1) + 'pos 'neg) + (cons #f 1))) + + (test/neg-blame + '->i35-f + '((contract (->i ([x any/c]) #:pre/name (x) "pair" (pair? x) #:pre/name (x) "car" (car x) any) + (λ (x) 1) + 'pos 'neg) + (cons #f 1))) (test/spec-passed/result '->i36 @@ -2570,51 +2602,95 @@ (test/spec-passed/result '->i44 '((contract (->i ([x () any/c]) - [y any/c] - #:post (x) x) - (lambda (x) x) - 'pos - 'neg) - #t) + [y any/c] + #:post (x) x) + (lambda (x) x) + 'pos + 'neg) + #t) '#t) - + (test/pos-blame '->i45 '((contract (->i ([x () any/c]) - [y any/c] - #:post (x) x) - (lambda (x) x) - 'pos - 'neg) - #f)) + [y any/c] + #:post (x) x) + (lambda (x) x) + 'pos + 'neg) + #f)) (test/spec-passed/result '->i46 '((contract (->i ([x any/c]) - [y () any/c] - #:post (y) y) - (lambda (x) x) - 'pos - 'neg) - #t) + [y () any/c] + #:post (y) y) + (lambda (x) x) + 'pos + 'neg) + #t) '#t) - + (test/pos-blame '->i47 '((contract (->i ([x any/c]) - [y () any/c] - #:post (y) y) - (lambda (x) x) - 'pos - 'neg) - #f)) + [y () any/c] + #:post (y) y) + (lambda (x) x) + 'pos + 'neg) + #f)) + + (test/pos-blame + '->i47-b + '((contract (->i ([x any/c]) + [y () any/c] + #:post (y) (even? y) + #:post (y) (positive? y)) + (lambda (x) x) + 'pos + 'neg) + -2)) + + (test/pos-blame + '->i47-c + '((contract (->i ([x any/c]) + [y () any/c] + #:post (y) (even? y) + #:post (y) (positive? y)) + (lambda (x) x) + 'pos + 'neg) + 3)) + + (test/pos-blame + '->i47-d + '((contract (->i ([x any/c]) + [y () any/c] + #:post (y) (pair? y) + #:post (y) (car y)) + (lambda (x) x) + 'pos + 'neg) + (cons #f 1))) + + (test/pos-blame + '->i47-e + '((contract (->i ([x any/c]) + [y () any/c] + #:post/name (y) "pair" (pair? y) + #:post/name (y) "car" (car y)) + (lambda (x) x) + 'pos + 'neg) + (cons #f 1))) (test/spec-passed/result '->i48 '(let ([x '()]) ((contract (->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)]) - [res () (begin - (set! x (cons 'res-eval x)) + [res () (begin + (set! x (cons 'res-eval x)) (λ (res) (set! x (cons 'res-check x))))]) (λ (arg) @@ -9538,7 +9614,11 @@ so that propagation occurs. (->i ([x integer?]) #:pre (x) #t [q (x) number?] #:post (x) #t)) (test-name '(->i ([x real?]) [_ (x) ...]) (->i ([x real?]) [_ (x) (>/c x)])) - + (test-name '(->i ([x any/c]) #:pre/name (x) "pair" ... #:pre/name (x) "car" ... any) + (->i ([x any/c]) #:pre/name (x) "pair" (pair? x) #:pre/name (x) "car" (car x) any)) + (test-name '(->i ([x any/c]) [y () ...] #:post/name (y) "pair" ... #:post/name (y) "car" ...) + (->i ([x any/c]) [y () any/c] #:post/name (y) "pair" (pair? y) #:post/name (y) "car" (car y))) + (test-name '(case->) (case->)) (test-name '(case-> (-> integer? any) (-> boolean? boolean? any) (-> char? char? char? any)) (case-> (-> integer? any) (-> boolean? boolean? any) (-> char? char? char? any)))