From 4ad8fdadeaf56e8e373a947f6d2d0f451d959233 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 28 Jan 2007 02:54:16 +0000 Subject: [PATCH] merged the opt/c changes back into the trunk (finally!) svn: r5481 --- collects/mzlib/contract.ss | 12 +- collects/mzlib/private/contract-arrow.ss | 80 +- .../mzlib/private/contract-basic-opters.ss | 163 +- collects/mzlib/private/contract-ds-helpers.ss | 215 ++- collects/mzlib/private/contract-ds.ss | 500 ++++- collects/mzlib/private/contract-guts.ss | 30 +- collects/mzlib/private/contract-opt-guts.ss | 179 +- collects/mzlib/private/contract-opt.ss | 249 ++- collects/mzlib/private/contract.ss | 432 +++-- collects/tests/mzscheme/contract-test.ss | 1607 ++++++++--------- 10 files changed, 2272 insertions(+), 1195 deletions(-) diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index 15c228c7c8..59a268708f 100644 --- a/collects/mzlib/contract.ss +++ b/collects/mzlib/contract.ss @@ -9,14 +9,10 @@ "private/contract-basic-opters.ss") (provide - ;; opt is not ready yet - #;(all-from "private/contract-opt.ss") - #;(all-from-except "private/contract-opt-guts.ss" - make-opt-contract - orig-ctc-prop - orig-ctc-pred? - orig-ctc-get) - (all-from "private/contract-ds.ss") + opt/c ;(all-from "private/contract-opt.ss") + (all-from-except "private/contract-ds.ss" + lazy-depth-to-look) + (all-from-except "private/contract-arrow.ss" check-procedure) (all-from-except "private/contract-guts.ss" diff --git a/collects/mzlib/private/contract-arrow.ss b/collects/mzlib/private/contract-arrow.ss index 504459c3cf..2e9bbdc15a 100644 --- a/collects/mzlib/private/contract-arrow.ss +++ b/collects/mzlib/private/contract-arrow.ss @@ -1747,21 +1747,27 @@ ;; ;; arrow opter ;; - (define/opter (-> opt/i pos neg stx) + (define/opter (-> opt/i opt/info stx) (define (opt/arrow-ctc doms rngs) (let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms) (generate-temporaries rngs))] - [(next-doms lifts-doms partials-doms) + [(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom) (let loop ([vars dom-vars] [doms doms] [next-doms null] [lifts-doms null] - [partials-doms null]) + [superlifts-doms null] + [partials-doms null] + [stronger-ribs null]) (cond - [(null? doms) (values (reverse next-doms) lifts-doms partials-doms)] + [(null? doms) (values (reverse next-doms) + lifts-doms + superlifts-doms + partials-doms + stronger-ribs)] [else - (let-values ([(next lift partial _ __) - (opt/i neg pos (car doms))]) + (let-values ([(next lift superlift partial _ __ this-stronger-ribs) + (opt/i (opt/info-swap-blame opt/info) (car doms))]) (loop (cdr vars) (cdr doms) (cons (with-syntax ((next next) @@ -1769,18 +1775,26 @@ (syntax (let ((val car-vars)) next))) next-doms) (append lifts-doms lift) - (append partials-doms partial)))]))] - [(next-rngs lifts-rngs partials-rngs) + (append superlifts-doms superlift) + (append partials-doms partial) + (append this-stronger-ribs stronger-ribs)))]))] + [(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng) (let loop ([vars rng-vars] [rngs rngs] [next-rngs null] [lifts-rngs null] - [partials-rngs null]) + [superlifts-rngs null] + [partials-rngs null] + [stronger-ribs null]) (cond - [(null? rngs) (values (reverse next-rngs) lifts-rngs partials-rngs)] + [(null? rngs) (values (reverse next-rngs) + lifts-rngs + superlifts-rngs + partials-rngs + stronger-ribs)] [else - (let-values ([(next lift partial _ __) - (opt/i pos neg (car rngs))]) + (let-values ([(next lift superlift partial _ __ this-stronger-ribs) + (opt/i opt/info (car rngs))]) (loop (cdr vars) (cdr rngs) (cons (with-syntax ((next next) @@ -1788,9 +1802,13 @@ (syntax (let ((val car-vars)) next))) next-rngs) (append lifts-rngs lift) - (append partials-rngs partial)))]))]) + (append superlifts-rngs superlift) + (append partials-rngs partial) + (append this-stronger-ribs stronger-ribs)))]))]) (values - (with-syntax ((pos pos) + (with-syntax ((pos (opt/info-pos opt/info)) + (src-info (opt/info-src-info opt/info)) + (orig-str (opt/info-orig-str opt/info)) ((dom-arg ...) dom-vars) ((rng-arg ...) rng-vars) ((next-dom ...) next-doms) @@ -1802,23 +1820,31 @@ (let-values ([(rng-arg ...) (val next-dom ...)]) (values next-rng ...)))))) (append lifts-doms lifts-rngs) + (append superlifts-doms superlifts-rngs) (append partials-doms partials-rngs) #f - #f))) + #f + (append stronger-ribs-dom stronger-ribs-rng)))) (define (opt/arrow-any-ctc doms) (let*-values ([(dom-vars) (generate-temporaries doms)] - [(next-doms lifts-doms partials-doms) + [(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom) (let loop ([vars dom-vars] [doms doms] [next-doms null] [lifts-doms null] - [partials-doms null]) + [superlifts-doms null] + [partials-doms null] + [stronger-ribs null]) (cond - [(null? doms) (values (reverse next-doms) lifts-doms partials-doms)] + [(null? doms) (values (reverse next-doms) + lifts-doms + superlifts-doms + partials-doms + stronger-ribs)] [else - (let-values ([(next lift partial flat _) - (opt/i pos neg (car doms))]) + (let-values ([(next lift superlift partial flat _ this-stronger-ribs) + (opt/i (opt/info-swap-blame opt/info) (car doms))]) (loop (cdr vars) (cdr doms) (cons (with-syntax ((next next) @@ -1826,9 +1852,13 @@ (syntax (let ((val car-vars)) next))) next-doms) (append lifts-doms lift) - (append partials-doms partial)))]))]) + (append superlifts-doms superlift) + (append partials-doms partial) + (append this-stronger-ribs stronger-ribs)))]))]) (values - (with-syntax ((pos pos) + (with-syntax ((pos (opt/info-pos opt/info)) + (src-info (opt/info-src-info opt/info)) + (orig-str (opt/info-orig-str opt/info)) ((dom-arg ...) dom-vars) ((next-dom ...) next-doms) (dom-len (length dom-vars))) @@ -1837,11 +1867,13 @@ (λ (dom-arg ...) (val next-dom ...))))) lifts-doms + superlifts-doms partials-doms #f - #f))) + #f + stronger-ribs-dom))) - (syntax-case stx (-> values any) + (syntax-case* stx (-> values any) module-or-top-identifier=? [(-> dom ... (values rng ...)) (opt/arrow-ctc (syntax->list (syntax (dom ...))) (syntax->list (syntax (rng ...))))] diff --git a/collects/mzlib/private/contract-basic-opters.ss b/collects/mzlib/private/contract-basic-opters.ss index b81bd8ed6c..37fbb6e153 100644 --- a/collects/mzlib/private/contract-basic-opters.ss +++ b/collects/mzlib/private/contract-basic-opters.ss @@ -1,81 +1,104 @@ (module contract-basic-opters mzscheme (require "contract-guts.ss" - "contract-opt.ss") + "contract-opt.ss" + "contract.ss") (require-for-syntax "contract-opt-guts.ss") ;; ;; opt/pred helper ;; - (define-for-syntax (opt/pred pos pred) - (let* ((lift-vars (generate-temporaries (syntax (pred)))) - (lift-pred-var (car lift-vars))) - (with-syntax ((lift-pred lift-pred-var)) - (values - (with-syntax ((pos pos)) - (syntax (if (lift-pred val) - val - (raise-contract-error - val - src-info - pos - orig-str - "expected <~a>, given: ~e" - ((name-get ctc) ctc) - val)))) - (list (cons lift-pred-var pred)) - null - (syntax (lift-pred val)) - #f)))) + (define-for-syntax (opt/pred opt/info pred) + (printf "~s\n" (list 'opt/pred opt/info pred)) + (with-syntax ((pred pred)) + (values + (with-syntax ((val (opt/info-val opt/info)) + (ctc (opt/info-contract opt/info)) + (pos (opt/info-pos opt/info)) + (src-info (opt/info-src-info opt/info)) + (orig-str (opt/info-orig-str opt/info))) + (syntax (if (pred val) + val + (raise-contract-error + val + src-info + pos + orig-str + "expected <~a>, given: ~e" + ((name-get ctc) ctc) + val)))) + null + null + null + (syntax (pred val)) + #f + null))) ;; ;; built-in predicate opters ;; - (define/opter (null? opt/i pos neg stx) + (define/opter (null? opt/i opt/info stx) (syntax-case stx (null?) - [null? (opt/pred pos #'null?)])) - (define/opter (boolean? opt/i pos neg stx) + [null? (opt/pred opt/info #'null?)])) + (define/opter (boolean? opt/i opt/info stx) + (printf "boolean opter\n") (syntax-case stx (boolean?) - [boolean? (opt/pred pos #'boolean?)])) - (define/opter (integer? opt/i pos neg stx) + [boolean? (opt/pred opt/info #'boolean?)])) + (define/opter (integer? opt/i opt/info stx) (syntax-case stx (integer?) - [integer? (opt/pred pos #'integer?)])) - (define/opter (char? opt/i pos neg stx) + [integer? (opt/pred opt/info #'integer?)])) + (define/opter (char? opt/i opt/info stx) (syntax-case stx (char?) - [char? (opt/pred pos #'char?)])) - (define/opter (number? opt/i pos neg stx) + [char? (opt/pred opt/info #'char?)])) + (define/opter (number? opt/i opt/info stx) (syntax-case stx (number?) - [number? (opt/pred pos #'number?)])) - (define/opter (pair? opt/i pos neg stx) + [number? (opt/pred opt/info #'number?)])) + (define/opter (pair? opt/i opt/info stx) (syntax-case stx (pair?) - [pair? (opt/pred pos #'pair?)])) + [pair? (opt/pred opt/info #'pair?)])) + (define/opter (not opt/i opt/info stx) + (syntax-case stx (not) + [not (opt/pred opt/info #'not)])) ;; ;; any/c ;; - (define/opter (any/c opt/i pos neg stx) + (define/opter (any/c opt/i opt/info stx) (syntax-case stx (any/c) [any/c (values - #'val + (opt/info-val opt/info) + null null null #'#t - #f)])) + #f + null)])) + + ;; + ;; false/c + ;; + (define/opter (false/c opt/i opt/info stx) + (syntax-case stx (false/c) + [false/c (opt/pred opt/info #'not)])) ;; ;; flat-contract helper ;; - (define-for-syntax (opt/flat-ctc pos pred checker) - (syntax-case pred (null? number? integer? boolean? pair?) + (define-for-syntax (opt/flat-ctc opt/info pred checker) + (syntax-case pred (null? number? integer? boolean? pair? not) ;; Better way of doing this? - [null? (opt/pred pos pred)] - [number? (opt/pred pos pred)] - [integer? (opt/pred pos pred)] - [boolean? (opt/pred pos pred)] - [pair? (opt/pred pos pred)] + [null? (opt/pred opt/info pred)] + [number? (opt/pred opt/info pred)] + [integer? (opt/pred opt/info pred)] + [boolean? (opt/pred opt/info pred)] + [pair? (opt/pred opt/info pred)] [pred (let* ((lift-vars (generate-temporaries (syntax (pred error-check)))) (lift-pred (car lift-vars))) - (with-syntax ((pos pos) + (with-syntax ((val (opt/info-val opt/info)) + (ctc (opt/info-contract opt/info)) + (pos (opt/info-pos opt/info)) + (src-info (opt/info-src-info opt/info)) + (orig-str (opt/info-orig-str opt/info)) (lift-pred lift-pred)) (values (syntax (if (lift-pred val) @@ -93,55 +116,17 @@ (list #'pred (cond [(eq? checker 'check-flat-contract) #'(check-flat-contract lift-pred)] [(eq? checker 'check-flat-named-contract) #'(check-flat-named-contract lift-pred)]))) null + null (syntax (lift-pred val)) - #f)))])) + #f + null)))])) ;; ;; flat-contract and friends ;; - (define/opter (flat-contract opt/i pos neg stx) + (define/opter (flat-contract opt/i opt/info stx) (syntax-case stx (flat-contract) - [(flat-contract pred) (opt/flat-ctc pos #'pred 'check-flat-contract)])) - (define/opter (flat-named-contract opt/i pos neg stx) + [(flat-contract pred) (opt/flat-ctc opt/info #'pred 'check-flat-contract)])) + (define/opter (flat-named-contract opt/i opt/info stx) (syntax-case stx (flat-named-contract) - [(flat-named-contract name pred) (opt/flat-ctc pos #'pred 'check-flat-named-contract)])) - - ;; - ;; unknown - ;; - ;; BUGS: currently, opt/c reports error on something like - ;; (opt/c (or/c (begin (print "side effect") number?) boolean?)) - ;; because the begin sequence is unrecognized, and we have no idea of - ;; knowing that `number?' is a pred that we can opt. - ;; WORKAROUND: wrap `flat-contract' around the pred, it optimizes to the same - ;; thing. - ;; - (define/opter (unknown opt/i pos neg stx) - (define (opt/unknown-ctc uctc) - (let* ((lift-vars (generate-temporaries (syntax (lift error-check)))) - (lift-var (car lift-vars)) - (partial-var (car (generate-temporaries (syntax (partial)))))) - (values - (with-syntax ((partial-var partial-var) - (lift-var lift-var) - (uctc uctc)) - (syntax (partial-var val))) - (interleave-lifts - lift-vars - (list uctc - (with-syntax ((lift-var lift-var)) - (syntax - (unless (contract? lift-var) - (error 'contract "expected contract, given ~e" lift-var)))))) - (list (cons - partial-var - (with-syntax ((lift-var lift-var) - (pos pos) - (neg neg)) - (syntax (((proj-get lift-var) lift-var) pos neg src-info orig-str))))) - #f - lift-var))) - - (syntax-case stx () - [ctc - (opt/unknown-ctc #'ctc)]))) \ No newline at end of file + [(flat-named-contract name pred) (opt/flat-ctc opt/info #'pred 'check-flat-named-contract)]))) \ No newline at end of file diff --git a/collects/mzlib/private/contract-ds-helpers.ss b/collects/mzlib/private/contract-ds-helpers.ss index bdcd2575b7..dd94575b35 100644 --- a/collects/mzlib/private/contract-ds-helpers.ss +++ b/collects/mzlib/private/contract-ds-helpers.ss @@ -2,9 +2,11 @@ (provide ensure-well-formed build-func-params build-clauses + build-enforcer-clauses generate-arglists) - (require (lib "list.ss")) + (require (lib "list.ss") + "contract-opt-guts.ss") (require-for-template mzscheme) #| @@ -32,14 +34,19 @@ which are then called when the contract's fields are explored (define (build-clauses name coerce-contract stx clauses) (let* ([field-names - (map (λ (clause) - (syntax-case clause () - [(id . whatever) (syntax id)] + (let loop ([clauses (syntax->list clauses)]) + (cond + [(null? clauses) null] + [else + (let ([clause (car clauses)]) + (syntax-case* clause (where and) raw-comparison? + [where null] + [and null] + [(id . whatever) (cons (syntax id) (loop (cdr clauses)))] [else (raise-syntax-error name "expected a field name and a contract together" stx - clause)])) - (syntax->list clauses))] + clause)]))]))] [all-ac-ids (generate-temporaries field-names)] [defeat-inlining ;; makes the procedure "big enough" so @@ -55,23 +62,165 @@ which are then called when the contract's fields are explored [maker-args '()]) (cond [(null? clauses) - (reverse maker-args)] + (with-syntax ([(maker-args ...) (reverse maker-args)]) + (syntax ((maker-args ... #f) + ())))] [else + (let ([clause (car clauses)]) + (syntax-case* clause (and where) raw-comparison? + [where + (build-clauses/where name stx (cdr clauses) field-names (reverse maker-args))] + [and + (build-clauses/and name stx (cdr clauses) '() '() (reverse maker-args))] + [else + (let ([ac-id (car ac-ids)]) + (syntax-case clause () + [(id (x ...) ctc-exp) + (and (identifier? (syntax id)) + (andmap identifier? (syntax->list (syntax (x ...))))) + (let ([maker-arg #`(λ #,(match-up (reverse prior-ac-ids) + (syntax (x ...)) + field-names) + #,(defeat-inlining + #`(#,coerce-contract '#,name ctc-exp)))]) + (loop (cdr clauses) + (cdr ac-ids) + (cons (car ac-ids) prior-ac-ids) + (cons maker-arg maker-args)))] + [(id (x ...) ctc-exp) + (begin + (unless (identifier? (syntax id)) + (raise-syntax-error name "expected identifier" stx (syntax id))) + (for-each (λ (x) (unless (identifier? x) + (raise-syntax-error name "expected identifier" stx x))) + (syntax->list (syntax (x ...)))))] + [(id ctc-exp) + (identifier? (syntax id)) + (loop (cdr clauses) + (cdr ac-ids) + (cons (car ac-ids) prior-ac-ids) + (cons #`(#,coerce-contract '#,name ctc-exp) maker-args))] + [(id ctc-exp) + (raise-syntax-error name "expected identifier" stx (syntax id))] + [_ + (raise-syntax-error name "expected name/identifier binding" stx clause)]))]))])))) + + (define (build-clauses/where name stx clauses field-names maker-args) + (with-syntax ([(field-names ...) field-names]) + (let loop ([clauses clauses] + [vars '()] + [procs '()]) + (cond + [(null? clauses) + ;; if there is no `and' clause, assume that it is always satisfied + (build-clauses/and name stx (list (syntax #t)) vars procs maker-args)] + [else + (let ([clause (car clauses)]) + (syntax-case* clause (and) raw-comparison? + [and (build-clauses/and name stx (cdr clauses) vars procs maker-args)] + [(id exp) + (identifier? (syntax id)) + (loop (cdr clauses) + (cons (syntax id) vars) + (cons (syntax (λ (field-names ...) exp)) procs))] + [(id exp) + (raise-syntax-error name "expected an identifier" stx (syntax id))] + [_ + (raise-syntax-error name "expected an identifier and an expression" stx clause)]))])))) + + + + (define (build-enforcer-clauses opt/i opt/info name stx clauses f-x/vals f-xs/vals + helper-id helper-info helper-freev) + (define (opt/enforcer-clause stx) + (syntax-case stx () + [(f arg ...) + ;; we need to override the default optimization of recursive calls to use our helper + (and (opt/info-recf opt/info) (module-identifier=? (opt/info-recf opt/info) #'f)) + (values + #`(f #,(opt/info-val opt/info) arg ...) + null + null + null + #f + #f + null)] + #; + [(f arg ...) + ;; we need to override the default optimization of recursive calls to use our helper + (module-identifier=? (opt/info-recf opt/info) #'f) + (with-syntax ((helper helper-id) + (val (opt/info-val opt/info)) + (info helper-info)) + (values + (syntax (helper val info arg ...)) + null + null + null + #f + #f + null))] + [else (opt/i opt/info stx)])) + + (let* ([field-names + (map (λ (clause) + (syntax-case clause () + [(id . whatever) (syntax id)] + [else (raise-syntax-error name + "expected a field name and a contract together" + stx + clause)])) + (syntax->list clauses))] + [all-ac-ids (generate-temporaries field-names)]) + (let loop ([clauses (syntax->list clauses)] + [let-vars f-x/vals] + [arglists f-xs/vals] + [ac-ids all-ac-ids] + [prior-ac-ids '()] + [maker-args '()] + [lifts-ps '()] + [superlifts-ps '()] + [stronger-ribs-ps '()]) + (cond + [(null? clauses) + (values (reverse maker-args) + lifts-ps + superlifts-ps + stronger-ribs-ps)] + [else (let ([clause (car clauses)] + [let-var (car let-vars)] + [arglist (car arglists)] [ac-id (car ac-ids)]) (syntax-case clause () [(id (x ...) ctc-exp) (and (identifier? (syntax id)) (andmap identifier? (syntax->list (syntax (x ...))))) - (let ([maker-arg #`(λ #,(match-up (reverse prior-ac-ids) - (syntax (x ...)) - field-names) - #,(defeat-inlining - #`(#,coerce-contract '#,name ctc-exp)))]) + (let*-values ([(next lifts superlifts partials _ _2 _3) + (opt/enforcer-clause (syntax ctc-exp))] + [(maker-arg) + (with-syntax ((val (opt/info-val opt/info)) + ((arg ...) arglist) + [(new-let-vars ...) (match-up (reverse prior-ac-ids) + (syntax (x ...)) + field-names)]) + #`(#,let-var + #,(bind-lifts + superlifts + #`(let ([new-let-vars arg] ...) + #,(bind-lifts + (append lifts partials) + #`(let ((val #,let-var)) + #,next))))))]) (loop (cdr clauses) + (cdr let-vars) + (cdr arglists) (cdr ac-ids) (cons (car ac-ids) prior-ac-ids) - (cons maker-arg maker-args)))] + (cons maker-arg maker-args) + lifts-ps + superlifts-ps + stronger-ribs-ps))] [(id (x ...) ctc-exp) (begin (unless (identifier? (syntax id)) @@ -81,13 +230,45 @@ which are then called when the contract's fields are explored (syntax->list (syntax (x ...)))))] [(id ctc-exp) (identifier? (syntax id)) - (loop (cdr clauses) - (cdr ac-ids) - (cons (car ac-ids) prior-ac-ids) - (cons #`(#,coerce-contract '#,name ctc-exp) maker-args))] + (let*-values ([(next lifts superlifts partials _ __ stronger-ribs) + (opt/enforcer-clause (syntax ctc-exp))] + [(maker-arg) + (with-syntax ((val (opt/info-val opt/info))) + #`(#,let-var + #,(bind-lifts + partials + #`(let ((val #,let-var)) + #,next))))]) + (loop (cdr clauses) + (cdr let-vars) + (cdr arglists) + (cdr ac-ids) + (cons (car ac-ids) prior-ac-ids) + (cons maker-arg maker-args) + (append lifts-ps lifts) + (append superlifts-ps superlifts) + (append stronger-ribs-ps stronger-ribs)))] [(id ctc-exp) (raise-syntax-error name "expected identifier" stx (syntax id))]))])))) + (define (build-clauses/and name stx clauses synth-names synth-procs maker-args) + (unless (pair? clauses) + (raise-syntax-error name "expected an expression after `and' keyword" stx)) + (unless (null? (cdr clauses)) + (raise-syntax-error name "expected only one expression after `and' keyword" stx (cadr clauses))) + (with-syntax ([(maker-args ...) maker-args] + [(synth-names ...) synth-names] + [(synth-procs ...) synth-procs] + [exp (car clauses)]) + (syntax ((maker-args ... (list (λ (ht) (let ([synth-names (hash-table-get ht 'synth-names)] ...) exp)) + (cons 'synth-names synth-procs) ...)) + (synth-names ...))))) + + (define (raw-comparison? x y) + (and (identifier? x) + (identifier? y) + (eq? (syntax-e x) (syntax-e y)))) + ;; generate-arglists : (listof X) -> (listof (listof X)) ;; produces the list of arguments to the dependent contract ;; functions, given the names of some variables. diff --git a/collects/mzlib/private/contract-ds.ss b/collects/mzlib/private/contract-ds.ss index 3d55718398..adbfb9b7a8 100644 --- a/collects/mzlib/private/contract-ds.ss +++ b/collects/mzlib/private/contract-ds.ss @@ -1,5 +1,10 @@ #| +Need to break the parent pointer links at some point. +This leaks, as is. + +--- + why make a separate struct for the contract information instead of putting it into the wrapper struct in an extra field? @@ -12,11 +17,27 @@ it around flattened out. (module contract-ds mzscheme - (require "contract-guts.ss") + (require "contract-guts.ss" + "contract-opt.ss" + "contract-ds-helpers.ss") (require-for-syntax "contract-ds-helpers.ss" - "contract-helpers.ss") + "contract-helpers.ss" + "contract-opt-guts.ss" + (lib "etc.ss")) - (provide define-contract-struct) + (provide define-contract-struct + + make-opt-contract/info + opt-contract/info-contract + opt-contract/info-enforcer + opt-contract/info-pos + opt-contract/info-neg + opt-contract/info-src-info + opt-contract/info-orig-str + lazy-depth-to-look + + unknown? + synthesized-value) (define-syntax (define-contract-struct stx) (syntax-case stx () @@ -43,9 +64,11 @@ it around flattened out. [predicate/val (list-ref struct-names 2)] [selectors/val (cdddr struct-names)] [struct/c-name/val (add-suffix "/c")] - [struct/dc-name/val(add-suffix "/dc")] + [struct/dc-name/val (add-suffix "/dc")] [field-count/val (length selectors/val)] - [f-x/vals (generate-temporaries (syntax (fields ...)))]) + [f-x/vals (generate-temporaries (syntax (fields ...)))] + [f-xs/vals (generate-arglists f-x/vals)]) + (with-syntax ([struct/c struct/c-name/val] [struct/dc struct/dc-name/val] [field-count field-count/val] @@ -57,8 +80,9 @@ it around flattened out. [(selector-indicies+1 ...) (map add1 (nums-up-to field-count/val))] [(ctc-x ...) (generate-temporaries (syntax (fields ...)))] [(f-x ...) f-x/vals] - [((f-xs ...) ...) (generate-arglists f-x/vals)] - [wrap-name (string->symbol (format "~a/lazy-contract" (syntax-e (syntax name))))]) + [((f-xs ...) ...) f-xs/vals] + [wrap-name (string->symbol (format "~a/lazy-contract" (syntax-e (syntax name))))] + [opt-wrap-name (string->symbol (format "~a/lazy-opt-contract" (syntax-e (syntax name))))]) #` (begin @@ -66,15 +90,52 @@ it around flattened out. #,@(if (eq? (syntax-local-context) 'top-level) (list (syntax - (define-syntaxes (contract-type contract-maker contract-predicate contract-get contract-set) + (define-syntaxes (contract-type contract-maker contract-predicate contract-get contract-set + already-there? burrow-in rewrite-fields wrap-get) (values)))) (list)) + (define (evaluate-attrs stct contract/info) + (when (wrap-parent-get stct 0) ;; test to make sure this even has attributes + (let* ([any-unknown? #f] + [any-became-known? #f] + [synth-info (wrap-parent-get stct 0)] + [ht (synth-info-vals synth-info)]) + (hash-table-for-each + ht + (lambda (k v) + (when (unknown? v) + (let ([proc (unknown-proc v)]) + (let ([new (proc (wrap-get stct selector-indicies+1) ...)]) + (cond + [(unknown? new) + (set! any-unknown? #t)] + [else + (set! any-became-known? #t) + (hash-table-put! ht k new)])))))) + (unless any-unknown? + (check-synth-info-test stct synth-info contract/info)) + (when any-became-known? + (for-each + (lambda (x) ((evaluate-attr-prop-accessor x) x contract/info)) + (synth-info-parents synth-info))) + (unless any-unknown? + (set-synth-info-parents! synth-info '()))))) + (define-values (wrap-type wrap-maker wrap-predicate wrap-get wrap-set) (make-struct-type 'wrap-name + wrap-parent-type ;; super struct + 2 ;; field count + (max 0 (- field-count 1)) ;; auto-field-k + #f ;; auto-field-v + (list (cons evaluate-attr-prop evaluate-attrs)) + inspector)) + + (define-values (opt-wrap-type opt-wrap-maker opt-wrap-predicate opt-wrap-get opt-wrap-set) + (make-struct-type 'opt-wrap-name #f ;; super struct 2 ;; field count - (- field-count 1) ;; auto-field-k + field-count ;; auto-field-k #f ;; auto-field-v '() ;; prop-value-list inspector)) @@ -88,17 +149,20 @@ it around flattened out. '() ;; prop-value-list inspector)) - (define (predicate x) (or (raw-predicate x) (wrap-predicate x))) + (define (predicate x) (or (raw-predicate x) (opt-wrap-predicate x) (wrap-predicate x))) (define-syntax (struct/dc stx) (syntax-case stx () [(_ clause (... ...)) - (with-syntax ([(maker-args (... ...)) + (with-syntax ([((maker-args (... ...)) + (names (... ...))) (build-clauses 'struct/dc (syntax coerce-contract) stx (syntax (clause (... ...))))]) - (syntax (contract-maker maker-args (... ...))))])) + (syntax + (let ([names 'names] (... ...)) + (contract-maker maker-args (... ...)))))])) (define (do-selection stct i+1) (let-values ([(stct fields ...) @@ -107,32 +171,54 @@ it around flattened out. [(raw-predicate stct) ;; found the original value (values #f (get stct selector-indicies) ...)] - [else + + [(opt-wrap-predicate stct) + (let ((inner (opt-wrap-get stct 0))) + (if inner + (let* ((info (opt-wrap-get stct 1)) + (enforcer (opt-contract/info-enforcer info))) + (let-values ([(inner-stct fields ...) (loop inner)]) + (let-values ([(fields ...) (enforcer stct fields ...)]) + (opt-wrap-set stct 0 #f) + (opt-wrap-set stct selector-indicies+1 fields) ... + (values stct fields ...)))) + + ;; found a cached version + (values #f (opt-wrap-get stct selector-indicies+1) ...)))] + [(wrap-predicate stct) (let ([inner (wrap-get stct 0)]) (if inner ;; we have a contract to update - (let-values ([(_1 fields ...) (loop inner)]) - (let-values ([(fields ...) - (rewrite-fields (wrap-get stct 1) fields ...)]) - (wrap-set stct 0 #f) - (wrap-set stct selector-indicies+1 fields) ... - (values stct fields ...))) - + (let ([contract/info (wrap-get stct 1)]) + (let-values ([(_1 fields ...) (loop inner)]) + (let-values ([(fields ...) + (rewrite-fields stct contract/info fields ...)]) + (wrap-set stct 0 #f) + (wrap-set stct selector-indicies+1 fields) ... + (evaluate-attrs stct contract/info) + (values stct fields ...)))) + ;; found a cached version of the value (values #f (wrap-get stct selector-indicies+1) ...)))]))]) - (wrap-get stct i+1))) + (cond + [(opt-wrap-predicate stct) (opt-wrap-get stct i+1)] + [(wrap-predicate stct) (wrap-get stct i+1)]))) - (define (rewrite-fields contract/info ctc-x ...) - (let* ([f-x (let ([ctc-field (contract-get (contract/info-contract contract/info) - selector-indicies)]) - (let ([ctc (if (procedure? ctc-field) + (define (rewrite-fields parent contract/info ctc-x ...) + (let* ([f-x (let* ([ctc-field (contract-get (contract/info-contract contract/info) + selector-indicies)] + [ctc (if (procedure? ctc-field) (ctc-field f-xs ...) - ctc-field)]) - ((((proj-get ctc) ctc) (contract/info-pos contract/info) - (contract/info-neg contract/info) - (contract/info-src-info contract/info) - (contract/info-orig-str contract/info)) - ctc-x)))] ...) + ctc-field)] + + [ctc-field-val + ((((proj-get ctc) ctc) (contract/info-pos contract/info) + (contract/info-neg contract/info) + (contract/info-src-info contract/info) + (contract/info-orig-str contract/info)) + ctc-x)]) + (update-parent-links parent ctc-field-val) + ctc-field-val)] ...) (values f-x ...))) (define (stronger-lazy-contract? a b) @@ -145,7 +231,8 @@ it around flattened out. (λ (pos-blame neg-blame src-info orig-str) (let ([contract/info (make-contract/info ctc pos-blame neg-blame src-info orig-str)]) (λ (val) - (unless (or (wrap-predicate val) + (unless (or (wrap-predicate val) + (opt-wrap-predicate val) (raw-predicate val)) (raise-contract-error val @@ -157,22 +244,43 @@ it around flattened out. [(already-there? contract/info val lazy-depth-to-look) val] [else - (wrap-maker val contract/info)]))))) + (let ([wrapper (wrap-maker val contract/info)]) + (let ([synth-setup-stuff (contract-get ctc field-count)]) + (when synth-setup-stuff + (let ([ht (make-hash-table)]) + (for-each (λ (pr) (hash-table-put! ht (car pr) (make-unknown (cdr pr)))) + (cdr synth-setup-stuff)) + (wrap-parent-set wrapper 0 (make-synth-info '() ht (car synth-setup-stuff)))))) + wrapper)]))))) + + (define (already-there/opt? val new-n new-r) + (cond + [(and (opt-wrap-predicate val) + (opt-wrap-get val 0)) + (let ([old-n (opt-wrap-get val 2)] + [old-r (opt-wrap-get val 3)]) + (flattened-stronger old-n old-r new-n new-r))] + [else #f])) + + (define (flattened-stronger this-val this-rank that-val that-rank) + (and (<= this-val that-val) + (>= this-rank that-rank))) (define (already-there? new-contract/info val depth) (cond [(raw-predicate val) #f] [(zero? depth) #f] - [(wrap-get val 0) - (let ([old-contract/info (wrap-get val 1)]) - (if (and (eq? (contract/info-pos new-contract/info) - (contract/info-pos old-contract/info)) - (eq? (contract/info-neg new-contract/info) - (contract/info-neg old-contract/info)) - (contract-stronger? (contract/info-contract old-contract/info) - (contract/info-contract new-contract/info))) - #t - (already-there? new-contract/info (wrap-get val 0) (- depth 1))))] + [(wrap-predicate val) + (and (wrap-get val 0) + (let ([old-contract/info (wrap-get val 1)]) + (if (and (eq? (contract/info-pos new-contract/info) + (contract/info-pos old-contract/info)) + (eq? (contract/info-neg new-contract/info) + (contract/info-neg old-contract/info)) + (contract-stronger? (contract/info-contract old-contract/info) + (contract/info-contract new-contract/info))) + #t + (already-there? new-contract/info (wrap-get val 0) (- depth 1)))))] [else ;; when the zeroth field is cleared out, we don't ;; have a contract to compare to anymore. @@ -180,14 +288,19 @@ it around flattened out. (define (struct/c ctc-x ...) (let ([ctc-x (coerce-contract 'struct/c ctc-x)] ...) - (contract-maker ctc-x ...))) + (contract-maker ctc-x ... #f))) - (define (selectors x) (burrow-in x 'selectors selector-indicies)) ... + (define (selectors x) + (burrow-in x 'selectors selector-indicies)) ... (define (burrow-in struct selector-name i) (cond [(raw-predicate struct) (get struct i)] + [(opt-wrap-predicate struct) + (if (opt-wrap-get struct 0) + (do-selection struct (+ i 1)) + (opt-wrap-get struct (+ i 1)))] [(wrap-predicate struct) (if (wrap-get struct 0) (do-selection struct (+ i 1)) @@ -196,32 +309,297 @@ it around flattened out. (error selector-name "expected <~a>, got ~e" 'name struct)])) (define (lazy-contract-name ctc) - (let ([list-of-subcontracts (list (contract-get ctc selector-indicies) ...)]) - (cond - [(andmap contract? list-of-subcontracts) - (apply build-compound-type-name 'struct/c list-of-subcontracts)] - [else - (let ([dots (string->symbol "...")]) - (apply build-compound-type-name 'struct/dc - (map (λ (field ctc) - (if (contract? ctc) - (build-compound-type-name field ctc) - (build-compound-type-name field dots))) - '(fields ...) - list-of-subcontracts)))]))) + (do-contract-name 'struct/c + 'struct/dc + (list (contract-get ctc selector-indicies) ...) + '(fields ...) + (contract-get ctc field-count))) (define-values (contract-type contract-maker contract-predicate contract-get contract-set) (make-struct-type 'contract-name #f - field-count + (+ field-count 1) ;; extra field is for synthesized attribute ctcs + ;; it is a list whose first element is + ;; a procedure (called once teh attrs are known) that + ;; indicates if the test passes. the rest of the elements are + ;; procedures that build the attrs + ;; this field is #f when there is no synthesized attrs 0 ;; auto-field-k '() ;; auto-field-v (list (cons proj-prop lazy-contract-proj) (cons name-prop lazy-contract-name) (cons first-order-prop (λ (ctc) predicate)) - (cons stronger-prop stronger-lazy-contract?)))))))])) + (cons stronger-prop stronger-lazy-contract?)))) + + (define-for-syntax (build-enforcer opt/i opt/info name stx clauses + helper-id-var helper-info helper-freev + enforcer-id-var) + (define (make-free-vars free-vars freev) + (let loop ([i 0] + [stx null] + [free-vars free-vars]) + (cond + [(null? free-vars) (reverse stx)] + [else (loop (+ i 1) + (cons (with-syntax ((var (car free-vars)) + (freev freev) + (j (+ i 2))) + (syntax (var (opt-wrap-get stct j)))) stx) + (cdr free-vars))]))) + + (let*-values ([(inner-val) #'val] + [(clauses lifts superlifts stronger-ribs) + (build-enforcer-clauses opt/i + (make-opt/info #'ctc + inner-val + #'pos + #'neg + #'src-info + #'orig-str + (opt/info-free-vars opt/info) + (opt/info-recf opt/info) + (opt/info-base-pred opt/info) + (opt/info-this opt/info) + (opt/info-that opt/info) + (opt/info-sv-index opt/info)) + name + stx + clauses + (list (syntax f-x) ...) + (list (list (syntax f-xs) ...) ...) + helper-id-var + helper-info + helper-freev)]) + (with-syntax ([(clause (... ...)) clauses] + [enforcer-id enforcer-id-var] + [helper-id helper-id-var] + [free-vars (make-free-vars (append (opt/info-free-vars opt/info)) #'freev)] + [(saved-lifts (... ...)) (lifts-to-save lifts)]) + (values + #`(λ (stct f-x ...) + (let* ([info (opt-wrap-get stct 1)] + [enforcer (opt-contract/info-enforcer info)] + [ctc (opt-contract/info-contract info)] + [pos (opt-contract/info-pos info)] + [neg (opt-contract/info-neg info)] + [src-info (opt-contract/info-src-info info)] + [orig-str (opt-contract/info-orig-str info)]) + (let free-vars + #,(bind-lifts + lifts + #`(let-syntax #,(if (opt/info-recf opt/info) + (#`[#,(opt/info-recf opt/info) + (lambda (stx) + (syntax-case stx () + [(f val args ((... ...) (... ...))) + #'(helper-id val + info + args + ((... ...) (... ...)) + saved-lifts (... ...))]))]) + #`()) + (let* (clause (... ...)) + (values f-x ...))))))) + lifts + superlifts + stronger-ribs)))) + + ;; + ;; struct/dc opter + ;; + (define/opter (struct/dc opt/i opt/info stx) + (syntax-case stx () + [(_ clause (... ...)) + (let ((enforcer-id-var (car (generate-temporaries (syntax (enforcer))))) + (helper-id-var (car (generate-temporaries (syntax (helper))))) + (contract/info-var (car (generate-temporaries (syntax (contract/info)))))) + (let-values ([(enforcer lifts superlifts stronger-ribs) + (build-enforcer opt/i + opt/info + 'struct/dc + stx + (syntax (clause (... ...))) + helper-id-var + #'info + #'freev + enforcer-id-var)]) + (let ([to-save (append (opt/info-free-vars opt/info) + (lifts-to-save lifts))]) + (with-syntax ((val (opt/info-val opt/info)) + (pos (opt/info-pos opt/info)) + (neg (opt/info-neg opt/info)) + (src-info (opt/info-src-info opt/info)) + (orig-str (opt/info-orig-str opt/info)) + (ctc (opt/info-contract opt/info)) + (base-pred (or (opt/info-base-pred opt/info) #'(λ (x) #f))) + (enforcer-id enforcer-id-var) + (helper-id helper-id-var) + (contract/info contract/info-var) + ((j (... ...)) (let loop ([i 2] + [lst to-save]) + (cond + [(null? lst) null] + [else (cons i (loop (+ i 1) (cdr lst)))]))) + ((free-var (... ...)) to-save)) + (values + (syntax (helper-id val contract/info free-var (... ...))) + lifts + (append + superlifts + (list (with-syntax ([(stronger-this-var (... ...)) (map stronger-rib-this-var stronger-ribs)] + [(stronger-that-var (... ...)) (map stronger-rib-that-var stronger-ribs)] + [(stronger-exps (... ...)) (map stronger-rib-stronger-exp stronger-ribs)] + [(stronger-indexes (... ...)) (build-list (length stronger-ribs) + (λ (x) (+ x 2)))] + [(stronger-var (... ...)) (map stronger-rib-save-id stronger-ribs)]) + (cons #'is-stronger? + #'(λ (val i free-var (... ...)) + (cond + [(= i 0) #f] + [(and (opt-wrap-predicate val) + (opt-wrap-get val 0)) + (let ([stronger-this-var stronger-var] + (... ...) + + ;; this computation is bogus + ;; it only works if the stronger vars and the things + ;; saved in the wrapper are the same + [stronger-that-var (opt-wrap-get val stronger-indexes)] + (... ...)) + + (or (and + ;; make sure this is the same contract -- if not, + ;; the rest of this test is bogus and may fail at runtime + (eq? enforcer-id (opt-contract/info-enforcer + (opt-wrap-get val 1))) + stronger-exps + (... ...)) + (is-stronger? (opt-wrap-get val 0) + (- i 1) + free-var (... ...))))] + [else #f])))) + (cons + helper-id-var + (syntax + (λ (val info free-var (... ...)) + (let ([ctc (opt-contract/info-contract info)] + [pos (opt-contract/info-pos info)] + [neg (opt-contract/info-neg info)] + [src-info (opt-contract/info-src-info info)] + [orig-str (opt-contract/info-orig-str info)]) + (cond + ;; FIXME terribly broken + [(base-pred val) val] + [else + (begin + (unless (or (wrap-predicate val) + (opt-wrap-predicate val) + (raw-predicate val)) + (raise-contract-error + val + src-info + pos + orig-str + "expected <~a>, got ~e" + ((name-get ctc) ctc) + val)) + (cond + ;; this is where the optimized stronger needs to be called. + [(is-stronger? val 5 free-var (... ...)) + val] + ;; ALLOCATE OPT-WRAP + [else + (let ([w (opt-wrap-maker val info)]) + (opt-wrap-set w j free-var) (... ...) + w)]))]))))) + (cons enforcer-id-var enforcer))) + (list (cons contract/info-var + (syntax + (make-opt-contract/info ctc + enforcer-id + pos + neg + src-info + orig-str)))) + #f + #f + stronger-ribs)))))])) + + )))])) + + (define (do-contract-name name/c name/dc list-of-subcontracts fields attrs) + (cond + [(and (andmap contract? list-of-subcontracts) (not attrs)) + (apply build-compound-type-name name/c list-of-subcontracts)] + [else + (let ([fields + (map (λ (field ctc) + (if (contract? ctc) + (build-compound-type-name field ctc) + (build-compound-type-name field '...))) + fields + list-of-subcontracts)]) + (cond + [attrs + (apply build-compound-type-name + name/dc + (append fields + (list 'where) + (map (λ (x) `(,(car x) ...)) + (reverse (cdr attrs))) + (list 'and '...)))] + [else (apply build-compound-type-name name/dc fields)]))])) (define-struct contract/info (contract pos neg src-info orig-str)) + (define-struct opt-contract/info (contract enforcer pos neg src-info orig-str)) + + ;; parents : (listof wrap-parent) + ;; vals : hash-table[symbol -o> (union (make-unknown proc[field-vals -> any]) any) + ;; test : proc[vals-hash-table -> boolean] + (define-struct synth-info (parents vals test)) + + (define-struct unknown (proc)) + + (define secret (gensym)) + (define (synthesized-value wrap key) + (unless (wrap-parent-predicate wrap) + (error 'synthesized-value "expected struct value with contract as first argument, got ~e" wrap)) + (let ([ans (hash-table-get (synth-info-vals (wrap-parent-get wrap 0)) + key + secret)]) + (when (eq? ans secret) + (error 'synthesized-value "the key ~e is not mapped in ~e" key wrap)) + ans)) + + (define (check-synth-info-test stct synth-info contract/info) + (unless ((synth-info-test synth-info) (synth-info-vals synth-info)) + (raise-contract-error + stct + (contract/info-src-info contract/info) + (contract/info-pos contract/info) + (contract/info-orig-str contract/info) + "failed `and' clause, got ~e" stct))) + + (define-values (evaluate-attr-prop evaluate-attr-prop-predicate evaluate-attr-prop-accessor) + (make-struct-type-property 'evaluate-attr-prop)) + + (define-values (wrap-parent-type wrap-parent-maker wrap-parent-predicate wrap-parent-get wrap-parent-set) + (make-struct-type 'wrap-parent + #f ;; parent + 0 ;; fields + 1 ;; auto fields + )) + + (define (update-parent-links parent ctc-field-val) + (when (wrap-parent-predicate ctc-field-val) + (let ([old (wrap-parent-get ctc-field-val 0)]) + (when old + ;; add in new parent + (wrap-parent-set ctc-field-val 0 + (make-synth-info + (cons parent (synth-info-parents old)) + (synth-info-vals old) + (synth-info-test old))))))) (define max-cache-size 5) (define lazy-depth-to-look 5) @@ -265,4 +643,4 @@ test-case: |# - ) \ No newline at end of file + ) diff --git a/collects/mzlib/private/contract-guts.ss b/collects/mzlib/private/contract-guts.ss index 96cf246daf..ef072979dd 100644 --- a/collects/mzlib/private/contract-guts.ss +++ b/collects/mzlib/private/contract-guts.ss @@ -193,16 +193,21 @@ (define (raise-contract-error val src-info blame contract-sexp fmt . args) (raise (make-exn:fail:contract2 - ((contract-violation->string) - val src-info blame contract-sexp (apply format fmt args)) + (string->immutable-string + ((contract-violation->string) val + src-info + blame + contract-sexp + (apply format fmt args))) (current-continuation-marks) (if src-info - (list (make-srcloc (syntax-source src-info) - (syntax-line src-info) - (syntax-column src-info) - (syntax-position src-info) - (syntax-span src-info))) - '())))) + (list (make-srcloc + (syntax-source src-info) + (syntax-line src-info) + (syntax-column src-info) + (syntax-position src-info) + (syntax-span src-info))) + '())))) (define print-contract-liner (let ([default (pretty-print-print-line)]) @@ -308,7 +313,12 @@ (error 'flat-contract-predicate "expected a flat contract, got ~e" x)) ((flat-get x) x)) (define (flat-contract? x) (flat-pred? x)) - (define (contract-name ctc) ((name-get ctc) ctc)) + (define (contract-name ctc) + (if (and (procedure? ctc) + (procedure-arity-includes? ctc 1)) + (or (object-name ctc) + 'unknown) + ((name-get ctc) ctc))) (define (contract? x) (proj-pred? x)) (define (contract-proc ctc) ((proj-get ctc) ctc)) @@ -444,4 +454,4 @@ (define (flat-contract/predicate? pred) (or (flat-contract? pred) (and (procedure? pred) - (procedure-arity-includes? pred 1))))) + (procedure-arity-includes? pred 1))))) \ No newline at end of file diff --git a/collects/mzlib/private/contract-opt-guts.ss b/collects/mzlib/private/contract-opt-guts.ss index 873db4f4c7..584175acb6 100644 --- a/collects/mzlib/private/contract-opt-guts.ss +++ b/collects/mzlib/private/contract-opt-guts.ss @@ -1,56 +1,48 @@ (module contract-opt-guts mzscheme - (require "contract-guts.ss") + (require (lib "private/boundmap.ss" "syntax") + (lib "list.ss") + "contract-guts.ss") + (require-for-template mzscheme) (provide get-opter reg-opter! opter + interleave-lifts - make-opt-contract - orig-ctc-prop orig-ctc-pred? orig-ctc-get - - make-lifts interleave-lifts) + make-opt/info + opt/info-contract + opt/info-val + opt/info-pos + opt/info-neg + opt/info-src-info + opt/info-orig-str + opt/info-free-vars + opt/info-recf + opt/info-base-pred + opt/info-this + opt/info-that + opt/info-sv-index + + sv-index + inc-sv-index! + + opt/info-swap-blame) - (define-values (orig-ctc-prop orig-ctc-pred? orig-ctc-get) - (make-struct-type-property 'original-contract)) - - ;; optimized contracts - ;; - ;; getting the name of an optimized contract is slow, but it is only - ;; called when blame is raised (thankfully). - ;; - ;; note that lifts, partials, flat, and unknown are all built into the - ;; projection itself and should not be exposed to the outside anyhow. - (define-struct/prop opt-contract (proj orig-ctc) - ((proj-prop (λ (ctc) ((opt-contract-proj ctc) ctc))) - (name-prop (λ (ctc) ((name-get ((orig-ctc-get ctc) ctc)) ((orig-ctc-get ctc) ctc)))) - (orig-ctc-prop (λ (ctc) ((opt-contract-orig-ctc ctc)))) - (stronger-prop (λ (this that) - #f)))) ;; TODO, how to do this? - ;; a hash table of opters (define opters-table - (make-hash-table 'equal)) + (make-module-identifier-mapping)) ;; get-opter : syntax -> opter (define (get-opter ctc) - (hash-table-get opters-table ctc #f)) + (module-identifier-mapping-get opters-table ctc (λ () #f))) ;; opter : (union symbol identifier) -> opter (define (opter ctc) - (if (or (identifier? ctc) (symbol? ctc)) - (let ((key (if (syntax? ctc) (syntax-e ctc) ctc))) - (get-opter key)) - (error 'opter "the argument must either be an identifier or a syntax object of an identifier, got ~e" ctc))) + (if (identifier? ctc) + (get-opter ctc) + (error 'opter "the argument must be a bound identifier, got ~e" ctc))) ;; reg-opter! : symbol opter -> (define (reg-opter! ctc opter) - (hash-table-put! opters-table ctc opter)) - - ;; make-lifts : list -> syntax - ;; converts a list of lifted-var lifted-expr pairs into a syntax object - ;; suitable for use in a let. - (define (make-lifts lst) - (map (λ (x) (with-syntax ((var (car x)) - (e (cdr x))) - (syntax (var e)))) lst)) + (module-identifier-mapping-put! opters-table ctc opter)) ;; interleave-lifts : list list -> list ;; interleaves a list of variables names and a list of sexps into a list of @@ -60,4 +52,115 @@ (if (null? vars) null (cons (cons (car vars) (car sexps)) (interleave-lifts (cdr vars) (cdr sexps)))) - (error 'interleave-lifts "expected lists of equal length, got ~e and ~e" vars sexps)))) \ No newline at end of file + (error 'interleave-lifts "expected lists of equal length, got ~e and ~e" vars sexps))) + + + ;; struct for color-keeping across opters + (define-struct opt/info (contract val pos neg src-info orig-str free-vars recf base-pred this that sv-index)) + + ;; sv-index : opt/info -> int + (define (sv-index info) + (unbox (opt/info-sv-index info))) + + ;; inc-sv-index! : opt/info int -> unit + (define (inc-sv-index! info n) + (let ((old (unbox (opt/info-sv-index info)))) + (set-box! (opt/info-sv-index info) (+ old n)))) + + ;; opt/info-swap-blame : opt/info -> opt/info + ;; swaps pos and neg + (define (opt/info-swap-blame info) + (let ((ctc (opt/info-contract info)) + (val (opt/info-val info)) + (pos (opt/info-neg info)) + (neg (opt/info-pos info)) + (src-info (opt/info-src-info info)) + (orig-str (opt/info-orig-str info)) + (free-vars (opt/info-free-vars info)) + (recf (opt/info-recf info)) + (base-pred (opt/info-base-pred info)) + (this (opt/info-this info)) + (that (opt/info-that info)) + (sv-index (opt/info-sv-index info))) + (make-opt/info ctc val pos neg src-info orig-str free-vars recf base-pred this that sv-index))) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; stronger helper functions + ;; + + ;; new-stronger-var : identifier (identifier identifier -> exp) -> stronger-rib + ;; the second identifier should be bound (in a lift) to an expression whose value has to be saved. + ;; The ids passed to cogen are expected to be bound to two contracts' values of that expression, when + ;; those contracts are being compared for strongerness + (define (new-stronger-var id cogen) + (with-syntax ([(var-this var-that) (generate-temporaries (list id id))]) + (make-stronger-rib (syntax var-this) + (syntax var-that) + id + (cogen (syntax var-this) + (syntax var-that))))) + + (define empty-stronger '()) + + (define-struct stronger-rib (this-var that-var save-id stronger-exp)) + + (provide new-stronger-var + (struct stronger-rib (this-var that-var save-id stronger-exp))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; lifting helper functions + ;; + (provide lift/binding lift/effect empty-lifts bind-lifts bind-superlifts lifts-to-save) + + ;; lift/binding : syntax[expression] identifier lifts -> (values syntax lifts) + ;; adds a new id to `lifts' that is bound to `e'. Returns the + ;; variable that was bound + ;; values that are lifted are also saved in the wrapper to make sure that the rhs's are evaluated at the right time. + (define (lift/binding e id-hint lifts) + (syntax-case e () + [x + (or (identifier? e) + (number? (syntax-e e)) + (boolean? (syntax-e e))) + (values e lifts)] + #; + [x + (identifier? e) + (values e + (snoc (cons e e) lifts))] + [else + (let ([x (car (generate-temporaries (list id-hint)))]) + (values x + (snoc (cons x e) lifts)))])) + + ;; lift/effect : syntax[expression] lifts -> lifts + ;; adds a new lift to `lifts' that is evaluated for effect. no variable returned + (define (lift/effect e lifts) + (let ([x (car (generate-temporaries '(lift/effect)))]) + (snoc (cons #f e) lifts))) + + (define (snoc x l) (append l (list x))) + + ;; empty-lifts : lifts + ;; the initial lifts + (define empty-lifts '()) + + (define (bind-lifts lifts stx) (do-bind-lifts lifts stx #'let*)) + (define (bind-superlifts lifts stx) (do-bind-lifts lifts stx #'letrec)) + + (define (do-bind-lifts lifts stx binding-form) + (if (null? lifts) + stx + (with-syntax ([((lifts-x . lift-e) ...) lifts]) + (with-syntax ([(lifts-x ...) (map (λ (x) (if (identifier? x) x (car (generate-temporaries '(junk))))) + (syntax->list (syntax (lifts-x ...))))] + [binding-form binding-form]) + #`(binding-form ([lifts-x lift-e] ...) + #,stx))))) + + (define (lifts-to-save lifts) (filter values (map car lifts))) + + ) \ No newline at end of file diff --git a/collects/mzlib/private/contract-opt.ss b/collects/mzlib/private/contract-opt.ss index 4c74f9d725..a98d4c385a 100644 --- a/collects/mzlib/private/contract-opt.ss +++ b/collects/mzlib/private/contract-opt.ss @@ -1,25 +1,31 @@ (module contract-opt mzscheme (require "contract-guts.ss" - "contract-opt-guts.ss") + (lib "etc.ss")) (require-for-syntax "contract-opt-guts.ss" + (lib "etc.ss") (lib "list.ss")) - (provide opt/c define/opter) + (provide opt/c define/opter define/osc opt-stronger-vars-ref) ;; define/opter : id -> syntax ;; ;; Takes an expression which is to be expected of the following signature: ;; - ;; opter : id id syntax -> - ;; syntax syntax-list syntax-list (union syntax #f) (union syntax #f) + ;; opter : id id syntax list-of-ids -> + ;; syntax syntax-list syntax-list syntax-list (union syntax #f) (union syntax #f) syntax + ;; ;; ;; It takes in an identifier for pos, neg, and the original syntax. An identifier ;; that can be used to call the opt/i function is also implicitly passed into - ;; every opter. + ;; every opter. A list of free-variables is implicitly passed if the calling context + ;; was define/osc otherwise it is null. ;; ;; Every opter needs to return: ;; - the optimized syntax ;; - lifted variables: a list of (id, sexp) pairs + ;; - super-lifted variables: functions or the such defined at the toplevel of the + ;; calling context of the opt routine. + ;; Currently this is only used for struct contracts. ;; - partially applied contracts: a list of (id, sexp) pairs ;; - if the contract being optimized is flat, ;; then an sexp that evals to bool, @@ -30,51 +36,240 @@ ;; then #f (that is, it is not unknown) ;; else the symbol of the lifted variable ;; This is used for contracts with subcontracts (like cons) doing checks. + ;; - a list of stronger-ribs (define-syntax (define/opter stx) (syntax-case stx () - [(_ (for opt/i pos neg stx) expr ...) + [(_ (for opt/i opt/info stx) expr ...) (if (identifier? #'for) #'(begin (begin-for-syntax (reg-opter! - 'for - (λ (opt/i pos neg stx) + #'for + (λ (opt/i opt/info stx) expr ...))) #t) (error 'define/opter "expected opter name to be an identifier, got ~e" (syntax-e #'for)))])) + ;; + ;; opt/unknown : opt/i id id syntax + ;; + (define-for-syntax (opt/unknown opt/i opt/info uctc) + (let* ((lift-var (car (generate-temporaries (syntax (lift))))) + (partial-var (car (generate-temporaries (syntax (partial))))) + (partial-flat-var (car (generate-temporaries (syntax (partial-flat)))))) + (values + (with-syntax ((partial-var partial-var) + (lift-var lift-var) + (uctc uctc) + (val (opt/info-val opt/info))) + (syntax (partial-var val))) + (list (cons lift-var + ;; FIXME needs to get the contract name somehow + (with-syntax ((uctc uctc)) + (syntax (coerce-contract 'opt/c uctc))))) + null + (list (cons + partial-var + (with-syntax ((lift-var lift-var) + (pos (opt/info-pos opt/info)) + (neg (opt/info-neg opt/info)) + (src-info (opt/info-src-info opt/info)) + (orig-str (opt/info-orig-str opt/info))) + (syntax (((proj-get lift-var) lift-var) pos neg src-info orig-str)))) + (cons + partial-flat-var + (with-syntax ((lift-var lift-var)) + (syntax (if (flat-pred? lift-var) + ((flat-get lift-var) lift-var) + (lambda (x) (error 'opt/unknown "flat called on an unknown that had no flat pred ~s ~s" + lift-var + x))))))) + (with-syntax ([val (opt/info-val opt/info)] + [partial-flat-var partial-flat-var]) + #'(partial-flat-var val)) + lift-var + null))) + + ;; + ;; opt/recursive-call + ;; + ;; BUG: currently does not try to optimize the arguments, this requires changing + ;; every opter to keep track of bound variables. + ;; + (define-for-syntax (opt/recursive-call opt/info stx) + (values + (with-syntax ((stx stx) + (val (opt/info-val opt/info)) + (pos (opt/info-pos opt/info)) + (neg (opt/info-neg opt/info)) + (src-info (opt/info-src-info opt/info)) + (orig-str (opt/info-orig-str opt/info))) + (syntax (let ((ctc stx)) + ((((proj-get ctc) ctc) pos neg src-info orig-str) val)))) + null + null + null + #f + #f + null + null)) + + ;; make-stronger : list-of-(union syntax #f) -> syntax + (define-for-syntax (make-stronger strongers) + (let ((filtered (filter (λ (x) (not (eq? x #f))) strongers))) + (if (null? filtered) + #t + (with-syntax (((stronger ...) strongers)) + (syntax (and stronger ...)))))) + ;; opt/c : syntax -> syntax ;; opt/c is an optimization routine that takes in an sexp containing ;; contract combinators and attempts to "unroll" those combinators to save ;; on things such as closure allocation time. (define-syntax (opt/c stx) - ;; opt/i : id id syntax -> + ;; opt/i : id opt/info syntax -> ;; syntax syntax-list syntax-list (union syntax #f) (union syntax #f) - (define (opt/i pos neg stx) - (syntax-case stx () + (define (opt/i opt/info stx) + (syntax-case stx (if) [(ctc arg ...) (and (identifier? #'ctc) (opter #'ctc)) - ((opter #'ctc) opt/i pos neg stx)] + ((opter #'ctc) opt/i opt/info stx)] [argless-ctc (and (identifier? #'argless-ctc) (opter #'argless-ctc)) - ((opter #'argless-ctc) opt/i pos neg stx)] + ((opter #'argless-ctc) opt/i opt/info stx)] [else - (if (opter 'unknown) - ((opter 'unknown) opt/i pos neg stx) - (error 'opt/c "opt libraries not loaded properly"))])) + (opt/unknown opt/i opt/info stx)])) (syntax-case stx () [(_ e) - (let-values ([(next lifts partials _ __) (opt/i #'pos #'neg #'e)]) + (let*-values ([(info) (make-opt/info #'ctc + #'val + #'pos + #'neg + #'src-info + #'orig-str + null + #f + #f + #'this + #'that + (box 0))] + [(next lifts superlifts partials _ __ stronger-ribs) (opt/i info #'e)]) + (with-syntax ((next next)) + (bind-superlifts + superlifts + (bind-lifts + lifts + #`(make-opt-contract + (λ (ctc) + (λ (pos neg src-info orig-str) + #,(bind-lifts + partials + #`(λ (val) + next)))) + (λ () e) + (λ (this that) #f) + (vector) + (begin-lifted (box #f)))))))])) + + ;; define/osc : syntax -> syntax + ;; define/osc allows you define optimized recursive contracts, and must be used + ;; to define struct contracts. + (define-syntax (define/osc stx) + + ;; opt/i : id opt/info syntax -> + ;; syntax syntax-list syntax-list (union syntax #f) (union syntax #f) + ;; + ;; this is different from opt/i only in the aspect that it calls the recursive-call opter + ;; if it recognizes a recursive call. + (define (opt/i opt/info stx) + (syntax-case stx () + [(ctc arg ...) + (and (identifier? #'ctc) (or (opter #'ctc) + (module-identifier=? (opt/info-recf opt/info) #'ctc))) + (if (module-identifier=? (opt/info-recf opt/info) #'ctc) + ;; this is a recursive call + (opt/recursive-call opt/info stx) + ((opter #'ctc) opt/i opt/info stx))] + [argless-ctc + (and (identifier? #'argless-ctc) (opter #'argless-ctc)) + ((opter #'argless-ctc) opt/i opt/info stx)] + [else + (opt/unknown opt/i opt/info stx)])) + + (syntax-case stx () + [(_ (f arg ...) base-pred e) + (let*-values ([(info) (make-opt/info #'ctc + #'val + #'pos + #'neg + #'src-info + #'orig-str + (syntax->list (syntax (arg ...))) + #'f + #'base-pred + #'this + #'that + (box 0))] + [(next lifts superlifts partials _ __ stronger-ribs) (opt/i info #'e)]) (with-syntax ((next next) - (lifts (make-lifts lifts)) - (partials (make-lifts partials)) - (stx stx)) - (syntax (make-opt-contract - (λ (ctc) - (let* lifts - (λ (pos neg src-info orig-str) - (let partials - (λ (val) next))))) - (λ () e)))))]))) \ No newline at end of file + ((superlift ...) (map (λ (x) (with-syntax ((var (car x)) + (e (cdr x))) + (syntax (define var e)))) superlifts)) + ((stronger-this-var ...) (map stronger-rib-this-var stronger-ribs)) + ((stronger-that-var ...) (map stronger-rib-that-var stronger-ribs)) + ((stronger-exps ...) (map stronger-rib-stronger-exp stronger-ribs)) + ((stronger-indexes ...) (build-list (length stronger-ribs) values)) + ((stronger-var ...) (map stronger-rib-save-id stronger-ribs))) + #`(begin + ;; superlifts are defines + superlift ... + + (define (f arg ...) + + #,(bind-lifts + lifts + #`(make-opt-contract + (λ (ctc) + (λ (pos neg src-info orig-str) + #,(bind-lifts + partials + #`(λ (val) (if (base-pred val) + val + next))))) + (λ () e) + (λ (this that) + (let ([stronger-that-var (vector-ref (opt-contract-stronger-vars that) stronger-indexes)] + ... + [stronger-this-var (vector-ref (opt-contract-stronger-vars this) stronger-indexes)] + ...) + (and stronger-exps ...))) + (vector stronger-var ...) + (begin-lifted (box #f))))))))])) + + ;; optimized contracts + ;; + ;; getting the name of an optimized contract is slow, but it is only + ;; called when blame is raised (thankfully). + ;; + ;; note that lifts, partials, flat, and unknown are all built into the + ;; projection itself and should not be exposed to the outside anyhow. + (define-values (orig-ctc-prop orig-ctc-pred? orig-ctc-get) + (make-struct-type-property 'original-contract)) + + (define-struct/prop opt-contract (proj orig-ctc stronger stronger-vars stamp) + ((proj-prop (λ (ctc) ((opt-contract-proj ctc) ctc))) + ;; I think provide/contract and contract calls this, so we are in effect allocating + ;; the original once + (name-prop (λ (ctc) (contract-name ((orig-ctc-get ctc) ctc)))) + (orig-ctc-prop (λ (ctc) ((opt-contract-orig-ctc ctc)))) + (stronger-prop (λ (this that) + (and (opt-contract? that) + (eq? (opt-contract-stamp this) (opt-contract-stamp that)) + ((opt-contract-stronger this) this that)))))) + + ;; opt-stronger-vars-ref : int opt-contract -> any + (define (opt-stronger-vars-ref i ctc) + (let ((v (opt-contract-stronger-vars ctc))) + (vector-ref v i)))) diff --git a/collects/mzlib/private/contract.ss b/collects/mzlib/private/contract.ss index 6b66cb7873..f59c84cb8a 100644 --- a/collects/mzlib/private/contract.ss +++ b/collects/mzlib/private/contract.ss @@ -279,18 +279,13 @@ add struct contracts for immutable structs? [predicate-id (list-ref struct-info 2)] [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 - (let ([fields (cadddr parent-info)]) - (cond - [(null? fields) 0] - [(not (car (last-pair fields))) - (raise-syntax-error - 'provide/contract - "cannot determine the number of fields in super struct" - provide-stx - struct-name)] - [else (length fields)]))))] + [all-parent-struct-count/names (get-field-counts/struct-names struct-name provide-stx)] + [parent-struct-count (if (null? all-parent-struct-count/names) + #f + (let ([pp (cdr all-parent-struct-count/names)]) + (if (null? pp) + #f + (car (car pp)))))] [field-contract-ids (map (λ (field-name) (a:mangle-id provide-stx "provide/contract-field-contract" @@ -364,6 +359,52 @@ add struct contracts for immutable structs? provide-stx struct-name)) + ;; make sure the field names are right. + (let* ([relative-counts (let loop ([c (map car all-parent-struct-count/names)]) + (cond + [(null? c) null] + [(null? (cdr c)) c] + [else (cons (- (car c) (cadr c)) + (loop (cdr c)))]))] + [names (map cdr all-parent-struct-count/names)] + [maker-name (format "~a" (syntax-e constructor-id))] + [struct-name (substring maker-name 5 (string-length maker-name))]) + (let loop ([count (car relative-counts)] + [name (car names)] + [counts (cdr relative-counts)] + [names (cdr names)] + [selector-strs (reverse (map (λ (x) (format "~a" (syntax-e x))) selector-ids))] + [field-names (reverse field-names)]) + + (cond + [(or (null? counts) (null? names) (null? selector-strs) (null? field-names)) + (void)] + [(zero? count) + (loop (car counts) (car names) (cdr counts) (cdr names) + selector-strs + field-names)] + [else + (let* ([selector-str (car selector-strs)] + [field-name (car field-names)] + [field-name-should-be + (substring selector-str + (+ (string-length name) 1) + (string-length selector-str))] + [field-name-is (format "~a" (syntax-e field-name))]) + (unless (equal? field-name-should-be field-name-is) + (raise-syntax-error 'provide/contract + (format "expected field name to be ~a, but found ~a" + field-name-should-be + field-name-is) + provide-stx + field-name)) + (loop (- count 1) + name + counts + names + (cdr selector-strs) + (cdr field-names)))]))) + (with-syntax ([((selector-codes selector-new-names) ...) (filter (λ (x) x) @@ -434,19 +475,18 @@ add struct contracts for immutable structs? [super-id (if (boolean? super-id) super-id (with-syntax ([super-id super-id]) - (syntax (cert #'super-id))))]) + (syntax ((syntax-local-certifier) #'super-id))))]) (syntax (begin (provide (rename id-rename struct-name)) (define-syntax id-rename - (let ([cert (syntax-local-certifier #t)]) - (list-immutable (cert #'-struct:struct-name) - (cert #'constructor-new-name) - (cert #'predicate-new-name) - (list-immutable (cert #'rev-selector-new-names) ... - (cert #'rev-selector-old-names) ...) - (list-immutable (cert #'rev-mutator-new-names) ... - (cert #'rev-mutator-old-names) ...) - super-id))))))] + (list-immutable ((syntax-local-certifier) #'-struct:struct-name) + ((syntax-local-certifier) #'constructor-new-name) + ((syntax-local-certifier) #'predicate-new-name) + (list-immutable ((syntax-local-certifier) #'rev-selector-new-names) ... + ((syntax-local-certifier) #'rev-selector-old-names) ...) + (list-immutable ((syntax-local-certifier) #'rev-mutator-new-names) ... + ((syntax-local-certifier) #'rev-mutator-old-names) ...) + super-id)))))] [struct:struct-name struct:struct-name] [-struct:struct-name -struct:struct-name] [struct-name struct-name] @@ -454,7 +494,7 @@ add struct contracts for immutable structs? (syntax/loc stx (begin struct-code - (define field-contract-ids field-contracts) ... + (define field-contract-ids (verify-contract field-contracts)) ... selector-codes ... mutator-codes ... predicate-code @@ -487,6 +527,37 @@ add struct contracts for immutable structs? (loop (cdr l1) (+ i 1)))]))) + ;; get-field-counts/struct-names : syntax syntax -> (listof (cons symbol number)) + ;; returns a list of numbers corresponding to the numbers of fields for each of the parent structs + (define (get-field-counts/struct-names struct-name provide-stx) + (let loop ([parent-info-id struct-name]) + (let ([parent-info + (and (identifier? parent-info-id) + (syntax-local-value parent-info-id (λ () #f)))]) + (cond + [(boolean? parent-info) null] + [else + (let ([fields (list-ref parent-info 3)] + [constructor (list-ref parent-info 1)]) + (cond + [(and (not (null? fields)) + (not (car (last-pair fields)))) + (raise-syntax-error + 'provide/contract + "cannot determine the number of fields in super struct" + provide-stx + struct-name)] + [else + (cons (cons (length fields) (constructor->struct-name constructor)) + (loop (list-ref parent-info 5)))]))])))) + + (define (constructor->struct-name stx) + (and stx + (let ([m (regexp-match #rx"^make-(.*)$" (format "~a" (syntax-e stx)))]) + (and m + (cadr m))))) + + ;; extract-parent-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...)) (define (extract-parent-struct-info stx) (syntax-case stx () @@ -497,7 +568,8 @@ add struct contracts for immutable structs? (raise-syntax-error 'provide/contract "expected a struct name" provide-stx - (syntax b))))] + (syntax b)))) + (syntax b)] [a #f])) ;; extract-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...)) @@ -575,7 +647,7 @@ add struct contracts for immutable structs? (provide (rename id-rename external-name)) (define pos-module-source (module-source-as-symbol #'pos-stx)) - (define contract-id ctrct) + (define contract-id (verify-contract ctrct)) (define-syntax id-rename (make-provide/contract-transformer (quote-syntax contract-id) @@ -594,6 +666,13 @@ add struct contracts for immutable structs? (begin bodies ...))))])) + (define (verify-contract x) + (unless (or (contract? x) + (and (procedure? x) + (procedure-arity-includes? x 1))) + (error 'provide/contract "expected a contract or a procedure of arity one, got ~e" x)) + x) + (define (make-pc-struct-type struct-name struct:struct-name . ctcs) (let-values ([(struct:struct-name _make _pred _get _set) @@ -643,7 +722,8 @@ add struct contracts for immutable structs? (contract/proc a-contract to-check pos-blame-e neg-blame-e (quote-syntax src-loc))))] [(_ a-contract-e to-check pos-blame-e neg-blame-e src-info-e) (syntax/loc stx - (contract/proc a-contract-e to-check pos-blame-e neg-blame-e src-info-e))])) + (begin + (contract/proc a-contract-e to-check pos-blame-e neg-blame-e src-info-e)))])) (define (contract/proc a-contract-raw name pos-blame neg-blame src-info) (unless (or (contract? a-contract-raw) @@ -988,66 +1068,119 @@ add struct contracts for immutable structs? ;; ;; or/c opter ;; - (define/opter (or/c opt/i pos neg stx) + (define/opter (or/c opt/i opt/info stx) + ;; FIXME code duplication + (define (opt/or-unknown uctc) + (let* ((lift-var (car (generate-temporaries (syntax (lift))))) + (partial-var (car (generate-temporaries (syntax (partial)))))) + (values + (with-syntax ((partial-var partial-var) + (lift-var lift-var) + (uctc uctc) + (val (opt/info-val opt/info))) + (syntax (partial-var val))) + (list (cons lift-var + ;; FIXME needs to get the contract name somehow + (with-syntax ((uctc uctc)) + (syntax (coerce-contract 'opt/c uctc))))) + null + (list (cons + partial-var + (with-syntax ((lift-var lift-var) + (pos (opt/info-pos opt/info)) + (neg (opt/info-neg opt/info)) + (src-info (opt/info-src-info opt/info)) + (orig-str (opt/info-orig-str opt/info))) + (syntax (((proj-get lift-var) lift-var) pos neg src-info orig-str))))) + #f + lift-var + (list #f) + null))) + (define (opt/or-ctc ps) (let ((lift-from-hos null) + (superlift-from-hos null) (partial-from-hos null)) - (let-values ([(opt-ps lift-ps partial-ps hos ho-ctc) + (let-values ([(opt-ps lift-ps superlift-ps partial-ps stronger-ribs hos ho-ctc) (let loop ([ps ps] [next-ps null] [lift-ps null] + [superlift-ps null] [partial-ps null] + [stronger-ribs null] [hos null] [ho-ctc #f]) (cond - [(null? ps) (values next-ps lift-ps partial-ps (reverse hos) ho-ctc)] + [(null? ps) (values next-ps + lift-ps + superlift-ps + partial-ps + stronger-ribs + (reverse hos) + ho-ctc)] [else - (let-values ([(next lift partial flat _) - (opt/i pos neg (car ps))]) + (let-values ([(next lift superlift partial flat _ this-stronger-ribs) + (opt/i opt/info (car ps))]) (if flat (loop (cdr ps) (cons flat next-ps) (append lift-ps lift) + (append superlift-ps superlift) (append partial-ps partial) + (append this-stronger-ribs stronger-ribs) hos ho-ctc) (if (< (length hos) 1) (loop (cdr ps) next-ps (append lift-ps lift) + (append superlift-ps superlift) (append partial-ps partial) + (append this-stronger-ribs stronger-ribs) (cons (car ps) hos) next) (loop (cdr ps) next-ps lift-ps + superlift-ps partial-ps + stronger-ribs (cons (car ps) hos) ho-ctc))))]))]) - (with-syntax ((next-ps (with-syntax (((opt-p ...) opt-ps)) - (syntax (or #f opt-p ...))))) + (with-syntax ((next-ps + (with-syntax (((opt-p ...) (reverse opt-ps))) + (syntax (or opt-p ...))))) (values (cond - [(null? hos) (with-syntax ((pos pos)) - (syntax - (if next-ps val - (raise-contract-error val src-info pos orig-str - "none of the branches of the or/c matched"))))] + [(null? hos) + (with-syntax ([val (opt/info-val opt/info)] + [pos (opt/info-pos opt/info)] + [src-info (opt/info-src-info opt/info)] + [orig-str (opt/info-orig-str opt/info)]) + (syntax + (if next-ps + val + (raise-contract-error val src-info pos orig-str + "none of the branches of the or/c matched"))))] [(= (length hos) 1) (with-syntax ((ho-ctc ho-ctc)) (syntax (if next-ps val ho-ctc)))] - [(> (length hos) 1) - (let-values ([(next-hos lift-hos partial-hos _ __) - ((opter 'unknown) opt/i pos neg (cons #'or/c hos))]) + ;; FIXME something's not right with this case. + [(> (length hos) 1) + (let-values ([(next-hos lift-hos superlift-hos partial-hos _ __ stronger-hos stronger-vars-hos) + (opt/or-unknown stx)]) (set! lift-from-hos lift-hos) + (set! superlift-from-hos superlift-hos) (set! partial-from-hos partial-hos) (with-syntax ((next-hos next-hos)) (syntax (if next-ps val next-hos))))]) (append lift-ps lift-from-hos) + (append superlift-ps superlift-from-hos) (append partial-ps partial-from-hos) (if (null? hos) (syntax next-ps) #f) - #f))))) + #f + stronger-ribs))))) (syntax-case stx (or/c) [(or/c p ...) @@ -1179,58 +1312,136 @@ add struct contracts for immutable structs? ;; ;; between/c opter helper ;; - (define-for-syntax (opt/between-ctc pos stx low high op checker) - (let* ((lift-vars (generate-temporaries (syntax (low high error-check)))) - (lift-low (car lift-vars)) - (lift-high (cadr lift-vars))) - (with-syntax ((pos pos) - (op op) - (n lift-low) - (m lift-high)) - (values - (syntax (if (and (number? val) (op n val m)) val - (raise-contract-error - val - src-info - pos - orig-str - "expected <~a>, given: ~e" - ((name-get ctc) ctc) - val))) - (interleave-lifts - lift-vars - (list low - high - (cond - [(eq? checker 'between/c) #'(check-between/c n m)] - [(eq? checker '>/c) #'(check-unary-between/c '>/c n)] - [(eq? checker '>=/c) #'(check-unary-between/c '>=/c n)] - [(eq? checker '/c)])) - (define/opter (>=/c opt/i pos neg stx) + [(between/c low high) + (let*-values ([(lift-low lifts1) (lift/binding #'low 'between-low empty-lifts)] + [(lift-high lifts2) (lift/binding #'high 'between-high lifts1)]) + (with-syntax ([n lift-low] + [m lift-high]) + (let ([lifts3 (lift/effect #'(check-between/c n m) lifts2)]) + (with-syntax ((val (opt/info-val opt/info)) + (ctc (opt/info-contract opt/info)) + (pos (opt/info-pos opt/info)) + (src-info (opt/info-src-info opt/info)) + (orig-str (opt/info-orig-str opt/info)) + (this (opt/info-this opt/info)) + (that (opt/info-that opt/info))) + (values + (syntax (if (and (number? val) (<= n val m)) + val + (raise-contract-error + val + src-info + pos + orig-str + "expected <~a>, given: ~e" + ((name-get ctc) ctc) + val))) + lifts3 + null + null + (syntax (and (number? val) (<= n val m))) + #f + (list (new-stronger-var + lift-low + (λ (this that) + (with-syntax ([this this] + [that that]) + (syntax (<= that this))))) + (new-stronger-var + lift-high + (λ (this that) + (with-syntax ([this this] + [that that]) + (syntax (<= this that)))))))))))])) + + (define-for-syntax (single-comparison-opter opt/info stx check-arg comparison arg) + (with-syntax ([comparison comparison]) + (let*-values ([(lift-low lifts2) (lift/binding arg 'single-comparison-val empty-lifts)]) + (with-syntax ([m lift-low]) + (let ([lifts3 (lift/effect (check-arg #'m) lifts2)]) + (with-syntax ((val (opt/info-val opt/info)) + (ctc (opt/info-contract opt/info)) + (pos (opt/info-pos opt/info)) + (src-info (opt/info-src-info opt/info)) + (orig-str (opt/info-orig-str opt/info)) + (this (opt/info-this opt/info)) + (that (opt/info-that opt/info))) + (values + (syntax (if (and (number? val) (comparison val m)) + val + (raise-contract-error + val + src-info + pos + orig-str + "expected <~a>, given: ~e" + ((name-get ctc) ctc) + val))) + lifts3 + null + null + (syntax (and (number? val) (comparison val m))) + #f + (list (new-stronger-var + lift-low + (λ (this that) + (with-syntax ([this this] + [that that]) + (syntax (comparison this that))))))))))))) + + (define/opter (>=/c opt/i opt/info stx) (syntax-case stx (>=/c) - [(>=/c low) (opt/between-ctc pos stx #'low #'+inf.0 #'<= '>=/c)])) - (define/opter (=/c low) + (single-comparison-opter + opt/info + stx + (λ (m) (with-syntax ([m m]) + #'(check-unary-between/c '>=/c m))) + #'>= + #'low)])) + + (define/opter (<=/c opt/i opt/info stx) (syntax-case stx (<=/c) - [(<=/c high) (opt/between-ctc pos stx #'-inf.0 #'high #'<= '<=/c)])) + [(<=/c high) + (single-comparison-opter + opt/info + stx + (λ (m) (with-syntax ([m m]) + #'(check-unary-between/c '<=/c m))) + #'<= + #'high)])) + + (define/opter (>/c opt/i opt/info stx) + (syntax-case stx (>/c) + [(>/c low) + (single-comparison-opter + opt/info + stx + (λ (m) (with-syntax ([m m]) + #'(check-unary-between/c '>/c m))) + #'> + #'low)])) + + (define/opter ( void ;; tests a passing specification (define (test/spec-passed name expression) (printf "testing: ~s\n" name) - (test (void) - (let ([for-each-eval (lambda (l) (for-each eval l))]) for-each-eval) - (list expression '(void)))) + (contract-eval + `(,test + (void) + (let ([for-each-eval (lambda (l) (for-each eval l))]) for-each-eval) + (list ',expression '(void)))) + (let/ec k + (contract-eval + `(,test (void) + (let ([for-each-eval (lambda (l) (for-each (λ (x) (eval x)) l))]) + for-each-eval) + (list ',(rewrite expression k) '(void)))))) (define (test/spec-passed/result name expression result) (printf "testing: ~s\n" name) - (test result + (contract-eval `(,test ',result eval ',expression)) + (let/ec k + (contract-eval + `(,test + ',result eval - expression)) + ',(rewrite expression k))))) + + ;; rewrites `contract' to use opt/c. If there is a module definition in there, we skip that test. + (define (rewrite exp k) + (let loop ([exp exp]) + (cond + [(null? exp) null] + [(list? exp) + (case (car exp) + [(contract) `(contract (opt/c ,(loop (cadr exp))) ,@(map loop (cddr exp)))] + [(module) (k #f)] + [else (map loop exp)])] + [(pair? exp) (cons (loop (car exp)) + (loop (cdr exp)))] + [else exp]))) (define (test/spec-failed name expression blame) - (cond - [(equal? blame "pos") - (test/pos-blame name expression)] - [(equal? blame "neg") - (test/neg-blame name expression)] - [else - (let () - (define (has-proper-blame? msg) - (equal? - blame - (cond - [(regexp-match #rx"^([^ ]*) broke" msg) => cadr] - [else (format "no blame in error message: \"~a\"" msg)]))) - (printf "testing: ~s\n" name) - (thunk-error-test - (lambda () (eval expression)) - (datum->syntax-object #'here expression) + (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)]))) + (printf "testing: ~s\n" name) + (contract-eval + `(,thunk-error-test + (lambda () ,expression) + (datum->syntax-object #'here ',expression) (lambda (exn) (and (exn? exn) - (has-proper-blame? (exn-message exn))))))])) + (,has-proper-blame? (exn-message exn)))))) + (let/ec k + (let ([rewritten (rewrite expression k)]) + (contract-eval + `(,thunk-error-test + (lambda () ,rewritten) + (datum->syntax-object #'here ',rewritten) + (lambda (exn) + (and (exn? exn) + (,has-proper-blame? (exn-message exn)))))))))) - (define (test/pos-blame name expression) - (define (has-pos-blame? exn) - (and (exn? exn) - (and (regexp-match #rx"pos broke" (exn-message exn))))) - (printf "testing: ~s\n" name) - (thunk-error-test - (lambda () (eval expression)) - (datum->syntax-object #'here expression) - has-pos-blame?)) - - (define (test/neg-blame name expression) - (define (has-neg-blame? exn) - (and (exn? exn) - (and (regexp-match #rx"neg broke" (exn-message exn))))) - (printf "testing: ~s\n" name) - (thunk-error-test - (lambda () (eval expression)) - (datum->syntax-object #'here expression) - has-neg-blame?)) + (define (test/pos-blame name expression) (test/spec-failed name expression "pos")) + (define (test/neg-blame name expression) (test/spec-failed name expression "neg")) (define (test/well-formed stx) - (test (void) - (let ([expand/ret-void (lambda (x) (expand x) (void))]) expand/ret-void) - stx)) + (contract-eval + `(,test (void) + (let ([expand/ret-void (lambda (x) (expand x) (void))]) expand/ret-void) + ,stx))) (define (test/no-error sexp) - (test (void) - eval - `(begin ,sexp (void)))) + (contract-eval + `(,test (void) + eval + '(begin ,sexp (void))))) (define (test-flat-contract contract pass fail) - (let ([name (if (pair? contract) - (car contract) - contract)]) - (test #t flat-contract? (eval contract)) - (test/spec-failed (format "~a fail" name) - `(contract ,contract ',fail 'pos 'neg) - "pos") - (test/spec-passed/result - (format "~a pass" name) - `(contract ,contract ',pass 'pos 'neg) - pass))) + (define (run-three-tests contract) + (let ([name (if (pair? contract) + (car contract) + contract)]) + (contract-eval `(,test #t flat-contract? ,contract)) + (test/spec-failed (format "~a fail" name) + `(contract ,contract ',fail 'pos 'neg) + "pos") + (test/spec-passed/result + (format "~a pass" name) + `(contract ,contract ',pass 'pos 'neg) + pass))) + (run-three-tests contract) + (let/ec k (run-three-tests (rewrite contract k)))) - (define (test-name name contract) - (test name contract-name contract)) + (define-syntax (test-name stx) + (syntax-case stx () + [(_ name contract) + #'(do-name-test 'name 'contract)])) + + (define (do-name-test name contract-exp) + (printf "~s\n" (list 'do-name-test name contract-exp)) + (contract-eval `(,test ,name contract-name ,contract-exp)) + (contract-eval `(,test ,name contract-name (opt/c ,contract-exp)))) (test/spec-passed 'contract-flat1 @@ -1406,59 +1454,62 @@ 'or/c14 '(contract (or/c not) #f 'pos 'neg)) - (test 1 - 'or/c-not-error-early - (begin (or/c (-> integer? integer?) (-> boolean? boolean?)) - 1)) - (error-test #'(contract (or/c (-> integer? integer?) (-> boolean? boolean?)) - (λ (x) x) - 'pos - 'neg) - exn:fail?) + (test/spec-passed/result + 'or/c-not-error-early + '(begin (or/c (-> integer? integer?) (-> boolean? boolean?)) + 1) + 1) - (test - '(1 2) + (contract-error-test + #'(contract (or/c (-> integer? integer?) (-> boolean? boolean?)) + (λ (x) x) + 'pos + 'neg) + exn:fail?) + + (test/spec-passed/result 'or/c-ordering - (let ([x '()]) - (contract (or/c (lambda (y) (set! x (cons 2 x)) #f) (lambda (y) (set! x (cons 1 x)) #t)) - 'anything - 'pos - 'neg) - x)) - - (test - '(2) - 'or/c-ordering2 - (let ([x '()]) - (contract (or/c (lambda (y) (set! x (cons 2 x)) #t) (lambda (y) (set! x (cons 1 x)) #t)) - 'anything - 'pos - 'neg) - x)) - - (test - '(1 2) - 'and/c-ordering - (let ([x '()]) - (contract (and/c (lambda (y) (set! x (cons 2 x)) #t) (lambda (y) (set! x (cons 1 x)) #t)) - 'anything - 'pos - 'neg) - x)) - - (test - (reverse '(1 3 4 2)) - 'ho-and/c-ordering - (let ([x '()]) - ((contract (and/c (-> (lambda (y) (set! x (cons 1 x)) #t) - (lambda (y) (set! x (cons 2 x)) #t)) - (-> (lambda (y) (set! x (cons 3 x)) #t) - (lambda (y) (set! x (cons 4 x)) #t))) - (λ (x) x) + '(let ([x '()]) + (contract (or/c (lambda (y) (set! x (cons 2 x)) #f) (lambda (y) (set! x (cons 1 x)) #t)) + 'anything 'pos 'neg) - 1) - x)) + x) + '(1 2)) + + (test/spec-passed/result + 'or/c-ordering2 + '(let ([x '()]) + (contract (or/c (lambda (y) (set! x (cons 2 x)) #t) (lambda (y) (set! x (cons 1 x)) #t)) + 'anything + 'pos + 'neg) + x) + '(2)) + + (test/spec-passed/result + 'and/c-ordering + '(let ([x '()]) + (contract (and/c (lambda (y) (set! x (cons 2 x)) #t) (lambda (y) (set! x (cons 1 x)) #t)) + 'anything + 'pos + 'neg) + x) + '(1 2)) + + (test/spec-passed/result + 'ho-and/c-ordering + '(let ([x '()]) + ((contract (and/c (-> (lambda (y) (set! x (cons 1 x)) #t) + (lambda (y) (set! x (cons 2 x)) #t)) + (-> (lambda (y) (set! x (cons 3 x)) #t) + (lambda (y) (set! x (cons 4 x)) #t))) + (λ (x) x) + 'pos + 'neg) + 1) + x) + (reverse '(1 3 4 2))) (test/spec-passed 'define/contract1 @@ -2609,65 +2660,70 @@ ;; test error message has right format ;; - (test "procedure m method: expects 1 argument, given 2: 1 2" - 'wrong-method-arity-error-message - (with-handlers ([exn:fail? exn-message]) - (send (contract (object-contract [m (integer? . -> . integer?)]) - (new (class object% (define/public (m x) x) (super-new))) - 'pos - 'neg) - m - 1 - 2))) + (test/spec-passed/result + 'wrong-method-arity-error-message + '(with-handlers ([exn:fail? exn-message]) + (send (contract (object-contract [m (integer? . -> . integer?)]) + (new (class object% (define/public (m x) x) (super-new))) + 'pos + 'neg) + m + 1 + 2)) + "procedure m method: expects 1 argument, given 2: 1 2") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; tests object utilities to be sure wrappers work right ;; - (let* ([o1 (new object%)] - [o2 (contract (object-contract) o1 'pos 'neg)]) - (test #t object=? o1 o1) - (test #f object=? o1 (new object%)) - (test #t object=? o1 o2) - (test #t object=? o2 o1) - (test #f object=? (new object%) o2)) + (let* ([o1 (contract-eval '(new object%))] + [o2 (contract-eval `(contract (object-contract) ,o1 'pos 'neg))]) + (test #t (contract-eval 'object=?) o1 o1) + (test #f (contract-eval 'object=?) o1 (contract-eval '(new object%))) + (test #t (contract-eval 'object=?) o1 o2) + (test #t (contract-eval 'object=?) o2 o1) + (test #f (contract-eval 'object=?) (contract-eval '(new object%)) o2)) - (test #t method-in-interface? 'm - (object-interface - (contract - (object-contract (m (integer? . -> . integer?))) - (new (class object% (define/public (m x) x) (super-new))) - 'pos - 'neg))) + (ctest #t + method-in-interface? + 'm + (object-interface + (contract + (object-contract (m (integer? . -> . integer?))) + (new (class object% (define/public (m x) x) (super-new))) + 'pos + 'neg))) - (let* ([i<%> (interface ())] - [c% (class* object% (i<%>) (super-new))] - [o (new c%)]) - (test #t is-a? o i<%>) - (test #t is-a? o c%) - (test #t is-a? (contract (object-contract) o 'pos 'neg) i<%>) - (test #t is-a? (contract (object-contract) o 'pos 'neg) c%)) + (let* ([i<%> (contract-eval '(interface ()))] + [c% (contract-eval `(class* object% (,i<%>) (super-new)))] + [o (contract-eval `(new ,c%))]) + (test #t (contract-eval 'is-a?) o i<%>) + (test #t (contract-eval 'is-a?) o c%) + (test #t (contract-eval 'is-a?) (contract-eval `(contract (object-contract) ,o 'pos 'neg)) i<%>) + (test #t (contract-eval 'is-a?) (contract-eval `(contract (object-contract) ,o 'pos 'neg)) c%)) (let ([c% (parameterize ([current-inspector (make-inspector)]) - (class object% (super-new)))]) + (contract-eval '(class object% (super-new))))]) (test (list c% #f) 'object-info - (call-with-values - (lambda () (object-info (contract (object-contract) (new c%) 'pos 'neg))) - list))) + (contract-eval + `(call-with-values + (lambda () (object-info (contract (object-contract) (new ,c%) 'pos 'neg))) + list)))) ;; object->vector tests (let* ([obj (parameterize ([current-inspector (make-inspector)]) - (new (class object% (field [x 1] [y 2]) (super-new))))] - [vec (object->vector obj)]) + (contract-eval '(new (class object% (field [x 1] [y 2]) (super-new)))))] + [vec (contract-eval `(object->vector ,obj))]) (test vec - object->vector - (contract (object-contract (field x integer?) (field y integer?)) - obj - 'pos - 'neg))) + (contract-eval 'object->vector) + (contract-eval + `(contract (object-contract (field x integer?) (field y integer?)) + ,obj + 'pos + 'neg)))) ; ; @@ -3096,9 +3152,9 @@ (test/spec-passed 'recursive-contract1 - (letrec ([ctc (-> integer? (recursive-contract ctc))]) - (letrec ([f (λ (x) f)]) - ((((contract ctc f 'pos 'neg) 1) 2) 3)))) + '(letrec ([ctc (-> integer? (recursive-contract ctc))]) + (letrec ([f (λ (x) f)]) + ((((contract ctc f 'pos 'neg) 1) 2) 3)))) (test/neg-blame 'recursive-contract2 @@ -3129,453 +3185,372 @@ ;; define-contract-struct tests ;; + (contract-eval '(define-contract-struct couple (hd tl))) (test/pos-blame 'd-c-s1 - '(let () - (define-contract-struct couple (hd tl)) - (contract (couple/c any/c any/c) 1 'pos 'neg))) - + '(begin + (eval '(module m mzscheme + (require (lib "contract.ss")) + (define-contract-struct couple (hd tl)) + (contract (couple/c any/c any/c) 1 'pos 'neg))) + (eval '(require m)))) (test/spec-passed 'd-c-s2 - '(let () - (define-contract-struct couple (hd tl)) - (contract (couple/c any/c any/c) (make-couple 1 2) 'pos 'neg))) + '(contract (couple/c any/c any/c) (make-couple 1 2) 'pos 'neg)) (test/spec-passed 'd-c-s3 - '(let () - (define-contract-struct couple (hd tl)) - (contract (couple/c number? number?) - (make-couple 1 2) - 'pos 'neg))) + '(contract (couple/c number? number?) + (make-couple 1 2) + 'pos 'neg)) (test/spec-passed 'd-c-s4 - '(let () - (define-contract-struct couple (hd tl)) - (couple-hd - (contract (couple/c number? number?) - (make-couple 1 2) - 'pos 'neg)))) + '(couple-hd + (contract (couple/c number? number?) + (make-couple 1 2) + 'pos 'neg))) (test/spec-passed 'd-c-s5 - '(let () - (define-contract-struct couple (hd tl)) - (couple-tl - (contract (couple/c number? number?) - (make-couple 1 2) - 'pos 'neg)))) + '(couple-tl + (contract (couple/c number? number?) + (make-couple 1 2) + 'pos 'neg))) + (test/pos-blame 'd-c-s6 - '(let () - (define-contract-struct couple (hd tl)) - (couple-tl - (contract (couple/c number? - number?) - (make-couple #f 2) - 'pos 'neg)))) + '(couple-tl + (contract (couple/c number? + number?) + (make-couple #f 2) + 'pos 'neg))) (test/pos-blame 'd-c-s7 - '(let () - (define-contract-struct couple (hd tl)) - (couple-hd - (contract (couple/c number? number?) - (make-couple #f 2) - 'pos 'neg)))) + '(couple-hd + (contract (couple/c number? number?) + (make-couple #f 2) + 'pos 'neg))) (test/pos-blame 'd-c-s8 - '(let () - (define-contract-struct couple (hd tl)) - (contract (couple/dc [hd any/c] [tl any/c]) - 1 - 'pos 'neg))) + '(contract (couple/dc [hd any/c] [tl any/c]) + 1 + 'pos 'neg)) (test/pos-blame 'd-c-s9 - '(let () - (define-contract-struct couple (hd tl)) - (contract (couple/dc [hd () any/c] [tl () any/c]) - 1 - 'pos 'neg))) + '(contract (couple/dc [hd () any/c] [tl () any/c]) + 1 + 'pos 'neg)) (test/spec-passed 'd-c-s10 - '(let () - (define-contract-struct couple (hd tl)) - (contract (couple/dc [hd any/c] [tl any/c]) (make-couple 1 2) - 'pos 'neg))) + '(contract (couple/dc [hd any/c] [tl any/c]) + (make-couple 1 2) + 'pos 'neg)) (test/spec-passed 'd-c-s11 - '(let () - (define-contract-struct couple (hd tl)) - (contract (couple/dc [hd () any/c] [tl () any/c]) - (make-couple 1 2) - 'pos 'neg))) + '(contract (couple/dc [hd () any/c] [tl () any/c]) + (make-couple 1 2) + 'pos 'neg)) (test/spec-passed 'd-c-s12 - '(let () - (define-contract-struct couple (hd tl)) - (contract (couple/dc [hd number?] - [tl number?]) - (make-couple 1 2) - 'pos 'neg))) + '(contract (couple/dc [hd number?] + [tl number?]) + (make-couple 1 2) + 'pos 'neg)) (test/spec-passed 'd-c-s13 - '(let () - (define-contract-struct couple (hd tl)) - (couple-hd - (contract (couple/dc [hd number?] - [tl number?]) - (make-couple 1 2) - 'pos 'neg)))) + '(couple-hd + (contract (couple/dc [hd number?] + [tl number?]) + (make-couple 1 2) + 'pos 'neg))) (test/spec-passed 'd-c-s14 - '(let () - (define-contract-struct couple (hd tl)) - (couple-tl - (contract (couple/dc [hd number?] - [tl number?]) - (make-couple 1 2) - 'pos 'neg)))) + '(couple-tl + (contract (couple/dc [hd number?] + [tl number?]) + (make-couple 1 2) + 'pos 'neg))) (test/pos-blame 'd-c-s15 - '(let () - (define-contract-struct couple (hd tl)) - (couple-hd - (contract (couple/dc [hd number?] - [tl number?]) - (make-couple #f 2) - 'pos 'neg)))) + '(couple-hd + (contract (couple/dc [hd number?] + [tl number?]) + (make-couple #f 2) + 'pos 'neg))) (test/pos-blame 'd-c-s16 - '(let () - (define-contract-struct couple (hd tl)) - (couple-tl - (contract (couple/dc [hd number?] - [tl number?]) - (make-couple #f 2) - 'pos 'neg)))) + '(couple-tl + (contract (couple/dc [hd number?] + [tl number?]) + (make-couple #f 2) + 'pos 'neg))) (test/spec-passed 'd-c-s17 - '(let () - (define-contract-struct couple (hd tl)) - (couple-hd - (contract (couple/dc [hd number?] - [tl (hd) (>=/c hd)]) - (make-couple 1 2) - 'pos 'neg)))) + '(couple-hd + (contract (couple/dc [hd number?] + [tl (hd) (>=/c hd)]) + (make-couple 1 2) + 'pos 'neg))) (test/pos-blame 'd-c-s18 - '(let () - (define-contract-struct couple (hd tl)) - (couple-hd - (contract (couple/dc [hd number?] - [tl (hd) (>=/c hd)]) - (make-couple 2 1) - 'pos 'neg)))) + '(couple-hd + (contract (couple/dc [hd number?] + [tl (hd) (>=/c hd)]) + (make-couple 2 1) + 'pos 'neg))) (test/spec-passed 'd-c-s19 - '(let () - (define-contract-struct couple (hd tl)) - (couple-tl - (couple-tl - (contract (couple/dc [hd number?] - [tl (hd) - (let ([hd1 hd]) - (couple/dc [hd (>=/c hd1)] - [tl (hd) (>=/c hd)]))]) - (make-couple 1 (make-couple 2 3)) - 'pos 'neg))))) + '(couple-tl + (couple-tl + (contract (couple/dc [hd number?] + [tl (hd) + (let ([hd1 hd]) + (couple/dc [hd (>=/c hd1)] + [tl (hd) (>=/c hd)]))]) + (make-couple 1 (make-couple 2 3)) + 'pos 'neg)))) (test/pos-blame 'd-c-s20 - '(let () - (define-contract-struct couple (hd tl)) - (couple-tl - (couple-tl - (contract (couple/dc [hd number?] - [tl (hd) - (let ([hd1 hd]) - (couple/dc [hd (>=/c hd1)] - [tl (hd) (>=/c hd1)]))]) - (make-couple 1 (make-couple 2 0)) - 'pos 'neg))))) + '(couple-tl + (couple-tl + (contract (couple/dc [hd number?] + [tl (hd) + (let ([hd1 hd]) + (couple/dc [hd (>=/c hd1)] + [tl (hd) (>=/c hd1)]))]) + (make-couple 1 (make-couple 2 0)) + 'pos 'neg)))) (test/spec-passed 'd-c-s21 - '(let () - (define-contract-struct couple (hd tl)) - - (couple-hd - (contract (couple/dc [hd number?] - [tl number?]) - (contract (couple/dc [hd number?] - [tl number?]) - (make-couple 1 2) - 'pos 'neg) - 'pos 'neg)))) + '(couple-hd + (contract (couple/dc [hd number?] + [tl number?]) + (contract (couple/dc [hd number?] + [tl number?]) + (make-couple 1 2) + 'pos 'neg) + 'pos 'neg))) (test/spec-passed 'd-c-s22 - '(let () - (define-contract-struct couple (hd tl)) - (couple-hd - (contract (couple/dc [hd (>=/c 0)] - [tl (>=/c 0)]) - (contract (couple/dc [hd number?] - [tl number?]) - (make-couple 1 2) - 'pos 'neg) - 'pos 'neg)))) + '(couple-hd + (contract (couple/dc [hd (>=/c 0)] + [tl (>=/c 0)]) + (contract (couple/dc [hd number?] + [tl number?]) + (make-couple 1 2) + 'pos 'neg) + 'pos 'neg))) (test/pos-blame 'd-c-s23 - '(let () - (define-contract-struct couple (hd tl)) - (couple-hd - (contract (couple/dc [hd (>=/c 0)] - [tl (>=/c 0)]) - (contract (couple/dc [hd number?] - [tl number?]) - (make-couple -1 2) - 'pos 'neg) - 'pos 'neg)))) + '(couple-hd + (contract (couple/dc [hd (>=/c 0)] + [tl (>=/c 0)]) + (contract (couple/dc [hd number?] + [tl number?]) + (make-couple -1 2) + 'pos 'neg) + 'pos 'neg))) (test/pos-blame 'd-c-s24 - '(let () - (define-contract-struct couple (hd tl)) - (couple-hd - (contract (couple/dc [hd number?] - [tl number?]) - (contract (couple/dc [hd (>=/c 0)] - [tl (>=/c 0)]) - (make-couple -1 2) - 'pos 'neg) - 'pos 'neg)))) + '(couple-hd + (contract (couple/dc [hd number?] + [tl number?]) + (contract (couple/dc [hd (>=/c 0)] + [tl (>=/c 0)]) + (make-couple -1 2) + 'pos 'neg) + 'pos 'neg))) (test/pos-blame 'd-c-s25 - '(let () - (define-contract-struct couple (hd tl)) - (couple-hd - (contract (couple/dc [hd number?] - [tl number?]) - (contract (couple/dc [hd number?] - [tl number?]) - (contract (couple/dc [hd (>=/c 0)] - [tl (>=/c 0)]) - (make-couple -1 2) - 'pos 'neg) - 'pos 'neg) - 'pos 'neg)))) + '(couple-hd + (contract (couple/dc [hd number?] + [tl number?]) + (contract (couple/dc [hd number?] + [tl number?]) + (contract (couple/dc [hd (>=/c 0)] + [tl (>=/c 0)]) + (make-couple -1 2) + 'pos 'neg) + 'pos 'neg) + 'pos 'neg))) (test/pos-blame 'd-c-s26 - '(let () - (define-contract-struct couple (hd tl)) - (couple-hd - (contract (couple/dc [hd (>=/c 10)] - [tl (>=/c 10)]) - (contract (couple/dc [hd positive?] - [tl positive?]) - (contract (couple/dc [hd number?] - [tl number?]) - (make-couple 1 2) - 'pos 'neg) - 'pos 'neg) - 'pos 'neg)))) + '(couple-hd + (contract (couple/dc [hd (>=/c 10)] + [tl (>=/c 10)]) + (contract (couple/dc [hd positive?] + [tl positive?]) + (contract (couple/dc [hd number?] + [tl number?]) + (make-couple 1 2) + 'pos 'neg) + 'pos 'neg) + 'pos 'neg))) ;; test caching (test/spec-passed 'd-c-s27 - '(let () - (define-contract-struct couple (hd tl)) - (let ([ctc (couple/c any/c any/c)]) - (couple-hd (contract ctc (contract ctc (make-couple 1 2) 'pos 'neg) 'pos 'neg))))) + '(let ([ctc (couple/c any/c any/c)]) + (couple-hd (contract ctc (contract ctc (make-couple 1 2) 'pos 'neg) 'pos 'neg)))) ;; make sure lazy really is lazy (test/spec-passed 'd-c-s28 - '(let () - (define-contract-struct couple (hd tl)) - (contract (couple/c number? number?) - (make-couple #f #f) - 'pos 'neg))) + '(contract (couple/c number? number?) + (make-couple #f #f) + 'pos 'neg)) (test/spec-passed 'd-c-s29 - '(let () - (define-contract-struct couple (hd tl)) - - (couple-hd - (contract (couple/c (couple/c number? number?) - (couple/c number? number?)) - (make-couple (make-couple #f #f) - (make-couple #f #f)) - 'pos 'neg)))) + '(couple-hd + (contract (couple/c (couple/c number? number?) + (couple/c number? number?)) + (make-couple (make-couple #f #f) + (make-couple #f #f)) + 'pos 'neg))) (test/spec-passed 'd-c-s30 - '(let () - (define-contract-struct couple (hd tl)) - - (couple-tl - (contract (couple/c (couple/c number? number?) - (couple/c number? number?)) - (make-couple (make-couple #f #f) - (make-couple #f #f)) - 'pos 'neg)))) + '(couple-tl + (contract (couple/c (couple/c number? number?) + (couple/c number? number?)) + (make-couple (make-couple #f #f) + (make-couple #f #f)) + 'pos 'neg))) ;; make sure second accesses work (test/spec-passed/result 'd-c-s31 - '(let () - (define-contract-struct couple (hd tl)) - (let ([v (contract (couple/c number? number?) - (make-couple 1 2) - 'pos 'neg)]) - (list (couple-hd v) (couple-hd v)))) + '(let ([v (contract (couple/c number? number?) + (make-couple 1 2) + 'pos 'neg)]) + (list (couple-hd v) (couple-hd v))) (list 1 1)) (test/pos-blame 'd-c-s32 - '(let () - (define-contract-struct couple (hd tl)) - (let ([v (contract (couple/c number? boolean?) - (make-couple 1 2) - 'pos 'neg)]) - (with-handlers ([void void]) (couple-hd v)) - (couple-hd v)))) + '(let ([v (contract (couple/c number? boolean?) + (make-couple 1 2) + 'pos 'neg)]) + (with-handlers ([void void]) (couple-hd v)) + (couple-hd v))) (test/pos-blame 'd-c-s33 - '(let () - (define-contract-struct couple (hd tl)) - (let ([v (contract (couple/c number? number?) - (make-couple 1 2) - 'pos 'neg)]) - (couple-hd v) - (couple-hd v) - (couple-hd - (contract (couple/c boolean? boolean?) - v - 'pos 'neg))))) - + '(let ([v (contract (couple/c number? number?) + (make-couple 1 2) + 'pos 'neg)]) + (couple-hd v) + (couple-hd v) + (couple-hd + (contract (couple/c boolean? boolean?) + v + 'pos 'neg)))) + + (contract-eval '(define-contract-struct single (a))) ;; a related test to the above: (test/spec-passed/result 'd-c-s34 - '(let () - (define-contract-struct s (a) (make-inspector)) - (let ([v (contract (s/c number?) (make-s 1) 'pos 'neg)]) - (s-a v) - (let ([v3 (contract (s/c number?) v 'pos 'neg)]) - (s-a v3)))) + '(let ([v (contract (single/c number?) (make-single 1) 'pos 'neg)]) + (single-a v) + (let ([v3 (contract (single/c number?) v 'pos 'neg)]) + (single-a v3))) 1) ;; make sure the caching doesn't break the semantics (test/pos-blame 'd-c-s35 - '(let () - (define-contract-struct couple (hd tl)) - (let ([v (contract (couple/c any/c - (couple/c any/c - (couple/c any/c - number?))) - (make-couple 1 - (make-couple 2 - (make-couple 3 - #f))) - 'pos 'neg)]) - (let* ([x (couple-tl v)] - [y (couple-tl x)]) - (couple-hd (couple-tl x)))))) + '(let ([v (contract (couple/c any/c + (couple/c any/c + (couple/c any/c + number?))) + (make-couple 1 + (make-couple 2 + (make-couple 3 + #f))) + 'pos 'neg)]) + (let* ([x (couple-tl v)] + [y (couple-tl x)]) + (couple-hd (couple-tl x))))) (test/spec-passed/result 'd-c-s36 - '(let () - (define-contract-struct couple (hd tl)) - (let ([x (make-couple 1 2)] - [y (make-couple 1 2)] - [c1 (couple/dc [hd any/c] - [tl (hd) any/c])] - [c2 (couple/c any/c any/c)]) - (couple-hd (contract c1 x 'pos 'neg)) - (couple-hd (contract c2 x 'pos 'neg)) - (couple-hd (contract c2 y 'pos 'neg)) - (couple-hd (contract c1 y 'pos 'neg)))) + '(let ([x (make-couple 1 2)] + [y (make-couple 1 2)] + [c1 (couple/dc [hd any/c] + [tl (hd) any/c])] + [c2 (couple/c any/c any/c)]) + (couple-hd (contract c1 x 'pos 'neg)) + (couple-hd (contract c2 x 'pos 'neg)) + (couple-hd (contract c2 y 'pos 'neg)) + (couple-hd (contract c1 y 'pos 'neg))) 1) ;; make sure that define-contract-struct contracts can go at the top level (test/spec-passed 'd-c-s37 - '(parameterize ([current-namespace (make-namespace)]) - (eval '(require (lib "contract.ss"))) - (eval '(define-contract-struct couple (hd tl))) - (eval '(contract-stronger? - (couple/dc [hd any/c] - [tl (hd) any/c]) - (couple/dc [hd any/c] - [tl (hd) any/c]))))) + '(contract-stronger? + (couple/dc [hd any/c] + [tl (hd) any/c]) + (couple/dc [hd any/c] + [tl (hd) any/c]))) ;; test functions inside structs (test/spec-passed/result 'd-c-s38 - '(let () - (define-contract-struct couple (hd tl)) - (let ([x (make-couple (lambda (x) x) (lambda (x) x))] - [c (couple/dc [hd (-> integer? integer?)] - [tl (hd) any/c])]) - ((couple-hd (contract c x 'pos 'neg)) 1))) + '(let ([x (make-couple (lambda (x) x) (lambda (x) x))] + [c (couple/dc [hd (-> integer? integer?)] + [tl (hd) any/c])]) + ((couple-hd (contract c x 'pos 'neg)) 1)) 1) (test/neg-blame 'd-c-s39 - '(let () - (define-contract-struct couple (hd tl)) - (let ([x (make-couple (lambda (x) x) (lambda (x) x))] - [c (couple/dc [hd (-> integer? integer?)] - [tl (hd) any/c])]) - ((couple-hd (contract c x 'pos 'neg)) #f)))) + '(let ([x (make-couple (lambda (x) x) (lambda (x) x))] + [c (couple/dc [hd (-> integer? integer?)] + [tl (hd) any/c])]) + ((couple-hd (contract c x 'pos 'neg)) #f))) (test/pos-blame 'd-c-s40 - '(let () - (define-contract-struct couple (hd tl)) - (let ([x (make-couple (lambda (x) #f) (lambda (x) #f))] - [c (couple/dc [hd (-> integer? integer?)] - [tl (hd) any/c])]) - ((couple-hd (contract c x 'pos 'neg)) 1)))) + '(let ([x (make-couple (lambda (x) #f) (lambda (x) #f))] + [c (couple/dc [hd (-> integer? integer?)] + [tl (hd) any/c])]) + ((couple-hd (contract c x 'pos 'neg)) 1))) (test/spec-passed/result 'd-c-s41 - '(let () - (define-contract-struct couple (hd tl)) - (let ([x (make-couple 5 (lambda (x) x))] - [c (couple/dc [hd number?] - [tl (hd) (-> (>=/c hd) (>=/c hd))])]) - ((couple-tl (contract c x 'pos 'neg)) 6))) + '(let ([x (make-couple 5 (lambda (x) x))] + [c (couple/dc [hd number?] + [tl (hd) (-> (>=/c hd) (>=/c hd))])]) + ((couple-tl (contract c x 'pos 'neg)) 6)) 6) (test/pos-blame 'd-c-s42 - '(let () - (define-contract-struct couple (hd tl)) - (let ([x (make-couple 5 (lambda (x) -10))] - [c (couple/dc [hd number?] - [tl (hd) (-> (>=/c hd) (>=/c hd))])]) - ((couple-tl (contract c x 'pos 'neg)) 6)))) + '(let ([x (make-couple 5 (lambda (x) -10))] + [c (couple/dc [hd number?] + [tl (hd) (-> (>=/c hd) (>=/c hd))])]) + ((couple-tl (contract c x 'pos 'neg)) 6))) (test/neg-blame 'd-c-s42 - '(let () - (define-contract-struct couple (hd tl)) - (let ([x (make-couple 5 (lambda (x) -10))] - [c (couple/dc [hd number?] - [tl (hd) (-> (>=/c hd) (>=/c hd))])]) - ((couple-tl (contract c x 'pos 'neg)) -11)))) + '(let ([x (make-couple 5 (lambda (x) -10))] + [c (couple/dc [hd number?] + [tl (hd) (-> (>=/c hd) (>=/c hd))])]) + ((couple-tl (contract c x 'pos 'neg)) -11))) + ;; NOT YET RELEASED @@ -3654,7 +3629,7 @@ (test/pos-blame 'd-c-s/attr-4 `(,node-r (,node-r (,node-r ,t))))) - + ;; NOT YET RELEASED #| @@ -3664,16 +3639,13 @@ so that propagation occurs. |# - ;; test the predicate - (let () - (define-contract-struct couple (hd tl)) - (test #t couple? (contract (couple/c any/c any/c) (make-couple 1 2) 'pos 'neg)) - (test #t couple? (make-couple 1 2)) - (test #t couple? (contract (couple/dc [hd any/c] [tl (hd) any/c]) (make-couple 1 2) 'pos 'neg)) - (test #f couple? 1) - (test #f couple? #f)) + (ctest #t couple? (contract (couple/c any/c any/c) (make-couple 1 2) 'pos 'neg)) + (ctest #t couple? (make-couple 1 2)) + (ctest #t couple? (contract (couple/dc [hd any/c] [tl (hd) any/c]) (make-couple 1 2) 'pos 'neg)) + (ctest #f couple? 1) + (ctest #f couple? #f) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; @@ -3681,18 +3653,18 @@ so that propagation occurs. ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (test #t flat-contract? (or/c)) - (test #t flat-contract? (or/c integer? (lambda (x) (> x 0)))) - (test #t flat-contract? (or/c (flat-contract integer?) (flat-contract boolean?))) - (test #t flat-contract? (or/c integer? boolean?)) + (ctest #t flat-contract? (or/c)) + (ctest #t flat-contract? (or/c integer? (lambda (x) (> x 0)))) + (ctest #t flat-contract? (or/c (flat-contract integer?) (flat-contract boolean?))) + (ctest #t flat-contract? (or/c integer? boolean?)) (test-flat-contract '(or/c (flat-contract integer?) char?) #\a #t) (test-flat-contract '(or/c (flat-contract integer?) char?) 1 #t) - (test #t flat-contract? (and/c)) - (test #t flat-contract? (and/c number? integer?)) - (test #t flat-contract? (and/c (flat-contract number?) + (ctest #t flat-contract? (and/c)) + (ctest #t flat-contract? (and/c number? integer?)) + (ctest #t flat-contract? (and/c (flat-contract number?) (flat-contract integer?))) - (test #t flat-contract? (let () + (ctest #t flat-contract? (let () (define-struct s (a b)) (struct/c s any/c any/c))) @@ -3719,25 +3691,29 @@ so that propagation occurs. (test-flat-contract '(one-of/c (expt 2 65)) (expt 2 65) 12) (test-flat-contract '(one-of/c #:x #:z) #:x #:y) - (let ([c% (class object% (super-new))]) - (test-flat-contract (subclass?/c c%) c% object%) - (test-flat-contract (subclass?/c c%) (class c%) (class object%))) + (let ([c% (contract-eval '(class object% (super-new)))]) + (test-flat-contract `(subclass?/c ,c%) c% (contract-eval `object%)) + (test-flat-contract `(subclass?/c ,c%) (contract-eval `(class ,c%)) (contract-eval `(class object%)))) - (let ([i<%> (interface ())]) - (test-flat-contract `(implementation?/c ,i<%>) (class* object% (i<%>) (super-new)) object%) - (test-flat-contract `(implementation?/c ,i<%>) (class* object% (i<%>) (super-new)) #f)) + (let ([i<%> (contract-eval '(interface ()))]) + (test-flat-contract `(implementation?/c ,i<%>) + (contract-eval `(class* object% (,i<%>) (super-new))) + (contract-eval 'object%)) + (test-flat-contract `(implementation?/c ,i<%>) + (contract-eval `(class* object% (,i<%>) (super-new))) + #f)) - (let ([i<%> (interface ())] - [c% (class object% (super-new))]) - (test-flat-contract `(is-a?/c ,i<%>) (new (class* object% (i<%>) (super-new))) (new object%)) - (test-flat-contract `(is-a?/c ,c%) (new c%) (new object%))) + (let ([i<%> (contract-eval '(interface ()))] + [c% (contract-eval '(class object% (super-new)))]) + (test-flat-contract `(is-a?/c ,i<%>) + (contract-eval `(new (class* object% (,i<%>) (super-new)))) + (contract-eval '(new object%))) + (test-flat-contract `(is-a?/c ,c%) + (contract-eval `(new ,c%)) + (contract-eval '(new object%)))) (test-flat-contract '(listof boolean?) (list #t #f) (list #f 3 #t)) (test-flat-contract '(listof any/c) (list #t #f) 3) - ;(test-flat-contract '(list-immutableof boolean?) (list-immutable #t #f) (list-immutable #f 3 #t)) - ;(test-flat-contract '(list-immutableof any/c) (list-immutable #t #f) 3) - ;(test-flat-contract '(list-immutableof boolean?) (list-immutable) (list)) - ;(test-flat-contract '(list-immutableof (-> boolean? boolean?)) (list-immutable (lambda (x) x)) (list (lambda (x) x))) (test-flat-contract '(vectorof boolean?) (vector #t #f) (vector #f 3 #t)) (test-flat-contract '(vectorof any/c) (vector #t #f) 3) @@ -3750,16 +3726,12 @@ so that propagation occurs. (test-flat-contract '(list/c boolean? (flat-contract integer?)) (list #t 1) (list 1 #f)) (test-flat-contract '(list/c boolean? (flat-contract integer?)) (list #t 1) #f) - ;(test-flat-contract '(cons-immutable/c boolean? (flat-contract integer?)) (cons-immutable #t 1) (cons-immutable 1 #f)) - ;(test-flat-contract '(cons-immutable/c boolean? (flat-contract integer?)) (cons-immutable #t 1) #f) - ;(test-flat-contract '(cons-immutable/c boolean? (flat-contract integer?)) (cons-immutable #t 1) (cons #t 1)) - ;(test-flat-contract '(cons-immutable/c (-> boolean? boolean?) integer?) (cons-immutable (lambda (x) x) 1) #f) - - ;(test-flat-contract '(list-immutable/c boolean? (flat-contract integer?)) (list-immutable #t 1) (list-immutable 1 #f)) - ;(test-flat-contract '(list-immutable/c boolean? (flat-contract integer?)) (list-immutable #t 1) #f) - ;(test-flat-contract '(list-immutable/c boolean? (flat-contract integer?)) (list-immutable #t 1) (list #t 1)) - ;(test-flat-contract '(list-immutable/c (-> boolean? boolean?) integer?) (list-immutable (lambda (x) x) 1) #f) - + (contract-eval '(define (a-predicate-that-wont-be-optimized x) (boolean? x))) + (test-flat-contract '(cons/c a-predicate-that-wont-be-optimized (flat-contract integer?)) (cons #t 1) (cons 1 #f)) + (test-flat-contract '(cons/c a-predicate-that-wont-be-optimized (flat-contract integer?)) (cons #t 1) #f) + (test-flat-contract '(list/c a-predicate-that-wont-be-optimized (flat-contract integer?)) (list #t 1) (list 1 #f)) + (test-flat-contract '(list/c a-predicate-that-wont-be-optimized (flat-contract integer?)) (list #t 1) #f) + (test-flat-contract '(box/c boolean?) (box #f) (box 1)) (test-flat-contract '(box/c (flat-contract boolean?)) (box #t) #f) @@ -3769,9 +3741,14 @@ so that propagation occurs. even1) '(1 2 3 4) '(1 2 3)) - (syntax-test #'(flat-murec-contract ([(x) y]) x)) ;; malformed binder - (syntax-test #'(flat-murec-contract ([x y]))) ;; missing body - + (test #t 'malformed-binder + (with-handlers ((exn? exn:fail:syntax?)) + (contract-eval '(flat-murec-contract ([(x) y]) x)) + 'no-err)) + (test #t 'missing-body + (with-handlers ((exn? exn:fail:syntax?)) + (contract-eval '(flat-murec-contract ([x y]))) + 'no-err)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; @@ -3779,19 +3756,19 @@ so that propagation occurs. ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (test/well-formed #'(case-> (-> integer? integer?))) - (test/well-formed #'(case-> (-> integer? integer?) (-> integer? integer? integer?))) - (test/well-formed #'(case-> (-> integer? integer?) (-> integer? integer? any))) - (test/well-formed #'(case-> (-> integer? any) (-> integer? integer? any))) + (test/well-formed '(case-> (-> integer? integer?))) + (test/well-formed '(case-> (-> integer? integer?) (-> integer? integer? integer?))) + (test/well-formed '(case-> (-> integer? integer?) (-> integer? integer? any))) + (test/well-formed '(case-> (-> integer? any) (-> integer? integer? any))) - (test/well-formed #'(case-> (->d (lambda x any/c)) (-> integer? integer?))) + (test/well-formed '(case-> (->d (lambda x any/c)) (-> integer? integer?))) - (test/well-formed #'(case-> (->* (any/c any/c) (integer?)) (-> integer? integer?))) - (test/well-formed #'(case-> (->* (any/c any/c) any/c (integer?)) (-> integer? integer?))) - (test/well-formed #'(case-> (->* (any/c any/c) any/c any) (-> integer? integer?))) + (test/well-formed '(case-> (->* (any/c any/c) (integer?)) (-> integer? integer?))) + (test/well-formed '(case-> (->* (any/c any/c) any/c (integer?)) (-> integer? integer?))) + (test/well-formed '(case-> (->* (any/c any/c) any/c any) (-> integer? integer?))) - (test/well-formed #'(case-> (->d* (any/c any/c) (lambda x any/c)) (-> integer? integer?))) - (test/well-formed #'(case-> (->d* (any/c any/c) any/c (lambda x any/c)) (-> integer? integer?))) + (test/well-formed '(case-> (->d* (any/c any/c) (lambda x any/c)) (-> integer? integer?))) + (test/well-formed '(case-> (->d* (any/c any/c) any/c (lambda x any/c)) (-> integer? integer?))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; @@ -3799,7 +3776,7 @@ so that propagation occurs. ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (eval + (contract-eval '(module contract-test-suite-inferred-name1 mzscheme (require (lib "contract.ss")) (define contract-inferred-name-test-contract (-> integer? any)) @@ -3832,15 +3809,15 @@ so that propagation occurs. (define contract-inferred-name-test7 (case-lambda [(x) (values x x)] [(x y) (values y y)])) (provide/contract (contract-inferred-name-test7 (opt->* (number?) (number?) (number? number?)))))) - (eval '(require contract-test-suite-inferred-name1)) + (contract-eval '(require contract-test-suite-inferred-name1)) ;; (eval '(test 'contract-inferred-name-test object-name contract-inferred-name-test)) ;; this one can't be made to pass, sadly. - (eval '(test 'contract-inferred-name-test2 object-name contract-inferred-name-test2)) - (eval '(test 'contract-inferred-name-test2b object-name contract-inferred-name-test2b)) - (eval '(test 'contract-inferred-name-test3 object-name contract-inferred-name-test3)) - (eval '(test 'contract-inferred-name-test4 object-name contract-inferred-name-test4)) - (eval '(test 'contract-inferred-name-test5 object-name contract-inferred-name-test5)) - (eval '(test 'contract-inferred-name-test6 object-name contract-inferred-name-test6)) - (eval '(test 'contract-inferred-name-test7 object-name contract-inferred-name-test7)) + (test 'contract-inferred-name-test2 object-name (contract-eval 'contract-inferred-name-test2)) + (test 'contract-inferred-name-test2b object-name (contract-eval 'contract-inferred-name-test2b)) + (test 'contract-inferred-name-test3 object-name (contract-eval 'contract-inferred-name-test3)) + (test 'contract-inferred-name-test4 object-name (contract-eval 'contract-inferred-name-test4)) + (test 'contract-inferred-name-test5 object-name (contract-eval 'contract-inferred-name-test5)) + (test 'contract-inferred-name-test6 object-name (contract-eval 'contract-inferred-name-test6)) + (test 'contract-inferred-name-test7 object-name (contract-eval 'contract-inferred-name-test7)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; @@ -3930,16 +3907,20 @@ so that propagation occurs. (test-name '(symbols 'a 'b 'c) (symbols 'a 'b 'c)) (test-name '(one-of/c 1 2 3) (one-of/c 1 2 3)) - (let ([c% (class object% (super-new))]) - (test-name '(subclass?/c class:c%) (subclass?/c c%))) + (test-name '(subclass?/c class:c%) + (let ([c% (class object% (super-new))]) (subclass?/c c%))) - (let ([i<%> (interface ())]) - (test-name '(implementation?/c interface:i<%>) (implementation?/c i<%>))) + (test-name '(implementation?/c interface:i<%>) + (let ([i<%> (interface ())]) + (implementation?/c i<%>))) - (let ([i<%> (interface ())] - [c% (class object% (super-new))]) - (test-name '(is-a?/c interface:i<%>) (is-a?/c i<%>)) - (test-name '(is-a?/c class:c%) (is-a?/c c%))) + (test-name '(is-a?/c interface:i<%>) + (let ([i<%> (interface ())]) + (is-a?/c i<%>))) + (test-name '(is-a?/c class:c%) + (let ([i<%> (interface ())] + [c% (class object% (super-new))]) + (is-a?/c c%))) (test-name '(listof boolean?) (listof boolean?)) (test-name '(listof any/c) (listof any/c)) @@ -4026,18 +4007,12 @@ so that propagation occurs. (test-name '(recursive-contract x) (let ([x (box/c boolean?)]) (recursive-contract x))) (test-name '(couple/c any/c any/c) - (let () - (define-contract-struct couple (hd tl)) - (couple/c any/c any/c))) + (couple/c any/c any/c)) (test-name '(couple/c any/c any/c) - (let () - (define-contract-struct couple (hd tl)) - (couple/dc [hd any/c] [tl any/c]))) + (couple/dc [hd any/c] [tl any/c])) (test-name '(couple/dc [hd any/c] [tl ...]) - (let () - (define-contract-struct couple (hd tl)) - (couple/dc [hd any/c] [tl (hd) any/c]))) - + (couple/dc [hd any/c] [tl (hd) any/c])) + ;; NOT YET RELEASED #; (test-name '(pr/dc [x integer?] @@ -4063,276 +4038,274 @@ so that propagation occurs. ;; stronger tests ;; - (test #t contract-stronger? any/c any/c) - (test #t contract-stronger? (between/c 1 3) (between/c 0 4)) - (test #f contract-stronger? (between/c 0 4) (between/c 1 3)) - (test #t contract-stronger? (>=/c 3) (>=/c 2)) - (test #f contract-stronger? (>=/c 2) (>=/c 3)) - (test #f contract-stronger? (<=/c 3) (<=/c 2)) - (test #t contract-stronger? (<=/c 2) (<=/c 3)) - (test #f contract-stronger? (recursive-contract (<=/c 2)) (recursive-contract (<=/c 3))) - (test #f contract-stronger? (recursive-contract (<=/c 3)) (recursive-contract (<=/c 2))) - (let ([f (λ (x) (recursive-contract (<=/c x)))]) - (test #t contract-stronger? (f 1) (f 1))) - (test #t contract-stronger? (-> integer? integer?) (-> integer? integer?)) - (test #f contract-stronger? (-> boolean? boolean?) (-> integer? integer?)) - (test #t contract-stronger? (-> (>=/c 3) (>=/c 3)) (-> (>=/c 4) (>=/c 3))) - (test #f contract-stronger? (-> (>=/c 4) (>=/c 3)) (-> (>=/c 3) (>=/c 3))) - (test #t contract-stronger? (-> (>=/c 3) (>=/c 3)) (-> (>=/c 3) (>=/c 2))) - (test #f contract-stronger? (-> (>=/c 3) (>=/c 2)) (-> (>=/c 3) (>=/c 3))) - (test #f contract-stronger? (-> (>=/c 2)) (-> (>=/c 3) (>=/c 3))) - (test #t contract-stronger? (or/c null? any/c) (or/c null? any/c)) - (test #f contract-stronger? (or/c null? any/c) (or/c boolean? any/c)) - (test #t contract-stronger? (or/c null? boolean?) (or/c null? boolean?)) - (test #f contract-stronger? (or/c null? boolean?) (or/c boolean? null?)) - (test #t contract-stronger? (or/c null? (-> integer? integer?)) (or/c null? (-> integer? integer?))) - (test #f contract-stronger? (or/c null? (-> boolean? boolean?)) (or/c null? (-> integer? integer?))) + (ctest #t contract-stronger? any/c any/c) + (ctest #t contract-stronger? (between/c 1 3) (between/c 0 4)) + (ctest #f contract-stronger? (between/c 0 4) (between/c 1 3)) + (ctest #t contract-stronger? (>=/c 3) (>=/c 2)) + (ctest #f contract-stronger? (>=/c 2) (>=/c 3)) + (ctest #f contract-stronger? (<=/c 3) (<=/c 2)) + (ctest #t contract-stronger? (<=/c 2) (<=/c 3)) + (ctest #f contract-stronger? (recursive-contract (<=/c 2)) (recursive-contract (<=/c 3))) + (ctest #f contract-stronger? (recursive-contract (<=/c 3)) (recursive-contract (<=/c 2))) + (let ([f (contract-eval '(λ (x) (recursive-contract (<=/c x))))]) + (test #t (contract-eval 'contract-stronger?) (contract-eval `(,f 1)) (contract-eval `(,f 1)))) + (ctest #t contract-stronger? (-> integer? integer?) (-> integer? integer?)) + (ctest #f contract-stronger? (-> boolean? boolean?) (-> integer? integer?)) + (ctest #t contract-stronger? (-> (>=/c 3) (>=/c 3)) (-> (>=/c 4) (>=/c 3))) + (ctest #f contract-stronger? (-> (>=/c 4) (>=/c 3)) (-> (>=/c 3) (>=/c 3))) + (ctest #t contract-stronger? (-> (>=/c 3) (>=/c 3)) (-> (>=/c 3) (>=/c 2))) + (ctest #f contract-stronger? (-> (>=/c 3) (>=/c 2)) (-> (>=/c 3) (>=/c 3))) + (ctest #f contract-stronger? (-> (>=/c 2)) (-> (>=/c 3) (>=/c 3))) + (ctest #t contract-stronger? (or/c null? any/c) (or/c null? any/c)) + (ctest #f contract-stronger? (or/c null? any/c) (or/c boolean? any/c)) + (ctest #t contract-stronger? (or/c null? boolean?) (or/c null? boolean?)) + (ctest #f contract-stronger? (or/c null? boolean?) (or/c boolean? null?)) + (ctest #t contract-stronger? (or/c null? (-> integer? integer?)) (or/c null? (-> integer? integer?))) + (ctest #f contract-stronger? (or/c null? (-> boolean? boolean?)) (or/c null? (-> integer? integer?))) - (test #t contract-stronger? number? number?) - (test #f contract-stronger? boolean? number?) + (ctest #t contract-stronger? number? number?) + (ctest #f contract-stronger? boolean? number?) - (test #t contract-stronger? (symbols 'x 'y) (symbols 'x 'y 'z)) - (test #f contract-stronger? (symbols 'x 'y 'z) (symbols 'x 'y)) - (test #t contract-stronger? (symbols 'x 'y) (symbols 'z 'x 'y)) - (test #f contract-stronger? (symbols 'z 'x 'y) (symbols 'x 'y)) - (test #t contract-stronger? (one-of/c (expt 2 100)) (one-of/c (expt 2 100) 12)) + (ctest #t contract-stronger? (symbols 'x 'y) (symbols 'x 'y 'z)) + (ctest #f contract-stronger? (symbols 'x 'y 'z) (symbols 'x 'y)) + (ctest #t contract-stronger? (symbols 'x 'y) (symbols 'z 'x 'y)) + (ctest #f contract-stronger? (symbols 'z 'x 'y) (symbols 'x 'y)) + (ctest #t contract-stronger? (one-of/c (expt 2 100)) (one-of/c (expt 2 100) 12)) - (test #t contract-stronger? + (ctest #t contract-stronger? (or/c (-> (>=/c 3) (>=/c 3)) (-> string?)) (or/c (-> (>=/c 4) (>=/c 3)) (-> string?))) - (test #f contract-stronger? + (ctest #f contract-stronger? (or/c (-> string?) (-> integer? integer?)) (or/c (-> string?) (-> any/c integer?))) - (test #f contract-stronger? + (ctest #f contract-stronger? (or/c (-> string?) (-> any/c integer?)) (or/c (-> string?) (-> integer? integer?))) - (test #t contract-stronger? + (ctest #t contract-stronger? (or/c (-> string?) (-> integer? integer?) integer? boolean?) (or/c (-> string?) (-> integer? integer?) integer? boolean?)) - (test #f contract-stronger? + (ctest #f contract-stronger? (or/c (-> string?) (-> integer? integer?) integer? char?) (or/c (-> string?) (-> integer? integer?) integer? boolean?)) - (test #f contract-stronger? + (ctest #f contract-stronger? (or/c (-> string?) (-> integer? integer?) integer?) (or/c (-> string?) (-> integer? integer?) integer? boolean?)) - (test #f contract-stronger? + (ctest #f contract-stronger? (or/c (-> string?) (-> integer? integer?) integer?) (or/c (-> integer? integer?) integer?)) - - (let () - (define-contract-struct couple (hd tl)) - (define (non-zero? x) (not (zero? x))) - (define list-of-numbers - (or/c null? - (couple/c number? - (recursive-contract list-of-numbers)))) - (define (short-list/less-than n) - (or/c null? - (couple/c (<=/c n) - (or/c null? - (couple/c (<=/c n) - any/c))))) - (define (short-sorted-list/less-than n) - (or/c null? - (couple/dc - [hd (<=/c n)] - [tl (hd) (or/c null? - (couple/c (<=/c hd) - any/c))]))) - - (define (sorted-list/less-than n) - (or/c null? - (couple/dc - [hd (<=/c n)] - [tl (hd) (sorted-list/less-than hd)]))) - - ;; for some reason, the `n' makes it harder to optimize. without it, this test isn't as good a test - (define (closure-comparison-test n) - (couple/dc - [hd any/c] - [tl (hd) any/c])) - - (test #t contract-stronger? (couple/c any/c any/c) (couple/c any/c any/c)) - (test #f contract-stronger? (couple/c (>=/c 2) (>=/c 3)) (couple/c (>=/c 4) (>=/c 5))) - (test #t contract-stronger? (couple/c (>=/c 4) (>=/c 5)) (couple/c (>=/c 2) (>=/c 3))) - (test #f contract-stronger? (couple/c (>=/c 1) (>=/c 5)) (couple/c (>=/c 5) (>=/c 1))) - (let ([ctc (couple/dc [hd any/c] [tl (hd) any/c])]) - (test #t contract-stronger? ctc ctc)) - (let ([ctc (couple/dc [hd any/c] [tl (hd) (<=/c hd)])]) - (test #t contract-stronger? ctc ctc)) - (test #t contract-stronger? list-of-numbers list-of-numbers) - (test #t contract-stronger? (short-list/less-than 4) (short-list/less-than 5)) - (test #f contract-stronger? (short-list/less-than 5) (short-list/less-than 4)) - (test #t contract-stronger? (short-sorted-list/less-than 4) (short-sorted-list/less-than 5)) - (test #f contract-stronger? (short-sorted-list/less-than 5) (short-sorted-list/less-than 4)) - (test #t contract-stronger? (sorted-list/less-than 4) (sorted-list/less-than 5)) - (test #f contract-stronger? (sorted-list/less-than 5) (sorted-list/less-than 4)) - (test #t contract-stronger? (closure-comparison-test 4) (closure-comparison-test 5))) - + + (contract-eval + `(let () + (define (non-zero? x) (not (zero? x))) + (define list-of-numbers + (or/c null? + (couple/c number? + (recursive-contract list-of-numbers)))) + (define (short-list/less-than n) + (or/c null? + (couple/c (<=/c n) + (or/c null? + (couple/c (<=/c n) + any/c))))) + (define (short-sorted-list/less-than n) + (or/c null? + (couple/dc + [hd (<=/c n)] + [tl (hd) (or/c null? + (couple/c (<=/c hd) + any/c))]))) + + (define (sorted-list/less-than n) + (or/c null? + (couple/dc + [hd (<=/c n)] + [tl (hd) (sorted-list/less-than hd)]))) + + ;; for some reason, the `n' makes it harder to optimize. without it, this test isn't as good a test + (define (closure-comparison-test n) + (couple/dc + [hd any/c] + [tl (hd) any/c])) + + (,test #t contract-stronger? (couple/c any/c any/c) (couple/c any/c any/c)) + (,test #f contract-stronger? (couple/c (>=/c 2) (>=/c 3)) (couple/c (>=/c 4) (>=/c 5))) + (,test #t contract-stronger? (couple/c (>=/c 4) (>=/c 5)) (couple/c (>=/c 2) (>=/c 3))) + (,test #f contract-stronger? (couple/c (>=/c 1) (>=/c 5)) (couple/c (>=/c 5) (>=/c 1))) + (let ([ctc (couple/dc [hd any/c] [tl (hd) any/c])]) + (,test #t contract-stronger? ctc ctc)) + (let ([ctc (couple/dc [hd any/c] [tl (hd) (<=/c hd)])]) + (,test #t contract-stronger? ctc ctc)) + (,test #t contract-stronger? list-of-numbers list-of-numbers) + (,test #t contract-stronger? (short-list/less-than 4) (short-list/less-than 5)) + (,test #f contract-stronger? (short-list/less-than 5) (short-list/less-than 4)) + (,test #t contract-stronger? (short-sorted-list/less-than 4) (short-sorted-list/less-than 5)) + (,test #f contract-stronger? (short-sorted-list/less-than 5) (short-sorted-list/less-than 4)) + (,test #t contract-stronger? (sorted-list/less-than 4) (sorted-list/less-than 5)) + (,test #f contract-stronger? (sorted-list/less-than 5) (sorted-list/less-than 4)) + (,test #t contract-stronger? (closure-comparison-test 4) (closure-comparison-test 5)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; first-order tests ;; - (test #t contract-first-order-passes? (flat-contract integer?) 1) - (test #f contract-first-order-passes? (flat-contract integer?) 'x) - (test #t contract-first-order-passes? (flat-contract boolean?) #t) - (test #f contract-first-order-passes? (flat-contract boolean?) 'x) - (test #t contract-first-order-passes? any/c 1) - (test #t contract-first-order-passes? any/c #t) - (test #t contract-first-order-passes? (-> integer? integer?) (λ (x) #t)) - (test #f contract-first-order-passes? (-> integer? integer?) (λ (x y) #t)) - (test #f contract-first-order-passes? (-> integer? integer?) 'x) - (test #t contract-first-order-passes? (-> integer? boolean? integer?) (λ (x y) #t)) - (test #f contract-first-order-passes? (-> integer? boolean? integer?) (λ (x) #t)) - (test #f contract-first-order-passes? (-> integer? boolean? integer?) (λ (x y z) #t)) + (ctest #t contract-first-order-passes? (flat-contract integer?) 1) + (ctest #f contract-first-order-passes? (flat-contract integer?) 'x) + (ctest #t contract-first-order-passes? (flat-contract boolean?) #t) + (ctest #f contract-first-order-passes? (flat-contract boolean?) 'x) + (ctest #t contract-first-order-passes? any/c 1) + (ctest #t contract-first-order-passes? any/c #t) + (ctest #t contract-first-order-passes? (-> integer? integer?) (λ (x) #t)) + (ctest #f contract-first-order-passes? (-> integer? integer?) (λ (x y) #t)) + (ctest #f contract-first-order-passes? (-> integer? integer?) 'x) + (ctest #t contract-first-order-passes? (-> integer? boolean? integer?) (λ (x y) #t)) + (ctest #f contract-first-order-passes? (-> integer? boolean? integer?) (λ (x) #t)) + (ctest #f contract-first-order-passes? (-> integer? boolean? integer?) (λ (x y z) #t)) - (test #t contract-first-order-passes? (->* (integer?) boolean? (char? any/c)) (λ (x . y) #f)) - (test #f contract-first-order-passes? (->* (integer?) boolean? (char? any/c)) (λ (x y . z) #f)) - (test #f contract-first-order-passes? (->* (integer?) boolean? (char? any/c)) (λ (x) #f)) - (test #t contract-first-order-passes? (->* (integer?) boolean? (char? any/c)) (λ x #f)) + (ctest #t contract-first-order-passes? (->* (integer?) boolean? (char? any/c)) (λ (x . y) #f)) + (ctest #f contract-first-order-passes? (->* (integer?) boolean? (char? any/c)) (λ (x y . z) #f)) + (ctest #f contract-first-order-passes? (->* (integer?) boolean? (char? any/c)) (λ (x) #f)) + (ctest #t contract-first-order-passes? (->* (integer?) boolean? (char? any/c)) (λ x #f)) - (test #t contract-first-order-passes? (->d integer? boolean? (lambda (x y) char?)) (λ (x y) x)) - (test #f contract-first-order-passes? (->d integer? boolean? (lambda (x y) char?)) (λ (x) x)) - (test #f contract-first-order-passes? (->d integer? boolean? (lambda (x y) char?)) (λ (x y z) x)) + (ctest #t contract-first-order-passes? (->d integer? boolean? (lambda (x y) char?)) (λ (x y) x)) + (ctest #f contract-first-order-passes? (->d integer? boolean? (lambda (x y) char?)) (λ (x) x)) + (ctest #f contract-first-order-passes? (->d integer? boolean? (lambda (x y) char?)) (λ (x y z) x)) - (test #t contract-first-order-passes? (list-immutableof integer?) (list-immutable 1)) - (test #f contract-first-order-passes? (list-immutableof integer?) (list 1)) - (test #f contract-first-order-passes? (list-immutableof integer?) #f) + (ctest #t contract-first-order-passes? (list-immutableof integer?) (list-immutable 1)) + (ctest #f contract-first-order-passes? (list-immutableof integer?) (list 1)) + (ctest #f contract-first-order-passes? (list-immutableof integer?) #f) - (test #t contract-first-order-passes? (vector-immutableof integer?) (vector->immutable-vector (vector 1))) - (test #f contract-first-order-passes? (vector-immutableof integer?) 'x) - (test #f contract-first-order-passes? (vector-immutableof integer?) '()) + (ctest #t contract-first-order-passes? (vector-immutableof integer?) (vector->immutable-vector (vector 1))) + (ctest #f contract-first-order-passes? (vector-immutableof integer?) 'x) + (ctest #f contract-first-order-passes? (vector-immutableof integer?) '()) - (test #t contract-first-order-passes? (promise/c integer?) (delay 1)) - (test #f contract-first-order-passes? (promise/c integer?) 1) + (ctest #t contract-first-order-passes? (promise/c integer?) (delay 1)) + (ctest #f contract-first-order-passes? (promise/c integer?) 1) - (test #t contract-first-order-passes? (->d* (integer? boolean?) (lambda (x y) char?)) (λ (x y) #t)) - (test #f contract-first-order-passes? (->d* (integer? boolean?) (lambda (x y) char?)) (λ (x) #t)) - (test #f contract-first-order-passes? (->d* (integer? boolean?) (lambda (x y) char?)) (λ (x y z) #t)) + (ctest #t contract-first-order-passes? (->d* (integer? boolean?) (lambda (x y) char?)) (λ (x y) #t)) + (ctest #f contract-first-order-passes? (->d* (integer? boolean?) (lambda (x y) char?)) (λ (x) #t)) + (ctest #f contract-first-order-passes? (->d* (integer? boolean?) (lambda (x y) char?)) (λ (x y z) #t)) - (test #t contract-first-order-passes? + (ctest #t contract-first-order-passes? (->d* (integer? boolean?) any/c (lambda (x y . z) char?)) (λ (x y . z) z)) - (test #t contract-first-order-passes? + (ctest #t contract-first-order-passes? (->d* (integer? boolean?) any/c (lambda (x y . z) char?)) (λ (y . z) z)) - (test #t contract-first-order-passes? + (ctest #t contract-first-order-passes? (->d* (integer? boolean?) any/c (lambda (x y . z) char?)) (λ z z)) - (test #f contract-first-order-passes? + (ctest #f contract-first-order-passes? (->d* (integer? boolean?) any/c (lambda (x y . z) char?)) (λ (x y z . w) 1)) - (test #f contract-first-order-passes? + (ctest #f contract-first-order-passes? (->d* (integer? boolean?) any/c (lambda (x y . z) char?)) (λ (x y) 1)) - (test #t contract-first-order-passes? (->r ((x number?)) number?) (λ (x) 1)) - (test #f contract-first-order-passes? (->r ((x number?)) number?) (λ (x y) 1)) - (test #f contract-first-order-passes? (->r ((x number?)) number?) (λ () 1)) - (test #t contract-first-order-passes? (->r ((x number?)) number?) (λ args 1)) + (ctest #t contract-first-order-passes? (->r ((x number?)) number?) (λ (x) 1)) + (ctest #f contract-first-order-passes? (->r ((x number?)) number?) (λ (x y) 1)) + (ctest #f contract-first-order-passes? (->r ((x number?)) number?) (λ () 1)) + (ctest #t contract-first-order-passes? (->r ((x number?)) number?) (λ args 1)) - (test #t contract-first-order-passes? (->pp ((x number?)) #t number? blech #t) (λ (x) 1)) - (test #f contract-first-order-passes? (->pp ((x number?)) #t number? blech #t) (λ () 1)) - (test #t contract-first-order-passes? (->pp ((x number?)) #t number? blech #t) (λ (x . y) 1)) + (ctest #t contract-first-order-passes? (->pp ((x number?)) #t number? blech #t) (λ (x) 1)) + (ctest #f contract-first-order-passes? (->pp ((x number?)) #t number? blech #t) (λ () 1)) + (ctest #t contract-first-order-passes? (->pp ((x number?)) #t number? blech #t) (λ (x . y) 1)) - (test #f contract-first-order-passes? + (ctest #f contract-first-order-passes? (case-> (-> integer? integer?) (-> integer? integer? integer?)) (λ () 1)) - (test #f contract-first-order-passes? + (ctest #f contract-first-order-passes? (case-> (-> integer? integer?) (-> integer? integer? integer?)) (λ (x) 1)) - (test #f contract-first-order-passes? + (ctest #f contract-first-order-passes? (case-> (-> integer? integer?) (-> integer? integer? integer?)) (λ (x y) 1)) - (test #f contract-first-order-passes? + (ctest #f contract-first-order-passes? (case->) 1) - (test #t contract-first-order-passes? + (ctest #t contract-first-order-passes? (case->) (case-lambda)) - (test #t contract-first-order-passes? + (ctest #t contract-first-order-passes? (case-> (-> integer? integer?) (-> integer? integer? integer?)) (case-lambda [(x) x] [(x y) x])) - (test #t contract-first-order-passes? + (ctest #t contract-first-order-passes? (case-> (-> integer? integer?) (-> integer? integer? integer?)) (case-lambda [() 1] [(x) x] [(x y) x])) - (test #t contract-first-order-passes? + (ctest #t contract-first-order-passes? (case-> (-> integer? integer?) (-> integer? integer? integer?)) (case-lambda [() 1] [(x) x] [(x y) x] [(x y z) x])) - (test #t contract-first-order-passes? (and/c (-> positive? positive?) (-> integer? integer?)) (λ (x) x)) - (test #t contract-first-order-passes? (and/c (-> positive? positive?) (-> integer? integer?)) values) - (test #f contract-first-order-passes? (and/c (-> integer?) (-> integer? integer?)) (λ (x) x)) + (ctest #t contract-first-order-passes? (and/c (-> positive? positive?) (-> integer? integer?)) (λ (x) x)) + (ctest #t contract-first-order-passes? (and/c (-> positive? positive?) (-> integer? integer?)) values) + (ctest #f contract-first-order-passes? (and/c (-> integer?) (-> integer? integer?)) (λ (x) x)) - (test #t contract-first-order-passes? + (ctest #t contract-first-order-passes? (cons-immutable/c boolean? (-> integer? integer?)) (list*-immutable #t (λ (x) x))) - (test #t contract-first-order-passes? + (ctest #t contract-first-order-passes? (cons-immutable/c boolean? (-> integer? integer?)) (list*-immutable 1 2)) - (test #f contract-first-order-passes? (flat-rec-contract the-name) 1) + (ctest #f contract-first-order-passes? (flat-rec-contract the-name) 1) + + (ctest #t contract-first-order-passes? + (object-contract (m (-> integer? integer?))) + (new object%)) + (ctest #t contract-first-order-passes? + (object-contract (m (-> integer? integer?))) + 1) + + (ctest #t contract-first-order-passes? + (couple/c any/c any/c) + (make-couple 1 2)) + + (ctest #f contract-first-order-passes? + (couple/c any/c any/c) + 2) + + (ctest #t contract-first-order-passes? + (couple/dc [hd any/c] [tl any/c]) + (make-couple 1 2)) + + (ctest #f contract-first-order-passes? + (couple/dc [hd any/c] [tl any/c]) + 1) + + (ctest #t contract-first-order-passes? + (couple/dc [hd any/c] [tl (hd) any/c]) + (make-couple 1 2)) + + (ctest #f contract-first-order-passes? + (couple/dc [hd any/c] [tl (hd) any/c]) + 1) - (test #t contract-first-order-passes? - (object-contract (m (-> integer? integer?))) - (new object%)) - (test #t contract-first-order-passes? - (object-contract (m (-> integer? integer?))) - 1) + (ctest #t contract-first-order-passes? (or/c (-> (>=/c 5) (>=/c 5)) boolean?) #t) + (ctest #t contract-first-order-passes? (or/c (-> (>=/c 5) (>=/c 5)) boolean?) (λ (x) x)) + (ctest #f contract-first-order-passes? (or/c (-> (>=/c 5) (>=/c 5)) boolean?) 'x) - (let () - (define-contract-struct couple (hd tl)) - (test #t contract-first-order-passes? - (couple/c any/c any/c) - (make-couple 1 2)) - - (test #f contract-first-order-passes? - (couple/c any/c any/c) - 2) - - (test #t contract-first-order-passes? - (couple/dc [hd any/c] [tl any/c]) - (make-couple 1 2)) - - (test #f contract-first-order-passes? - (couple/dc [hd any/c] [tl any/c]) - 1) - - (test #t contract-first-order-passes? - (couple/dc [hd any/c] [tl (hd) any/c]) - (make-couple 1 2)) - - (test #f contract-first-order-passes? - (couple/dc [hd any/c] [tl (hd) any/c]) - 1)) - - (test #t contract-first-order-passes? (or/c (-> (>=/c 5) (>=/c 5)) boolean?) #t) - (test #t contract-first-order-passes? (or/c (-> (>=/c 5) (>=/c 5)) boolean?) (λ (x) x)) - (test #f contract-first-order-passes? (or/c (-> (>=/c 5) (>=/c 5)) boolean?) 'x) - - (test #t contract-first-order-passes? + (ctest #t contract-first-order-passes? (or/c (-> integer? integer? integer?) (-> integer? integer?)) (λ (x) x)) - (test #t contract-first-order-passes? + (ctest #t contract-first-order-passes? (or/c (-> integer? integer? integer?) (-> integer? integer?)) (λ (x y) x)) - (test #f contract-first-order-passes? + (ctest #f contract-first-order-passes? (or/c (-> integer? integer? integer?) (-> integer? integer?)) (λ () x)) - (test #f contract-first-order-passes? + (ctest #f contract-first-order-passes? (or/c (-> integer? integer? integer?) (-> integer? integer?)) 1) @@ -4348,7 +4321,7 @@ so that propagation occurs. (or/c boolean? (-> (>=/c 5) (>=/c 5)))) - (test 1 + (ctest 1 length (let ([f (contract (-> integer? any) (lambda (x) @@ -4359,7 +4332,7 @@ so that propagation occurs. (with-continuation-mark 'x 'x (f 1)))) - (test 2 + (ctest 2 length (let ([f (contract (-> integer? list?) (lambda (x) @@ -4380,9 +4353,9 @@ so that propagation occurs. 'provide/contract1 '(let () (eval '(module contract-test-suite1 mzscheme - (require (lib "contract.ss")) - (define x 1) - (provide/contract (x integer?)))) + (require (lib "contract.ss")) + (define x 1) + (provide/contract (x integer?)))) (eval '(require contract-test-suite1)) (eval 'x))) @@ -4390,8 +4363,8 @@ so that propagation occurs. 'provide/contract2 '(let () (eval '(module contract-test-suite2 mzscheme - (require (lib "contract.ss")) - (provide/contract))) + (require (lib "contract.ss")) + (provide/contract))) (eval '(require contract-test-suite2)))) (test/spec-failed @@ -4407,7 +4380,7 @@ so that propagation occurs. (test/spec-passed 'provide/contract4 - '(parameterize ([current-namespace (make-namespace)]) + '(begin (eval '(module contract-test-suite4 mzscheme (require (lib "contract.ss")) (define-struct s (a)) @@ -4420,7 +4393,7 @@ so that propagation occurs. (test/spec-passed/result 'provide/contract4-b - '(parameterize ([current-namespace (make-namespace)]) + '(begin (eval '(module contract-test-suite4-b mzscheme (require (lib "contract.ss")) (define-struct s (a b)) @@ -4438,7 +4411,7 @@ so that propagation occurs. (test/spec-passed 'provide/contract5 - '(parameterize ([current-namespace (make-namespace)]) + '(begin (eval '(module contract-test-suite5 mzscheme (require (lib "contract.ss")) (define-struct s (a)) @@ -4457,17 +4430,7 @@ so that propagation occurs. (test/spec-passed 'provide/contract6 - '(parameterize ([current-namespace (make-namespace)]) - (eval '(module contract-test-suite6 mzscheme - (require (lib "contract.ss")) - (define-struct s (a)) - (provide/contract (struct s ((a any/c)))))) - (eval '(require contract-test-suite6)) - (eval '(define-struct (t s) ())))) - - (test/spec-passed - 'provide/contract6 - '(parameterize ([current-namespace (make-namespace)]) + '(begin (eval '(module contract-test-suite6 mzscheme (require (lib "contract.ss")) (define-struct s (a)) @@ -4477,7 +4440,7 @@ so that propagation occurs. (test/spec-passed 'provide/contract6b - '(parameterize ([current-namespace (make-namespace)]) + '(begin (eval '(module contract-test-suite6b mzscheme (require (lib "contract.ss")) (define-struct s_ (a)) @@ -4495,7 +4458,7 @@ so that propagation occurs. (test/spec-passed 'provide/contract7 - '(parameterize ([current-namespace (make-namespace)]) + '(begin (eval '(module contract-test-suite7 mzscheme (require (lib "contract.ss")) (define-struct s (a b)) @@ -4513,7 +4476,7 @@ so that propagation occurs. (test/spec-passed 'provide/contract8 - '(parameterize ([current-namespace (make-namespace)]) + '(begin (eval '(module contract-test-suite8 mzscheme (require (lib "contract.ss")) (define-struct i-s (contents)) @@ -4525,7 +4488,7 @@ so that propagation occurs. (test/spec-passed 'provide/contract9 - '(parameterize ([current-namespace (make-namespace)]) + '(begin (eval '(module contract-test-suite9 mzscheme (require (lib "contract.ss")) (define the-internal-name 1) @@ -4536,71 +4499,71 @@ so that propagation occurs. (test/spec-passed 'provide/contract10 - '(parameterize ([current-namespace (make-namespace)]) - (eval '(module m mzscheme + '(begin + (eval '(module pc10-m mzscheme (require (lib "contract.ss")) (define-struct s (a b) (make-inspector)) (provide/contract (struct s ((a number?) (b number?)))))) - (eval '(module n mzscheme + (eval '(module pc10-n mzscheme (require (lib "struct.ss") - m) + pc10-m) (print-struct #t) (copy-struct s (make-s 1 2) [s-a 3]))) - (eval '(require n)))) + (eval '(require pc10-n)))) (test/spec-passed 'provide/contract11 - '(parameterize ([current-namespace (make-namespace)]) - (eval '(module m mzscheme + '(begin + (eval '(module pc11-m mzscheme (require (lib "contract.ss")) (define x 1) (provide/contract [rename x y integer?] [rename x z integer?]))) - (eval '(module n mzscheme - (require m) + (eval '(module pc11-n mzscheme + (require pc11-m) (+ y z))) - (eval '(require n)))) + (eval '(require pc11-n)))) ;; this test is broken, not sure why #| (test/spec-failed - 'provide/contract11 + 'provide/contract11b '(parameterize ([current-namespace (make-namespace)]) - (eval '(module m mzscheme + (eval '(module pc11b-m mzscheme (require (lib "contract.ss")) (define-struct s (a b) (make-inspector)) (provide/contract (struct s ((a number?) (b number?)))))) - (eval '(module n mzscheme + (eval '(module pc11b-n mzscheme (require (lib "struct.ss") m) (print-struct #t) (copy-struct s (make-s 1 2) [s-a #f]))) - (eval '(require n))) + (eval '(require pc11b-n))) 'n) |# (test/spec-passed 'provide/contract12 - '(parameterize ([current-namespace (make-namespace)]) - (eval '(module m mzscheme + '(begin + (eval '(module pc12-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)))) + (eval '(require pc12-m)))) (test/spec-passed/result 'provide/contract13 - '(parameterize ([current-namespace (make-namespace)]) - (eval '(module common-msg-structs mzscheme + '(begin + (eval '(module pc13-common-msg-structs mzscheme (require (lib "contract.ss" "mzlib")) (define-struct register (name type) (make-inspector)) (provide/contract (struct register ([name any/c] [type any/c]))))) - (eval '(require common-msg-structs)) + (eval '(require pc13-common-msg-structs)) (eval '(require (lib "plt-match.ss"))) (eval '(match (make-register 1 2) [(struct register (name type)) @@ -4609,8 +4572,8 @@ so that propagation occurs. (test/spec-passed 'provide/contract14 - '(parameterize ([current-namespace (make-namespace)]) - (eval '(module test1 mzscheme + '(begin + (eval '(module pc14-test1 mzscheme (require (lib "contract.ss")) (define-struct type (flags)) @@ -4623,16 +4586,16 @@ so that propagation occurs. (struct (type:ptr type) ([flags (listof string?)] [type type?]))))) - (eval '(module test2 mzscheme + (eval '(module pc14-test2 mzscheme (require (lib "plt-match.ss")) - (require test1) + (require pc14-test1) (match (make-type:ptr '() (make-type '())) [(struct type:ptr (flags type)) #f]))) - (eval '(require test2)))) + (eval '(require pc14-test2)))) ;; make sure unbound identifier exception is raised. - (error-test - #'(parameterize ([current-namespace (make-namespace)]) + (contract-error-test + #'(begin (eval '(module pos mzscheme (require (lib "contract.ss")) (provide/contract [i any/c])))) @@ -4642,7 +4605,7 @@ so that propagation occurs. ;; this test is bogus, because provide/contract'd variables can be set!'d. (test/pos-blame 'provide/contract15 - '(parameterize ([current-namespace (make-namespace)]) + '(begin (eval '(module pos mzscheme (require (lib "contract.ss")) (define i #f) @@ -4652,7 +4615,7 @@ so that propagation occurs. ;; this is really a positive violation, but name the module `neg' just for an addl test (test/neg-blame 'provide/contract16 - '(parameterize ([current-namespace (make-namespace)]) + '(begin (eval '(module neg mzscheme (require (lib "contract.ss")) (define i #f) @@ -4664,7 +4627,7 @@ so that propagation occurs. #; (test/neg-blame 'provide/contract17 - '(parameterize ([current-namespace (make-namespace)]) + '(begin (eval '(module pos mzscheme (require (lib "contract.ss")) (define-struct s (a)) @@ -4675,55 +4638,63 @@ so that propagation occurs. (make-t #f))) (eval '(require neg)))) + (test/spec-passed + 'provide/contract18 + '(begin + (eval '(module pc18-pos mzscheme + (require (lib "contract.ss")) + (define-struct s ()) + (provide/contract [struct s ()]))) + (eval '(require pc18-pos)) + (eval '(make-s)))) - (error-test - #'(parameterize ([current-namespace (make-namespace)]) - (eval '(module bug mzscheme + (contract-error-test + #'(begin + (eval '(module pce1-bug mzscheme (require (lib "contract.ss")) (define the-defined-variable1 'five) (provide/contract [the-defined-variable1 number?]))) - (eval '(require bug))) + (eval '(require pce1-bug))) (λ (x) (and (exn? x) (regexp-match #rx"on the-defined-variable1" (exn-message x))))) - (error-test - #'(parameterize ([current-namespace (make-namespace)]) - (eval '(module bug mzscheme + (contract-error-test + #'(begin + (eval '(module pce2-bug mzscheme (require (lib "contract.ss")) (define the-defined-variable2 values) (provide/contract [the-defined-variable2 (-> number? any)]))) - (eval '(require bug)) + (eval '(require pce2-bug)) (eval '(the-defined-variable2 #f))) (λ (x) (and (exn? x) (regexp-match #rx"on the-defined-variable2" (exn-message x))))) - (error-test - #'(parameterize ([current-namespace (make-namespace)]) - (eval '(module bug mzscheme + (contract-error-test + #'(begin + (eval '(module pce3-bug mzscheme (require (lib "contract.ss")) (define the-defined-variable3 (λ (x) #f)) (provide/contract [the-defined-variable3 (-> any/c number?)]))) - (eval '(require bug)) + (eval '(require pce3-bug)) (eval '(the-defined-variable3 #f))) (λ (x) (and (exn? x) (regexp-match #rx"on the-defined-variable3" (exn-message x))))) - (error-test - #'(parameterize ([current-namespace (make-namespace)]) - (eval '(module bug mzscheme + (contract-error-test + #'(begin + (eval '(module pce4-bug mzscheme (require (lib "contract.ss")) (define the-defined-variable4 (λ (x) #f)) (provide/contract [the-defined-variable4 (-> any/c number?)]))) - (eval '(require bug)) + (eval '(require pce4-bug)) (eval '((if #t the-defined-variable4) #f))) (λ (x) (and (exn? x) (regexp-match #rx"on the-defined-variable4" (exn-message x))))) - + (report-errs) )) -(report-errs)