diff --git a/pkgs/plt-services/meta/props b/pkgs/plt-services/meta/props index 6f49d4c188..9360e9f8c1 100755 --- a/pkgs/plt-services/meta/props +++ b/pkgs/plt-services/meta/props @@ -1228,7 +1228,7 @@ path/s is either such a string or a list of them. "pkgs/racket-pkgs/racket-test/tests/racket/contract-opt-tests.rkt" responsible (robby) drdr:command-line (racket "-r" *) "pkgs/racket-pkgs/racket-test/tests/racket/contract-stress-argmin.rkt" responsible (robby) drdr:command-line (racket "-r" *) "pkgs/racket-pkgs/racket-test/tests/racket/contract-stress-take-right.rkt" responsible (robby) drdr:command-line (racket "-r" *) -"pkgs/racket-pkgs/racket-test/tests/racket/contract-test.rktl" responsible (robby) drdr:command-line (racket "-r" *) +"pkgs/racket-pkgs/racket-test/tests/racket/contract" responsible (robby) "pkgs/racket-pkgs/racket-test/tests/racket/date.rktl" drdr:random #t "pkgs/racket-pkgs/racket-test/tests/racket/embed-me4.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/embed-me9.rkt" drdr:command-line #f diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract-test.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/contract-test.rktl deleted file mode 100644 index 9b1be4bbfb..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/contract-test.rktl +++ /dev/null @@ -1,15824 +0,0 @@ - -(load-relative "loadtest.rktl") -(Section 'contract) - -(parameterize ([error-print-width 200]) -(let () - - (define contract-namespace - (let ([n (make-base-namespace)]) - (parameterize ([current-namespace n]) - (namespace-require '(for-syntax scheme/base)) - (namespace-require '(for-template scheme/base)) - (namespace-require 'scheme/contract) - (namespace-require 'scheme/set) - (namespace-require '(only racket/contract/private/arrow procedure-accepts-and-more?)) - (namespace-require '(only racket/contract/private/blame blame-fmt->-string make-blame)) - (namespace-require 'scheme/class) - (namespace-require 'scheme/promise) - (namespace-require 'scheme/match)) - n)) - - (define (contract-eval x) - (parameterize ([current-namespace contract-namespace]) - (eval x))) - - (define (contract-compile x) - (parameterize ([current-namespace contract-namespace]) - (compile x))) - - (define (contract-expand-once x) - (parameterize ([current-namespace contract-namespace]) - (expand-once x))) - - (define exn:fail:contract:blame-object (contract-eval 'exn:fail:contract:blame-object)) - (define exn:fail:contract:blame? (contract-eval 'exn:fail:contract:blame?)) - - (define-syntax (ctest stx) - (syntax-case stx () - [(_ a ...) - (syntax (contract-eval `(,test a ...)))])) - - (define-syntax (ctest-no-error stx) - (syntax-case stx () - [(_ name e) - (syntax - (ctest - #t - name - (with-handlers ([exn:fail? (lambda (x) `(exn ,(exn-message x)))]) - e - #t)))])) - - (define (contract-error-test name exp exn-ok?) - (test #t - name - (contract-eval `(with-handlers ((exn:fail? (λ (x) (and (,exn-ok? x) #t)))) ,exp)))) - - (define (contract-syntax-error-test name exp [reg #rx""]) - (test #t - name - (contract-eval `(with-handlers ((exn:fail:syntax? - (lambda (x) (and (regexp-match ,reg (exn-message x)) #t)))) - (eval ',exp))))) - - ;; test/spec-passed : symbol sexp -> void - ;; tests a passing specification - (define (test/spec-passed name expression) - (printf "testing: ~s\n" name) - (parameterize ([compile-enforce-module-constants #f]) - (contract-eval - `(,test - (void) - (let ([for-each-eval (lambda (l) (for-each eval l))]) for-each-eval) - (list ',expression '(void)))) - (let ([new-expression (rewrite-out expression)]) - (when new-expression - (contract-eval - `(,test - (void) - (let ([for-each-eval (lambda (l) (for-each eval l))]) for-each-eval) - (list ',new-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) - (parameterize ([compile-enforce-module-constants #f]) - (printf "testing: ~s\n" name) - (contract-eval `(,test ',result eval ',expression)) - (let/ec k - (contract-eval - `(,test - ',result - eval - ',(rewrite expression k)))) - (let ([new-expression (rewrite-out expression)]) - (when new-expression - (printf "testing contract-out rewritten: ~s\n" name) - (contract-eval - `(,test - ',result - eval - ',new-expression)))))) - - ;; rewrites `provide/contract' to use `contract-out' - (define (rewrite-out orig-exp) - (define rewrote? #f) - (define maybe-rewritten? - (let loop ([exp orig-exp]) - (match exp - [`(module ,modname ,lang ,bodies ...) - (define at-beginning '()) - (define at-end '()) - - ;; remove (and save) the provide/contract & contract-out - ;; declarations, switching their senses - (define removed-bodies - (apply - append - (for/list ([body (in-list bodies)]) - (match body - [`(provide/contract . ,args) - (set! rewrote? #t) - (set! at-beginning (cons `(provide (contract-out . ,args)) - at-beginning)) - (list)] - [`(provide (contract-out . ,args)) - (set! rewrote? #t) - (set! at-end (cons `(provide/contract . ,args) - at-end)) - (list)] - [else - (list body)])))) - - ;; insert the provide/contract (rewrite to contract-out) after the - ;; first require that has 'contract' in it - (define inserted-bodies - (if (equal? lang 'racket) - (append (reverse at-beginning) - removed-bodies) - (apply - append - (for/list ([body (in-list removed-bodies)]) - (match body - [`(require . ,(? (λ (l) - (for/or ([x (in-list l)]) - (and (symbol? x) - (regexp-match #rx"contract" (symbol->string x))))))) - (cons body (reverse at-beginning))] - [else - (list body)]))))) - - `(module ,modname ,lang - (void) ;; always insert this to work around bug in 'provide' - ,@inserted-bodies ,@(reverse at-end))] - [(? list?) - (map loop exp)] - [else exp]))) - - (and rewrote? maybe-rewritten?)) - - ;; 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]))) - - ;; blame : (or/c 'pos 'neg string?) - ;; if blame is a string, expect to find the string (format "blaming: ~a" blame) in the exn message - (define (test/spec-failed name expression blame) - (let () - (define (has-proper-blame? msg) - (define reg - (cond - [(eq? blame 'pos) #rx"blaming: pos"] - [(eq? blame 'neg) #rx"blaming: neg"] - [(string? blame) (string-append "blaming: " (regexp-quote blame))] - [else #f])) - - (when reg - (unless (regexp-match? reg msg) - (eprintf "ACK!! ~s ~s\n" blame msg) - (custodian-shutdown-all (current-custodian)))) - (and reg (regexp-match? reg msg))) - (printf "testing: ~s\n" name) - (contract-eval - `(,thunk-error-test - (lambda () ,expression) - (datum->syntax #'here ',expression) - (lambda (exn) - (and (exn:fail:contract:blame? exn) - (,has-proper-blame? (exn-message exn)))))) - (let/ec k - (let ([rewritten (rewrite expression k)]) - (contract-eval - `(,thunk-error-test - (lambda () ,rewritten) - (datum->syntax #'here ',rewritten) - (lambda (exn) - (and (exn:fail:contract:blame? exn) - (,has-proper-blame? (exn-message exn)))))))))) - - (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-syntax (ctest/rewrite stx) - (syntax-case stx () - [(_ expected name expression) - #'(begin - (contract-eval `(,test expected name expression)) - (let/ec k - (contract-eval `(,test expected - ',(string->symbol (format "~a+opt/c" name)) - ,(rewrite 'expression k)))))])) - - (define (test/well-formed stx) - (contract-eval - `(,test (void) - (let ([expand/ret-void (lambda (x) (expand x) (void))]) expand/ret-void) - ,stx))) - - (define (test/no-error sexp) - (contract-eval - `(,test (void) - eval - '(begin ,sexp (void)))) - (let/ec k - (contract-eval - `(,test (void) - eval - '(begin ,(rewrite sexp k) (void)))))) - - (define (test-flat-contract contract pass fail) - (contract-eval `(,test #t flat-contract? ,contract)) - (define (run-two-tests maybe-rewrite) - (let ([name (if (pair? contract) - (car contract) - contract)]) - (let/ec k - (test/spec-failed (format "~a fail" name) - (maybe-rewrite `(contract ,contract ',fail 'pos 'neg) k) - 'pos)) - (let/ec k - (test/spec-passed/result - (format "~a pass" name) - (maybe-rewrite `(contract ,contract ',pass 'pos 'neg) k) - pass)))) - (run-two-tests (λ (x k) x)) - (run-two-tests rewrite)) - - (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)))) - - - (define (test-obligations quoted-expr expected-props) - - (define (cleanup key obj stx) - (case key - [(racket/contract:contract) - (define (cleanup-ent x) - (sort (map syntax->datum (vector-ref obj x)) string<=? #:key (λ (x) (format "~s" x)))) - (list key (cleanup-ent 1) (cleanup-ent 2))] - [(racket/contract:positive-position racket/contract:negative-position) - (list key (syntax->datum stx))] - [(racket/contract:contract-on-boundary) - `(racket/contract:contract-on-boundary ,(syntax->datum stx))] - [(racket/contract:internal-contract) - `(racket/contract:internal-contract ,(syntax->datum stx))] - [else - (error 'test-obligations "unknown property ~s" key)])) - - (let ([props '()]) - (let ([stx (contract-expand-once quoted-expr)]) - (let loop ([stx stx]) - (cond - [(syntax? stx) - (for ([key (in-list (syntax-property-symbol-keys stx))]) - (when (regexp-match #rx"^racket/contract:" (symbol->string key)) - (set! props (cons (cleanup key (syntax-property stx key) stx) - props)))) - (loop (syntax-e stx))] - [(pair? stx) - (loop (car stx)) - (loop (cdr stx))]))) - (test expected-props - `(obligations-for ,quoted-expr) - (sort props string<=? #:key (λ (x) (format "~s" x)))))) - - -; -; -; -; ; ; ;; -; ;; ;; ;; -; ;;;;; ;;;; ;;;; ;;; ;;;;; ;;;;; ;;; ;;; ;;;; ;;;; ;;;;; ;;;;; ;;;; ;;;; ;;; -; ;;;;;; ;;;;;; ;;;;;;;;; ;;;;;; ;;;;;; ;;;;;;; ;;;; ;;;; ;;;;;; ;;;;;; ;;;; ;;;;;; ;;;;;;;;; -; ;;;;;;; ;;;;;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;; ;;;; ;;;; ;;;;;;; ;;;; ;;;; ;;;;;;;; ;;;; ;;;; -; ;;;; ;;;; ;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;; ;;;; ;;;; -; ;;;;;;; ;;;;;;;; ;;;; ;;;; ;;;; ;;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;;; ;;;; ;;;;;;;; ;;;; ;;;; -; ;;;;;; ;;;;;; ;;;; ;;;; ;;;;;; ;;;;; ;;;; ;;;;;;;;; ;;;;;; ;;;;; ;;;; ;;;;;; ;;;; ;;;; -; ;;;;; ;;;; ;;;; ;;;; ;;;;; ;;;; ;;;; ;;; ;;;; ;;;;; ;;;; ;;;; ;;;; ;;;; ;;;; -; -; -; - - (test/no-error '(-> integer? integer?)) - (test/no-error '(-> (flat-contract integer?) (flat-contract integer?))) - (test/no-error '(-> integer? any)) - (test/no-error '(-> (flat-contract integer?) any)) - - (test/no-error '(->* (integer?) () (values integer?))) - (test/no-error '(->* (integer?) () #:rest integer? integer?)) - (test/no-error '(->* (integer?) () #:rest integer? any)) - (test/no-error '(->* ((flat-contract integer?)) () (flat-contract integer?))) - (test/no-error '(->* ((flat-contract integer?)) () #:rest (flat-contract integer?) - (flat-contract integer?))) - (test/no-error '(->* ((flat-contract integer?)) () #:rest (flat-contract integer?) - (values (flat-contract integer?) (flat-contract boolean?)))) - (test/no-error '(->* ((flat-contract integer?)) () #:rest (flat-contract integer?) any)) - (test/no-error '(->* ((flat-contract integer?)) () #:pre #t (flat-contract integer?) #:post #t)) - - (test/no-error '(->d ([x integer?]) ([y integer?]) any)) - (test/no-error '(->d ([x integer?]) ([y integer?]) (values [a number?] [b boolean?]))) - (test/no-error '(->d ([x integer?] #:z [z integer?]) ([y integer?] #:w [w integer?]) - (range boolean?))) - (test/no-error '(->d ([x integer?] #:z [z integer?]) ([y integer?] #:w [w integer?]) - #:rest rest any/c (range boolean?))) - (test/no-error '(->d ([x integer?] #:z [z integer?]) #:rest rest any/c (range boolean?))) - - (test/no-error '(->i ([x integer?]) ([y integer?]) any)) - (test/no-error '(->i ([x integer?]) ([y integer?]) (values [a number?] [b boolean?]))) - (test/no-error '(->i ([x integer?] #:z [z integer?]) ([y integer?] #:w [w integer?]) - (range boolean?))) - (test/no-error '(->i ([x integer?] #:z [z integer?]) ([y integer?] #:w [w integer?]) - #:rest [rest any/c] (range boolean?))) - (test/no-error '(->i ([x integer?] #:z [z integer?]) #:rest [rest any/c] (range boolean?))) - - (test/no-error '(unconstrained-domain-> number?)) - (test/no-error '(unconstrained-domain-> (flat-contract number?))) - - (test/no-error '(listof any/c)) - (test/no-error '(listof (lambda (x) #t))) - (test/no-error '(((lambda (x) x) listof) #t)) - (test/no-error '(non-empty-listof any/c)) - (test/no-error '(non-empty-listof (lambda (x) #t))) - - - (test/no-error '(list/c 'x "x" #t #f #\c #rx"a" #rx#"b")) - - - -; -; -; -; ;;;; -; ;;;;;; -; ;;;;;;; ;;;; ;;; ;;; ;;; ;;; ;; ;;;; ;;; ;;;; ;;;; ;;; ;;; -; ;;;;;;;; ;;;;;;;;; ;;; ;;;; ;;;;; ;;;;;;;;; ;;;;;; ;;;;;;;;; ;;;;; -; ;;;; ;;;; ;;;; ;;;;;; ;;; ;;; ;;;; ;;;; ;;;;;;;; ;;;; ;;;; ;;;; ;; -; ;;;;;;; ;;;; ;;;; ;;;;;; ;;;;;;; ;;;; ;;;; ;;;; ;;; ;;;; ;;;; ;;;;;;; -; ;; ;;;; ;;;; ;;;; ;;;;; ;;; ;;;; ;;;; ;;;; ;;;;;;;; ;;;; ;;;; ;;;;; -; ;;;;;;;; ;;;; ;;;; ;;;; ;;;;;;;;; ;;;; ;;;; ;;;;;; ;;;; ;;;; ;;;;;; -; ;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; -; ;;;; -; ;;;; -; - - - (test/spec-passed/result 'any/c '(contract any/c 1 'pos 'neg) 1) - (test/pos-blame 'none/c '(contract none/c 1 'pos 'neg)) - - -; -; -; -; ;;; -; ; ; ;;; ; -; ;;; ;;;;;;;;; -; ;;;; ;;;;;;; -; ;;; ;;;;;;; -; ;;;;; ;;; ;;;;;;;;; -; ;;;;; ;;;; ; ;;; ; -; ;;; ;;; -; ; -; -; -; - - - (test/spec-passed - 'contract-arrow-star0a - '(contract (->* (integer?) () integer?) - (lambda (x) x) - 'pos - 'neg)) - - (test/neg-blame - 'contract-arrow-star0b - '((contract (->* (integer?) () integer?) - (lambda (x) x) - 'pos - 'neg) - #f)) - - (test/pos-blame - 'contract-arrow-star0c - '((contract (->* (integer?) () integer?) - (lambda (x) #f) - 'pos - 'neg) - 1)) - - (test/spec-passed - 'contract-arrow-star1 - '(let-values ([(a b) ((contract (->* (integer?) () (values integer? integer?)) - (lambda (x) (values x x)) - 'pos - 'neg) - 2)]) - 1)) - - (test/neg-blame - 'contract-arrow-star2 - '((contract (->* (integer?) () (values integer? integer?)) - (lambda (x) (values x x)) - 'pos - 'neg) - #f)) - - (test/pos-blame - 'contract-arrow-star3 - '((contract (->* (integer?) () (values integer? integer?)) - (lambda (x) (values 1 #t)) - 'pos - 'neg) - 1)) - - (test/pos-blame - 'contract-arrow-star4 - '((contract (->* (integer?) () (values integer? integer?)) - (lambda (x) (values #t 1)) - 'pos - 'neg) - 1)) - - - (test/spec-passed - 'contract-arrow-star5 - '(let-values ([(a b) ((contract (->* (integer?) () - #:rest (listof integer?) - (values integer? integer?)) - (lambda (x . y) (values x x)) - 'pos - 'neg) - 2)]) - 1)) - - (test/neg-blame - 'contract-arrow-star6 - '((contract (->* (integer?) () #:rest (listof integer?) (values integer? integer?)) - (lambda (x . y) (values x x)) - 'pos - 'neg) - #f)) - - (test/pos-blame - 'contract-arrow-star7 - '((contract (->* (integer?) () #:rest (listof integer?) (values integer? integer?)) - (lambda (x . y) (values 1 #t)) - 'pos - 'neg) - 1)) - - (test/pos-blame - 'contract-arrow-star8 - '((contract (->* (integer?) () #:rest (listof integer?) (values integer? integer?)) - (lambda (x) (values #t 1)) - 'pos - 'neg) - 1)) - - (test/spec-passed - 'contract-arrow-star9 - '((contract (->* (integer?) () #:rest (listof integer?) integer?) - (lambda (x . y) 1) - 'pos - 'neg) - 1 2)) - - (test/neg-blame - 'contract-arrow-star10 - '((contract (->* (integer?) () #:rest (listof integer?) integer?) - (lambda (x . y) 1) - 'pos - 'neg) - 1 2 'bad)) - - (test/spec-passed - 'contract-arrow-star11 - '(let-values ([(a b) ((contract (->* (integer?) () - #:rest (listof integer?) - any) - (lambda (x . y) (values x x)) - 'pos - 'neg) - 2)]) - 1)) - - (test/pos-blame - 'contract-arrow-star11b - '(let-values ([(a b) ((contract (->* (integer?) () - #:rest (listof integer?) - any) - (lambda (x) (values x x)) - 'pos - 'neg) - 2)]) - 1)) - - (test/neg-blame - 'contract-arrow-star12 - '((contract (->* (integer?) () #:rest (listof integer?) any) - (lambda (x . y) (values x x)) - 'pos - 'neg) - #f)) - - (test/spec-passed - 'contract-arrow-star13 - '((contract (->* (integer?) () #:rest (listof integer?) any) - (lambda (x . y) 1) - 'pos - 'neg) - 1 2)) - - (test/neg-blame - 'contract-arrow-star14 - '((contract (->* (integer?) () #:rest (listof integer?) any) - (lambda (x . y) 1) - 'pos - 'neg) - 1 2 'bad)) - - (test/spec-passed - 'contract-arrow-star15 - '(let-values ([(a b) ((contract (->* (integer?) () any) - (lambda (x) (values x x)) - 'pos - 'neg) - 2)]) - 1)) - - (test/spec-passed - 'contract-arrow-star16 - '((contract (->* (integer?) () any) - (lambda (x) x) - 'pos - 'neg) - 2)) - - (test/neg-blame - 'contract-arrow-star17 - '((contract (->* (integer?) () any) - (lambda (x) (values x x)) - 'pos - 'neg) - #f)) - - (test/pos-blame - 'contract-arrow-star-arity-check1 - '(contract (->* (integer?) () #:rest (listof integer?) (values integer? integer?)) - (lambda (x) (values 1 #t)) - 'pos - 'neg)) - - (test/pos-blame - 'contract-arrow-star-arity-check2 - '(contract (->* (integer?) () #:rest (listof integer?) (values integer? integer?)) - (lambda (x y) (values 1 #t)) - 'pos - 'neg)) - - (test/pos-blame - 'contract-arrow-star-arity-check3 - '(contract (->* (integer?) () #:rest (listof integer?) (values integer? integer?)) - (case-lambda [(x y) #f] [(x y . z) #t]) - 'pos - 'neg)) - - (test/spec-passed - 'contract-arrow-star-arity-check4 - '(contract (->* (integer?) () #:rest (listof integer?) (values integer? integer?)) - (case-lambda [(x y) #f] [(x y . z) #t] [(x) #f]) - 'pos - 'neg)) - - (test/pos-blame - 'contract-arrow-star-keyword1 - '(contract (->* (integer?) () #:rest (listof integer?) (values integer?)) - (λ (x #:y y . args) x) - 'pos - 'neg)) - - (test/pos-blame - 'contract-arrow-star-keyword2 - '(contract (->* (integer?) () #:rest (listof integer?) any) - (λ (x #:y y . args) x) - 'pos - 'neg)) - - (test/spec-passed - 'contract-arrow-star-keyword3 - '(contract (->* (integer? #:y integer?) () #:rest (listof integer?) (values integer? integer?)) - (λ (x #:y y . args) x) - 'pos - 'neg)) - - (test/spec-passed - 'contract-arrow-star-keyword4 - '(contract (->* (integer? #:y integer?) () #:rest (listof integer?) any) - (λ (x #:y y . args) x) - 'pos - 'neg)) - - (test/neg-blame - 'contract-arrow-star-keyword5 - '((contract (->* (integer? #:y integer?) () #:rest (listof integer?) (values integer? integer?)) - (λ (x #:y y . args) x) - 'pos - 'neg) - 1 #:y #t)) - - (test/neg-blame - 'contract-arrow-star-keyword6 - '((contract (->* (integer? #:y integer?) () #:rest (listof integer?) any) - (λ (x #:y y . args) x) - 'pos - 'neg) - 1 #:y #t)) - - (test/neg-blame - 'contract-arrow-star-keyword7 - '((contract (->* (integer? #:y integer?) () #:rest (listof integer?) (values integer? integer?)) - (λ (x #:y y . args) x) - 'pos - 'neg) - #t #:y 1)) - - (test/neg-blame - 'contract-arrow-star-keyword8 - '((contract (->* (integer? #:y integer?) () #:rest (listof integer?) any) - (λ (x #:y y . args) x) - 'pos - 'neg) - #t #:y 1)) - - (test/spec-passed - 'contract-arrow-star-keyword9 - '((contract (->* (integer? #:y integer?) () #:rest (listof integer?) (values integer? integer?)) - (λ (x #:y y . args) (values x x)) - 'pos - 'neg) - 2 #:y 1)) - - (test/spec-passed - 'contract-arrow-star-keyword10 - '((contract (->* (integer? #:y integer?) () #:rest (listof integer?) any) - (λ (x #:y y . args) (values x x)) - 'pos - 'neg) - 2 #:y 1)) - - (test/spec-passed - 'contract-arrow-star-optional1 - '(contract (->* (#:x boolean?) (#:y string? #:z char? integer?) any) - (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) - (list x s c i)) - 'pos 'neg)) - - (test/pos-blame - 'contract-arrow-star-optional2 - '(contract (->* (#:x boolean?) (#:y string? #:z char? integer?) any) - (λ (#:x x #:z [c #\c] [i 5]) - (list x s c i)) - 'pos 'neg)) - - (test/spec-passed - 'contract-arrow-star-optional3 - '(contract (->* (#:x boolean?) (#:z char? integer?) any) - (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) - (list x s c i)) - 'pos 'neg)) - - (test/pos-blame - 'contract-arrow-star-optional4 - '(contract (->* (#:x boolean?) (#:y string? #:z char? integer?) any) - (λ (#:x x #:y [s "s"] #:z [c #\c]) - (list x s c i)) - 'pos 'neg)) - - (test/spec-passed/result - 'contract-arrow-star-optional5 - '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) any) - (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) - (list x s c i)) - 'pos 'neg) - #:x #t #:y "" #:z #\d 6) - '(#t "" #\d 6)) - - (test/spec-passed/result - 'contract-arrow-star-optional6 - '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) any) - (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) - (list x s c i)) - 'pos 'neg) - #:x #t) - '(#t "s" #\c 5)) - - (test/neg-blame - 'contract-arrow-star-optional7 - '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) any) - (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) - (list x s c i)) - 'pos 'neg) - #:x #t #:y 'x #:z #\d 6)) - - (test/neg-blame - 'contract-arrow-star-optional8 - '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) any) - (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) - (list x s c i)) - 'pos 'neg) - #:x #t #:y "" #:z 'x 6)) - - (test/neg-blame - 'contract-arrow-star-optional9 - '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) any) - (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) - (list x s c i)) - 'pos 'neg) - #:x #t #:y "" #:z #\d 'x)) - - (test/pos-blame - 'contract-arrow-star-optional10 - '(contract (->* (#:x boolean?) (#:y string?) any) - (λ (#:x [x #f] #:y s) - (list x s c i)) - 'pos 'neg)) - - (test/spec-passed - 'contract-arrow-star-optional11 - '(contract (->* (#:x boolean?) (#:y string? #:z char? integer?) - (list/c boolean? string? char? integer?)) - (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) - (list x s c i)) - 'pos 'neg)) - - (test/pos-blame - 'contract-arrow-star-optional12 - '(contract (->* (#:x boolean?) (#:y string? #:z char? integer?) - (list/c boolean? string? char? integer?)) - (λ (#:x x #:z [c #\c] [i 5]) - (list x s c i)) - 'pos 'neg)) - - (test/spec-passed - 'contract-arrow-star-optional13 - '(contract (->* (#:x boolean?) (#:z char? integer?) (list/c boolean? string? char? integer?)) - (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) - (list x s c i)) - 'pos 'neg)) - - (test/pos-blame - 'contract-arrow-star-optional14 - '(contract (->* (#:x boolean?) (#:y string? #:z char? integer?) - (list/c boolean? string? char? integer?)) - (λ (#:x x #:y [s "s"] #:z [c #\c]) - (list x s c i)) - 'pos 'neg)) - - (test/spec-passed/result - 'contract-arrow-star-optional15 - '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) - (list/c boolean? string? char? integer?)) - (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) - (list x s c i)) - 'pos 'neg) - #:x #t #:y "" #:z #\d 6) - '(#t "" #\d 6)) - - (test/spec-passed/result - 'contract-arrow-star-optional16 - '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) - (list/c boolean? string? char? integer?)) - (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) - (list x s c i)) - 'pos 'neg) - #:x #t) - '(#t "s" #\c 5)) - - (test/neg-blame - 'contract-arrow-star-optional17 - '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) - (list/c boolean? string? char? integer?)) - (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) - (list x s c i)) - 'pos 'neg) - #:x #t #:y 'x #:z #\d 6)) - - (test/neg-blame - 'contract-arrow-star-optional18 - '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) - (list/c boolean? string? char? integer?)) - (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) - (list x s c i)) - 'pos 'neg) - #:x #t #:y "" #:z 'x 6)) - - (test/neg-blame - 'contract-arrow-star-optional19 - '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) - (list/c boolean? string? char? integer?)) - (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) - (list x s c i)) - 'pos 'neg) - #:x #t #:y "" #:z #\d 'x)) - - (test/pos-blame - 'contract-arrow-star-optional20 - '(contract (->* (#:x boolean?) (#:y string?) (list/c boolean? string? char? integer?)) - (λ (#:x [x #f] #:y s) - (list x s c i)) - 'pos 'neg)) - - (test/spec-passed - 'contract-arrow-star-optional21 - '((contract (->* () () (values)) - (λ () (values)) - 'pos 'neg))) - - (test/spec-passed - 'contract-arrow-star-optional22 - '((contract (->* () () (values integer? char?)) - (λ () (values 1 #\c)) - 'pos 'neg))) - - (test/pos-blame - 'contract-arrow-star-optional23 - '((contract (->* () () (values integer? char?)) - (λ () (values 1 2)) - 'pos 'neg))) - - (test/spec-passed - 'contract-arrow-star-optional24 - '(let () - (define (statement? s) - (and (string? s) - (> (string-length s) 3))) - (define statement/c (flat-contract statement?)) - - (define new-statement - (make-keyword-procedure - (λ (kws kw-args . statement) - (format "kws=~s kw-args=~s statement=~s" kws kw-args statement)))) - - (contract (->* (statement/c) (#:s string?) statement/c) - new-statement - 'pos 'neg))) - - (test/spec-passed - 'contract-arrow-star-keyword-ordering - '((contract (->* (integer? #:x boolean?) (string? #:y char?) any) - (λ (x #:x b [s ""] #:y [c #\c]) - (list x b s c)) - 'pos - 'neg) - 1 "zz" #:x #f #:y #\d)) - - - (test/spec-passed - '->*-pre/post-1 - '((contract (->* () () integer? #:post #t) - (λ () 1) - 'pos - 'neg))) - - (test/pos-blame - '->*-pre/post-2 - '((contract (->* () () integer? #:post #t) - (λ () 'not-an-int) - 'pos - 'neg))) - - (test/spec-passed - '->*-pre/post-3 - '((contract (->* () () (values integer? boolean?) #:post #t) - (λ () (values 1 #t)) - 'pos - 'neg))) - - (test/pos-blame - '->*-pre/post-4 - '((contract (->* () () (values integer? boolean?) #:post #t) - (λ () (values 1 'not-a-boolean)) - 'pos - 'neg))) - - (test/neg-blame - '->*-pre/post-5 - '((contract (->* () () #:pre #f integer? #:post #t) - (λ () 1) - 'pos - 'neg))) - - (test/pos-blame - '->*-pre/post-6 - '((contract (->* () () #:pre #t integer? #:post #f) - (λ () 1) - 'pos - 'neg))) - - (test/neg-blame - '->*-pre/post-7 - '((contract (->* () () #:pre #f integer? #:post #f) - (λ () 1) - 'pos - 'neg))) - - (test/spec-passed - '->*-opt-optional1 - '((contract (->* () integer?) (lambda () 1) 'pos 'neg))) - - (test/spec-passed - '->*-opt-optional2 - '((contract (->* () (values boolean? integer?)) (lambda () (values #t 1)) 'pos 'neg))) - - (test/spec-passed - '->*-opt-optional3 - '((contract (->* () #:rest any/c integer?) (lambda x 1) 'pos 'neg))) - - (test/spec-passed - '->*-opt-optional4 - '((contract (->* () #:pre #t integer?) (lambda x 1) 'pos 'neg))) - - (test/spec-passed - '->*-opt-optional5 - '((contract (->* () integer? #:post #t) (lambda x 1) 'pos 'neg))) - -; -; -; -; -; ; -; ;;; -; ;;;; -; ;;; -; ;;;;; ;;; -; ;;;;; ;;;; -; ;;; -; ; -; -; -; - - - (test/spec-passed - 'contract-arrow-values1 - '(let-values ([(a b) ((contract (-> integer? (values integer? integer?)) - (lambda (x) (values x x)) - 'pos - 'neg) - 2)]) - 1)) - - (test/neg-blame - 'contract-arrow-values2 - '((contract (-> integer? (values integer? integer?)) - (lambda (x) (values x x)) - 'pos - 'neg) - #f)) - - (test/pos-blame - 'contract-arrow-values3 - '((contract (-> integer? (values integer? integer?)) - (lambda (x) (values 1 #t)) - 'pos - 'neg) - 1)) - - (test/pos-blame - 'contract-arrow-values4 - '((contract (-> integer? (values integer? integer?)) - (lambda (x) (values #t 1)) - 'pos - 'neg) - 1)) - - (test/pos-blame - 'contract-arrow-values5 - '((contract (-> integer? (values integer? integer?)) - (lambda (x) x) - 'pos - 'neg) - 1)) - - - (test/pos-blame - 'contract-arrow-keyword1 - '(contract (-> integer? any) - (λ (x #:y y) x) - 'pos - 'neg)) - - (test/pos-blame - 'contract-arrow-keyword1b - '(contract (-> integer? #:y integer? any) - (λ (x) x) - 'pos - 'neg)) - - (test/spec-passed - 'contract-arrow-keyword2 - '(contract (-> integer? #:y boolean? any) - (λ (x #:y y) x) - 'pos - 'neg)) - - (test/spec-passed - 'contract-arrow-keyword2b - '(contract (-> #:x boolean? #:y boolean? any) - (λ (#:x x #:y y) x) - 'pos - 'neg)) - - (test/spec-passed - 'contract-arrow-keyword2c - '(contract (-> #:y boolean? #:x boolean? any) - (λ (#:x x #:y y) x) - 'pos - 'neg)) - - (test/spec-passed - 'contract-arrow-keyword2d - '(contract (-> #:y boolean? #:x boolean? any) - (λ (#:y y #:x x) x) - 'pos - 'neg)) - - (test/spec-passed - 'contract-arrow-keyword2e - '(contract (-> #:x boolean? #:y boolean? any) - (λ (#:y y #:x x) x) - 'pos - 'neg)) - - (test/neg-blame - 'contract-arrow-keyword3 - '((contract (-> integer? #:y boolean? any) - (λ (x #:y y) x) - 'pos - 'neg) - 1 #:y 1)) - - (test/neg-blame - 'contract-arrow-keyword4 - '((contract (-> integer? #:y boolean? any) - (λ (x #:y y) x) - 'pos - 'neg) - #t #:y #t)) - - (test/spec-passed - 'contract-arrow-keyword5 - '((contract (-> integer? #:y boolean? any) - (λ (x #:y y) x) - 'pos - 'neg) - 1 #:y #t)) - - (test/pos-blame - 'contract-arrow-keyword6 - '(contract (-> integer? integer?) - (λ (x #:y y) x) - 'pos - 'neg)) - - (test/spec-passed - 'contract-arrow-keyword7 - '(contract (-> integer? #:y boolean? integer?) - (λ (x #:y y) x) - 'pos - 'neg)) - - (test/neg-blame - 'contract-arrow-keyword8 - '((contract (-> integer? #:y boolean? integer?) - (λ (x #:y y) x) - 'pos - 'neg) - 1 #:y 1)) - - (test/neg-blame - 'contract-arrow-keyword9 - '((contract (-> integer? #:y boolean? integer?) - (λ (x #:y y) x) - 'pos - 'neg) - #t #:y #t)) - - (test/spec-passed - 'contract-arrow-keyword10 - '((contract (-> integer? #:y boolean? integer?) - (λ (x #:y y) x) - 'pos - 'neg) - 1 #:y #t)) - - (test/pos-blame - 'contract-arrow-keyword11 - '(contract (-> integer? (values integer? integer?)) - (λ (x #:y y) x) - 'pos - 'neg)) - - (test/spec-passed - 'contract-arrow-keyword12 - '(contract (-> integer? #:y boolean? (values integer? integer?)) - (λ (x #:y y) x) - 'pos - 'neg)) - - (test/neg-blame - 'contract-arrow-keyword13 - '((contract (-> integer? #:y boolean? (values integer? integer?)) - (λ (x #:y y) x) - 'pos - 'neg) - 1 #:y 1)) - - (test/neg-blame - 'contract-arrow-keyword14 - '((contract (-> integer? #:y boolean? (values integer? integer?)) - (λ (x #:y y) x) - 'pos - 'neg) - #t #:y #t)) - - (test/spec-passed - 'contract-arrow-keyword15 - '((contract (-> integer? #:y boolean? (values integer? integer?)) - (λ (x #:y y) (values x x)) - 'pos - 'neg) - 1 #:y #t)) - - (test/spec-passed - 'contract-arrow-keyword16 - '((contract (-> integer? integer?) - (λ (x #:y [y #f]) x) - 'pos - 'neg) - 1)) - - (test/neg-blame - 'contract-arrow-keyword17 - '((contract (-> integer? integer?) - (λ (x #:y [y #f]) x) - 'pos - 'neg) - #f)) - - (test/pos-blame - 'contract-arrow-keyword18 - '((contract (-> integer? integer?) - (λ (x #:y [y #f]) y) - 'pos - 'neg) - 1)) - - (test/neg-blame - 'contract-arrow-keyword19 - '((contract (-> boolean?) - (λ (#:x [x #f]) x) - 'pos - 'neg) - #:x 1)) - - (test/spec-passed - 'contract-arrow1 - '(contract (integer? . -> . integer?) (lambda (x) x) 'pos 'neg)) - - ;; make sure we skip the optimizations - (test/spec-passed - 'contract-arrow1b - '(contract (-> integer? integer? integer? integer? integer? - integer? integer? integer? integer? integer? - integer?) - (lambda (x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) x1) 'pos 'neg)) - - (test/pos-blame - 'contract-arrow2 - '(contract (integer? . -> . integer?) (lambda (x y) x) 'pos 'neg)) - - (test/neg-blame - 'contract-arrow3 - '((contract (integer? . -> . integer?) (lambda (x) #f) 'pos 'neg) #t)) - - (test/pos-blame - 'contract-arrow4 - '((contract (integer? . -> . integer?) (lambda (x) #f) 'pos 'neg) 1)) - - (test/neg-blame - 'contract-arrow-arity1 - '((contract (-> number? number? number?) - (λ (x . r) x) - 'pos 'neg) - 1)) - - (test/spec-passed - 'contract-arrow-any1 - '(contract (integer? . -> . any) (lambda (x) x) 'pos 'neg)) - - (test/pos-blame - 'contract-arrow-any2 - '(contract (integer? . -> . any) (lambda (x y) x) 'pos 'neg)) - - (test/neg-blame - 'contract-arrow-any3 - '((contract (integer? . -> . any) (lambda (x) #f) 'pos 'neg) #t)) - - (test/spec-passed - 'contract-arrow-all-anys1 - '((contract (-> any) (lambda () #f) 'pos 'neg))) - - (test/pos-blame - 'contract-arrow-all-anys2 - '((contract (-> any) (lambda (x) #f) 'pos 'neg))) - - (test/spec-passed - 'contract-arrow-all-anys3 - '((contract (-> any) (lambda ([x #f]) #f) 'pos 'neg))) - - (test/spec-passed - 'contract-arrow-all-kwds - '(contract (-> #:a string? string?) - (make-keyword-procedure void) - 'pos 'neg)) - - (test/pos-blame - 'contract-arrow-non-function - '(contract (-> any/c any) 1 'pos 'neg)) - - (test/spec-passed - 'contract-arrow-all-kwds2 - '((contract (-> #:a string? void?) - (make-keyword-procedure void) - 'pos 'neg) - #:a "abcdef")) - - (contract-error-test - 'contract-arrow-kwd-name-in-message - #'((contract - (-> #:a any/c #:the-missing-keyword-arg-b any/c any) - (λ (#:a [a 0] #:the-missing-keyword-arg-b [b 0]) b) - 'pos - 'neg) - #:a 0) - (λ (x) - (and (exn:fail:contract:blame? x) - (regexp-match #rx"expected keyword argument #:the-missing-keyword-arg-b" - (exn-message x))))) - - (test/pos-blame - 'predicate/c1 - '(contract predicate/c 1 'pos 'neg)) - (test/pos-blame - 'predicate/c2 - '(contract predicate/c (λ (x y) 1) 'pos 'neg)) - (test/pos-blame - 'predicate/c3 - '((contract predicate/c (λ (x) 1) 'pos 'neg) 12)) - (test/spec-passed - 'predicate/c4 - '((contract predicate/c (λ (x) #t) 'pos 'neg) 12)) - - ;; this test ensures that no contract wrappers - ;; are created for struct predicates - (test/spec-passed/result - 'predicate/c5 - '(let () - (struct x (a)) - (eq? (contract predicate/c x? 'pos 'neg) x?)) - #t) - - - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; procedure accepts-and-more - ;; - - (ctest #t procedure-accepts-and-more? (lambda (x . y) 1) 3) - (ctest #t procedure-accepts-and-more? (lambda (x . y) 1) 2) - (ctest #t procedure-accepts-and-more? (lambda (x . y) 1) 1) - (ctest #f procedure-accepts-and-more? (lambda (x . y) 1) 0) - - (ctest #t procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 3) - (ctest #t procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 2) - (ctest #t procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 1) - (ctest #f procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 0) - - (ctest #t procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 2) - (ctest #t procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 1) - (ctest #f procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 0) - -; -; -; -; ;;;; -; ; ;;;; -; ;;; ;;;;;;; -; ;;;; ;;;;;;;; -; ;;; ;;;;;;;;; -; ;;;;; ;;; ;;;; ;;;; -; ;;;;; ;;;; ;;;;;;;;; -; ;;; ;;;;;;;; -; ; ;;;;;;; -; -; -; - - (test/spec-passed - '->d1 - '((contract (->d () () [x number?]) (lambda () 1) 'pos 'neg))) - - (test/spec-passed - '->d2 - '((contract (->d ([x number?]) () (values [r number?])) (lambda (x) (+ x 1)) 'pos 'neg) 1)) - - (test/pos-blame - '->d3 - '((contract (->d () () [r number?]) 1 'pos 'neg))) - - (test/pos-blame - '->d4 - '((contract (->d () () [r number?]) (lambda (x) x) 'pos 'neg))) - - (test/neg-blame - '->d5 - '((contract (->d ([x number?]) () any) (lambda (x) (+ x 1)) 'pos 'neg) #f)) - - (test/pos-blame - '->d6 - '((contract (->d ([x number?]) () [r (<=/c x)]) (lambda (x) (+ x 1)) 'pos 'neg) 1)) - - (test/spec-passed - '->d7 - '((contract (->d ([x number?] [y (<=/c x)]) () [r (<=/c x)]) - (lambda (x y) (- x 1)) 'pos 'neg) 1 0)) - - (test/neg-blame - '->d8 - '((contract (->d ([x number?] [y (<=/c x)]) () [r (<=/c x)]) - (lambda (x y) (+ x 1)) 'pos 'neg) 1 2)) - - (test/spec-passed - '->d9 - '((contract (->d ([y (<=/c x)] [x number?]) () [r (<=/c x)]) - (lambda (y x) (- x 1)) 'pos 'neg) 1 2)) - - (test/neg-blame - '->d10 - '((contract (->d ([y (<=/c x)] [x number?]) () [r (<=/c x)]) - (lambda (y x) (+ x 1)) 'pos 'neg) 1 0)) - - (test/spec-passed - '->d11 - '((contract (->d () () #:rest rest any/c [r number?]) (lambda x 1) 'pos 'neg))) - - (test/spec-passed - '->d12 - '((contract (->d ([x number?]) () #:rest rest any/c [r number?]) - (lambda (x . y) (+ x 1)) 'pos 'neg) 1)) - - (test/pos-blame - '->d13 - '((contract (->d () () #:rest rest any/c [r number?]) 1 'pos 'neg))) - - (test/pos-blame - '->d14 - '((contract (->d () () #:rest rest any/c [r number?]) (lambda (x) x) 'pos 'neg))) - - (test/neg-blame - '->d15 - '((contract (->d ([x number?]) () #:rest rest any/c any) (lambda (x . y) (+ x 1)) 'pos 'neg) #f)) - - (test/pos-blame - '->d16 - '((contract (->d ([x number?]) () #:rest rest any/c [r (<=/c x)]) - (lambda (x . y) (+ x 1)) 'pos 'neg) 1)) - - (test/spec-passed - '->d17 - '((contract (->d ([x number?] [y (<=/c x)]) () #:rest rest any/c [r (<=/c x)]) - (lambda (x y . z) (- x 1)) 'pos 'neg) 1 0)) - - (test/neg-blame - '->d18 - '((contract (->d ([x number?] [y (<=/c x)]) () #:rest rest any/c [r (<=/c x)]) - (lambda (x y . z) (+ x 1)) 'pos 'neg) 1 2)) - - (test/spec-passed - '->d19 - '((contract (->d ([y (<=/c x)] [x number?]) () #:rest rest any/c [r (<=/c x)]) - (lambda (y x . z) (- x 1)) 'pos 'neg) 1 2)) - - (test/neg-blame - '->d20 - '((contract (->d ([y (<=/c x)] [x number?]) () #:rest rest any/c [r (<=/c x)]) - (lambda (y x . z) (+ x 1)) 'pos 'neg) 1 0)) - - (test/spec-passed - '->d21 - '((contract (->d () () #:rest rst (listof number?) [r any/c]) (lambda w 1) 'pos 'neg) 1)) - - (test/neg-blame - '->d22 - '((contract (->d () () #:rest rst (listof number?) [r any/c]) (lambda w 1) 'pos 'neg) #f)) - - (test/spec-passed - '->d-any1 - '((contract (->d () () any) (lambda () 1) 'pos 'neg))) - - (test/spec-passed - '->d-any2 - '((contract (->d ([x number?]) () any) (lambda (x) (+ x 1)) 'pos 'neg) 1)) - - (test/pos-blame - '->d-any3 - '((contract (->d () () any) 1 'pos 'neg))) - - (test/pos-blame - '->d-any4 - '((contract (->d () () any) (lambda (x) x) 'pos 'neg))) - - (test/neg-blame - '->d-any5 - '((contract (->d ([x number?]) () any) (lambda (x) (+ x 1)) 'pos 'neg) #f)) - - (test/spec-passed - '->d-any6 - '((contract (->d ([x number?] [y (<=/c x)]) () any) (lambda (x y) (- x 1)) 'pos 'neg) 1 0)) - - (test/neg-blame - '->d-any7 - '((contract (->d ([x number?] [y (<=/c x)]) () any) (lambda (x y) (+ x 1)) 'pos 'neg) 1 2)) - - (test/spec-passed - '->d-any8 - '((contract (->d ([y (<=/c x)] [x number?]) () any) (lambda (y x) (- x 1)) 'pos 'neg) 1 2)) - - (test/neg-blame - '->d-any9 - '((contract (->d ([y (<=/c x)] [x number?]) () any) (lambda (y x) (+ x 1)) 'pos 'neg) 1 0)) - - (test/spec-passed - '->d-any10 - '((contract (->d () () #:rest rest any/c any) (lambda x 1) 'pos 'neg))) - - (test/spec-passed - '->d-any11 - '((contract (->d ([x number?]) () #:rest rest any/c any) (lambda (x . y) (+ x 1)) 'pos 'neg) 1)) - - (test/pos-blame - '->d-any12 - '((contract (->d () () #:rest rest any/c any) 1 'pos 'neg))) - - (test/pos-blame - '->d-any13 - '((contract (->d () () #:rest rest any/c any) (lambda (x) x) 'pos 'neg))) - - (test/neg-blame - '->d-any14 - '((contract (->d ([x number?]) () #:rest rest any/c any) (lambda (x . y) (+ x 1)) 'pos 'neg) #f)) - - (test/spec-passed - '->d-any15 - '((contract (->d ([x number?] [y (<=/c x)]) () #:rest rest any/c any) - (lambda (x y . z) (- x 1)) 'pos 'neg) 1 0)) - - (test/neg-blame - '->d-any16 - '((contract (->d ([x number?] [y (<=/c x)]) () #:rest rest any/c any) - (lambda (x y . z) (+ x 1)) 'pos 'neg) 1 2)) - - (test/spec-passed - '->d-any17 - '((contract (->d ([y (<=/c x)] [x number?]) () #:rest rest any/c any) - (lambda (y x . z) (- x 1)) 'pos 'neg) 1 2)) - - (test/neg-blame - '->d-any18 - '((contract (->d ([y (<=/c x)] [x number?]) () #:rest rest any/c any) - (lambda (y x . z) (+ x 1)) 'pos 'neg) 1 0)) - - (test/spec-passed - '->d-any19 - '((contract (->d () () #:rest rst (listof number?) any) (lambda w 1) 'pos 'neg) 1)) - - (test/neg-blame - '->d-any20 - '((contract (->d () () #:rest rst (listof number?) any) (lambda w 1) 'pos 'neg) #f)) - - (test/spec-passed - '->d-values1 - '((contract (->d () () (values [x boolean?] [y number?])) (lambda () (values #t 1)) 'pos 'neg))) - - (test/spec-passed - '->d-values2 - '((contract (->d ([x number?]) () (values [z boolean?] [y number?])) - (lambda (x) (values #t (+ x 1))) 'pos 'neg) 1)) - - (test/pos-blame - '->d-values3 - '((contract (->d () () (values [x boolean?] [y number?])) 1 'pos 'neg))) - - (test/pos-blame - '->d-values4 - '((contract (->d () () (values [x boolean?] [y number?])) (lambda (x) x) 'pos 'neg))) - - (test/neg-blame - '->d-values5 - '((contract (->d ([x number?]) () (values [y boolean?] [z (<=/c x)])) - (lambda (x) (+ x 1)) 'pos 'neg) #f)) - - (test/pos-blame - '->d-values6 - '((contract (->d ([x number?]) () (values [y boolean?] [z (<=/c x)])) - (lambda (x) (values #t (+ x 1))) 'pos 'neg) 1)) - - (test/spec-passed - '->d-values7 - '((contract (->d ([x number?] [y (<=/c x)]) () (values [z boolean?] [w (<=/c x)])) - (lambda (x y) (values #t (- x 1))) - 'pos - 'neg) - 1 - 0)) - - (test/neg-blame - '->d-values8 - '((contract (->d ([x number?] [y (<=/c x)]) () (values [z boolean?] [w (<=/c x)])) - (lambda (x y) (values #f (+ x 1))) - 'pos - 'neg) - 1 - 2)) - - (test/spec-passed - '->d-values9 - '((contract (->d ([y (<=/c x)] [x number?]) () (values [z boolean?] [w (<=/c x)])) - (lambda (y x) (values #f (- x 1))) - 'pos - 'neg) - 1 - 2)) - - (test/neg-blame - '->d-values10 - '((contract (->d ([y (<=/c x)] [x number?]) () (values [z boolean?] [w (<=/c x)])) - (lambda (y x) (values #f (+ x 1))) 'pos 'neg) - 1 0)) - - (test/spec-passed - '->d-values11 - '((contract (->d () () #:rest rest any/c (values [z boolean?] [w number?])) - (lambda x (values #f 1)) 'pos 'neg))) - - (test/spec-passed - '->d-values12 - '((contract (->d ([x number?]) () #:rest rest any/c (values [z boolean?] [w number?])) - (lambda (x . y) (values #f (+ x 1))) - 'pos - 'neg) - 1)) - - (test/pos-blame - '->d-values13 - '((contract (->d () () #:rest rest any/c (values [z boolean?] [w number?])) 1 'pos 'neg))) - - (test/pos-blame - '->d-values14 - '((contract (->d () () #:rest rest any/c (values [z boolean?] [w number?])) - (lambda (x) x) 'pos 'neg))) - - (test/neg-blame - '->d-values15 - '((contract (->d ([x number?]) () #:rest rest any/c (values [z boolean?] [w (<=/c x)])) - (lambda (x . y) (+ x 1)) 'pos 'neg) - #f)) - - (test/pos-blame - '->d-values16 - '((contract (->d ([x number?]) () #:rest rest any/c (values [z boolean?] [w (<=/c x)])) - (lambda (x . y) (values #f (+ x 1))) 'pos 'neg) - 1)) - - (test/spec-passed - '->d-values17 - '((contract (->d ([x number?] [y (<=/c x)]) () #:rest rest any/c - (values [z boolean?] [w (<=/c x)])) - (lambda (x y . z) (values #f (- x 1))) 'pos 'neg) - 1 0)) - - (test/neg-blame - '->d-values18 - '((contract (->d ([x number?] [y (<=/c x)]) () #:rest rest any/c - (values [z boolean?] [w (<=/c x)])) - (lambda (x y . z) (values #f (+ x 1))) 'pos 'neg) - 1 2)) - - (test/spec-passed - '->d-values19 - '((contract (->d ([y (<=/c x)] [x number?]) () #:rest rest any/c - (values [z boolean?] [w (<=/c x)])) - (lambda (y x . z) (values #f (- x 1))) 'pos 'neg) - 1 2)) - - (test/neg-blame - '->d-values20 - '((contract (->d ([y (<=/c x)] [x number?]) () #:rest rest any/c - (values [z boolean?] [w (<=/c x)])) - (lambda (y x . z) (values #f (+ x 1))) 'pos 'neg) - 1 0)) - - (test/spec-passed - '->d-values21 - '((contract (->d () () #:rest rst (listof number?) (values [z boolean?] [w any/c])) - (lambda w (values #f 1)) 'pos 'neg) 1)) - - (test/neg-blame - '->d-values22 - '((contract (->d () () #:rest rst (listof number?) (values [z boolean?] [w any/c])) - (lambda w (values #f 1)) 'pos 'neg) #f)) - - (test/spec-passed - '->d-values23 - '((contract (->d () () (values [x number?] [y (>=/c x)])) (lambda () (values 1 2)) 'pos 'neg))) - - (test/pos-blame - '->d-values24 - '((contract (->d () () (values [x number?] [y (>=/c x)])) (lambda () (values 2 1)) 'pos 'neg))) - - (test/spec-passed - '->d-values25 - '((contract (->d ([x number?]) () (values [z number?] [y (>=/c x)])) - (lambda (x) (values 1 2)) 'pos 'neg) 1)) - - (test/pos-blame - '->d-values26 - '((contract (->d ([x number?]) () (values [z number?] [y (>=/c x)])) - (lambda (x) (values 2 1)) 'pos 'neg) 4)) - - (test/spec-passed/result - '->d23 - '((contract (->d ((i number?) (j (and/c number? (>=/c i)))) () [r number?]) - (λ (i j) 1) - 'pos - 'neg) - 1 - 2) - 1) - - (test/spec-passed/result - '->d24 - '((contract (->d ((i number?) (j (and/c number? (>=/c i)))) () any) - (λ (i j) 1) - 'pos - 'neg) - 1 - 2) - 1) - - (test/spec-passed/result - '->d25 - '(call-with-values - (λ () - ((contract (->d ((i number?) (j (and/c number? (>=/c i)))) () (values [x number?] [y number?])) - (λ (i j) (values 1 2)) - 'pos - 'neg) - 1 - 2)) - list) - '(1 2)) - - (test/spec-passed/result - '->d26 - '((contract (->d ((i number?) (j (and/c number? (>=/c i)))) () #:rest rest-args any/c [r number?]) - (λ (i j . z) 1) - 'pos - 'neg) - 1 - 2) - 1) - - (test/spec-passed/result - '->d27 - '((contract (->d ((i number?) (j (and/c number? (>=/c i)))) () #:rest rest-args any/c any) - (λ (i j . z) 1) - 'pos - 'neg) - 1 - 2) - 1) - - (test/spec-passed/result - '->d28 - '(call-with-values - (λ () - ((contract (->d ((i number?) (j (and/c number? (>=/c i)))) () - #:rest rest-args any/c - (values [x number?] [y number?])) - (λ (i j . z) (values 1 2)) - 'pos - 'neg) - 1 - 2)) - list) - '(1 2)) - - (test/neg-blame - '->d30 - '((contract (->d ([x number?]) () #:rest rst number? any) - (λ (x . rst) (values 4 5)) - 'pos - 'neg) - #f)) - - (test/pos-blame - '->d-arity1 - '(contract (->d ([x number?]) () any) (λ () 1) 'pos 'neg)) - - (test/pos-blame - '->d-arity2 - '(contract (->d ([x number?]) () any) (λ (x #:y y) 1) 'pos 'neg)) - - (test/spec-passed - '->d-arity3 - '(contract (->d ([x number?] #:y [y integer?]) () any) (λ (x #:y y) 1) 'pos 'neg)) - - (test/pos-blame - '->d-arity4 - '(contract (->d () ([x integer?]) any) (λ (x) 1) 'pos 'neg)) - - (test/pos-blame - '->d-arity5 - '(contract (->d () ([x integer?]) any) (λ () 1) 'pos 'neg)) - - (test/spec-passed - '->d-arity6 - '(contract (->d () ([x integer?]) any) (λ ([x 1]) 1) 'pos 'neg)) - - (test/pos-blame - '->d-arity7 - '(contract (->d () (#:x [x integer?]) any) (λ ([x 1]) 1) 'pos 'neg)) - - (test/pos-blame - '->d-arity8 - '(contract (->d () (#:x [x integer?]) any) (λ () 1) 'pos 'neg)) - - (test/pos-blame - '->d-arity8 - '(contract (->d () (#:x [x integer?]) any) (λ (#:x x) 1) 'pos 'neg)) - - (test/spec-passed - '->d-arity10 - '(contract (->d () (#:x [x integer?]) any) (λ (#:x [x 1]) 1) 'pos 'neg)) - - (test/spec-passed - '->d-pp0 - '((contract (->d ([x number?]) () #:pre (= x 1) [result number?] #:post (= x 1)) - (λ (x) x) - 'pos - 'neg) - 1)) - - (test/pos-blame - '->d-pp1 - '((contract (->d ([x number?]) () #:pre-cond (= x 1) [result number?] #:post-cond (= x 2)) - (λ (x) x) - 'pos - 'neg) - 1)) - - (test/neg-blame - '->d-pp2 - '((contract (->d ([x number?]) () #:pre-cond (= x 1) [result number?] #:post-cond (= x 2)) - (λ (x) x) - 'pos - 'neg) - 2)) - - (test/pos-blame - '->d-pp3 - '((contract (->d ([x number?]) () #:pre-cond (= x 1) [result number?] #:post-cond (= result 2)) - (λ (x) x) - 'pos - 'neg) - 1)) - - (test/spec-passed - '->d-pp3.5 - '((contract (->d ([x number?]) () #:pre-cond (= x 1) [result number?] #:post-cond (= result 2)) - (λ (x) 2) - 'pos - 'neg) - 1)) - - (test/neg-blame - '->d-pp4 - '((contract (->d ([x number?]) () #:pre-cond (= x 1) any) - (λ (x) x) - 'pos - 'neg) - 2)) - - (test/neg-blame - '->d-pp5 - '((contract (->d ([x number?]) () #:pre-cond (= x 1) (values [z number?] [y number?]) - #:post-cond (= x y z 3)) - (λ (x) (values 4 5)) - 'pos - 'neg) - 2)) - - (test/pos-blame - '->d-pp6 - '((contract (->d ([x number?]) () #:pre-cond (= x 1) (values [z number?] [y number?]) - #:post-cond (= z y 3)) - (λ (x) (values 4 5)) - 'pos - 'neg) - 1)) - - (test/pos-blame - '->d-pp-r1 - '((contract (->d ([x number?]) () #:rest rst any/c #:pre-cond (= x 1) [result number?] - #:post-cond (= x 2)) - (λ (x . rst) x) - 'pos - 'neg) - 1)) - - (test/neg-blame - '->d-pp-r2 - '((contract (->d ([x number?]) () #:rest rst any/c #:pre-cond (= x 1) [result number?] - #:post-cond (= x 2)) - (λ (x . rst) x) - 'pos - 'neg) - 2)) - - (test/pos-blame - '->d-pp-r3 - '((contract (->d ([x number?]) () #:rest rst any/c #:pre-cond (= x 1) [result number?] - #:post-cond (= result 2)) - (λ (x . rst) x) - 'pos - 'neg) - 1)) - - (test/spec-passed - '->d-pp-r3.5 - '((contract (->d ([x number?]) () #:rest rst any/c #:pre-cond (= x 1) [result number?] - #:post-cond (= result 2)) - (λ (x . rst) 2) - 'pos - 'neg) - 1)) - - (test/neg-blame - '->d-pp-r4 - '((contract (->d ([x number?]) () #:rest rst any/c #:pre-cond (= x 1) any) - (λ (x . rst) x) - 'pos - 'neg) - 2)) - - (test/neg-blame - '->d-pp-r5 - '((contract (->d ([x number?]) () #:rest rst any/c - #:pre-cond (= x 1) (values [z number?] [y number?]) - #:post-cond (= x y z 3)) - (λ (x . rst) (values 4 5)) - 'pos - 'neg) - 2)) - - (test/pos-blame - '->d-pp-r6 - '((contract (->d ([x number?]) () #:rest rst any/c - #:pre-cond (= x 1) (values [z number?] [y number?]) - #:post-cond (= z x y 3)) - (λ (x . rst) (values 4 5)) - 'pos - 'neg) - 1)) - - (test/neg-blame - '->d-protect-shared-state - '(let ([x 1]) - ((contract (let ([save #f]) - (-> (->d () () #:pre-cond (set! save x) [range any/c] #:post-cond (= save x)) - any)) - (λ (t) (t)) - 'pos - 'neg) - (lambda () (set! x 2))))) - - - (test/spec-passed - '->d-optopt1 - '((contract (->d ([x number?]) any) - (λ (x) x) - 'pos 'neg) - 1)) - - (test/spec-passed - '->d-optopt2 - '((contract (->d ([x number?]) #:rest rst any/c any) - (λ (x . y) x) - 'pos 'neg) - 1)) - - (test/spec-passed - '->d-optopt3 - '((contract (->d ([x number?]) #:pre-cond #t any) - (λ (x) x) - 'pos 'neg) - 1)) - - (test/spec-passed - '->d-optopt4 - '((contract (->d ([x number?]) #:rest rst any/c #:pre-cond #t any) - (λ (x . y) x) - 'pos 'neg) - 1)) - - (test/spec-passed - '->d-optopt5 - '((contract (->d ([x number?]) #:rest rst any/c #:pre-cond #t [res any/c] #:post-cond #t) - (λ (x . y) x) - 'pos 'neg) - 1)) - - (test/spec-passed - '->d-optopt6 - '((contract (->d ([x number?]) #:rest rst any/c [res any/c] #:post-cond #t) - (λ (x . y) x) - 'pos 'neg) - 1)) - - (test/spec-passed - '->d-optopt7 - '((contract (->d ([x number?]) #:pre-cond #t [res any/c] #:post-cond #t) - (λ (x . y) x) - 'pos 'neg) - 1)) - - (test/spec-passed - '->d-optopt8 - '((contract (->d ([x number?]) [res any/c] #:post-cond #t) - (λ (x . y) x) - 'pos 'neg) - 1)) - - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; make sure the variables are all bound properly - ;; - - (test/spec-passed - '->d-binding1 - '((contract (->d ([x number?]) () #:rest rest any/c [range any/c] - #:post-cond (equal? rest '(2 3 4))) - (λ (x . y) y) - 'pos - 'neg) - 1 2 3 4)) - - (test/spec-passed - '->d-binding2 - '((contract (->d ([x number?]) () #:rest rest any/c [range any/c] #:post-cond (equal? x 1)) - (λ (x . y) y) - 'pos - 'neg) - 1 2 3 4)) - - (test/spec-passed - '->d-binding3 - '(let ([p 'p] - [q 'q] - [r 'r]) - ((contract (->d ([x number?] [y number?] #:z [z number?] #:w [w number?]) - ([a number?] [b number?] #:c [c number?] #:d [d number?]) - #:rest rest any/c - #:pre-cond (equal? (list x y z w a b c d rest p q r) - (list 1 2 3 4 5 6 7 8 '(z) 'p 'q 'r)) - (values [p number?] [q number?] [r number?])) - (λ (x y #:z z #:w w [a 101] [b 102] #:c [c 103] #:d [d 104] . rest) - (values 11 12 13)) - 'pos - 'neg) - 1 2 #:z 3 #:w 4 5 6 #:c 7 #:d 8 'z))) - - (test/spec-passed - '->d-binding4 - '((contract (->d ([x number?] [y number?] #:z [z number?] #:w [w number?]) - ([a number?] [b number?] #:c [c number?] #:d [d number?]) - #:rest rest any/c - (values [p number?] [q number?] [r number?]) - #:post-cond (equal? (list x y z w a b c d rest p q r) - (list 1 2 3 4 5 6 7 8 '(z) 11 12 13))) - (λ (x y #:z z #:w w [a 101] [b 102] #:c [c 103] #:d [d 104] . rest) - (values 11 12 13)) - 'pos - 'neg) - 1 2 #:z 3 #:w 4 5 6 #:c 7 #:d 8 'z)) - - (test/spec-passed - '->d-binding5 - '(let ([p 'p] - [q 'q] - [r 'r]) - ((contract (->d ([x number?] [y number?] #:z [z number?] #:w [w number?]) - ([a number?] [b number?] #:c [c number?] #:d [d number?]) - #:rest rest any/c - #:pre-cond (equal? (list x y z w a b c d rest p q r) - (list 1 2 3 4 - the-unsupplied-arg the-unsupplied-arg - the-unsupplied-arg the-unsupplied-arg - '() 'p 'q 'r)) - (values [p number?] [q number?] [r number?])) - (λ (x y #:z z #:w w [a 101] [b 102] #:c [c 103] #:d [d 104] . rest) - (values 11 12 13)) - 'pos - 'neg) - 1 2 #:z 3 #:w 4))) - - (test/spec-passed - '->d-binding6 - '((contract (->d ([x number?] [y number?] #:z [z number?] #:w [w number?]) - ([a number?] [b number?] #:c [c number?] #:d [d number?]) - #:rest rest any/c - (values [p number?] [q number?] [r number?]) - #:post-cond (equal? (list x y z w a b c d rest p q r) - (list 1 2 3 4 - the-unsupplied-arg the-unsupplied-arg - the-unsupplied-arg the-unsupplied-arg - '() 11 12 13))) - (λ (x y #:z z #:w w [a 101] [b 102] #:c [c 103] #:d [d 104] . rest) - (values 11 12 13)) - 'pos - 'neg) - 1 2 #:z 3 #:w 4)) - - ;; test that the rest parameter is right when there aren't - ;; enough arguments to even make it to the rest parameter - (test/spec-passed - '->d-binding7 - '((contract (->d () - ([a number?]) - #:rest rest any/c - [_ any/c] - #:post-cond (equal? (list a rest) (list the-unsupplied-arg '()))) - (λ ([a 1] . rest) 1) - 'pos - 'neg))) - - (test/pos-blame - '->d-underscore1 - '((contract (->d ([b (box/c integer?)]) - () - [_ (let ([old (unbox b)]) - (and/c - void? - (λ (new) - (= old (unbox b)))))]) - (λ (b) - (set-box! b (+ (unbox b) 1))) - 'pos - 'neg) - (box 1))) - - (test/spec-passed/result - '->d-underscore2 - '(let ([x '()]) - ((contract (->d () () [_ (begin (set! x (cons 'ctc x)) any/c)]) - (λ () (set! x (cons 'body x))) - 'pos - 'neg)) - x) - '(body ctc)) - - (test/spec-passed/result - '->d-underscore3 - '(let ([x '()]) - ((contract (->d () () [res (begin (set! x (cons 'ctc x)) any/c)]) - (λ () (set! x (cons 'body x))) - 'pos - 'neg)) - x) - '(ctc body)) - - (test/spec-passed/result - '->d-underscore4 - '((contract (->d ([str any/c]) () #:rest rest (listof any/c) [_ any/c]) - (λ (x . y) (cons x y)) - 'pos 'neg) - 1 2 3) - '(1 2 3)) - - (test/spec-passed/result - '->d-underscore5 - '((contract (->d ([str any/c]) () #:rest rest (listof any/c) [_ any/c]) - (λ (x . y) (cons x y)) - 'pos 'neg) - 1 2 3 4 5) - '(1 2 3 4 5)) - - -; -; -; -; -; ;; -; ; ;; -; ; -; ;; ;; -; ;;;; ;; ;; -; ;;; ;; -; ;;; ;; -; ;; ;; -; ; ;; -; -; -; - - - - (test/spec-passed - '->i-stx-1 - '(->i ([x (y) number?] - [y number?]) - any)) - - (test/spec-passed - '->i-stx-2 - (->i () - (values [x (y) number?] - [y number?]))) - - (test/spec-passed - '->i-stx-3 - (->i () - #:rest [x number?] - [y (x) number?])) - - (contract-syntax-error-test - '->i-stx4 - '(->i (#:kwd1 [x number?] - #:kwd2 [x number?]) - (values [y number?] - [z number?]))) - - (contract-syntax-error-test - '->i-stx5 - #'(->i (#:kwd1 [w number?] - #:kwd1 [x number?]) - (values [y number?] - [z number?]))) - - (contract-syntax-error-test - '->i-stx6 - #'(->i (#:kwd1 [w number?] - #:kwd2 [x number?]) - (values [y number?] - [w number?]))) - - (contract-syntax-error-test - '->i-stx7 - #'(->i (#:kwd1 [w number?] - #:kwd2 [x number?]) - (values [y number?] - [y number?]))) - - (contract-syntax-error-test - '->i-stx8 - #'(->i (#:kwd1 [w number?] - #:kwd2 [x number?]) - (values [y number?] - [w number?]))) - - (contract-syntax-error-test - '->i-stx10 - #'(->i (#:kwd1 [x number?] - #:kwd2 [y number?]) - [x number?])) - - (contract-syntax-error-test - '->i-stx11 - #'(->i (#:kwd1 [x number?] - #:kwd2 [y number?]) - #:rest [x any/c] - any)) - - (contract-syntax-error-test - '->i-stx12 - #'(let ([c integer?]) - (->i ((arg any/c)) () (values (_ (arg) c) (x (arg) c) (_ (arg) c))))) - - (contract-syntax-error-test - '->i-stx13 - #'(->i ([x (y) number?]) - any)) - - (contract-syntax-error-test - '->i-stx14 - #'(->i ([x number?]) #:pre (y) #t any)) - - (contract-syntax-error-test - '->i-stx15 - #'(->i ([x number?]) #:pre (x) #t [res any/c] #:post (y) #t)) - - (contract-syntax-error-test - '->i-stx16 - #'(->i ([x (y) number?]) - [y number?])) - - (contract-syntax-error-test - '->i-stx17 - #'(->i () - #:rest [x (y) number?] - [y number?])) - - (contract-syntax-error-test - '->i-stx18 - #'(->i ([x number?]) #:pre (res) #t [res any/c] #:post (x) #t)) - - (contract-syntax-error-test - '->i-stx19 - #'(->i ([x (x) number?]) - any)) - - (contract-syntax-error-test - '->i-stx20 - #'(->i ([x (y) number?] - [y (x) number?]) - any)) - - (contract-syntax-error-test - '->i-stx21 - #'(->i ([in number?]) - (values [x (y) number?] - [y (z) number?] - [z (x) number?]))) - - (contract-syntax-error-test - '->i-stx22 - #'(->i () - #:rest [x (x) number?] - any)) - - (test/spec-passed - '->i1 - '((contract (->i () () [x number?]) (lambda () 1) 'pos 'neg))) - - (test/spec-passed - '->i2 - '((contract (->i ([x number?]) () (values [r number?])) (lambda (x) (+ x 1)) 'pos 'neg) 1)) - - (test/pos-blame - '->i3 - '((contract (->i () () [r number?]) 1 'pos 'neg))) - - (test/pos-blame - '->i4 - '((contract (->i () () [r number?]) (lambda (x) x) 'pos 'neg))) - - (test/neg-blame - '->i5 - '((contract (->i ([x number?]) () any) (lambda (x) (+ x 1)) 'pos 'neg) #f)) - - (test/pos-blame - '->i6 - '((contract (->i ([x number?]) () [r (x) (<=/c x)]) (lambda (x) (+ x 1)) 'pos 'neg) 1)) - - (test/spec-passed - '->i7 - '((contract (->i ([x number?] [y (x) (<=/c x)]) () [r (x) (<=/c x)]) - (lambda (x y) (- x 1)) 'pos 'neg) 1 0)) - - (test/neg-blame - '->i8 - '((contract (->i ([x number?] [y (x) (<=/c x)]) () [r (x) (<=/c x)]) - (lambda (x y) (+ x 1)) 'pos 'neg) 1 2)) - - (test/spec-passed - '->i9 - '((contract (->i ([y (x) (<=/c x)] [x number?]) () [r (x) (<=/c x)]) - (lambda (y x) (- x 1)) 'pos 'neg) 1 2)) - - (test/neg-blame - '->i10 - '((contract (->i ([y (x) (<=/c x)] [x number?]) () [r (x) (<=/c x)]) - (lambda (y x) (+ x 1)) 'pos 'neg) 1 0)) - - (test/spec-passed - '->i11 - '((contract (->i () () #:rest [rest any/c] [r number?]) (lambda x 1) 'pos 'neg))) - - (test/spec-passed - '->i12 - '((contract (->i ([x number?]) () #:rest [rest any/c] [r number?]) - (lambda (x . y) (+ x 1)) 'pos 'neg) 1)) - - (test/pos-blame - '->i13 - '((contract (->i () () #:rest [rest any/c] [r number?]) 1 'pos 'neg))) - - (test/pos-blame - '->i14 - '((contract (->i () () #:rest [rest any/c] [r number?]) (lambda (x) x) 'pos 'neg))) - - (test/neg-blame - '->i15 - '((contract (->i ([x number?]) () #:rest [rest any/c] any) (lambda (x . y) (+ x 1)) 'pos 'neg) #f)) - - (test/pos-blame - '->i16 - '((contract (->i ([x number?]) () #:rest [rest any/c] [r (x) (<=/c x)]) - (lambda (x . y) (+ x 1)) 'pos 'neg) 1)) - - (test/spec-passed - '->i17 - '((contract (->i ([x number?] [y (x) (<=/c x)]) () #:rest [rest any/c] [r (x) (<=/c x)]) - (lambda (x y . z) (- x 1)) 'pos 'neg) 1 0)) - - (test/neg-blame - '->i18 - '((contract (->i ([x number?] [y (x) (<=/c x)]) () #:rest [rest any/c] [r (x) (<=/c x)]) - (lambda (x y . z) (+ x 1)) 'pos 'neg) 1 2)) - - (test/spec-passed - '->i19 - '((contract (->i ([y (x) (<=/c x)] [x number?]) () #:rest [rest any/c] [r (x) (<=/c x)]) - (lambda (y x . z) (- x 1)) 'pos 'neg) 1 2)) - - (test/neg-blame - '->i20 - '((contract (->i ([y (x) (<=/c x)] [x number?]) () #:rest [rest any/c] [r (x) (<=/c x)]) - (lambda (y x . z) (+ x 1)) 'pos 'neg) 1 0)) - - (test/spec-passed - '->i21 - '((contract (->i () () #:rest [rst (listof number?)] [r any/c]) (lambda w 1) 'pos 'neg) 1)) - - (test/neg-blame - '->i22 - '((contract (->i () () #:rest [rst (listof number?)] [r any/c]) (lambda w 1) 'pos 'neg) #f)) - - (test/spec-passed/result - '->i22 - '(send (contract (object-contract - [m (->i ([x any/c] #:y [y any/c]) ([z any/c]) any)]) - (new (class object% - (define/public (m x #:y y [z 1]) x) - (super-new))) - 'pos - 'neg) - m 1 #:y 2) - 1) - - (test/spec-passed/result - '->i23 - '((contract (->i ([x any/c] #:y [y any/c]) ([z any/c]) any) - (let () - (define (m x #:y y [z 1]) x) - m) - 'pos - 'neg) - 1 #:y 2) - 1) - - (test/spec-passed/result - '->i24 - '((contract (->i ([x any/c]) ([y any/c]) any) - (let () - (define (m x [y 1]) x) - m) - 'pos - 'neg) - 1) - 1) - - (test/spec-passed/result - '->i25 - '(send (contract (object-contract - [m (->i ([x any/c]) ([y any/c]) any)]) - (new (class object% - (define/public (m x [y 1]) x) - (super-new))) - 'pos - 'neg) - m 1) - 1) - - (test/spec-passed/result - '->i26 - '(send (contract (object-contract - [m (->i ([x any/c]) #:rest [rest any/c] any)]) - (new (class object% - (define/public (m x . y) x) - (super-new))) - 'pos - 'neg) - m 1) - 1) - - (test/spec-passed/result - '->i27 - '(send (contract (object-contract - [m (->i ([x any/c]) any)]) - (new (class object% - (define/public (m x) x) - (super-new))) - 'pos - 'neg) - m 1) - 1) - - (test/spec-passed/result - '->i28 - '((contract (->i ([x real?]) - #:rest [rest (x) (listof (>=/c x))] - any) - (λ (x . rest) - (cons x rest)) - 'pos - 'neg) - 1 - 2 - 3) - '(1 2 3)) - - (test/neg-blame - '->i29 - '((contract (->i ([x real?]) - #:rest [rest (x) (listof (>=/c x))] - any) - (λ (x . rest) - (cons x rest)) - 'pos - 'neg) - 1 - -2 - -3)) - - (test/spec-passed - '->i-any1 - '((contract (->i () () any) (lambda () 1) 'pos 'neg))) - - (test/spec-passed - '->i-any2 - '((contract (->i ([x number?]) () any) (lambda (x) (+ x 1)) 'pos 'neg) 1)) - - (test/pos-blame - '->i-any3 - '((contract (->i () () any) 1 'pos 'neg))) - - (test/pos-blame - '->i-any4 - '((contract (->i () () any) (lambda (x) x) 'pos 'neg))) - - (test/neg-blame - '->i-any5 - '((contract (->i ([x number?]) () any) (lambda (x) (+ x 1)) 'pos 'neg) #f)) - - (test/spec-passed - '->i-any6 - '((contract (->i ([x number?] [y (x) (<=/c x)]) () any) (lambda (x y) (- x 1)) 'pos 'neg) 1 0)) - - (test/neg-blame - '->i-any7 - '((contract (->i ([x number?] [y (x) (<=/c x)]) () any) (lambda (x y) (+ x 1)) 'pos 'neg) 1 2)) - - (test/spec-passed - '->i-any8 - '((contract (->i ([y (x) (<=/c x)] [x number?]) () any) (lambda (y x) (- x 1)) 'pos 'neg) 1 2)) - - (test/neg-blame - '->i-any9 - '((contract (->i ([y (x) (<=/c x)] [x number?]) () any) (lambda (y x) (+ x 1)) 'pos 'neg) 1 0)) - - (test/spec-passed - '->i-any10 - '((contract (->i () () #:rest [rest any/c] any) (lambda x 1) 'pos 'neg))) - - (test/spec-passed - '->i-any11 - '((contract (->i ([x number?]) () #:rest [rest any/c] any) (lambda (x . y) (+ x 1)) 'pos 'neg) 1)) - - (test/pos-blame - '->i-any12 - '((contract (->i () () #:rest [rest any/c] any) 1 'pos 'neg))) - - (test/pos-blame - '->i-any13 - '((contract (->i () () #:rest [rest any/c] any) (lambda (x) x) 'pos 'neg))) - - (test/neg-blame - '->i-any14 - '((contract (->i ([x number?]) () #:rest [rest any/c] any) (lambda (x . y) (+ x 1)) 'pos 'neg) #f)) - - (test/spec-passed - '->i-any15 - '((contract (->i ([x number?] [y (x) (<=/c x)]) () #:rest [rest any/c] any) - (lambda (x y . z) (- x 1)) 'pos 'neg) 1 0)) - - (test/neg-blame - '->i-any16 - '((contract (->i ([x number?] [y (x) (<=/c x)]) () #:rest [rest any/c] any) - (lambda (x y . z) (+ x 1)) 'pos 'neg) 1 2)) - - (test/spec-passed - '->i-any17 - '((contract (->i ([y (x) (<=/c x)] [x number?]) () #:rest [rest any/c] any) - (lambda (y x . z) (- x 1)) 'pos 'neg) 1 2)) - - (test/neg-blame - '->i-any18 - '((contract (->i ([y (x) (<=/c x)] [x number?]) () #:rest [rest any/c] any) - (lambda (y x . z) (+ x 1)) 'pos 'neg) 1 0)) - - (test/spec-passed - '->i-any19 - '((contract (->i () () #:rest [rst (listof number?)] any) (lambda w 1) 'pos 'neg) 1)) - - (test/neg-blame - '->i-any20 - '((contract (->i () () #:rest [rst (listof number?)] any) (lambda w 1) 'pos 'neg) #f)) - - (test/spec-passed - '->i-values1 - '((contract (->i () () (values [x boolean?] [y number?])) (lambda () (values #t 1)) 'pos 'neg))) - - (test/spec-passed - '->i-values2 - '((contract (->i ([x number?]) () (values [z boolean?] [y number?])) - (lambda (x) (values #t (+ x 1))) 'pos 'neg) 1)) - - (test/pos-blame - '->i-values3 - '((contract (->i () () (values [x boolean?] [y number?])) 1 'pos 'neg))) - - (test/pos-blame - '->i-values4 - '((contract (->i () () (values [x boolean?] [y number?])) (lambda (x) x) 'pos 'neg))) - - (test/neg-blame - '->i-values5 - '((contract (->i ([x number?]) () (values [y boolean?] [z (x) (<=/c x)])) - (lambda (x) (+ x 1)) 'pos 'neg) #f)) - - (test/pos-blame - '->i-values6 - '((contract (->i ([x number?]) () (values [y boolean?] [z (x) (<=/c x)])) - (lambda (x) (values #t (+ x 1))) 'pos 'neg) 1)) - - (test/spec-passed - '->i-values7 - '((contract (->i ([x number?] [y (x) (<=/c x)]) () (values [z boolean?] [w (x) (<=/c x)])) - (lambda (x y) (values #t (- x 1))) - 'pos - 'neg) - 1 - 0)) - - (test/neg-blame - '->i-values8 - '((contract (->i ([x number?] [y (x) (<=/c x)]) () (values [z boolean?] [w (x) (<=/c x)])) - (lambda (x y) (values #f (+ x 1))) - 'pos - 'neg) - 1 - 2)) - - (test/spec-passed - '->i-values9 - '((contract (->i ([y (x) (<=/c x)] [x number?]) () (values [z boolean?] [w (x) (<=/c x)])) - (lambda (y x) (values #f (- x 1))) - 'pos - 'neg) - 1 - 2)) - - (test/neg-blame - '->i-values10 - '((contract (->i ([y (x) (<=/c x)] [x number?]) () (values [z boolean?] [w (x) (<=/c x)])) - (lambda (y x) (values #f (+ x 1))) 'pos 'neg) - 1 0)) - - (test/spec-passed - '->i-values11 - '((contract (->i () () #:rest [rest any/c] (values [z boolean?] [w number?])) - (lambda x (values #f 1)) 'pos 'neg))) - - (test/spec-passed - '->i-values12 - '((contract (->i ([x number?]) () #:rest [rest any/c] (values [z boolean?] [w number?])) - (lambda (x . y) (values #f (+ x 1))) - 'pos - 'neg) - 1)) - - (test/pos-blame - '->i-values13 - '((contract (->i () () #:rest [rest any/c] (values [z boolean?] [w number?])) 1 'pos 'neg))) - - (test/pos-blame - '->i-values14 - '((contract (->i () () #:rest [rest any/c] (values [z boolean?] [w number?])) - (lambda (x) x) 'pos 'neg))) - - (test/neg-blame - '->i-values15 - '((contract (->i ([x number?]) () #:rest [rest any/c] (values [z boolean?] [w (x) (<=/c x)])) - (lambda (x . y) (+ x 1)) 'pos 'neg) - #f)) - - (test/pos-blame - '->i-values16 - '((contract (->i ([x number?]) () #:rest [rest any/c] (values [z boolean?] [w (x) (<=/c x)])) - (lambda (x . y) (values #f (+ x 1))) 'pos 'neg) - 1)) - - (test/spec-passed - '->i-values17 - '((contract (->i ([x number?] [y (x) (<=/c x)]) () #:rest [rest any/c] - (values [z boolean?] [w (x) (<=/c x)])) - (lambda (x y . z) (values #f (- x 1))) 'pos 'neg) - 1 0)) - - (test/neg-blame - '->i-values18 - '((contract (->i ([x number?] [y (x) (<=/c x)]) () #:rest [rest any/c] - (values [z boolean?] [w (x) (<=/c x)])) - (lambda (x y . z) (values #f (+ x 1))) 'pos 'neg) - 1 2)) - - (test/spec-passed - '->i-values19 - '((contract (->i ([y (x) (<=/c x)] [x number?]) () #:rest [rest any/c] - (values [z boolean?] [w (x) (<=/c x)])) - (lambda (y x . z) (values #f (- x 1))) 'pos 'neg) - 1 2)) - - (test/neg-blame - '->i-values20 - '((contract (->i ([y (x) (<=/c x)] [x number?]) () #:rest [rest any/c] - (values [z boolean?] [w (x) (<=/c x)])) - (lambda (y x . z) (values #f (+ x 1))) 'pos 'neg) - 1 0)) - - (test/spec-passed - '->i-values21 - '((contract (->i () () #:rest [rst (listof number?)] (values [z boolean?] [w any/c])) - (lambda w (values #f 1)) 'pos 'neg) 1)) - - (test/neg-blame - '->i-values22 - '((contract (->i () () #:rest [rst (listof number?)] (values [z boolean?] [w any/c])) - (lambda w (values #f 1)) 'pos 'neg) #f)) - - (test/spec-passed - '->i-values23 - '((contract (->i () () (values [x number?] [y (x) (>=/c x)])) (lambda () (values 1 2)) 'pos 'neg))) - - (test/pos-blame - '->i-values24 - '((contract (->i () () (values [x number?] [y (x) (>=/c x)])) (lambda () (values 2 1)) 'pos 'neg))) - - (test/spec-passed - '->i-values25 - '((contract (->i ([x number?]) () (values [z number?] [y (x) (>=/c x)])) - (lambda (x) (values 1 2)) 'pos 'neg) 1)) - - (test/pos-blame - '->i-values26 - '((contract (->i ([x number?]) () (values [z number?] [y (x) (>=/c x)])) - (lambda (x) (values 2 1)) 'pos 'neg) 4)) - - (test/spec-passed/result - '->i23 - '((contract (->i ((i number?) (j (i) (and/c number? (>=/c i)))) () [r number?]) - (λ (i j) 1) - 'pos - 'neg) - 1 - 2) - 1) - - (test/spec-passed/result - '->i24 - '((contract (->i ([i number?] [j (i) (and/c number? (>=/c i))]) () any) - (λ (i j) 1) - 'pos - 'neg) - 1 - 2) - 1) - - (test/spec-passed/result - '->i25 - '(call-with-values - (λ () - ((contract (->i ((i number?) (j (i) (and/c number? (>=/c i)))) () - (values [x number?] [y number?])) - (λ (i j) (values 1 2)) - 'pos - 'neg) - 1 - 2)) - list) - '(1 2)) - - (test/spec-passed/result - '->i26 - '((contract (->i ((i number?) (j (i) (and/c number? (>=/c i)))) () - #:rest [rest-args any/c] [r number?]) - (λ (i j . z) 1) - 'pos - 'neg) - 1 - 2) - 1) - - (test/spec-passed/result - '->i27 - '((contract (->i ((i number?) (j (i) (and/c number? (>=/c i)))) () #:rest [rest-args any/c] any) - (λ (i j . z) 1) - 'pos - 'neg) - 1 - 2) - 1) - - (test/spec-passed/result - '->i28 - '(call-with-values - (λ () - ((contract (->i ((i number?) (j (i) (and/c number? (>=/c i)))) () - #:rest [rest-args any/c] - (values [x number?] [y number?])) - (λ (i j . z) (values 1 2)) - 'pos - 'neg) - 1 - 2)) - list) - '(1 2)) - - (test/neg-blame - '->i30 - '((contract (->i ([x number?]) () #:rest [rst number?] any) - (λ (x . rst) (values 4 5)) - 'pos - 'neg) - #f)) - - (test/spec-passed/result - '->i34 - '((contract (->i ([x number?] - [y (x z) (between/c x z)] - [z number?]) - any) - (λ (x y z) (+ x y z)) - 'pos 'neg) - 1 2 3) - 6) - - (test/neg-blame - '->i35 - '((contract (->i ([x number?]) #:pre () (= 1 2) any) - (λ (x) 1) - 'pos 'neg) 2)) - - (test/neg-blame - '->i35-b - '((contract (->i ([x number?]) #:pre () #t #:pre () (= 1 2) any) - (λ (x) 1) - 'pos 'neg) 2)) - - (test/neg-blame - '->i35-c - '((contract (->i ([x number?]) #:pre (x) (even? x) #:pre (x) (positive? x) any) - (λ (x) 1) - 'pos 'neg) 3)) - - (test/neg-blame - '->i35-d - '((contract (->i ([x number?]) #:pre (x) (even? x) #:pre (x) (positive? x) any) - (λ (x) 1) - 'pos 'neg) -2)) - - (test/neg-blame - '->i35-e - '((contract (->i ([x any/c]) #:pre (x) (pair? x) #:pre (x) (car x) any) - (λ (x) 1) - 'pos 'neg) - (cons #f 1))) - - (test/neg-blame - '->i35-f - '((contract (->i ([x any/c]) #:pre/name (x) "pair" (pair? x) #:pre/name (x) "car" (car x) any) - (λ (x) 1) - 'pos 'neg) - (cons #f 1))) - - (test/spec-passed/result - '->i36 - '((contract (->i ([f (-> number? number?)]) [res number?]) - (λ (f) (f 1)) - 'pos 'neg) - (λ (n) (+ n 1))) - 2) - - (test/pos-blame - '->i37 - '((contract (->i ([f (-> number? number?)]) [res number?]) - (λ (f) #f) - 'pos 'neg) - (λ (n) (+ n 1)))) - - (test/spec-passed/result - '->i38 - '((contract (->i ([x integer?]) () #:rest [rst (listof number?)] [r any/c]) (lambda w w) 'pos 'neg) - 1 2) - '(1 2)) - - (test/spec-passed/result - '->i39 - '((contract (->i (#:x [x integer?]) () #:rest [rst (listof number?)] [r any/c]) - (lambda (#:x x . w) (cons x w)) 'pos 'neg) #:x 1 2) - '(1 2)) - - (test/spec-passed/result - '->i40 - '((contract (->i () ([x integer?]) #:rest [rst (listof number?)] [r any/c]) - (lambda w w) 'pos 'neg) 1 2) - '(1 2)) - - (test/spec-passed/result - '->i41 - '((contract (->i () (#:x [x integer?]) #:rest [rst (listof number?)] [r any/c]) - (lambda (#:x [x 1] . w) (cons x w)) 'pos 'neg) #:x 2 3) - '(2 3)) - - (test/spec-passed/result - '->i42 - '((contract (->i () (#:x [x integer?]) #:rest [rst (listof number?)] [r any/c]) - (lambda (#:x [x 1] . w) (cons x w)) 'pos 'neg) 2 3) - '(1 2 3)) - - (test/spec-passed/result - '->i43 - '(let ([b (box '())]) - ((contract (->i ([i (box/c (listof integer?))]) - (values [_ (i) - (begin - (set-box! i (cons 1 (unbox i))) - (λ (x) - (set-box! i (cons 4 (unbox i))) - #t))] - [_ (i) - (begin - (set-box! i (cons 2 (unbox i))) - (λ (x) - (set-box! i (cons 5 (unbox i))) - #t))])) - (λ (i) - (set-box! i (cons 3 (unbox i))) - (values 2 2)) - (quote pos) - (quote neg)) - b) - (unbox b)) - '(5 4 3 2 1)) - - (test/spec-passed/result - '->i44 - '((contract (->i ([x () any/c]) - [y any/c] - #:post (x) x) - (lambda (x) x) - 'pos - 'neg) - #t) - '#t) - - (test/pos-blame - '->i45 - '((contract (->i ([x () any/c]) - [y any/c] - #:post (x) x) - (lambda (x) x) - 'pos - 'neg) - #f)) - - (test/spec-passed/result - '->i46 - '((contract (->i ([x any/c]) - [y () any/c] - #:post (y) y) - (lambda (x) x) - 'pos - 'neg) - #t) - '#t) - - (test/pos-blame - '->i47 - '((contract (->i ([x any/c]) - [y () any/c] - #:post (y) y) - (lambda (x) x) - 'pos - 'neg) - #f)) - - (test/pos-blame - '->i47-b - '((contract (->i ([x any/c]) - [y () any/c] - #:post (y) (even? y) - #:post (y) (positive? y)) - (lambda (x) x) - 'pos - 'neg) - -2)) - - (test/pos-blame - '->i47-c - '((contract (->i ([x any/c]) - [y () any/c] - #:post (y) (even? y) - #:post (y) (positive? y)) - (lambda (x) x) - 'pos - 'neg) - 3)) - - (test/pos-blame - '->i47-d - '((contract (->i ([x any/c]) - [y () any/c] - #:post (y) (pair? y) - #:post (y) (car y)) - (lambda (x) x) - 'pos - 'neg) - (cons #f 1))) - - (test/pos-blame - '->i47-e - '((contract (->i ([x any/c]) - [y () any/c] - #:post/name (y) "pair" (pair? y) - #:post/name (y) "car" (car y)) - (lambda (x) x) - 'pos - 'neg) - (cons #f 1))) - - (test/spec-passed/result - '->i48 - '(let ([x '()]) - ((contract (->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)]) - [res () (begin - (set! x (cons 'res-eval x)) - (λ (res) - (set! x (cons 'res-check x))))]) - (λ (arg) - (set! x (cons 'body x))) - 'pos - 'neg) - 1) - x) - '(res-check res-eval body arg-eval)) - - (test/spec-passed/result - '->i49 - '(let ([x '()]) - ((contract (->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)]) - [_ () (begin - (set! x (cons 'res-eval x)) - (λ (res) - (set! x (cons 'res-check x))))]) - (λ (arg) - (set! x (cons 'body x))) - 'pos - 'neg) - 1) - x) - '(res-check body res-eval arg-eval)) - - (test/spec-passed/result - '->i50 - '(let ([x '()]) - ((contract (->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)]) - [res (begin - (set! x (cons 'res-eval x)) - (λ (res) - (set! x (cons 'res-check x))))]) - (λ (arg) - (set! x (cons 'body x))) - 'pos - 'neg) - 1) - x) - '(res-check body res-eval arg-eval)) - - (test/spec-passed/result - '->i51 - '(let ([x '()]) - ((contract (->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)]) - [_ (begin - (set! x (cons 'res-eval x)) - (λ (res) - (set! x (cons 'res-check x))))]) - (λ (arg) - (set! x (cons 'body x))) - 'pos - 'neg) - 1) - x) - '(res-check body res-eval arg-eval)) - - (test/spec-passed/result - '->i52 - '((contract (->i () - ([x integer?]) - any) - (λ ([x 'qq]) x) - 'pos - 'neg)) - 'qq) - - (test/pos-blame - '->i-arity1 - '(contract (->i ([x number?]) () any) (λ () 1) 'pos 'neg)) - - (test/pos-blame - '->i-arity2 - '(contract (->i ([x number?]) () any) (λ (x #:y y) 1) 'pos 'neg)) - - (test/spec-passed - '->i-arity3 - '(contract (->i ([x number?] #:y [y integer?]) () any) (λ (x #:y y) 1) 'pos 'neg)) - - (test/pos-blame - '->i-arity4 - '(contract (->i () ([x integer?]) any) (λ (x) 1) 'pos 'neg)) - - (test/pos-blame - '->i-arity5 - '(contract (->i () ([x integer?]) any) (λ () 1) 'pos 'neg)) - - (test/spec-passed - '->i-arity6 - '(contract (->i () ([x integer?]) any) (λ ([x 1]) 1) 'pos 'neg)) - - (test/pos-blame - '->i-arity7 - '(contract (->i () (#:x [x integer?]) any) (λ ([x 1]) 1) 'pos 'neg)) - - (test/pos-blame - '->i-arity8 - '(contract (->i () (#:x [x integer?]) any) (λ () 1) 'pos 'neg)) - - (test/pos-blame - '->i-arity8 - '(contract (->i () (#:x [x integer?]) any) (λ (#:x x) 1) 'pos 'neg)) - - (test/spec-passed - '->i-arity10 - '(contract (->i () (#:x [x integer?]) any) (λ (#:x [x 1]) 1) 'pos 'neg)) - - (test/pos-blame - '->i-pp1 - '((contract (->i ([x number?]) () #:pre (x) (= x 1) [result number?] #:post (x) (= x 2)) - (λ (x) x) - 'pos - 'neg) - 1)) - - (test/neg-blame - '->i-pp2 - '((contract (->i ([x number?]) () #:pre (x) (= x 1) [result number?] #:post (x) (= x 2)) - (λ (x) x) - 'pos - 'neg) - 2)) - - (test/pos-blame - '->i-pp3 - '((contract (->i ([x number?]) () #:pre (x) (= x 1) [result number?] #:post (result) (= result 2)) - (λ (x) x) - 'pos - 'neg) - 1)) - - (test/spec-passed - '->i-pp3.5 - '((contract (->i ([x number?]) () #:pre (x) (= x 1) [result number?] #:post (result) (= result 2)) - (λ (x) 2) - 'pos - 'neg) - 1)) - - (test/neg-blame - '->i-pp4 - '((contract (->i ([x number?]) () #:pre (x) (= x 1) any) - (λ (x) x) - 'pos - 'neg) - 2)) - - (test/neg-blame - '->i-pp5 - '((contract (->i ([x number?]) () #:pre (x) (= x 1) (values [z number?] [y number?]) - #:post (x y z) (= x y z 3)) - (λ (x) (values 4 5)) - 'pos - 'neg) - 2)) - - (test/pos-blame - '->i-pp6 - '((contract (->i ([x number?]) () #:pre (x) (= x 1) (values [z number?] [y number?]) - #:post (z y) (= z y 3)) - (λ (x) (values 4 5)) - 'pos - 'neg) - 1)) - - (test/pos-blame - '->i-pp-r1 - '((contract (->i ([x number?]) () #:rest [rst any/c] #:pre (x) (= x 1) [result number?] - #:post (x) (= x 2)) - (λ (x . rst) x) - 'pos - 'neg) - 1)) - - (test/neg-blame - '->i-pp-r2 - '((contract (->i ([x number?]) () #:rest [rst any/c] - #:pre (x) (= x 1) [result number?] - #:post (x) (= x 2)) - (λ (x . rst) x) - 'pos - 'neg) - 2)) - - (test/pos-blame - '->i-pp-r3 - '((contract (->i ([x number?]) () #:rest [rst any/c] - #:pre (x) (= x 1) [result number?] - #:post (result) (= result 2)) - (λ (x . rst) x) - 'pos - 'neg) - 1)) - - (test/spec-passed - '->i-pp-r3.5 - '((contract (->i ([x number?]) () #:rest [rst any/c] - #:pre (x) (= x 1) [result number?] - #:post (result) (= result 2)) - (λ (x . rst) 2) - 'pos - 'neg) - 1)) - - (test/neg-blame - '->i-pp-r4 - '((contract (->i ([x number?]) () #:rest [rst any/c] #:pre (x) (= x 1) any) - (λ (x . rst) x) - 'pos - 'neg) - 2)) - - (test/neg-blame - '->i-pp-r5 - '((contract (->i ([x number?]) () #:rest [rst any/c] - #:pre (x) (= x 1) (values [z number?] [y number?]) - #:post (x y z) (= x y z 3)) - (λ (x . rst) (values 4 5)) - 'pos - 'neg) - 2)) - - (test/pos-blame - '->i-pp-r6 - '((contract (->i ([x number?]) () #:rest [rst any/c] - #:pre (x) (= x 1) (values [z number?] [y number?]) - #:post (x y z) (= z x y 3)) - (λ (x . rst) (values 4 5)) - 'pos - 'neg) - 1)) - - - ;; test to make sure the values are in the error messages - (contract-error-test - '->i-contract-error-test1 - #'((contract (->i ([x number?]) #:pre (x) #f any) - (λ (x) x) - 'pos - 'neg) - 123456789) - (λ (x) - (and (exn:fail:contract:blame? x) - (regexp-match #rx"x: 123456789" (exn-message x))))) - (contract-error-test - '->i-contract-error-test2 - #'((contract (->i ([|x y| number?]) #:pre (|x y|) #f any) - (λ (x) x) - 'pos - 'neg) - 123456789) - (λ (x) - (and (exn:fail:contract:blame? x) - (regexp-match (regexp-quote "|x y|: 123456789") (exn-message x))))) - - ;; test to make sure the collects directories are appropriately prefixed - (contract-error-test - '->i-contract-error-test3 - '(contract symbol? "not a symbol" 'pos 'neg 'not-a-symbol - (datum->syntax - #f - 'here - (vector (collection-file-path "base.rkt" "racket") - 1 1 1 1))) - (lambda (x) - (and (exn:fail:contract:blame? x) - (let ([msg (exn-message x)]) - (define ans (regexp-match? #px"" msg)) - (unless ans - (printf "msg: ~s\n" msg)) - ans)))) - - ;; make sure that ->i checks its arguments - (contract-error-test - '->i-contract-error-test4 - #'(->i ([x (λ (x y z) #f)]) any) - exn:fail?) - - (contract-error-test - '->i-contract-error-test5 - #'(->i () (values [x (λ (x y z) #f)][y 5])) - exn:fail?) - - (test/neg-blame - '->i-protect-shared-state - '(let ([x 1]) - ((contract (let ([save #f]) - (-> (->i () () #:pre () (set! save x) [range any/c] #:post () (= save x)) - any)) - (λ (t) (t)) - 'pos - 'neg) - (lambda () (set! x 2))))) - - - (test/spec-passed - '->i-optopt1 - '((contract (->i ([x number?]) any) - (λ (x) x) - 'pos 'neg) - 1)) - - (test/spec-passed - '->i-optopt2 - '((contract (->i ([x number?]) #:rest [rst any/c] any) - (λ (x . y) x) - 'pos 'neg) - 1)) - - (test/spec-passed - '->i-optopt3 - '((contract (->i ([x number?]) #:pre () #t any) - (λ (x) x) - 'pos 'neg) - 1)) - - (test/spec-passed - '->i-optopt4 - '((contract (->i ([x number?]) #:rest [rst any/c] #:pre () #t any) - (λ (x . y) x) - 'pos 'neg) - 1)) - - (test/spec-passed - '->i-optopt5 - '((contract (->i ([x number?]) #:rest [rst any/c] #:pre () #t [res any/c] #:post () #t) - (λ (x . y) x) - 'pos 'neg) - 1)) - - (test/spec-passed - '->i-optopt6 - '((contract (->i ([x number?]) #:rest [rst any/c] [res any/c] #:post () #t) - (λ (x . y) x) - 'pos 'neg) - 1)) - - (test/spec-passed - '->i-optopt7 - '((contract (->i ([x number?]) #:pre () #t [res any/c] #:post () #t) - (λ (x . y) x) - 'pos 'neg) - 1)) - - (test/spec-passed - '->i-optopt8 - '((contract (->i ([x number?]) [res any/c] #:post () #t) - (λ (x . y) x) - 'pos 'neg) - 1)) - - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; make sure the variables are all bound properly - ;; - - (test/spec-passed - '->i-binding1 - '((contract (->i ([x number?]) () - #:rest [rest any/c] [range any/c] - #:post (rest) (equal? rest '(2 3 4))) - (λ (x . y) y) - 'pos - 'neg) - 1 2 3 4)) - - (test/spec-passed - '->i-binding2 - '((contract (->i ([x number?]) () #:rest [rest any/c] [range any/c] #:post (x) (equal? x 1)) - (λ (x . y) y) - 'pos - 'neg) - 1 2 3 4)) - - (test/spec-passed - '->i-binding3 - '(let ([p 'p] - [q 'q] - [r 'r]) - ((contract (->i ([x number?] [y number?] #:z [z number?] #:w [w number?]) - ([a number?] [b number?] #:c [c number?] #:d [d number?]) - #:rest [rest any/c] - #:pre (x y z w a b c d rest) - (equal? (list x y z w a b c d rest p q r) - (list 1 2 3 4 5 6 7 8 '(z) 'p 'q 'r)) - (values [p number?] [q number?] [r number?])) - (λ (x y #:z z #:w w [a 101] [b 102] #:c [c 103] #:d [d 104] . rest) - (values 11 12 13)) - 'pos - 'neg) - 1 2 #:z 3 #:w 4 5 6 #:c 7 #:d 8 'z))) - - (test/spec-passed - '->i-binding4 - '((contract (->i ([x number?] [y number?] #:z [z number?] #:w [w number?]) - ([a number?] [b number?] #:c [c number?] #:d [d number?]) - #:rest [rest any/c] - (values [p number?] [q number?] [r number?]) - #:post (x y z w a b c d rest p q r) - (equal? (list x y z w a b c d rest p q r) - (list 1 2 3 4 5 6 7 8 '(z) 11 12 13))) - (λ (x y #:z z #:w w [a 101] [b 102] #:c [c 103] #:d [d 104] . rest) - (values 11 12 13)) - 'pos - 'neg) - 1 2 #:z 3 #:w 4 5 6 #:c 7 #:d 8 'z)) - - (test/spec-passed - '->i-binding5 - '(let ([p 'p] - [q 'q] - [r 'r]) - ((contract (->i ([x number?] [y number?] #:z [z number?] #:w [w number?]) - ([a number?] [b number?] #:c [c number?] #:d [d number?]) - #:rest [rest any/c] - #:pre (x y z w a b c d rest) - (equal? (list x y z w a b c d rest p q r) - (list 1 2 3 4 - the-unsupplied-arg the-unsupplied-arg - the-unsupplied-arg the-unsupplied-arg - '() 'p 'q 'r)) - (values [p number?] [q number?] [r number?])) - (λ (x y #:z z #:w w [a 101] [b 102] #:c [c 103] #:d [d 104] . rest) - (values 11 12 13)) - 'pos - 'neg) - 1 2 #:z 3 #:w 4))) - - (test/spec-passed - '->i-binding6 - '((contract (->i ([x number?] [y number?] #:z [z number?] #:w [w number?]) - ([a number?] [b number?] #:c [c number?] #:d [d number?]) - #:rest [rest any/c] - (values [p number?] [q number?] [r number?]) - #:post (x y z w a b c d rest p q r) - (equal? (list x y z w a b c d rest p q r) - (list 1 2 3 4 - the-unsupplied-arg the-unsupplied-arg - the-unsupplied-arg the-unsupplied-arg - '() 11 12 13))) - (λ (x y #:z z #:w w [a 101] [b 102] #:c [c 103] #:d [d 104] . rest) - (values 11 12 13)) - 'pos - 'neg) - 1 2 #:z 3 #:w 4)) - - ;; test that the rest parameter is right when there aren't - ;; enough arguments to even make it to the rest parameter - (test/spec-passed - '->i-binding7 - '((contract (->i () - ([a number?]) - #:rest [rest any/c] - [_ any/c] - #:post (a rest) (equal? (list a rest) (list the-unsupplied-arg '()))) - (λ ([a 1] . rest) 1) - 'pos - 'neg))) - - (test/pos-blame - '->i-underscore1 - '((contract (->i ([b (box/c integer?)]) - () - [_ (b) - (let ([old (unbox b)]) - (and/c - void? - (λ (new) - (= old (unbox b)))))]) - (λ (b) - (set-box! b (+ (unbox b) 1))) - 'pos - 'neg) - (box 1))) - - (test/spec-passed/result - '->i-underscore2 - '(let ([x '()]) - ((contract (->i () () [_ (begin (set! x (cons 'ctc x)) any/c)]) - (λ () (set! x (cons 'body x))) - 'pos - 'neg)) - x) - '(body ctc)) - - (test/spec-passed/result - '->i-underscore3 - '(let ([x '()]) - ((contract (->i () () [res (begin (set! x (cons 'ctc x)) any/c)]) - (λ () (set! x (cons 'body x))) - 'pos - 'neg)) - x) - '(body ctc)) - - (test/spec-passed/result - '->i-underscore4 - '((contract (->i ([str any/c]) () #:rest [rest (listof any/c)] [_ any/c]) - (λ (x . y) (cons x y)) - 'pos 'neg) - 1 2 3) - '(1 2 3)) - - (test/spec-passed/result - '->i-underscore5 - '((contract (->i ([str any/c]) () #:rest [rest (listof any/c)] [_ any/c]) - (λ (x . y) (cons x y)) - 'pos 'neg) - 1 2 3 4 5) - '(1 2 3 4 5)) - - (test/spec-passed/result - '->i-underscore6 - '(let ([x '()]) - ((contract (->i ([a integer?]) () [_ (a) (begin (set! x (cons 'ctc x)) any/c)]) - (λ (a) (set! x (cons 'body x))) - 'pos - 'neg) - 11) - x) - '(body ctc)) - - (test/pos-blame - '->i-bad-number-of-result-values1 - '((contract (->i ((x any/c)) (result (x) any/c)) - (λ (x) (values 1 2)) - 'pos - 'neg) - 1)) - - (test/pos-blame - '->i-bad-number-of-result-values2 - '((contract (->i ((giraffe any/c)) (elephant any/c)) - (λ (x) (values 1 2)) - 'pos - 'neg) - 1)) - - ;; this used to cause a runtime error in the code that parses ->i - (ctest 'no-crash - '->i-no-vars-with-dep - (begin (->i ([x () any/c] [y (x) any/c]) any) 'no-crash)) - - - -; -; -; -; -; ; -; ;;;;; ;;;;;;; ;;;;; ;;; ;;; -; ;;;;;; ;;;;;;;; ;;;;;; ;;;;; ;;;; -; ;;;;;;; ;;;; ;;;; ;;;; ;; ;;; -; ;;;; ;;;;;;; ;;;; ;;;;;;; ;;;;; ;;; -; ;;;;;;; ;; ;;;; ;;;; ;;;;; ;;;;; ;;;; -; ;;;;;; ;;;;;;;; ;;;;;; ;;;;;; ;;; -; ;;;;; ;; ;;;; ;;;;; ;;;; ; -; -; -; - - - (test/spec-passed - 'contract-case->0a - '(contract (case->) - (lambda (x) x) - 'pos - 'neg)) - - (test/spec-passed - 'contract-case->0b - '(contract (case->) - (lambda () 1) - 'pos - 'neg)) - - (test/pos-blame - 'contract-case->0c - '(contract (case->) - 1 - 'pos - 'neg)) - - (test/spec-passed - 'contract-case->0d - '(contract (case->) - (case-lambda) - 'pos - 'neg)) - - - (test/pos-blame - 'contract-case->1 - '(contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?)) - (lambda (x) x) - 'pos - 'neg)) - - (test/pos-blame - 'contract-case->2 - '((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?)) - (case-lambda - [(x y) 'case1] - [(x) 'case2]) - 'pos - 'neg) - 1 2)) - - (test/pos-blame - 'contract-case->3 - '((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?)) - (case-lambda - [(x y) 'case1] - [(x) 'case2]) - 'pos - 'neg) - 1)) - - (test/neg-blame - 'contract-case->4 - '((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?)) - (case-lambda - [(x y) 'case1] - [(x) 'case2]) - 'pos - 'neg) - 'a 2)) - - (test/neg-blame - 'contract-case->5 - '((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?)) - (case-lambda - [(x y) 'case1] - [(x) 'case2]) - 'pos - 'neg) - 2 'a)) - - (test/neg-blame - 'contract-case->6 - '((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?)) - (case-lambda - [(x y) 'case1] - [(x) 'case2]) - 'pos - 'neg) - #t)) - - (test/pos-blame - 'contract-case->7 - '((contract (case-> (integer? integer? . -> . integer?) (-> integer? #:rest any/c boolean?)) - (lambda x #\a) - 'pos - 'neg) - 1 2)) - - - (test/pos-blame - 'contract-case->8 - '((contract (case-> (integer? integer? . -> . integer?) (-> integer? #:rest any/c boolean?)) - (lambda x #t) - 'pos - 'neg) - 1 2)) - - (test/spec-passed - 'contract-case->8 - '((contract (case-> (integer? integer? . -> . integer?) (-> integer? #:rest any/c boolean?)) - (lambda x 1) - 'pos - 'neg) - 1 2)) - - (test/spec-passed/result - 'contract-case->9 - '((contract (case-> (-> integer? any)) - (lambda (x) 1) - 'pos - 'neg) - 1) - 1) - - (test/neg-blame - 'contract-case->10 - '((contract (case-> (-> integer? any)) - (lambda (x) 1) - 'pos - 'neg) - #f)) - - (test/pos-blame - 'contract-case->11 - '(contract (case-> (-> integer? any) (-> integer? integer? any)) - (lambda (x) 1) - 'pos - 'neg)) - - (test/neg-blame - 'contract-case->12 - '((contract (case-> (-> integer? any) (-> integer? integer? any)) - (case-lambda [(x) 1] [(x y) 1]) - 'pos - 'neg) - #f)) - - (test/spec-passed/result - 'contract-case->13 - '((contract (case-> (-> integer? any) (-> integer? integer? any)) - (case-lambda [(x) 1] [(x y) 1]) - 'pos - 'neg) - 1) - 1) - - (test/spec-passed/result - 'contract-case->14 - '(let ([f - (contract (case-> (-> char?) (-> integer? boolean?) (-> symbol? input-port? string?)) - (case-lambda - [() #\a] - [(x) (= x 0)] - [(sym port) - (string-append - (symbol->string sym) - (read port))]) - 'pos - 'neg)]) - (list (f) - (f 1) - (f 'x (open-input-string (format "~s" "string"))))) - (list #\a #f "xstring")) - - (test/pos-blame - 'contract-case->15 - '((contract (case-> (-> real? real? real?) - (-> real? (values real? real?))) - (case-lambda - [(x y) 1] - [(x) 1]) - 'pos 'neg) - 1)) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; ;; - ;; case-> arity checking tests ;; - ;; ;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (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/spec-passed - 'unconstrained-domain->1 - '(contract (unconstrained-domain-> number?) (λ (x) x) 'pos 'neg)) - (test/pos-blame - 'unconstrained-domain->2 - '(contract (unconstrained-domain-> number?) 1 'pos 'neg)) - (test/spec-passed - 'unconstrained-domain->3 - '((contract (unconstrained-domain-> number?) (λ (x) x) 'pos 'neg) 1)) - (test/pos-blame - 'unconstrained-domain->4 - '((contract (unconstrained-domain-> number?) (λ (x) x) 'pos 'neg) #f)) - - (test/spec-passed/result - 'unconstrained-domain->5 - '((contract (->d ([size natural-number/c] - [proc (and/c (unconstrained-domain-> number?) - (λ (p) (procedure-arity-includes? p size)))]) - () - [range number?]) - (λ (i f) (apply f (build-list i add1))) - 'pos - 'neg) - 10 +) - 55) - - (test/spec-passed/result - 'unconstrained-domain->6 - ((contract (unconstrained-domain-> any/c) - (λ (#:key k) k) - 'pos - 'neg) - #:key 1) - 1) - - (test/pos-blame - 'unconstrained-domain->7 - '((contract (unconstrained-domain-> number?) (λ (#:x x) x) 'pos 'neg) #:x #f)) - - - -; -; -; -; -; ; ;;; ; -; ;;; ; ; -; ;;; ;; ;;;;; ;;; ;;;;;;; ;;; ;; ;;; ;;;; ;;;; ;;; ;;;; ;;; ;;;; ; ;;; -; ;;;;;;; ;;;;;;; ;;;;;;;;;;;; ;;;;;;;;;;; ;; ;;; ;;;; ;;;;;;;; ;;;;; ;;;;; ; ;;;;; -; ;;; ;;; ;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;; ; ;;; ;; -; ;;; ;;; ;;;;; ;;; ;;;;; ;;; ;;; ;;; ;;;;;;; ;;; ;;; ;;; ;;; ;;;; ;;;;; ; ;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;;; ;;;; ; ;;; ;; -; ;;;;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;; ;;;; ;;; ;;; ;;;;; ; ; ;;;;; -; ;;; ;; ;;;;;; ;;; ;;;;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;; ; ;;; -; ;;; -; ;;; -; -; - - - (test/spec-passed/result - 'parametric->/c1 - '((contract (parametric->/c (A) (-> A A)) - (λ (x) x) - 'pos 'neg) - 1) - 1) - - (test/pos-blame - 'parametric->/c2 - '((contract (parametric->/c (A) (-> A A)) - (λ (x) 1) - 'pos 'neg) - 1)) - - (test/pos-blame - 'parametric->/c3 - '((contract (parametric->/c (A B) (-> A B)) - (λ (x) x) - 'pos 'neg) - 1)) - - ;; this should (probably) not require the - ;; application to 1, but parametric->/c - ;; currently checks only that its argument - ;; is a procedure and otherwise delays any - ;; checking until the first application of - ;; the wrapper - (test/pos-blame - 'parametric->/c4 - '((contract (parametric->/c (A) (-> A A)) - (λ (x y) x) - 'pos 'neg) - 1)) - - (test/pos-blame - 'parametric->/c5 - '(contract (parametric->/c (A) (-> A A)) - 5 - 'pos 'neg)) - - (test/spec-passed/result - 'parametric->/c6 - '((contract (parametric->/c (A B) (-> A B (or/c A B))) - (λ (x y) x) - 'pos 'neg) - 1 "foo") - 1) - - -; -; -; -; ;; -; ;; -; ;;;; ;;; ;;; ;; ;;;;; -; ;;;;;; ;;;;;;; ;; ;;;;;; -; ;;;;;;;; ;;;; ;; ;;;;;;;;; -; ;;;; ;;; ;;;; ;; ;;;; -; ;;;;;;;; ;;;; ;; ;;;;;;; -; ;;;;;; ;;;; ;; ;;;;;; -; ;;;; ;;;; ;; ;;;;; -; ;; -; -; - - - (test/pos-blame - 'or/c1 - '(contract (or/c false/c) #t 'pos 'neg)) - - (test/spec-passed - 'or/c2 - '(contract (or/c false/c) #f 'pos 'neg)) - - (test/spec-passed - 'or/c3 - '((contract (or/c (-> integer? integer?)) (lambda (x) x) 'pos 'neg) 1)) - - (test/neg-blame - 'or/c4 - '((contract (or/c (-> integer? integer?)) (lambda (x) x) 'pos 'neg) #f)) - - (test/pos-blame - 'or/c5 - '((contract (or/c (-> integer? integer?)) (lambda (x) #f) 'pos 'neg) 1)) - - (test/spec-passed - 'or/c6 - '(contract (or/c false/c (-> integer? integer?)) #f 'pos 'neg)) - - (test/spec-passed - 'or/c7 - '((contract (or/c false/c (-> integer? integer?)) (lambda (x) x) 'pos 'neg) 1)) - - (test/spec-passed/result - 'or/c8 - '((contract ((or/c false/c (-> string?)) . -> . any) - (λ (y) y) - 'pos - 'neg) - #f) - #f) - - (test/spec-passed/result - 'or/c9 - '((contract (or/c (-> string?) (-> integer? integer?)) - (λ () "x") - 'pos - 'neg)) - "x") - - (test/spec-passed/result - 'or/c10 - '((contract (or/c (-> string?) (-> integer? integer?)) - (λ (x) x) - 'pos - 'neg) - 1) - 1) - - (test/pos-blame - 'or/c11 - '(contract (or/c (-> string?) (-> integer? integer?)) - 1 - 'pos - 'neg)) - - (test/pos-blame - 'or/c12 - '((contract (or/c (-> string?) (-> integer? integer?)) - 1 - 'pos - 'neg) - 'x)) - - (test/pos-blame - 'or/c13 - '(contract (or/c not) #t 'pos 'neg)) - - (test/spec-passed - 'or/c14 - '(contract (or/c not) #f 'pos 'neg)) - - (test/spec-passed/result - 'or/c-not-error-early - '(begin (or/c (-> integer? integer?) (-> boolean? boolean?)) - 1) - 1) - - (contract-error-test - 'contract-error-test4 - #'(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) - '(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 - 'or/c-hmm - (let ([funny/c (or/c (and/c procedure? (-> any)) (listof (-> number?)))]) - (contract (-> funny/c any) void 'pos 'neg))) - - - (test/spec-passed - 'or/c-opt-unknown-flat - (let () - (define arr (-> number? number?)) - ((contract (opt/c (or/c not arr)) (λ (x) x) 'pos 'neg) 1))) - - - -; -; -; -; ;;;; ;; -; ;;;; ;; -; ;;;;;;; ;;;; ;;; ;;;;;;; ;; ;;;;; -; ;;;;;;;; ;;;;;;;;; ;;;;;;;; ;; ;;;;;; -; ;;;; ;;;; ;;;; ;;;;;;;;; ;;;;;;;;; -; ;;;;;;; ;;;; ;;;; ;;;; ;;;; ;; ;;;; -; ;; ;;;; ;;;; ;;;; ;;;;;;;;; ;; ;;;;;;; -; ;;;;;;;; ;;;; ;;;; ;;;;;;;; ;; ;;;;;; -; ;; ;;;; ;;;; ;;;; ;;;;;;; ;; ;;;;; -; ;; -; -; - - (test/spec-passed - 'and/c1 - '((contract (and/c (-> (<=/c 100) (<=/c 100)) - (-> (>=/c -100) (>=/c -100))) - (λ (x) x) - 'pos - 'neg) - 1)) - - (test/neg-blame - 'and/c2 - '((contract (and/c (-> (<=/c 100) (<=/c 100)) - (-> (>=/c -100) (>=/c -100))) - (λ (x) x) - 'pos - 'neg) - 200)) - - (test/pos-blame - 'and/c3 - '((contract (and/c (-> (<=/c 100) (<=/c 100)) - (-> (>=/c -100) (>=/c -100))) - (λ (x) 200) - 'pos - 'neg) - 1)) - - - - - (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) - (reverse x)) - '(3 1 2 4)) - - (test/spec-passed/result - 'and/c-isnt - '(and (regexp-match #rx"isn't: even?" - (with-handlers ((exn:fail? exn-message)) - (contract (and/c integer? even? positive?) - -3 - 'pos - 'neg) - "not the error!")) - #t) - #t) - - (test/spec-passed - 'contract-flat1 - '(contract not #f 'pos 'neg)) - - (test/pos-blame - 'contract-flat2 - '(contract not #t 'pos 'neg)) - - - -; -; -; -; ; ;; -; ;; ;; -; ;;;;;;; ;;;;;;; ;;; ;;; ;;;;;;; ;;;;;;; ;;;; ;;; ;;;;; ;;; ;;; ;;; ;; ;;;;; -; ;;;;;;;; ;;;;;;;; ;;;;;;; ;;;;;;;; ;;;;;;;;;;;;; ;;;;; ;;;;;; ;;;;; ;;;;;;; ;; ;;;;;; -; ;;;;;;;;; ;;;; ;;;; ;; ;;;; ;;;; ;;; ;;;; ;;;; ;; ;;;; ;;;; ;; ;;;; ;; ;;;;;;;;; -; ;;;; ;;;; ;;;;;;; ;;;; ;;;;;;; ;;;; ;;; ;;;; ;;;;;;; ;;;; ;;;;;;; ;;;; ;; ;;;; -; ;;;;;;;;; ;; ;;;; ;;;; ;; ;;;; ;;;; ;;; ;;;; ;;;;; ;;;;; ;;;;; ;;;; ;; ;;;;;;; -; ;;;;;;;; ;;;;;;;; ;;;; ;;;;;;;; ;;;; ;;; ;;;; ;;;;;; ;;;;; ;;;;;; ;;;; ;; ;;;;;; -; ;;;;;;; ;; ;;;; ;;;; ;; ;;;; ;;;; ;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;; ;;;;; -; ;;;; ;; -; ;;;; -; - - - (test/neg-blame - 'parameter/c1 - '((contract (parameter/c integer?) - (make-parameter 1) - 'pos 'neg) - #f)) - - (test/pos-blame - 'parameter/c2 - '((contract (parameter/c integer?) - (make-parameter 'not-an-int) - 'pos 'neg))) - - (test/pos-blame - 'parameter/c3 - '((contract (parameter/c integer? string?) - (make-parameter 'not-an-int number->string) - 'pos 'neg))) - - (test/neg-blame - 'parameter/c4 - '((contract (parameter/c integer? string?) - (make-parameter 5 number->string) - 'pos 'neg) - 'not-an-int)) - - (test/spec-passed - 'parameter/c5 - '((contract (parameter/c integer? string?) - (make-parameter "foo" number->string) - 'pos 'neg))) - - (test/spec-passed - 'parameter/c6 - '((contract (parameter/c integer? string?) - (make-parameter "foo" number->string) - 'pos 'neg) - 5)) - - (test/pos-blame - 'parameter/c7 - '((contract (parameter/c integer? string?) - (make-parameter 5 values) - 'pos 'neg))) - -; -; -; -; -; -; -; ;; ;; ; -; ;; ;; ; -; ;;;;;; ;;;; ;;;;; ;;;;;; ;; ;;;; -; ;;;;;; ;; ;; ;; ;; ;;;;;; ; ;;;;;; -; ;; ;; ;;;; ;;;;; ;; ;; ; ;;; -; ;; ;; ;;; ;; ;;;; ;; ;; ; ;;; -; ;; ;; ;;; ;; ;; ;;; ;; ;; ;; ;;;;;; -; ;; ;; ;;;;;; ;;;;; ;; ;; ; ;;;; -; -; -; - - (test/spec-passed - 'hash/c1 - '(contract (hash/c symbol? boolean?) - (make-hash) - 'pos - 'neg)) - - (test/spec-passed - 'hash/c1b - '(contract (hash/c symbol? boolean? #:flat? #t) - (make-hash) - 'pos - 'neg)) - - (test/spec-passed - 'hash/c1c - '(let ([h (contract (hash/c symbol? boolean?) - (make-hash) - 'pos - 'neg)]) - (hash-set! h 'x #t) - (hash-ref h 'x))) - - (test/neg-blame - 'hash/c1d - '(let ([h (contract (hash/c symbol? boolean?) - (make-hash) - 'pos - 'neg)]) - (hash-set! h 3 #t))) - - (test/neg-blame - 'hash/c1e - '(let ([h (contract (hash/c symbol? boolean?) - (make-hash) - 'pos - 'neg)]) - (hash-set! h 'x 3))) - - (test/neg-blame - 'hash/c1f - '(let ([h (contract (hash/c symbol? boolean?) - (make-hash) - 'pos - 'neg)]) - (hash-ref h 3))) - - (test/spec-passed - 'hash/c2 - '(contract (hash/c symbol? boolean?) - (let ([h (make-hash)]) - (hash-set! h 'x #t) - h) - 'pos - 'neg)) - - (test/pos-blame - 'hash/c3 - '(contract (hash/c symbol? boolean?) - (let ([h (make-hash)]) - (hash-set! h 'x 'x) - h) - 'pos - 'neg)) - - (test/pos-blame - 'hash/c4 - '(contract (hash/c symbol? boolean?) - (let ([h (make-hash)]) - (hash-set! h #t #f) - h) - 'pos - 'neg)) - - (test/pos-blame - 'hash/c5 - '(contract (hash/c symbol? boolean? #:immutable #t) - (let ([h (make-hash)]) - (hash-set! h 'x #f) - h) - 'pos - 'neg)) - - (test/spec-passed - 'hash/c6 - '(contract (hash/c symbol? boolean? #:immutable #t) - (make-immutable-hash '((x . #f))) - 'pos - 'neg)) - - (test/spec-passed - 'hash/c7 - '(contract (hash/c symbol? boolean? #:immutable #f) - (let ([h (make-hash)]) - (hash-set! h 'x #f) - h) - 'pos - 'neg)) - - (test/pos-blame - 'hash/c8 - '(contract (hash/c symbol? boolean? #:immutable #f) - (make-immutable-hash '((x . #f))) - 'pos - 'neg)) - - (test/spec-passed - 'hash/c9 - '(contract (hash/c symbol? boolean? #:immutable 'dont-care) - (make-immutable-hash '((x . #f))) - 'pos - 'neg)) - - (test/spec-passed - 'hash/c10 - '(contract (hash/c symbol? boolean? #:immutable 'dont-care) - (let ([h (make-hash)]) - (hash-set! h 'x #f) - h) - 'pos - 'neg)) - - (test/spec-passed/result - 'hash/c11 - '(hash-ref (contract (hash/c symbol? number? #:immutable #t) - (make-immutable-hash '((x . 1))) - 'pos - 'neg) - 'x) - 1) - - (test/spec-passed/result - 'hash/c12 - '(hash-ref (contract (hash/c symbol? number?) - (let ([ht (make-hash)]) - (hash-set! ht 'x 1) - ht) - 'pos - 'neg) - 'x) - 1) - - (test/pos-blame - 'hash/c13a - '(contract (hash/c (hash/c number? number?) number?) - (make-hasheq) - 'pos - 'neg)) - - (test/pos-blame - 'hash/c13b - '(contract (hash/c (hash/c number? number?) number?) - (make-hasheq) - 'pos - 'neg)) - - (test/neg-blame - 'hash/c13c - '(let ([h (contract (hash/c (hash/c number? number?) number?) - (make-hash) - 'pos - 'neg)]) - (hash-set! h (make-hash '((2 . 3))) 2) - (hash-set! h (make-hash '((3 . #t))) 3) - (for ([(k v) (in-hash h)]) - (hash-ref k v)))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; prompt-tag/c - ;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (test/spec-passed - 'prompt-tag/c-fo-1 - '(contract (prompt-tag/c string?) - (make-continuation-prompt-tag) - 'pos 'neg)) - - (test/pos-blame - 'prompt-tag/c-fo-2 - '(contract (prompt-tag/c string?) 5 'pos 'neg)) - - (test/spec-passed - 'prompt-tag/c-ho-1 - '(let ([pt (contract (prompt-tag/c number?) - (make-continuation-prompt-tag) - 'pos - 'neg)]) - (call-with-continuation-prompt - (λ () (abort-current-continuation pt 3)) - pt - (λ (x) (+ x 1))))) - - (test/neg-blame - 'prompt-tag/c-ho-2 - '(let ([pt (contract (prompt-tag/c string?) - (make-continuation-prompt-tag) - 'pos - 'neg)]) - (call-with-continuation-prompt - (λ () (abort-current-continuation pt 3)) - pt - (λ (x) (+ x 1))))) - - (test/neg-blame - 'prompt-tag/c-ho-3 - '(let ([pt (contract (prompt-tag/c (-> string? number?)) - (make-continuation-prompt-tag) - 'pos - 'neg)]) - (call-with-continuation-prompt - (λ () (abort-current-continuation pt (λ (x) 5))) - pt - (λ (x) (x 8))))) - - (test/neg-blame - 'prompt-tag/c-ho-4 - '(let ([pt (contract (prompt-tag/c (-> string? number?)) - (make-continuation-prompt-tag) - 'pos - 'neg)]) - (call-with-continuation-prompt - (λ () (abort-current-continuation pt (λ (x) "bad"))) - pt - (λ (x) (x "potato"))))) - - (test/pos-blame - 'prompt-tag/c-ho-5 - '(let* ([pt (make-continuation-prompt-tag)] - [do-prompt (contract - (-> (-> (prompt-tag/c (-> number? number?)) - any) - number?) - (λ (f) (call-with-continuation-prompt - (λ () (f pt)) - pt - (λ (f) (f "bad")))) - 'pos - 'neg)]) - (do-prompt (λ (pt) - (abort-current-continuation pt (λ (v) (+ v 1))))))) - - (test/spec-failed - 'prompt-tag/c-ho-5 - '(let* ([pt (make-continuation-prompt-tag)] - [do-prompt (contract - (-> (-> (prompt-tag/c (-> number? number?)) - any) - number?) - (λ (f) (call-with-continuation-prompt - (λ () (f pt)) - pt - (λ (f) (f 0)))) - 'A - 'B)] - [do-prompt2 (contract - (-> (-> (prompt-tag/c (-> string? number?)) - any) - number?) - do-prompt - 'B - 'C)]) - (do-prompt2 - (λ (pt) (abort-current-continuation pt (λ (v) (+ v 1)))))) - "B") - - (test/neg-blame - 'prompt-tag/c-ho-6 - '(let ([pt (contract (prompt-tag/c string? number?) - (make-continuation-prompt-tag) - 'pos - 'neg)]) - (call-with-continuation-prompt - (λ () (abort-current-continuation pt 3 "bad")) - pt - (λ (x y) (values x y))))) - - (test/spec-passed - 'prompt-tag/c-ho-7 - '(let ([pt (contract (prompt-tag/c string? number?) - (make-continuation-prompt-tag) - 'pos - 'neg)]) - (call-with-continuation-prompt - (λ () (abort-current-continuation pt "good" 5)) - pt - (λ (x y) (values x y))))) - - (test/spec-passed - 'prompt-tag/c-call/cc-1 - '(let* ([pt (contract (prompt-tag/c string? - #:call/cc string?) - (make-continuation-prompt-tag) - 'pos - 'neg)] - [abort-k (call-with-continuation-prompt - (λ () (call/cc (λ (k) k) pt)) - pt)]) - (call-with-continuation-prompt - (λ () (abort-k "ok")) - pt - (λ (s) (string-append s "post"))))) - - (test/spec-passed - 'prompt-tag/c-call/cc-2 - '(let* ([pt (contract (prompt-tag/c string? - #:call/cc (values string? integer?)) - (make-continuation-prompt-tag) - 'pos - 'neg)] - [abort-k (call-with-continuation-prompt - (λ () (call/cc (λ (k) k) pt)) - pt)]) - (call-with-continuation-prompt - (λ () (abort-k "ok" 5)) - pt - (λ (s n) (string-append s "post"))))) - - (test/neg-blame - 'prompt-tag/c-call/cc-2 - '(letrec ([pt (make-continuation-prompt-tag)] - [do-test (λ () - (+ 1 - (call-with-continuation-prompt - (lambda () - (+ 1 (abort-k 1))) - pt)))] - [cpt (contract (prompt-tag/c #:call/cc number?) - pt - 'pos - 'neg)] - [abort-k (call-with-continuation-prompt - (λ () - (let ([v (call/cc (lambda (k) k) cpt)]) - (if (procedure? v) - v - (format "~a" v)))) - pt)]) - (do-test))) - - (test/spec-passed/result - 'prompt-tag/c-has-contract - '(let ([pt (contract (prompt-tag/c string? number?) - (make-continuation-prompt-tag) - 'pos - 'neg)]) - (has-contract? pt)) - #t) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; continuation-mark-key/c - ;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (test/spec-passed - 'continuation-mark-key/c-fo-1 - '(contract (continuation-mark-key/c string?) - (make-continuation-mark-key) - 'pos 'neg)) - - (test/pos-blame - 'continuation-mark-key/c-fo-2 - '(contract (continuation-mark-key/c string?) 5 'pos 'neg)) - - (test/neg-blame - 'continuation-mark-key/c-ho-1 - '(let ([mark (contract (continuation-mark-key/c number?) - (make-continuation-mark-key) - 'pos - 'neg)]) - (with-continuation-mark mark "bad" - 42))) - - (test/spec-passed - 'continuation-mark-key/c-ho-2 - '(let ([mark (contract (continuation-mark-key/c number?) - (make-continuation-mark-key) - 'pos - 'neg)]) - (with-continuation-mark mark 5 - (continuation-mark-set-first - (current-continuation-marks) mark)))) - - (test/neg-blame - 'continuation-mark-key/c-ho-3 - '(let ([mark (contract (continuation-mark-key/c number?) - (make-continuation-mark-key) - 'pos - 'neg)]) - (with-continuation-mark mark "bad" - (continuation-mark-set-first - (current-continuation-marks) mark)))) - - (test/neg-blame - 'continuation-mark-key/c-ho-4 - '(let* ([mark (make-continuation-mark-key)] - [do-mark (contract (-> (-> (continuation-mark-key/c (-> number? number?)) - number?) - number?) - (lambda (f) - (with-continuation-mark mark (lambda (x) (+ x 1)) - (f mark))) - 'pos - 'neg)]) - (do-mark - (lambda (mark) - ((continuation-mark-set-first - (current-continuation-marks) mark) - "bad"))))) - - (test/pos-blame - 'continuation-mark-key/c-ho-5 - '(let* ([mark (make-continuation-mark-key)] - [do-mark (contract (-> (-> (continuation-mark-key/c (-> number? number?)) - number?) - number?) - (lambda (f) - (with-continuation-mark mark (lambda (x) "bad") - (f mark))) - 'pos - 'neg)]) - (do-mark - (lambda (mark) - ((continuation-mark-set-first - (current-continuation-marks) mark) - 0))))) - - (test/spec-passed - 'continuation-mark-key/c-ho-6 - '(let* ([mark (make-continuation-mark-key)] - [do-mark (contract (-> (-> (continuation-mark-key/c (-> number? number?)) - number?) - number?) - (lambda (f) - (with-continuation-mark mark (lambda (x) (+ x 1)) - (f mark))) - 'pos - 'neg)]) - (do-mark - (lambda (mark) - ((continuation-mark-set-first - (current-continuation-marks) mark) - 0))))) - - (test/neg-blame - 'continuation-mark-key/c-ho-7 - '(let ([mark (contract (continuation-mark-key/c (-> number? number?)) - (make-continuation-mark-key) - 'pos - 'neg)]) - (with-continuation-mark mark (lambda (x) "bad") - ((continuation-mark-set-first - (current-continuation-marks) mark) - 5)))) - - (test/spec-passed - 'continuation-mark-key/c-ho-8 - '(let ([mark (contract (continuation-mark-key/c (-> number? number?)) - (make-continuation-mark-key) - 'pos - 'neg)]) - (with-continuation-mark mark (lambda (x) (+ x 1)) - ((continuation-mark-set-first - (current-continuation-marks) mark) - 0)))) - - (test/pos-blame - 'continuation-mark-key/c-ho-9 - '(let* ([mark (make-continuation-mark-key)] - [do-mark (contract (-> (continuation-mark-key/c (-> number? number?)) - number?) - (lambda (mark) - ((continuation-mark-set-first - (current-continuation-marks) mark) - "bad")) - 'pos - 'neg)]) - (with-continuation-mark mark (lambda (x) (+ x 1)) - (do-mark mark)))) - - (test/pos-blame - 'continuation-mark-key/c-ho-10 - '(let* ([mark (make-continuation-mark-key)] - [ctc-mark (contract (continuation-mark-key/c number?) - mark - 'pos - 'neg)]) - (with-continuation-mark mark "not a number" - (+ 1 (continuation-mark-set-first #f ctc-mark))))) - - (test/spec-passed - 'continuation-mark-key/c-ho-11 - '(let* ([mark (make-continuation-mark-key)] - [ctc-mark (contract (continuation-mark-key/c number?) - mark - 'pos - 'neg)]) - (continuation-mark-set-first #f ctc-mark))) - - (test/spec-passed/result - 'continuation-mark-key/c-has-contract - '(let* ([mark (make-continuation-mark-key)] - [ctc-mark (contract (continuation-mark-key/c number?) - mark - 'pos - 'neg)]) - (has-contract? ctc-mark)) - #t) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; make-contract - ;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (contract-eval - '(define proj:add1->sub1 - (make-contract - #:name 'proj:add1->sub1 - #:projection - (lambda (blame) - (lambda (f) - (unless (and (procedure? f) (procedure-arity-includes? f 1)) - (raise-blame-error blame f "expected a unary function, got: ~e" f)) - (lambda (x) - (unless (and (integer? x) (exact? x)) - (raise-blame-error (blame-swap blame) x - "expected an integer, got: ~e" x)) - (let* ([y (f (add1 x))]) - (unless (and (integer? y) (exact? y)) - (raise-blame-error blame y "expected an integer, got: ~e" y)) - (sub1 y))))) - #:first-order - (lambda (f) - (and (procedure? f) (procedure-arity-includes? f 1)))))) - - (test/spec-passed/result - 'make-contract-1 - '((contract proj:add1->sub1 sqrt 'pos 'neg) 15) - 3) - - (test/pos-blame - 'make-contract-2 - '(contract proj:add1->sub1 'dummy 'pos 'neg)) - - (test/pos-blame - 'make-contract-3 - '((contract proj:add1->sub1 (lambda (x) 'dummy) 'pos 'neg) 2)) - - (test/neg-blame - 'make-contract-4 - '((contract proj:add1->sub1 sqrt 'pos 'neg) 'dummy)) - - (ctest #t contract? proj:add1->sub1) - (ctest #f flat-contract? proj:add1->sub1) - (ctest #f chaperone-contract? proj:add1->sub1) - (ctest #t impersonator-contract? proj:add1->sub1) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; make-chaperone-contract - ;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (contract-eval - '(define proj:prime-box-list/c - (let* ([prime? (λ (n) - (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) - (not (= (remainder n m) 0))))] - [wrap-box (λ (blame b) - (chaperone-box - b - (λ (b v) - (unless (prime? v) - (raise-blame-error blame v - "expected prime, got ~v" v)) - v) - (λ (b v) - (unless (prime? v) - (raise-blame-error (blame-swap blame) v - "expected prime, got ~v" v)) - v)))]) - (make-chaperone-contract - #:name 'prime-box-list/c - #:first-order (λ (v) (and (list? v) (andmap box? v))) - #:projection (λ (blame) - (λ (v) - (unless (and (list? v) (andmap box? v)) - (raise-blame-error blame v - "expected list of boxes, got ~v" v)) - (map (λ (b) (wrap-box blame b)) v))))))) - - (test/spec-passed/result - 'make-chaperone-contract-1 - '(contract proj:prime-box-list/c - (list (box 2) (box 3) (box 5) (box 7)) - 'pos 'neg) - (list (box 2) (box 3) (box 5) (box 7))) - - (test/pos-blame - 'make-chaperone-contract-2 - '(let ([boxes (contract proj:prime-box-list/c - (list (box 2) (box 3) (box 4) (box 5)) - 'pos 'neg)]) - (unbox (caddr boxes)))) - - (test/neg-blame - 'make-chaperone-contract-3 - '(let ([boxes (contract proj:prime-box-list/c - (list (box 2) (box 3) (box 4) (box 5)) - 'pos 'neg)]) - (set-box! (caddr boxes) 6))) - - (ctest #t contract? proj:prime-box-list/c) - (ctest #f flat-contract? proj:prime-box-list/c) - (ctest #t chaperone-contract? proj:prime-box-list/c) - (ctest #f impersonator-contract? proj:prime-box-list/c) - - (contract-eval - '(define proj:bad-prime-box-list/c - (let* ([prime? (λ (n) - (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) - (not (= (remainder n m) 0))))] - [wrap-box (λ (blame b) (box (unbox b)))]) - (make-chaperone-contract - #:name 'bad-prime-box-list/c - #:first-order (λ (v) (and (list? v) (andmap box? v))) - #:projection (λ (blame) - (λ (v) - (unless (and (list? v) (andmap box? v)) - (raise-blame-error blame v - "expected list of boxes, got ~v" v)) - (map (λ (b) (wrap-box blame b)) v))))))) - - (ctest #t contract? proj:bad-prime-box-list/c) - (ctest #f flat-contract? proj:bad-prime-box-list/c) - (ctest #t chaperone-contract? proj:bad-prime-box-list/c) - (ctest #f impersonator-contract? proj:bad-prime-box-list/c) - - (contract-error-test - 'contract-error-test5 - '(contract proj:bad-prime-box-list/c (list (box 2) (box 3)) 'pos 'neg) - exn:fail?) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; make-flat-contract - ;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (contract-eval - '(define proj:prime/c - (let ([prime? (λ (n) - (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) - (not (= (remainder n m) 0))))]) - (make-flat-contract - #:name 'prime/c - #:first-order prime?)))) - - (test/spec-passed/result - 'make-flat-contract-1 - '(contract proj:prime/c 2 'pos 'neg) - 2) - - (test/pos-blame - 'make-flat-contract-2 - '(contract proj:prime/c 4 'pos 'neg)) - - (ctest #t contract? proj:prime/c) - (ctest #t flat-contract? proj:prime/c) - - (test/spec-passed/result - 'make-flat-contract-5 - '(chaperone-contract? proj:prime/c) - #t) - - ;; Check to make sure that flat contracts always return the original value, - ;; even if the projection is written badly. - (contract-eval - '(define proj:prime-list/c - (let ([prime? (λ (n) - (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) - (not (= (remainder n m) 0))))]) - (make-flat-contract - #:name 'prime-list/c - #:first-order (λ (v) (and (list? v) (andmap prime? v))) - #:projection (λ (b) - (λ (v) - (unless (and (list? v) (andmap prime? v)) - (raise-blame-error b v "expected prime list, got ~v" v)) - (map values v))))))) - - (test/spec-passed/result - 'make-flat-contract-bad-1 - '(contract proj:prime-list/c (list 2 3 5 7) 'pos 'neg) - (list 2 3 5 7)) - - (test/pos-blame - 'make-flat-contract-bad-2 - '(contract proj:prime-list/c (list 2 3 4 5) 'pos 'neg)) - - (test/spec-passed/result - 'make-flat-contract-bad-3 - '(let ([l (list 2 3 5 7)]) - (eq? l (contract proj:prime-list/c l 'pos 'neg))) - #t) - - (ctest #t contract? proj:prime-list/c) - (ctest #t flat-contract? proj:prime-list/c) - - (test/spec-passed/result - 'make-flat-contract-bad-6 - '(chaperone-contract? proj:prime-list/c) - #t) - - -;; Adding tests for using vector/box/hash contracts with already chaperoned values - - (test/no-error - '(let ([v (chaperone-vector (vector-immutable 1) - (λ (vec i v) v) - (λ (vec i v) v))]) - (contract (vectorof any/c) v 'pos 'neg))) - - (test/no-error - '(let ([v (chaperone-vector (vector-immutable 1) - (λ (vec i v) v) - (λ (vec i v) v))]) - (contract (vector/c any/c) v 'pos 'neg))) - - (test/no-error - '(let ([v (chaperone-box (box-immutable 1) - (λ (box v) v) - (λ (box v) v))]) - (contract (box/c any/c) v 'pos 'neg))) - - (test/no-error - '(let ([v (chaperone-hash (make-immutable-hash (list (cons 1 2))) - (λ (hash k) (values k (λ (h k v) v))) - (λ (hash k v) (values k v)) - (λ (hash k) k) - (λ (hash k) k))]) - (contract (hash/c any/c any/c) v 'pos 'neg))) - - (test/no-error - '(let ([v (chaperone-hash (make-immutable-hasheq (list (cons 1 2))) - (λ (hash k) (values k (λ (h k v) v))) - (λ (hash k v) (values k v)) - (λ (hash k) k) - (λ (hash k) k))]) - (contract (hash/c any/c any/c) v 'pos 'neg))) - - (test/no-error - '(let ([v (chaperone-hash (make-immutable-hasheqv (list (cons 1 2))) - (λ (hash k) (values k (λ (h k v) v))) - (λ (hash k v) (values k v)) - (λ (hash k) k) - (λ (hash k) k))]) - (contract (hash/c any/c any/c) v 'pos 'neg))) - -; -; -; -; ; ;;;; ; -; ;; ; ; ; -; ; ; ; ; ; -; ; ; ; ; ; -; ;; ; ;;; ;;;; ; ; ;; ;;; ; ;;; ;; ; ;; ;;;; ; ;; ;;; ;;; ;;;; -; ; ;; ; ; ; ;; ;;; ; ; ; ; ; ; ; ; ;;; ; ; ;;; ; ; ; ; ; -; ; ; ;;;;; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ;; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; -; ;; ; ;;; ;;;;;;;;;; ;;; ;;; ; ;;; ;; ;;; ;;; ;; ;;; ;; ;; ;;; ;; -; -; -; - - (test/spec-passed - 'define/contract1 - '(let () - (define/contract i integer? 1) - i)) - - (test/spec-failed - 'define/contract2 - '(let () - (define/contract i integer? #t) - i) - "(definition i)") - - (test/spec-failed - 'define/contract3 - '(let () - (define/contract i (-> integer? integer?) (lambda (x) #t)) - (i 1)) - "(definition i)") - - (test/spec-failed - 'define/contract4 - '(let () - (define/contract i (-> integer? integer?) (lambda (x) 1)) - (i #f)) - "top-level") - - (test/spec-failed - 'define/contract5 - '(let () - (define/contract (i x) (-> integer? integer?) 1) - (i #f)) - "top-level") - - (test/spec-passed - 'define/contract6 - '(let () - (define/contract (i x) (-> integer? integer?) - (cond - [(not (integer? x)) 1] - [else (i #f)])) - (i 1))) - - (test/spec-passed - 'define/contract7 - '(let () - (define/contract (contracted-func label t) - (string? string? . -> . string?) - t) - (contracted-func - "I'm a string constant with side effects" - "ans"))) - - (test/spec-passed - 'define/contract8 - '(let () - (eval '(module contract-test-suite-define1 scheme/base - (require scheme/contract) - (define/contract x string? "a") - x)) - (eval '(require 'contract-test-suite-define1)))) - - (test/spec-failed - 'define/contract9 - '(let () - (define/contract (a n) - (-> number? number?) - (define/contract (b m) - (-> number? number?) - (+ m 1)) - (b (zero? n))) - (a 5)) - "(function a)") - - (test/spec-failed - 'define/contract10 - '(let () - (define/contract (a n) - (-> number? number?) - (define/contract (b m) - (-> number? number?) - #t) - (b (add1 n))) - (a 5)) - "(function b)") - - (test/spec-passed - 'define/contract11 - '(let () - (define/contract (f n) - (-> number? number?) - (+ n 1)) - (define/contract (g b m) - (-> boolean? number? number?) - (if b (f m) (f #t))) - (g #t 3))) - - ;; For some of the following tests, it may not be clear - ;; why the blame is what it is. The contract(s) entered - ;; into via with-contract are between the contracting - ;; region and its context. If the context allows the - ;; value to flow into other regions without contracts - ;; that protect it from misuses in those regions, it's - ;; the context's fault. - (test/spec-failed - 'define/contract12 - '(let () - (define/contract (f n) - (-> number? number?) - (+ n 1)) - (define/contract (g b m) - (-> boolean? number? number?) - (if b (f m) (f #t))) - (g #f 3)) - "top-level") - - (test/spec-failed - 'define/contract13 - '(begin - (eval '(module foo-dc13 scheme/base - (require scheme/contract) - (define/contract (foo-dc13 n) - (-> number? number?) - (+ n 1)) - (foo-dc13 #t))) - (eval '(require 'foo-dc13))) - "foo-dc13") - - (test/spec-failed - 'define/contract14 - '(begin - (eval '(module foo-dc14 scheme/base - (require scheme/contract) - (provide foo-dc14) - (define/contract (foo-dc14 n) - (-> number? number?) - (+ n 1)))) - (eval '(module bar-dc14 scheme/base - (require 'foo-dc14) - (foo-dc14 #t))) - (eval '(require 'bar-dc14))) - "foo-dc14") - - (test/spec-failed - 'define/contract15 - '(begin - (eval '(module foo-dc15 scheme/base - (require scheme/contract) - (provide foo-dc15) - (define/contract (foo-dc15 n) - (-> number? number?) - (+ n 1)))) - (eval '(require 'foo-dc15)) - (eval '(foo-dc15 #t))) - "foo-dc15") - - ;; Let's see how units + define/contract interact - - (test/spec-failed - 'define/contract16 - '(begin - (eval '(module foo-dc16 scheme/base - (require scheme/contract) - (require scheme/unit) - (let () - (define/contract (foo n) - (-> number? number?) - (define-signature U^ - ((contracted [x (-> number? number?)]))) - (define-unit U@ - (import) - (export U^) - (define (x n) #t)) - (define-values/invoke-unit U@ - (import) - (export U^)) - (x n)) - (foo 3)))) - (eval '(require 'foo-dc16))) - "(unit U@)") - - (test/spec-failed - 'define/contract16a - '(begin - (eval '(module foo-dc16a scheme/base - (require scheme/contract) - (require scheme/unit) - (let () - (define/contract (foo n) - (-> number? number?) - (define-signature U^ - (x)) - (define-unit/contract U@ - (import) - (export (U^ [x (-> number? number?)])) - (define (x n) #t)) - (define-values/invoke-unit U@ - (import) - (export U^)) - (x n)) - (foo 3)))) - (eval '(require 'foo-dc16a))) - "(unit U@)") - - (test/spec-failed - 'define/contract17 - '(begin - (eval '(module foo-dc17 scheme/base - (require scheme/contract) - (require scheme/unit) - (let () - (define/contract (foo n) - (-> number? number?) - (define-signature U^ - ((contracted [x (-> number? number?)]))) - (define-unit U@ - (import) - (export U^) - (define (x n) 3)) - (define-values/invoke-unit U@ - (import) - (export U^)) - (x (zero? n))) - (foo 3)))) - (eval '(require 'foo-dc17))) - "(function foo)") - - (test/spec-failed - 'define/contract18 - '(begin - (eval '(module foo-dc18 scheme/base - (require scheme/contract) - (require scheme/unit) - (let () - (define-signature U^ - ((contracted [x (-> number? number?)]))) - (define-unit U@ - (import) - (export U^) - ;; Can't define/contract x directly because - ;; x ends up bound to a transformer and thus - ;; is syntax. - (define/contract (y n) - (-> number? boolean?) #t) - (define x y)) - (define-values/invoke-unit U@ - (import) - (export U^)) - (x 3)))) - (eval '(require 'foo-dc18))) - "(unit U@)") - - (test/spec-failed - 'define/contract19 - '(let () - (define y 3) - (define/contract (f n) - (-> number? number?) - #:freevar y (-> number? boolean?) - 3) - 1) - "top-level") - - (test/spec-passed - 'define/contract20 - '(let () - (define y (lambda (n) 4)) - (define/contract (f n) - (-> number? number?) - #:freevar y (-> number? boolean?) - 3) - 1)) - - (test/spec-passed - 'define/contract21 - '(let () - (define y (lambda (n) 4)) - (define/contract (f n) - (-> number? number?) - #:freevar y (-> number? boolean?) - (if (y n) 3 1)) - 1)) - - (test/spec-failed - 'define/contract22 - '(let () - (define y 4) - (define/contract (f n) - (-> number? number?) - #:freevar y (-> number? boolean?) - 3) - 1) - "top-level") - - (test/spec-failed - 'define/contract23 - '(let () - (define y (lambda (n) #t)) - (define/contract (f n) - (-> number? number?) - #:freevar y (-> number? number?) - (y n)) - (f 5)) - "top-level") - - (test/spec-failed - 'define/contract24 - '(let () - (define y (lambda (n) 4)) - (define/contract (f n) - (-> number? number?) - #:freevar y (-> number? boolean?) - (if (y #t) 3 1)) - (f 5)) - "(function f)") - - (test/spec-failed - 'define/contract25 - '(let () - (define y #t) - (define z 3) - (define/contract f - number? - #:freevars ([y number?] [z number?]) - (+ y z)) - 1) - "top-level") - - (test/spec-passed - 'define/contract - '(let () - (define/contract (f x #:y [y 3]) - (->* (integer?) (#:y integer?) integer?) - x) - (f 3 #:y 7))) - - (test/spec-failed - 'define/contract - '(let () - (define/contract (f x #:y [y 3]) - (->* (integer?) (#:y integer?) integer?) - x) - (f 3 #:y #f)) - "top-level") - - -; -; -; -; -; ;;; ;;;;;;; ; ; ; -; ;;; ;;; ;;; ;;; ; -; ;; ;;; ;;;; ;;;; ;;; ;;; ;; ;;;; ;;;; ;;;; ;;; ;;;; ;;; ;;; ;;;; ; -; ;;;;;;; ;; ;;; ;;;; ;;; ;;;;;;; ;; ;;; ;;; ;; ;;;; ;;;;;;;; ;;; ;;;;; ;;;; ; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ; -; ;;; ;;; ;;;;;;; ;;; ;;; ;;; ;;; ;;;;;;; ;;;; ;;;; ;;; ;;; ;;; ;;; ;;; ;;; ; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ; -; ;;;;;;; ;;;;;; ;;; ;;; ;;; ;;; ;;;;;; ;; ;;; ;;;; ;;; ;;;;;;; ;;;;; ;;;; ; -; ;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;;; ;;;; ;;; ;;; ;; ;;; ;;; ;;; ; -; -; -; -; -; -; -; -; -; ; ; -; ;;; ;;; -; ;;; ;;; ;;; ;; ;;;; ;;; ;;;;;;; ;;; ;;;; -; ;;;;; ;;;;; ;;;;;;; ;;;; ;;;;;;;;;;;; ;;;;; ;;;; -; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;; ;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;; ;;; ;;; -; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; -; ;;;;; ;;;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;;;; ;;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;; ;;; ;;; -; -; -; -; - - - (test/spec-passed - 'define-struct/contract1 - '(let () - (define-struct/contract foo ([x number?] [y number?])) - 1)) - - (test/spec-passed - 'define-struct/contract2 - '(let () - (define-struct/contract foo ([x number?] [y number?])) - (make-foo 1 2))) - - (test/spec-failed - 'define-struct/contract3 - '(let () - (define-struct/contract foo ([x number?] [y number?])) - (make-foo 1 #t)) - "top-level") - - (test/spec-passed - 'define-struct/contract4 - '(let () - (define-struct/contract foo ([x number?] [y number?])) - (foo-y (make-foo 2 3)))) - - (test/spec-failed - 'define-struct/contract5 - '(let () - (define-struct/contract foo ([x number?] [y number?])) - (foo-y 1)) - "top-level") - - (test/spec-passed - 'define-struct/contract6 - '(let () - (define-struct/contract foo ([x number?] [y number?]) #:mutable) - (set-foo-y! (make-foo 1 2) 3) - (set-foo-x! (make-foo 1 2) 3))) - - (test/spec-failed - 'define-struct/contract7 - '(let () - (define-struct/contract foo ([x number?] [y number?]) #:mutable) - (set-foo-y! (make-foo 1 2) #f)) - "top-level") - - (test/spec-passed - 'define-struct/contract8 - '(let () - (define-struct/contract foo ([(x #:mutable) number?] [y number?])) - (set-foo-x! (make-foo 1 2) 4))) - - (test/spec-failed - 'define-struct/contract9 - '(let () - (define-struct/contract foo ([(x #:mutable) number?] [y number?])) - (set-foo-x! (make-foo 1 2) #f)) - "top-level") - - (test/spec-failed - 'define-struct/contract10 - '(let () - (define-struct/contract foo ([x number?] [(y #:auto) number?])) - (make-foo 1)) - "(struct foo)") - - (test/spec-passed - 'define-struct/contract11 - '(let () - (define-struct/contract foo ([x number?] [(y #:auto) number?]) #:auto-value 3) - (make-foo 1))) - - (test/spec-passed - 'define-struct/contract12 - '(let () - (define-struct/contract foo ([x number?] [(y #:auto #:mutable) number?]) #:auto-value 3) - (set-foo-y! (make-foo 1) 3))) - - (test/spec-failed - 'define-struct/contract13 - '(let () - (define-struct/contract foo ([x number?] [(y #:auto #:mutable) number?]) #:auto-value 3) - (set-foo-y! (make-foo 1) #t)) - "top-level") - - (test/spec-passed - 'define-struct/contract14 - '(let () - (define-struct/contract foo ([x number?] [y number?]) #:transparent) - 1)) - - (test/spec-passed - 'define-struct/contract15 - '(let () - (define-struct foo (x)) - (define-struct/contract (bar foo) ([z string?])) - (make-bar 2 "x"))) - - (test/spec-failed - 'define-struct/contract16 - '(let () - (define-struct foo (x)) - (define-struct/contract (bar foo) ([z string?])) - (make-bar 2 #f)) - "top-level") - - (test/spec-passed - 'define-struct/contract17 - '(let () - (define-struct foo (x)) - (define-struct/contract (bar foo) ([z string?]) #:mutable) - (set-bar-z! (make-bar 2 "x") "y"))) - - (test/spec-failed - 'define-struct/contract18 - '(let () - (define-struct foo (x)) - (define-struct/contract (bar foo) ([z string?]) #:mutable) - (set-bar-z! (make-bar 2 "x") #f)) - "top-level") - - (test/spec-passed - 'define-struct/contract19 - '(let () - (define-struct foo (x)) - (define-struct/contract (bar foo) ([z string?])) - (define-struct/contract (baz bar) ([x number?])) - (make-baz 2 "x" 5))) - - (test/spec-failed - 'define-struct/contract20 - '(let () - (define-struct foo (x)) - (define-struct/contract (bar foo) ([z string?])) - (define-struct/contract (baz bar) ([x number?])) - (make-baz 2 "x" #f)) - "top-level") - - (test/spec-failed - 'define-struct/contract21 - '(let () - (define-struct foo (x)) - (define-struct/contract (bar foo) ([z string?])) - (define-struct/contract (baz bar) ([x number?])) - (make-baz 2 #f 3)) - "top-level") - - (test/spec-passed - 'define-struct/contract21 - '(let () - (define-struct foo (x) #:mutable) - (define-struct/contract (bar foo) ([z string?])) - (set-foo-x! (make-bar 2 "x") #f))) - - (test/spec-passed - 'define-struct/contract22 - '(define-struct/contract foo ([x number?] [y number?]) #:mutable #:transparent)) - - (test/spec-passed - 'define-struct/contract23 - '(define-struct/contract foo ([x number?] [y number?]) - #:mutable #:transparent - #:property prop:custom-write - (lambda (a b c) (void)))) - - (test/spec-passed/result - 'define-struct/contract24 - '(let () - (define-struct/contract point - ([x number?] [y number?]) - #:transparent) - (define-struct/contract (color-point point) - ([c symbol?]) - #:transparent) - - (match (make-color-point 1 2 'red) - [(struct color-point [dx dy color]) - (list dx dy color)] - [(struct point [dx dy]) (list dx dy)] - [v (box v)])) - (list 1 2 'red)) - - (test/spec-passed - 'define-struct/contract25 - '(let () - (define-struct/contract point - ([x number?] [y number?]) - #:transparent) - (point 1 2))) - - (test/spec-failed - 'define-struct/contract26 - '(let () - (define-struct/contract point - ([x number?] [y number?]) - #:transparent) - (point 1 #t)) - "top-level") -; -; -; -; ; ; -; ;; -; ; ; ; ; -; ; ; ; ; -; ;;; ;;; ;;; ; ;;;; ; ;; ;;; ;; ; ;; ;;;; ; ;; ;;; ;;; ;;;; -; ; ; ; ;; ; ;; ; ; ; ; ; ;;; ; ; ;;; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; -; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ;; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ;; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; -; ; ; ;;; ;; ;;; ;;; ;;; ;; ;;; ;;; ;; ;;; ;; ;; ;;; ;; -; -; -; - - (test/spec-passed - 'with-contract-def-1 - '(let () - (with-contract odd-even - ([oddp (-> number? boolean?)] - [evenp (-> number? boolean?)]) - (define (oddp n) - (if (zero? n) #f (evenp (sub1 n)))) - (define (evenp n) - (if (zero? n) #t (oddp (sub1 n))))) - (oddp 5))) - - (test/spec-failed - 'with-contract-def-2 - '(let () - (with-contract odd-even - ([oddp (-> number? boolean?)] - [evenp (-> number? boolean?)]) - (define (oddp n) - (if (zero? n) #f (evenp (sub1 n)))) - (define (evenp n) - (if (zero? n) #t (oddp (sub1 n))))) - (oddp #t)) - "top-level") - - (test/spec-failed - 'with-contract-def-3 - '(let () - (with-contract odd-even - ([oddp (-> number? boolean?)] - [evenp (-> number? boolean?)]) - (define (oddp n) - (if (zero? n) n (evenp (sub1 n)))) - (define (evenp n) - (if (zero? n) #t (oddp (sub1 n))))) - (oddp 4)) - "(region odd-even)") - - ;; Functions within the same with-contract region can call - ;; each other however they want, so here we have even? - ;; call odd? with a boolean, even though its contract in - ;; the odd-even contract says it only takes numbers. - (test/spec-passed - 'with-contract-def-4 - '(let () - (with-contract odd-even - ([oddp (-> number? boolean?)] - [evenp (-> number? boolean?)]) - (define (oddp n) - (cond - [(not (number? n)) #f] - [(zero? n) #f] - [else (evenp (sub1 n))])) - (define (evenp n) - (if (zero? n) #t (oddp (zero? n))))) - (oddp 5))) - - (test/spec-passed - 'with-contract-def-5 - '(let () - (with-contract region1 - ([x (-> number? number?)]) - (with-contract region2 - ([y (-> number? boolean?)]) - (define (y n) #t)) - (define (x n) (if (y n) 0 3))) - (x 4))) - - (test/spec-failed - 'with-contract-def-6 - '(let () - (with-contract region1 - ([x (-> number? number?)]) - (with-contract region2 - ([y (-> number? boolean?)]) - (define (y n) #t)) - (define (x n) (y n))) - (x 4)) - "(region region1)") - - (test/spec-failed - 'with-contract-def-7 - '(let () - (with-contract region1 - ([x (-> number? number?)]) - (with-contract region2 - ([y (-> number? boolean?)]) - (define (y n) #t)) - (define (x n) (if (y #t) 4 0))) - (x 4)) - "(region region1)") - - (test/spec-failed - 'with-contract-def-8 - '(let () - (with-contract region1 - ([x (-> number? number?)]) - (with-contract region2 - ([y (-> number? boolean?)]) - (define (y n) 3)) - (define (x n) (if (y n) 4 0))) - (x 4)) - "(region region2)") - - ;; make sure uncontracted exports make it out - (test/spec-passed - 'with-contract-def-9 - '(let () - (with-contract region1 () - (define f 3)) - f)) - - (test/spec-failed - 'with-contract-def-10 - '(let () - (with-contract r - ([x number?]) - (define x 3) - (define-values () - (begin (set! x #f) (values)))) - x) - "(region r)") - - (test/spec-failed - 'with-contract-def-11 - '(let () - (with-contract r - ([x number?]) - (define x 3)) - (set! x #f) - x) - "top-level") - - (test/spec-passed - 'with-contract-exp-1 - '(with-contract r - #:result number? - 3)) - - (test/spec-failed - 'with-contract-exp-2 - '(with-contract r - #:result number? - "foo") - "(region r)") - - (test/spec-passed - 'with-contract-exp-3 - '((with-contract r - #:result (-> number? number?) - (λ (x) 5)) - 3)) - - (test/spec-failed - 'with-contract-exp-4 - '((with-contract r - #:result (-> number? number?) - (λ (x) (zero? x))) - 3) - "(region r)") - - (test/spec-failed - 'with-contract-exp-5 - '((with-contract r - #:result (-> number? number?) - (λ (x) 5)) - #t) - "top-level") - - (test/spec-passed - 'with-contract-exp-values-1 - '(let-values ([() (with-contract r #:results () (values))]) - 1)) - - (test/spec-passed - 'with-contract-exp-values-1 - '(let-values ([(x y) (with-contract r - #:results (number? string?) - (values 3 "foo"))]) - 1)) - - (test/spec-failed - 'with-contract-exp-values-2 - '(let-values ([(x y) (with-contract r - #:results (number? string?) - (values "bar" "foo"))]) - 1) - "(region r)") - - (test/spec-passed - 'with-contract-exp-values-3 - '(let-values ([(x y) (with-contract r - #:results (number? string?) - (define (f) (values 3 "foo")) - (f))]) - 1)) - - (test/spec-passed/result - 'with-contract-#%app - '(begin - (eval '(module with-contract-#%app-app racket - (define-syntax (-app x) #''apped) - (provide (rename-out (-app #%app))))) - (eval '(module with-contract-#%app-client racket - (require 'with-contract-#%app-app) - (provide with-contract-#%app-h with-contract-#%app-i) - (with-contract x ([f any/c]) (define (f x) 'f)) - (define (g x) 'g) - (define with-contract-#%app-h (f 2)) - (define with-contract-#%app-i (g 2)))) - (eval '(require 'with-contract-#%app-client)) - (eval '(list with-contract-#%app-h with-contract-#%app-i))) - (list 'apped 'apped)) - - (test/spec-passed/result - 'with-contract-one-contract-app-per-mutation-1 - '(let* ([counter 0] - [ctc (λ (x) (set! counter (add1 counter)) (number? x))]) - (with-contract foo ([x ctc]) - (define x 3)) - (+ x 4) - (+ x 6) - counter) - 1) - - (test/spec-passed/result - 'with-contract-one-contract-app-per-mutation-2 - '(let* ([counter 0] - [ctc (λ (x) (set! counter (add1 counter)) (number? x))]) - (with-contract foo ([x ctc]) - (define x 3)) - (+ x 4) - (+ x 6) - (set! x 6) - (+ x 6) - (+ x 2) - counter) - ;; 3 because of a double wrapping that occurs for outside mutations - ;; (that is, internal gets wrapped, then external gets wrapped again - ;; to fix blame. Could be optimized away if we had blame collapsing, - ;; e.g., (contract ctc (contract ctc x n1 p1) n2 p2) => - ;; (contract ctc x n2 p1), so if this breaks after adding such adjust it. - 3) - - ;; Check to make sure that any non-delayed set!s within the region don't - ;; get overridden when accessing the external version. - (test/spec-passed/result - 'with-contract-on-contract-app-per-mutation-3 - '(let () - (with-contract foo ([x number?]) - (define x 3) - (set! x 4)) - x) - 4) - - -; -; -; -; -; ;;; ;;; ; ; ; -; ;;; ;;; ;;; ;;; -; ;;; ;;; ;; ;;; ;;;; ;;; ;;;; ;;; ;;; ;;; ;; ;;;; ;;; ;;;;;;; ;;; ;;;; -; ;;;;; ;;;;;;; ;;; ;; ;;; ;;;;; ;;;; ;;;;; ;;;;; ;;;;;;; ;;;; ;;;;;;;;;;;; ;;;;; ;;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;; ;;; -; ;;; ;;; ;;; ;;; ;;; ;;;;;;; ;;; ;;; ;;;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;; ;;; ;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;;;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; -; ;;;;; ;;;;;;; ;;; ;;;;;; ;;;;; ;;;; ;;;;; ;;;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;;;; ;;;; -; ;;; ;;; ;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;; ;;; ;;; -; ;;;; -; ;;; -; -; - - (test/spec-passed - 'object-contract0 - '(contract (object-contract) - (new object%) - 'pos - 'neg)) - - (test/pos-blame - 'object-contract/field1 - '(contract (object-contract (field x integer?)) - (new object%) - 'pos - 'neg)) - - (test/pos-blame - 'object-contract/field2 - '(get-field - x - (contract (object-contract (field x integer?)) - (new (class object% (field [x #t]) (super-new))) - 'pos - 'neg))) - - (test/spec-passed/result - 'object-contract/field3 - '(get-field - x - (contract (object-contract (field x integer?)) - (new (class object% (field [x 12]) (super-new))) - 'pos - 'neg)) - 12) - - (test/pos-blame - 'object-contract/field4 - '(get-field - y - (contract (object-contract (field x boolean?) (field y boolean?)) - (new (class object% (field [x #t] [y 'x]) (super-new))) - 'pos - 'neg))) - - (test/pos-blame - 'object-contract/field5 - '(get-field - x - (contract (object-contract (field x symbol?) (field y symbol?)) - (new (class object% (field [x #t] [y 'x]) (super-new))) - 'pos - 'neg))) - - (test/spec-passed/result - 'object-contract/field6 - '(let ([o (contract (object-contract [m (integer? . -> . integer?)]) - (new (class object% (field [x 1]) (define/public (m y) x) (super-new))) - 'pos - 'neg)]) - (list (send o m 2) - (send/apply o m '(2)) - (let ([x '(2)]) (send o m . x)) - (with-method ([mm (o m)]) - (mm 2)) - (send* o (m 3) (m 4)))) - (list 1 1 1 1 1)) - - (test/spec-passed/result - 'object-contract/field7 - '(let ([o (contract (object-contract) - (new (class object% (field [x 1]) (define/public (m y) x) (super-new))) - 'pos - 'neg)]) - (list (send o m 2) - (send/apply o m '(2)) - (let ([x '(2)]) (send o m . x)) - (with-method ([mm (o m)]) - (mm 2)) - (send* o (m 3) (m 4)))) - (list 1 1 1 1 1)) - - (test/spec-passed/result - 'object-contract/field8 - '(let ([o (contract (object-contract [m (integer? . -> . integer?)]) - (new (class object% (define x 6) (define/public (m y) x) (super-new))) - 'pos - 'neg)]) - (list (send o m 2) - (send/apply o m '(2)) - (let ([x '(2)]) (send o m . x)) - (with-method ([mm (o m)]) - (mm 2)) - (send* o (m 3) (m 4)))) - (list 6 6 6 6 6)) - - (test/spec-passed/result - 'object-contract/field9 - '(let ([o (contract (object-contract) - (new (class object% (define x 6) (define/public (m y) x) (super-new))) - 'pos - 'neg)]) - (list (send o m 2) - (send/apply o m '(2)) - (let ([x '(2)]) (send o m . x)) - (with-method ([mm (o m)]) - (mm 2)) - (send* o (m 3) (m 4)))) - (list 6 6 6 6 6)) - - (test/spec-passed/result - 'object-contract/field10 - '(send (contract (object-contract) - (new (class object% (define x 1) (define/public (m y) x) (super-new))) - 'pos - 'neg) - m - 2) - 1) - - (test/spec-passed/result - 'object-contract->1 - '(send - (contract (object-contract (m (integer? . -> . integer?))) - (new (class object% (define/public (m x) x) (super-new))) - 'pos - 'neg) - m - 1) - 1) - - (test/pos-blame - 'object-contract->2 - '(contract (object-contract (m (integer? . -> . integer?))) - (make-object object%) - 'pos - 'neg)) - - (test/neg-blame - 'object-contract->3 - '(send - (contract (object-contract (m (integer? . -> . integer?))) - (make-object (class object% (define/public (m x) x) (super-new))) - 'pos - 'neg) - m - 'x)) - - (test/pos-blame - 'object-contract->4 - '(send - (contract (object-contract (m (integer? . -> . integer?))) - (make-object (class object% (define/public (m x) 'x) (super-new))) - 'pos - 'neg) - m - 1)) - - (test/pos-blame - 'object-contract->5 - '(contract (object-contract (m (integer? integer? . -> . integer?))) - (make-object (class object% (define/public (m x) 'x) (super-new))) - 'pos - 'neg)) - - (test/spec-passed/result - 'object-contract->6 - '(send - (contract (object-contract (m (integer? . -> . any))) - (new (class object% (define/public (m x) x) (super-new))) - 'pos - 'neg) - m - 1) - 1) - - (test/neg-blame - 'object-contract->7 - '(send - (contract (object-contract (m (integer? . -> . any))) - (make-object (class object% (define/public (m x) x) (super-new))) - 'pos - 'neg) - m - 'x)) - - (test/spec-passed - 'object-contract->8 - '(begin - (send - (contract (object-contract (m (integer? . -> . any))) - (make-object (class object% (define/public (m x) (values 1 2)) (super-new))) - 'pos - 'neg) - m - 1) - (void))) - - (test/spec-passed - 'object-contract->9 - '(begin - (send - (contract (object-contract (m (integer? . -> . any))) - (make-object (class object% (define/public (m x) (values)) (super-new))) - 'pos - 'neg) - m - 1) - (void))) - - (test/spec-passed - 'object-contract->10 - '(begin - (send (contract (object-contract (m (integer? . -> . (values integer? boolean?)))) - (make-object (class object% (define/public (m x) (values 1 #t)) (super-new))) - 'pos - 'neg) - m 1) - (void))) - - (test/neg-blame - 'object-contract->11 - '(send - (contract (object-contract (m (integer? . -> . (values integer? boolean?)))) - (make-object (class object% (define/public (m x) (values #t #t)) (super-new))) - 'pos - 'neg) - m - #f)) - - (test/pos-blame - 'object-contract->12 - '(send - (contract (object-contract (m (integer? . -> . (values integer? boolean?)))) - (make-object (class object% (define/public (m x) (values #t #t)) (super-new))) - 'pos - 'neg) - m - 1)) - - (test/pos-blame - 'object-contract->13 - '(send (contract (object-contract (m (integer? . -> . (values integer? boolean?)))) - (make-object (class object% (define/public (m x) (values #f #t)) (super-new))) - 'pos - 'neg) - m 1)) - - (test/pos-blame - 'object-contract->14 - '(send (contract (object-contract (m (integer? . -> . (values integer? boolean?)))) - (make-object (class object% (define/public (m x) (values 5 6)) (super-new))) - 'pos - 'neg) - m 1)) - - (test/pos-blame - 'object-contract-case->1 - '(contract (object-contract (m (case-> (boolean? . -> . boolean?) - (integer? integer? . -> . integer?)))) - (new object%) - 'pos - 'neg)) - - (test/pos-blame - 'object-contract-case->2 - '(contract (object-contract (m (case-> (boolean? . -> . boolean?) - (integer? integer? . -> . integer?)))) - (new (class object% (define/public (m x) x) (super-new))) - 'pos - 'neg)) - - (test/pos-blame - 'object-contract-case->3 - '(contract (object-contract (m (case-> (boolean? . -> . boolean?) - (integer? integer? . -> . integer?)))) - (new (class object% (define/public (m x y) x) (super-new))) - 'pos - 'neg)) - - (test/spec-passed - 'object-contract-case->4 - '(contract (object-contract (m (case-> (boolean? . -> . boolean?) - (integer? integer? . -> . integer?)))) - (new (class object% - (define/public m - (case-lambda - [(b) (not b)] - [(x y) (+ x y)])) - (super-new))) - 'pos - 'neg)) - - (test/spec-passed/result - 'object-contract-case->5 - '(send (contract (object-contract (m (case-> (boolean? . -> . boolean?) - (integer? integer? . -> . integer?)))) - (new (class object% - (define/public m - (case-lambda - [(b) (not b)] - [(x y) (+ x y)])) - (super-new))) - 'pos - 'neg) - m - #t) - #f) - - (test/spec-passed/result - 'object-contract-case->6 - '(send (contract (object-contract (m (case-> (boolean? . -> . boolean?) - (integer? integer? . -> . integer?)))) - (new (class object% - (define/public m - (case-lambda - [(b) (not b)] - [(x y) (+ x y)])) - (super-new))) - 'pos - 'neg) - m - 3 - 4) - 7) - - (test/pos-blame - 'object-contract->*1 - '(contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) - (new (class object% - (define/public m - (lambda (x [y 'a]) - x)) - (super-new))) - 'pos - 'neg)) - - (test/pos-blame - 'object-contract->*2 - '(contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) - (new (class object% - (define/public m - (lambda (x y [z #t]) - x)) - (super-new))) - 'pos - 'neg)) - - (test/spec-passed - 'object-contract->*3 - '(contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) - (new (class object% - (define/public m - (lambda (x [y 'a] [z #t]) - x)) - (super-new))) - 'pos - 'neg)) - - (test/spec-passed/result - 'object-contract->*4 - '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) - (new (class object% - (define/public m - (lambda (x [y 'a] [z #t]) - x)) - (super-new))) - 'pos - 'neg) - m - 1) - 1) - - (test/spec-passed/result - 'object-contract->*5 - '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) - (new (class object% - (define/public m - (lambda (x [y 'a] [z #t]) - x)) - (super-new))) - 'pos - 'neg) - m - 2 - 'z) - 2) - - (test/spec-passed/result - 'object-contract->*7 - '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) - (new (class object% - (define/public m - (lambda (x [y 'a] [z #t]) - x)) - (super-new))) - 'pos - 'neg) - m - 3 - 'z - #f) - 3) - - (test/neg-blame - 'object-contract->*8 - '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) - (new (class object% - (define/public m - (lambda (x [y 'a] [z #t]) - x)) - (super-new))) - 'pos - 'neg) - m - #f)) - - (test/neg-blame - 'object-contract->*9 - '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) - (new (class object% - (define/public m - (lambda (x [y 'a] [z #t]) - x)) - (super-new))) - 'pos - 'neg) - m - 2 - 4)) - - (test/neg-blame - 'object-contract->*10 - '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) - (new (class object% - (define/public m - (lambda (x [y 'a] [z #t]) - x)) - (super-new))) - 'pos - 'neg) - m - 3 - 'z - 'y)) - - (test/pos-blame - 'object-contract->*11 - '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) - (new (class object% - (define/public m - (lambda (x [y 'a] [z #t]) - 'x)) - (super-new))) - 'pos - 'neg) - m - 3 - 'z - #f)) - - (test/spec-passed/result - 'object-contract->*12 - '(let-values ([(x y) - (send (contract (object-contract - (m (->* (integer?) (symbol? boolean?) (values number? symbol?)))) - (new (class object% - (define/public m - (lambda (x [y 'a] [z #t]) - (values 1 'x))) - (super-new))) - 'pos - 'neg) - m - 3 - 'z - #f)]) - (cons x y)) - (cons 1 'x)) - - (test/pos-blame - 'object-contract->*13 - '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) (values number? symbol?)))) - (new (class object% - (define/public m - (lambda (x [y 'a] [z #t]) - (values 'x 'x))) - (super-new))) - 'pos - 'neg) - m - 3 - 'z - #f)) - - (test/pos-blame - 'object-contract->*14 - '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) - (values number? symbol?)))) - (new (class object% - (define/public m - (lambda (x [y 'a] [z #t]) - (values 1 1))) - (super-new))) - 'pos - 'neg) - m - 3 - 'z - #f)) - - (test/pos-blame - 'object-contract->*1 - '(contract (object-contract (m (-> integer? boolean?))) - (new (class object% (define/public (m x y) x) (super-new))) - 'pos - 'neg)) - - (test/neg-blame - 'object-contract->*2 - '(send (contract (object-contract (m (-> integer? boolean?))) - (new (class object% (define/public (m x) x) (super-new))) - 'pos - 'neg) - m #f)) - - (test/pos-blame - 'object-contract->*3 - '(send (contract (object-contract (m (-> integer? boolean?))) - (new (class object% (define/public (m x) x) (super-new))) - 'pos - 'neg) - m 1)) - - (test/spec-passed - 'object-contract->*4 - '(send (contract (object-contract (m (-> integer? boolean?))) - (new (class object% (define/public (m x) #f) (super-new))) - 'pos - 'neg) - m 1)) - - (test/pos-blame - 'object-contract->*5 - '(contract (object-contract (m (->* (integer?) () #:rest any/c boolean?))) - (new (class object% (define/public (m x y . z) x) (super-new))) - 'pos - 'neg)) - - (test/neg-blame - 'object-contract->*6 - '(send (contract (object-contract (m (->* (integer?) () #:rest any/c boolean?))) - (new (class object% (define/public (m x . z) x) (super-new))) - 'pos - 'neg) - m #t)) - - (test/pos-blame - 'object-contract->*7 - '(send (contract (object-contract (m (->* (integer?) () #:rest any/c boolean?))) - (new (class object% (define/public (m x . z) 1) (super-new))) - 'pos - 'neg) - m 1)) - - (test/spec-passed - 'object-contract->*8 - '(send (contract (object-contract (m (->* (integer?) () #:rest any/c boolean?))) - (new (class object% (define/public (m x . z) #f) (super-new))) - 'pos - 'neg) - m 1)) - - (test/spec-passed - 'object-contract->*9 - '(send (contract (object-contract (m (->* () () #:rest (listof number?) boolean?))) - (new (class object% (define/public (m . z) #f) (super-new))) - 'pos - 'neg) - m 1 2 3)) - - (test/neg-blame - 'object-contract->*10 - '(send (contract (object-contract (m (->* () () #:rest (listof number?) boolean?))) - (new (class object% (define/public (m . z) #f) (super-new))) - 'pos - 'neg) - m - #t)) - - (test/spec-passed - 'object-contract-->d1 - '(send (contract (object-contract (m (->d ([x number?]) () [range (<=/c x)]))) - (new (class object% (define/public m (lambda (x) (- x 1))) (super-new))) - 'pos - 'neg) - m - 1)) - - (test/spec-passed - 'object-contract-->d1b - '(send (contract (object-contract (m (->d ([x number?]) () [range (<=/c x)]))) - (new (class object% (define/public m (lambda (x) (- x 1))) (super-new))) - 'pos - 'neg) - m - 1)) - - (test/pos-blame - 'object-contract-->d2 - '(send (contract (object-contract (m (->d ([x number?]) () [range (<=/c x)]))) - (new (class object% (define/public m (lambda (x) (+ x 1))) (super-new))) - 'pos - 'neg) - m - 1)) - - (test/pos-blame - 'object-contract-->d2b - '(send (contract (object-contract (m (->d ([x number?]) () [range (<=/c x)]))) - (new (class object% (define/public m (lambda (x) (+ x 1))) (super-new))) - 'pos - 'neg) - m - 1)) - - (test/spec-passed - 'object-contract-->d3 - '(send (contract (object-contract (m (->d () () #:rest rst (listof number?) [range any/c]))) - (new (class object% (define/public m (lambda w 1)) (super-new))) - 'pos - 'neg) - m - 1)) - - (test/neg-blame - 'object-contract-->d4 - '(send (contract (object-contract (m (->d () () #:rest rst (listof number?) [range any/c]))) - (new (class object% (define/public m (lambda w 1)) (super-new))) - 'pos - 'neg) - m - #f)) - - (test/spec-passed - 'object-contract-->d5 - '(send (contract (object-contract (m (->d () () any))) - (new (class object% (define/public m (lambda () 1)) (super-new))) - 'pos - 'neg) - m)) - - (test/spec-passed - 'object-contract-->d6 - '(send (contract (object-contract (m (->d () () (values [x number?] [y (>=/c x)])))) - (new (class object% (define/public m (lambda () (values 1 2))) (super-new))) - 'pos - 'neg) - m)) - - (test/pos-blame - 'object-contract-->d7 - '(send (contract (object-contract (m (->d () () (values [x number?] [y (>=/c x)])))) - (new (class object% (define/public m (lambda () (values 2 1))) (super-new))) - 'pos - 'neg) - m)) - - (test/neg-blame - 'object-contract-->d/this-1 - '(send (contract (object-contract - (m (->d ([x (and/c integer? (lambda (x) (= x (get-field f this))))]) - () - any))) - (new (class object% (field [f 1]) (define/public m (lambda (x) 1)) (super-new))) - 'pos - 'neg) - m - 2)) - - (test/spec-passed - 'object-contract-->d/this-2 - '(send (contract (object-contract - (m (->d ([x (and/c integer? (lambda (x) (= x (get-field f this))))]) - () - any))) - (new (class object% (field [f 1]) (define/public m (lambda (x) 1)) (super-new))) - 'pos - 'neg) - m - 1)) - - (test/neg-blame - 'object-contract-->d/this-3 - '(send (contract (object-contract - (m (->d ([x (and/c integer? (lambda (x) (= x (get-field f this))))]) - () - #:rest rest-var any/c - any))) - (new (class object% (field [f 1]) - (define/public m (lambda (x . rest) 1)) - (super-new))) - 'pos - 'neg) - m - 2)) - - (test/spec-passed - 'object-contract-->d/this-4 - '(send (contract (object-contract - (m (->d ([x (and/c integer? (lambda (x) (= x (get-field f this))))]) - () - #:rest rest-var any/c - any))) - (new (class object% - (field [f 1]) - (define/public m (lambda (x . rest) 1)) - (super-new))) - 'pos - 'neg) - m - 1)) - - (test/spec-passed - 'object-contract-->pp1 - '(send (contract (object-contract - (m (->d ([x number?]) () #:pre-cond #t [unused (<=/c x)] #:post-cond #t))) - (new (class object% (define/public m (lambda (x) (- x 1))) (super-new))) - 'pos - 'neg) - m - 1)) - - (test/spec-passed - 'object-contract-->pp1b - '(send (contract (object-contract - (m (->d ([x number?]) () #:pre-cond #t [unused (<=/c x)] #:post-cond #t))) - (new (class object% - (define/public m (case-lambda [(x) (- x 1)] - [(x y) y])) - (super-new))) - 'pos - 'neg) - m - 1)) - - (test/pos-blame - 'object-contract-->pp2 - '(send (contract (object-contract - (m (->d ([x number?]) () #:pre-cond #t [unused (<=/c x)] #:post-cond #t))) - (new (class object% (define/public m (lambda (x) (+ x 1))) (super-new))) - 'pos - 'neg) - m - 1)) - - (test/pos-blame - 'object-contract-->pp2b - '(send (contract (object-contract - (m (->d ([x number?]) () #:pre-cond #t [unused (<=/c x)] #:post-cond #t))) - (new (class object% - (define/public m (case-lambda [(x) (+ x 1)])) - (super-new))) - 'pos - 'neg) - m - 1)) - - (test/spec-passed - 'object-contract-->pp3 - '(send (contract (object-contract - (m (->d () () #:rest rst (listof number?) - #:pre-cond #t [unused any/c] - #:post-cond #t))) - (new (class object% (define/public m (lambda w 1)) (super-new))) - 'pos - 'neg) - m - 1)) - - (test/neg-blame - 'object-contract-->pp4 - '(send (contract (object-contract - (m (->d () () #:rest rst (listof number?) - #:pre-cond #t [unused any/c] - #:post-cond #t))) - (new (class object% (define/public m (lambda w 1)) (super-new))) - 'pos - 'neg) - m - #f)) - - (test/spec-passed - 'object-contract-->pp5 - '(send (contract (object-contract (m (->d () () #:pre-cond #t any))) - (new (class object% (define/public m (lambda () 1)) (super-new))) - 'pos - 'neg) - m)) - - (test/spec-passed - 'object-contract-->pp6 - '(send (contract (object-contract (m (->d () () - #:pre-cond #t (values [x number?] [y (>=/c x)]) - #:post-cond #t))) - (new (class object% (define/public m (lambda () (values 1 2))) (super-new))) - 'pos - 'neg) - m)) - - (test/pos-blame - 'object-contract-->pp7 - '(send (contract (object-contract (m (->d () () #:pre-cond #t (values [x number?] [y (>=/c x)]) - #:post-cond #t))) - (new (class object% (define/public m (lambda () (values 2 1))) (super-new))) - 'pos - 'neg) - m)) - - (test/neg-blame - 'object-contract-->pp/this-1 - '(send (contract (object-contract (m (->d () - () - #:pre-cond (= 1 (get-field f this)) - [result-x any/c] - #:post-cond (= 2 (get-field f this))))) - (new (class object% - (field [f 2]) - (define/public m (lambda () (set! f 3))) - (super-new))) - 'pos - 'neg) - m)) - - (test/pos-blame - 'object-contract-->pp/this-2 - '(send (contract (object-contract (m (->d () () - #:pre-cond (= 1 (get-field f this)) - [result-x any/c] - #:post-cond (= 2 (get-field f this))))) - (new (class object% - (field [f 1]) - (define/public m (lambda () (set! f 3))) - (super-new))) - 'pos - 'neg) - m)) - - (test/spec-passed - 'object-contract-->pp/this-3 - '(send (contract (object-contract (m (->d () () - #:pre-cond (= 1 (get-field f this)) - [result-x any/c] - #:post-cond (= 2 (get-field f this))))) - (new (class object% - (field [f 1]) - (define/public m (lambda () (set! f 2))) - (super-new))) - 'pos - 'neg) - m)) - - (test/neg-blame - 'object-contract-->pp/this-4 - '(send (contract (object-contract (m (->d () () - #:rest rest-id any/c - #:pre-cond (= 1 (get-field f this)) - [result-x any/c] - #:post-cond (= 2 (get-field f this))))) - (new (class object% (field [f 2]) - (define/public m (lambda args (set! f 3))) - (super-new))) - 'pos - 'neg) - m)) - - (test/pos-blame - 'object-contract-->pp/this-5 - '(send (contract (object-contract (m (->d () () - #:rest rest-id any/c - #:pre-cond (= 1 (get-field f this)) - [result-x any/c] - #:post-cond (= 2 (get-field f this))))) - (new (class object% - (field [f 1]) - (define/public m (lambda args (set! f 3))) - (super-new))) - 'pos - 'neg) - m)) - - (test/spec-passed - 'object-contract-->pp/this-6 - '(send (contract (object-contract (m (->d () () - #:rest rest-id any/c - #:pre-cond (= 1 (get-field f this)) - [result-x any/c] - #:post-cond (= 2 (get-field f this))))) - (new (class object% - (field [f 1]) - (define/public m (lambda args (set! f 2))) - (super-new))) - 'pos - 'neg) - m)) -#| - (test/spec-passed - 'object-contract-->i1 - '(send (contract (object-contract (m (->i ([x number?]) () [range (x) (<=/c x)]))) - (new (class object% (define/public m (lambda (x) (- x 1))) (super-new))) - 'pos - 'neg) - m - 1)) - - (test/spec-passed - 'object-contract-->i1b - '(send (contract (object-contract (m (->i ([x number?]) () [range (x) (<=/c x)]))) - (new (class object% (define/public m (lambda (x) (- x 1))) (super-new))) - 'pos - 'neg) - m - 1)) - - (test/pos-blame - 'object-contract-->i2 - '(send (contract (object-contract (m (->i ([x number?]) () [range (x) (<=/c x)]))) - (new (class object% (define/public m (lambda (x) (+ x 1))) (super-new))) - 'pos - 'neg) - m - 1)) - - (test/pos-blame - 'object-contract-->i2b - '(send (contract (object-contract (m (->i ([x number?]) () [range (x) (<=/c x)]))) - (new (class object% (define/public m (lambda (x) (+ x 1))) (super-new))) - 'pos - 'neg) - m - 1)) - - (test/spec-passed - 'object-contract-->i3 - '(send (contract (object-contract (m (->i () () #:rest [rst (listof number?)] [range any/c]))) - (new (class object% (define/public m (lambda w 1)) (super-new))) - 'pos - 'neg) - m - 1)) - - (test/neg-blame - 'object-contract-->i4 - '(send (contract (object-contract (m (->i () () #:rest [rst (listof number?)] [range any/c]))) - (new (class object% (define/public m (lambda w 1)) (super-new))) - 'pos - 'neg) - m - #f)) - - (test/spec-passed - 'object-contract-->i5 - '(send (contract (object-contract (m (->i () () any))) - (new (class object% (define/public m (lambda () 1)) (super-new))) - 'pos - 'neg) - m)) - - (test/spec-passed - 'object-contract-->i6 - '(send (contract (object-contract (m (->i () () (values [x number?] [y (x) (>=/c x)])))) - (new (class object% (define/public m (lambda () (values 1 2))) (super-new))) - 'pos - 'neg) - m)) - - (test/pos-blame - 'object-contract-->i7 - '(send (contract (object-contract (m (->i () () (values [x number?] [y (x) (>=/c x)])))) - (new (class object% (define/public m (lambda () (values 2 1))) (super-new))) - 'pos - 'neg) - m)) - - (test/neg-blame - 'object-contract-->i/this-1 - '(send (contract (object-contract (m (->i ([x (and/c integer? (lambda (x) - (= x (get-field f this))))]) - () - any))) - (new (class object% (field [f 1]) (define/public m (lambda (x) 1)) (super-new))) - 'pos - 'neg) - m - 2)) - - (test/spec-passed - 'object-contract-->i/this-2 - '(send (contract (object-contract (m (->i ([x (and/c integer? (lambda (x) - (= x (get-field f this))))]) - () - any))) - (new (class object% (field [f 1]) (define/public m (lambda (x) 1)) (super-new))) - 'pos - 'neg) - m - 1)) - - (test/neg-blame - 'object-contract-->i/this-3 - '(send (contract (object-contract (m (->i ([x (and/c integer? (lambda (x) - (= x (get-field f this))))]) - () - #:rest [rest-var any/c] - any))) - (new (class object% (field [f 1]) (define/public m (lambda (x . rest) 1)) - (super-new))) - 'pos - 'neg) - m - 2)) - - (test/spec-passed - 'object-contract-->i/this-4 - '(send (contract (object-contract (m (->i ([x (and/c integer? (lambda (x) - (= x (get-field f this))))]) - () - #:rest [rest-var any/c] - any))) - (new (class object% (field [f 1]) (define/public m (lambda (x . rest) 1)) - (super-new))) - 'pos - 'neg) - m - 1)) - - (test/spec-passed - 'object-contract-->i-pp1 - '(send (contract (object-contract - (m (->i ([x number?]) () #:pre () #t [unused (x) (<=/c x)] #:post () #t))) - (new (class object% (define/public m (lambda (x) (- x 1))) (super-new))) - 'pos - 'neg) - m - 1)) - - (test/spec-passed - 'object-contract-->i-pp1b - '(send (contract (object-contract - (m (->i ([x number?]) () #:pre () #t [unused (x) (<=/c x)] #:post () #t))) - (new (class object% - (define/public m (case-lambda [(x) (- x 1)] - [(x y) y])) - (super-new))) - 'pos - 'neg) - m - 1)) - - (test/pos-blame - 'object-contract-->i-pp2 - '(send (contract (object-contract - (m (->i ([x number?]) () #:pre () #t [unused (x) (<=/c x)] #:post () #t))) - (new (class object% (define/public m (lambda (x) (+ x 1))) (super-new))) - 'pos - 'neg) - m - 1)) - - (test/pos-blame - 'object-contract-->i-pp2b - '(send (contract (object-contract - (m (->i ([x number?]) () #:pre () #t [unused (x) (<=/c x)] #:post () #t))) - (new (class object% - (define/public m (case-lambda [(x) (+ x 1)])) - (super-new))) - 'pos - 'neg) - m - 1)) - - (test/spec-passed - 'object-contract-->i-pp3 - '(send (contract (object-contract - (m (->i () () #:rest [rst (listof number?)] #:pre () #t [unused any/c] - #:post () #t))) - (new (class object% (define/public m (lambda w 1)) (super-new))) - 'pos - 'neg) - m - 1)) - - (test/neg-blame - 'object-contract-->i-pp4 - '(send (contract (object-contract (m (->i () () #:rest [rst (listof number?)] - #:pre () #t [unused any/c] #:post () #t))) - (new (class object% (define/public m (lambda w 1)) (super-new))) - 'pos - 'neg) - m - #f)) - - (test/spec-passed - 'object-contract-->i-pp5 - '(send (contract (object-contract (m (->i () () #:pre () #t any))) - (new (class object% (define/public m (lambda () 1)) (super-new))) - 'pos - 'neg) - m)) - - (test/spec-passed - 'object-contract-->i-pp6 - '(send (contract (object-contract (m (->i () () #:pre () #t (values [x number?] [y (x) (>=/c x)]) - #:post () #t))) - (new (class object% (define/public m (lambda () (values 1 2))) (super-new))) - 'pos - 'neg) - m)) - - (test/pos-blame - 'object-contract-->i-pp7 - '(send (contract (object-contract (m (->i () () #:pre () #t (values [x number?] [y (>=/c x)]) - #:post () #t))) - (new (class object% (define/public m (lambda () (values 2 1))) (super-new))) - 'pos - 'neg) - m)) - - (test/neg-blame - 'object-contract-->i-pp/this-1 - '(send (contract (object-contract (m (->i () - () - #:pre () (= 1 (get-field f this)) - [result-x any/c] - #:post () (= 2 (get-field f this))))) - (new (class object% (field [f 2]) (define/public m (lambda () (set! f 3))) - (super-new))) - 'pos - 'neg) - m)) - - (test/pos-blame - 'object-contract-->i-pp/this-2 - '(send (contract (object-contract (m (->i () () - #:pre () (= 1 (get-field f this)) - [result-x any/c] - #:post () (= 2 (get-field f this))))) - (new (class object% (field [f 1]) (define/public m (lambda () (set! f 3))) - (super-new))) - 'pos - 'neg) - m)) - - (test/spec-passed - 'object-contract-->i-pp/this-3 - '(send (contract (object-contract (m (->i () () - #:pre () (= 1 (get-field f this)) - [result-x any/c] - #:post () (= 2 (get-field f this))))) - (new (class object% (field [f 1]) (define/public m (lambda () (set! f 2))) - (super-new))) - 'pos - 'neg) - m)) - - (test/neg-blame - 'object-contract-->i-pp/this-4 - '(send (contract (object-contract (m (->i () () - #:rest [rest-id any/c] - #:pre () (= 1 (get-field f this)) - [result-x any/c] - #:post () (= 2 (get-field f this))))) - (new (class object% (field [f 2]) (define/public m (lambda args (set! f 3))) - (super-new))) - 'pos - 'neg) - m)) - - (test/pos-blame - 'object-contract-->i-pp/this-5 - '(send (contract (object-contract (m (->i () () - #:rest [rest-id any/c] - #:pre () (= 1 (get-field f this)) - [result-x any/c] - #:post () (= 2 (get-field f this))))) - (new (class object% (field [f 1]) (define/public m (lambda args (set! f 3))) - (super-new))) - 'pos - 'neg) - m)) - - (test/spec-passed - 'object-contract-->i-pp/this-6 - '(send (contract (object-contract (m (->i () () - #:rest [rest-id any/c] - #:pre () (= 1 (get-field f this)) - [result-x any/c] - #:post () (= 2 (get-field f this))))) - (new (class object% (field [f 1]) (define/public m (lambda args (set! f 2))) - (super-new))) - 'pos - 'neg) - m)) - |# - - (test/spec-passed/result - 'object-contract-drop-method1 - '(send (contract (object-contract (m (-> integer? integer?))) - (new (class object% (define/public (m x) x) (define/public (n x) x) (super-new))) - 'pos - 'neg) - n 1) - 1) - - (test/spec-passed/result - 'object-contract-drop-method2 - '(let ([o (contract (object-contract (m (-> integer? integer?))) - (new (class object% - (define/public (m x) x) - (define/public (n x) x) - (super-new))) - 'pos - 'neg)]) - (with-method ([m (o m)] - [n (o n)]) - (list (m 1) (n 2)))) - '(1 2)) - - (test/spec-passed/result - 'object-contract-drop-field1 - '(get-field g (contract (object-contract (field f integer?)) - (new (class object% (field [f 1] [g 2]) (super-new))) - 'pos - 'neg)) - 2) - - (test/spec-passed/result - 'object-contract-drop-field2 - '(field-bound? g (contract (object-contract (field f integer?)) - (new (class object% (field [f 1] [g 2]) (super-new))) - 'pos - 'neg)) - #t) - - (test/spec-passed/result - 'object-contract-drop-field3 - '(field-names - (contract (object-contract) - (new (class object% (field [g 2]) (super-new))) - 'pos - 'neg)) - '(g)) - - - (test/spec-passed/result - 'object-contract-ho-method1 - '(send (contract (object-contract (m (-> (-> integer? integer?) integer?))) - (new (class object% (define/public (m f) (f 1)) (super-new))) - 'pos - 'neg) - m - (λ (x) x)) - 1) - - (test/spec-passed/result - 'object-contract-ho-method2 - '(send (contract (object-contract (m (-> (->* (integer?) () integer?) integer?))) - (new (class object% (define/public (m f) (f 1)) (super-new))) - 'pos - 'neg) - m - (λ (x) x)) - 1) - - (test/spec-passed/result - 'object-contract-ho-method3 - '(send (contract (object-contract (m (-> (->i ([x integer?]) () [r integer?]) integer?))) - (new (class object% (define/public (m f) (f 1)) (super-new))) - 'pos - 'neg) - m - (λ (x) x)) - 1) - - (test/spec-passed/result - 'object-contract-layered1 - '(send (contract (object-contract (m (-> number? number?))) - (contract (object-contract) - (new (class object% (super-new) (define/public (m x) x))) - 'pos - 'neg) - 'pos - 'neg) - m - 5) - 5) - - ;; Make sure we're not dropping projections on the floor. - (test/neg-blame - 'object-contract-layered2 - '(send (contract (object-contract (m (-> number? number?))) - (contract (object-contract (m (-> string? string?))) - (new (class object% (super-new) (define/public (m x) x))) - 'pos - 'neg) - 'pos - 'neg) - m - 5)) - - (test/spec-passed/result - 'object-contract/arrow-special-case1 - '(send (contract (object-contract - [m (-> any/c boolean?)]) - (new (class object% - (define/public (m x) #t) - (super-new))) - 'pos - 'neg) - m 1) - #t) - - (test/spec-passed/result - 'object-contract/arrow-special-case2 - '(send (contract (object-contract - [m (-> any/c any)]) - (new (class object% - (define/public (m x) #t) - (super-new))) - 'pos - 'neg) - m 1) - #t) - - - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; test error message has right format - ;; - - (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)) - (string-append - "m method: arity mismatch;\n" - " the expected number of arguments does not match the given number\n" - " expected: 1\n" - " given: 2\n" - " arguments...:\n" - " 1\n" - " 2")) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; tests object utilities to be sure wrappers work right - ;; - - (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)) - - (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<%> (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%)) - - ;; Currently the new object contracts using impersonators don't even attempt to ensure that - ;; these reflective operations still work, and I'm not even sure they should. For now, I - ;; just get the class info from the original object, which means that all contracts are evaded. - ;; - ;; Just as a note, if we move the class-insp-mk - ;; values forward in class/c-proj and make-wrapper-class, - ;; we get a failure in object->vector for the second - ;; testcase because the field-ref/field-set! in the - ;; contracted version of the class (for a struct subtype - ;; of the original class's struct type) doesn't - ;; know how to get the fields out of the object struct. - ;; We can always force it with unsafe-struct-ref, - ;; but if we had impersonate-struct-type, with the same ability to replace the prop:object as - ;; impersonate-struct has, then we might be able to handle this better. - - (let ([c% (parameterize ([current-inspector (make-inspector)]) - (contract-eval '(class object% (super-new))))]) - (test (list c% #f) - 'object-info - (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)]) - (contract-eval '(new (class object% (field [x 1] [y 2]) (super-new)))))] - [vec (contract-eval `(object->vector ,obj))]) - (test vec - (contract-eval 'object->vector) - (contract-eval - `(contract (object-contract (field x integer?) (field y integer?)) - ,obj - 'pos - 'neg)))) - - -; -; -; ;; ;; -; ;; ;; -; ;; ;; -; ;;;; ;; ;;;;; ;;;;; ;;;;; ;; ;;;; -; ;;;;;; ;; ;;;;;;; ;;;;;;; ;;;;;;; ;; ;;;;;; -; ;;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;; ;; -; ;; ;; ;;;; ;;;; ;;;; ;; ;; -; ;; ;; ;;;;;; ;;;;; ;;;;; ;; ;; -; ;; ;; ;;; ;; ;;;; ;;;; ;; ;; -; ;;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;; ;; -; ;;;;; ;; ;;;;;;; ;;;;;;; ;;;;;;; ;; ;;;;; -; ;;; ;; ;;;; ;; ;;;;; ;;;;; ;; ;;; -; -; -; - - (test/pos-blame - 'class/c-first-order-class-1 - '(contract (class/c) - 3 - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-class-2 - '(contract (class/c) - object% - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-opaque-class-1 - '(contract (class/c #:opaque) - object% - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-opaque-class-2 - '(contract (class/c #:opaque) - (class object% (super-new) (define/public (m x) (add1 x))) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-method-1 - '(contract (class/c [m (-> any/c number? number?)]) - object% - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-method-2 - '(contract (class/c [m (-> any/c number? number?)]) - (class object% (super-new) (define/public (m x) (add1 x))) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-method-3 - '(contract (class/c [m (-> any/c number? number?)]) - (class object% (super-new) (define/public (m) 3)) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-method-4 - '(contract (class/c m) - object% - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-method-5 - '(contract (class/c m) - (class object% (super-new) (define/public (m) 3)) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-method-6 - '(contract (class/c [m (-> any/c number? number?)]) - (class object% (super-new) (define/public (m) 3)) - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-local-method-1 - '(let () - (define-local-member-name m) - (contract (class/c [m (->m number? number?)]) - (class object% (super-new) (define/public (m x) 3)) - 'pos - 'neg))) - - (test/pos-blame - 'class/c-first-order-local-method-2 - '(let () - (define-local-member-name m) - (contract (class/c [m (->m number? number? number?)]) - (class object% (super-new) (define/public (m x) 3)) - 'pos - 'neg))) - - (test/pos-blame - 'class/c-first-order-local-method-3 - '(let () - (define-local-member-name m) - (contract (class/c [m (->m number? number? number?)]) - (class object% (super-new)) - 'pos - 'neg))) - - (test/spec-passed - 'class/c-first-order-opaque-method-1 - '(contract (class/c #:opaque [m (-> any/c number? number?)]) - (class object% (super-new) (define/public (m x) 3)) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-opaque-method-2 - '(contract (class/c #:opaque [m (-> any/c number? number?)]) - (class object% (super-new) (define/public (m x) 3) (define/public (n) 4)) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-opaque-method-3 - '(let () - (define-local-member-name n) - (contract (class/c #:opaque [m (-> any/c number? number?)]) - (class object% (super-new) (define/public (m x) 3) (define/public (n) 4)) - 'pos - 'neg))) - - (test/pos-blame - 'class/c-first-order-opaque-method-4 - '(contract - (class/c #:opaque [m (-> any/c number? number?)]) - (let () - (define-local-member-name n) - (class object% (super-new) (define/public (m x) 3) (define/public (n) 4))) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-opaque-method-5 - '(contract - (class/c #:opaque [m (-> any/c number? number?)] [n (-> any/c number?)]) - (let () - (define-local-member-name n) - (class object% (super-new) (define/public (m x) 3) (define/public (n) 4))) - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-opaque-method-6 - '(let () - (define-local-member-name n) - (contract (class/c #:opaque [m (-> any/c number? number?)] [n (-> any/c number?)]) - (class object% (super-new) (define/public (m x) 3) (define/public (n) 4)) - 'pos - 'neg))) - - (test/pos-blame - 'class/c-first-order-field-1 - '(contract (class/c (field [n number?])) - object% - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-field-2 - '(contract (class/c (field [n number?])) - (class object% (super-new) (field [n 3])) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-field-3 - '(contract (class/c (field n)) - object% - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-field-4 - '(contract (class/c (field n)) - (class object% (super-new) (field [n 3])) - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-local-field-1 - '(let () - (define-local-member-name n) - (contract (class/c (field n)) - (class object% (super-new) (field [n 3])) - 'pos - 'neg))) - - (test/spec-passed - 'class/c-first-order-local-field-2 - '(let () - (define-local-member-name n) - (contract (class/c (field [n integer?])) - (class object% (super-new) (field [n 3])) - 'pos - 'neg))) - - (test/pos-blame - 'class/c-first-order-local-field-3 - '(let () - (define-local-member-name n) - (contract (class/c (field [n integer?])) - (class object% (super-new)) - 'pos - 'neg))) - - (test/spec-passed - 'class/c-first-order-opaque-field-1 - '(contract (class/c #:opaque (field n)) - (class object% (super-new) (field [n 3])) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-opaque-field-2 - '(contract (class/c #:opaque (field n)) - (class object% (super-new) (field [m 5] [n 3])) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-opaque-field-2 - '(contract (class/c #:opaque (field [m number?])) - (let () - (define-local-member-name n) - (class object% (super-new) (field [m 5] [n 3]))) - 'pos - 'neg)) - - ;; No true first-order tests here, other than just to make - ;; sure they're accepted. For init-field, we can at least - ;; make sure the given field is public (which happens - ;; naturally by splitting an init-field into init and field). - (test/spec-passed - 'class/c-first-order-init-1 - '(contract (class/c (init [a number?])) - (class object% (super-new) (init a)) - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-init-field-1 - '(contract (class/c (init-field [a number?])) - (class object% (super-new) (init-field a)) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-init-field-2 - '(contract (class/c (init-field [a number?])) - object% - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-inherit-field-1 - '(contract (class/c (inherit-field [n number?])) - object% - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-inherit-field-2 - '(contract (class/c (inherit-field [n number?])) - (class object% (super-new) (field [n 3])) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-inherit-field-3 - '(contract (class/c (inherit-field f)) - object% - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-inherit-field-4 - '(contract (class/c (inherit-field f)) - (class object% (super-new) (field [f 10])) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-super-1 - '(contract (class/c (super [m (-> any/c number? number?)])) - object% - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-super-2 - '(contract (class/c (super [m (-> any/c number? number?)])) - (class object% (super-new) (define/pubment (m x) (add1 x))) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-super-3 - '(contract (class/c (super [m (-> any/c number? number?)])) - (class object% (super-new) (define/public-final (m x) (add1 x))) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-super-4 - '(contract (class/c (super [m (-> any/c number? number?)])) - (let ([c% (class object% (super-new) (define/public (m x) (add1 x)))]) - (class c% (super-new) (define/overment (m x) (add1 x)))) - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-super-5 - '(contract (class/c (super [m (-> any/c number? number?)])) - (class object% (super-new) (define/public (m x) (add1 x))) - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-super-6 - '(contract (class/c (super [m (-> any/c number? number?)])) - (let ([c% (class object% (super-new) (define/pubment (m x) (inner x m x)))]) - (class c% (super-new) (define/augride (m x) (add1 x)))) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-super-7 - '(contract (class/c (super m)) - object% - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-super-8 - '(contract (class/c (super m)) - (class object% (super-new) (define/public (m) 3)) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-super-9 - '(contract (class/c (super [m (-> any/c number? number?)])) - (class object% (super-new) (define/public (m) 3)) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-opaque-super-1 - '(contract (class/c #:opaque (super m)) - (class (class object% (super-new) (define/public (m) 3)) (super-new)) - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-opaque-super-2 - '(contract (class/c #:opaque (super m) m) - (class (class object% (super-new) (define/public (m) 3)) (super-new)) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-opaque-super-3 - '(contract (class/c #:opaque) - (class (let () - (define-local-member-name m) - (class object% (super-new) (define/public (m) 3))) - (super-new)) - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-opaque-super-4 - '(contract (class/c #:opaque (super m) m) - (class (class object% (super-new) (define/public (m) 3)) (super-new)) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-inner-1 - '(contract (class/c (inner [m (-> any/c number? number?)])) - object% - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-inner-2 - '(contract (class/c (inner [m (-> any/c number? number?)])) - (class object% (super-new) (define/pubment (m x) (inner x m x))) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-inner-3 - '(contract (class/c (inner [m (-> any/c number? number?)])) - (class object% (super-new) (define/public (m x) (add1 x))) - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-inner-4 - '(contract (class/c (inner [m (-> any/c number? number?)])) - (let ([c% (class object% (super-new) (define/pubment (m x) (inner x m x)))]) - (class c% (super-new) (define/augride (m x) (add1 x)))) - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-inner-5 - '(contract (class/c (inner [m (-> any/c number? number?)])) - (let ([c% (class object% (super-new) (define/public (m x) (add1 x)))]) - (class c% (super-new) (define/overment (m x) (+ (super m x) (inner x m x))))) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-inner-6 - '(contract (class/c (inner [m (-> any/c number? number?)])) - (let* ([c% (class object% (super-new) (define/pubment (m x) (inner x m x)))] - [d% (class c% (super-new) (define/augride (m x) (add1 x)))]) - (class d% (super-new) (define/override-final (m x) (add1 x)))) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-inner-7 - '(contract (class/c (inner m)) - object% - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-inner-8 - '(let* ([c% (contract (class/c (inner m)) - (class object% (super-new) (define/pubment (m) (inner 3 m))) - 'pos - 'neg)]) - (class c% (super-new) (define/augment (m) 5)))) - - (test/neg-blame - 'class/c-first-order-inner-9 - '(let* ([c% (contract (class/c (inner [m (-> any/c number? number?)])) - (class object% (super-new) (define/pubment (m x) (inner x m x))) - 'pos - 'neg)]) - (class c% (super-new) (define/augment (m) 5)))) - - (test/pos-blame - 'class/c-first-order-opaque-inner-1 - '(contract (class/c #:opaque (inner m)) - (let ([c% (class object% (super-new) (define/pubment (m x) (inner x m x)))]) - (class c% (super-new) (define/augride (m x) (add1 x)))) - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-opaque-inner-2 - '(contract (class/c #:opaque (inner m) m) - (let ([c% (class object% (super-new) (define/pubment (m x) (inner x m x)))]) - (class c% (super-new) (define/augride (m x) (add1 x)))) - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-local-inner-1 - '(let () - (define-local-member-name m) - (contract (class/c (inner m) m) - (let ([c% (class object% (super-new) (define/pubment (m x) (inner x m x)))]) - (class c% (super-new) (define/augride (m x) (add1 x)))) - 'pos - 'neg))) - - (test/pos-blame - 'class/c-first-order-local-inner-2 - '(let () - (define-local-member-name m) - (contract (class/c (inner m)) - object% - 'pos - 'neg))) - - (test/pos-blame - 'class/c-first-order-override-1 - '(contract (class/c (override [m (-> any/c number? number?)])) - object% - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-override-2 - '(contract (class/c (override [m (-> any/c number? number?)])) - (class object% (super-new) (define/public (m x) (add1 x))) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-override-3 - '(contract (class/c (override [m (-> any/c number? number?)])) - (class object% (super-new) (define/pubment (m x) (add1 x))) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-override-4 - '(contract (class/c (override [m (-> any/c number? number?)])) - (let ([c% (class object% (super-new) (define/public (m x) (add1 x)))]) - (class c% (super-new) (define/overment (m x) (+ (super m x) (inner x m x))))) - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-override-5 - '(contract (class/c (override [m (-> any/c number? number?)])) - (let ([c% (class object% (super-new) (define/public (m x) (add1 x)))]) - (class c% (super-new) (define/override (m x) (add1 (super m x))))) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-override-6 - '(contract (class/c (override [m (-> any/c number? number?)])) - (let* ([c% (class object% (super-new) (define/public (m x) (add1 x)))] - [d% (class c% (super-new) (define/overment (m x) - (+ (super m x) (inner x m x))))]) - (class d% (super-new) (define/augride (m x) x))) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-override-7 - '(contract (class/c (override m)) - object% - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-override-8 - '(let ([c% (contract (class/c (override m)) - (class object% (super-new) (define/public (m) 3)) - 'pos - 'neg)]) - (class c% (super-new) (define/override (m) 5)))) - - (test/neg-blame - 'class/c-first-order-override-9 - '(let ([c% (contract (class/c (override [m (-> any/c number? number?)])) - (class object% (super-new) (define/public (m x) 3)) - 'pos - 'neg)]) - (class c% (super-new) (define/override (m) 5)))) - - (test/pos-blame - 'class/c-first-order-opaque-override-1 - '(contract (class/c #:opaque (override m)) - (let ([c% (class object% (super-new) (define/public (m x) (add1 x)))]) - (class c% (super-new) (define/override (m x) (add1 (super m x))))) - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-opaque-override-2 - '(contract (class/c #:opaque (override m) m) - (let ([c% (class object% (super-new) (define/public (m x) (add1 x)))]) - (class c% (super-new) (define/override (m x) (add1 (super m x))))) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-local-override-1 - '(let () - (define-local-member-name m) - (contract (class/c (override m)) - object% - 'pos - 'neg))) - - (test/spec-passed - 'class/c-first-order-local-override-2 - '(let () - (define-local-member-name m) - (define c% (contract (class/c (override m)) - (class object% (super-new) (define/public (m) 3)) - 'pos - 'neg)) - (class c% (super-new) (define/override (m) 5)))) - - (test/pos-blame - 'class/c-first-order-augment-1 - '(contract (class/c (augment [m (-> any/c number? number?)])) - object% - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-augment-2 - '(contract (class/c (augment [m (-> any/c number? number?)])) - (class object% (super-new) (define/pubment (m x) (add1 x))) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-augment-3 - '(contract (class/c (augment [m (-> any/c number? number?)])) - (class object% (super-new) (define/public (m x) (add1 x))) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-augment-4 - '(contract (class/c (augment [m (-> any/c number? number?)])) - (let ([c% (class object% (super-new) (define/pubment (m x) (inner x m x)))]) - (class c% (super-new) (define/augride (m x) (add1 x)))) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-augment-5 - '(contract (class/c (augment [m (-> any/c number? number?)])) - (let ([c% (class object% (super-new) (define/public (m x) (add1 x)))]) - (class c% (super-new) (define/override (m x) (add1 (super m x))))) - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-augment-6 - '(contract (class/c (augment [m (-> any/c number? number?)])) - (let* ([c% (class object% (super-new) (define/public (m x) (add1 x)))] - [d% (class c% (super-new) (define/overment (m x) - (+ (super m x) (inner x m x))))]) - (class d% (super-new) (define/augment (m x) x))) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-augment-7 - '(contract (class/c (augment m)) - object% - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-augment-8 - '(let ([c% (contract (class/c (augment m)) - (class object% (super-new) (define/pubment (m) 3)) - 'pos - 'neg)]) - (class c% (super-new) (inherit m)))) - - (test/pos-blame - 'class/c-first-order-augment-9 - '(let ([c% (contract (class/c (augment [m (-> any/c number? number?)])) - (class object% (super-new) (define/pubment (m) 3)) - 'pos - 'neg)]) - (class c% (super-new) (inherit m)))) - - (test/pos-blame - 'class/c-first-order-opaque-augment-1 - '(contract (class/c #:opaque (augment m)) - (class object% (super-new) (define/pubment (m x) (add1 x))) - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-opaque-augment-2 - '(contract (class/c #:opaque (augment m) m) - (class object% (super-new) (define/pubment (m x) (add1 x))) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-local-augment-1 - '(let () - (define-local-member-name m) - (contract (class/c (augment m)) - object% - 'pos - 'neg))) - - (test/spec-passed - 'class/c-first-order-local-augment-2 - '(let () - (define-local-member-name m) - (define c% (contract (class/c (augment m)) - (class object% (super-new) (define/pubment (m) 3)) - 'pos - 'neg)) - (class c% (super-new) (inherit m)))) - - (test/pos-blame - 'class/c-first-order-augride-1 - '(contract (class/c (augride [m (-> any/c number? number?)])) - object% - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-augride-2 - '(contract (class/c (augride [m (-> any/c number? number?)])) - (class object% (super-new) (define/pubment (m x) (add1 x))) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-augride-4 - '(contract (class/c (augride [m (-> any/c number? number?)])) - (class object% (super-new) (define/public (m x) (add1 x))) - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-augride-5 - '(contract (class/c (augride [m (-> any/c number? number?)])) - (let ([c% (class object% (super-new) (define/pubment (m x) (inner x m x)))]) - (class c% (super-new) (define/augride (m x) (add1 x)))) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-augride-5 - '(contract (class/c (augride [m (-> any/c number? number?)])) - (let ([c% (class object% (super-new) (define/public (m x) (add1 x)))]) - (class c% (super-new) (define/override (m x) (add1 (super m x))))) - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-augride-6 - '(contract (class/c (augride [m (-> any/c number? number?)])) - (let* ([c% (class object% (super-new) (define/public (m x) (add1 x)))] - [d% (class c% (super-new) (define/overment (m x) - (+ (super m x) (inner x m x))))]) - (class d% (super-new) (define/augride (m x) x))) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-augride-7 - '(contract (class/c (augride m)) - object% - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-augride-8 - '(let ([c% (contract (class/c (augride m)) - (class (class object% (super-new) (define/pubment (m) 3)) - (super-new) (define/augride (m) 4)) - 'pos - 'neg)]) - (class c% (super-new) (inherit m)))) - - (test/pos-blame - 'class/c-first-order-augride-9 - '(let ([c% (contract (class/c (augride [m (-> any/c number? number?)])) - (class (class object% (super-new) (define/pubment (m) 3)) - (super-new) (define/augride (m) 4)) - 'pos - 'neg)]) - (class c% (super-new) (inherit m)))) - - (test/pos-blame - 'class/c-first-order-opaque-augride-1 - '(contract (class/c #:opaque (augride m)) - (let ([c% (class object% (super-new) (define/pubment (m x) (inner x m x)))]) - (class c% (super-new) (define/augride (m x) (add1 x)))) - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-opaque-augride-2 - '(contract (class/c #:opaque (augride m) m) - (let ([c% (class object% (super-new) (define/pubment (m x) (inner x m x)))]) - (class c% (super-new) (define/augride (m x) (add1 x)))) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-local-augride-1 - '(let () - (define-local-member-name m) - (contract (class/c (augride m)) - object% - 'pos - 'neg))) - - (test/spec-passed - 'class/c-first-order-local-augride-2 - '(let () - (define-local-member-name m) - (define c% (contract (class/c (augride m)) - (class (class object% (super-new) (define/pubment (m) 3)) - (super-new) (define/augride (m) 4)) - 'pos - 'neg)) - (class c% (super-new) (inherit m)))) - - (test/pos-blame - 'class/c-first-order-inherit-1 - '(let* ([c% (contract (class/c (inherit [m (-> any/c number? number?)])) - object% - 'pos - 'neg)] - [d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))]) - (send (new d%) f))) - - (test/spec-passed - 'class/c-first-order-inherit-2 - '(let* ([c% (contract (class/c (inherit [m (-> any/c number? number?)])) - (class object% (super-new) (define/public (m x) x)) - 'pos - 'neg)] - [d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))]) - (send (new d%) f))) - - (test/pos-blame - 'class/c-first-order-inherit-3 - '(let* ([c% (contract (class/c (inherit [m (-> any/c number? number?)])) - (class object% (super-new) (define/public (m) 3)) - 'pos - 'neg)] - [d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))]) - (send (new d%) f))) - - (test/pos-blame - 'class/c-first-order-opaque-inherit-1 - '(let* ([c% (contract (class/c #:opaque (inherit [m (-> any/c number? number?)])) - (class object% (super-new) (define/public (m x) x)) - 'pos - 'neg)] - [d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))]) - (send (new d%) f))) - - (test/spec-passed - 'class/c-first-order-opaque-inherit-2 - '(let* ([c% (contract (class/c #:opaque m (inherit [m (-> any/c number? number?)])) - (class object% (super-new) (define/public (m x) x)) - 'pos - 'neg)] - [d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))]) - (send (new d%) f))) - - (test/pos-blame - 'class/c-first-order-local-inherit-1 - '(let () - (define-local-member-name m) - (define c% (contract (class/c (inherit [m (-> any/c number? number?)])) - object% - 'pos - 'neg)) - (define d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))) - (send (new d%) f))) - - (test/spec-passed - 'class/c-first-order-local-inherit-2 - '(let () - (define-local-member-name m) - (define c% (contract (class/c (inherit [m (-> any/c number? number?)])) - (class object% (super-new) (define/public (m x) x)) - 'pos - 'neg)) - (define d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))) - (send (new d%) f))) - - (test/spec-passed - 'class/c-first-order-absent-1 - '(contract (class/c (absent m)) object% 'pos 'neg)) - - (test/pos-blame - 'class/c-first-order-absent-2 - '(contract (class/c (absent m)) - (class object% (super-new) (define/public (m) 3)) - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-absent-3 - '(contract (class/c (absent (field f))) object% 'pos 'neg)) - - (test/pos-blame - 'class/c-first-order-absent-4 - '(contract (class/c (absent (field f))) - (class object% (super-new) (field [f 3])) - 'pos - 'neg)) - - (test/spec-passed - 'class/c-first-order-local-absent-1 - '(let () - (define-local-member-name f) - (contract (class/c (absent (field f))) object% 'pos 'neg))) - - (test/pos-blame - 'class/c-first-order-local-absent-2 - '(let () - (define-local-member-name f) - (contract (class/c (absent (field f))) - (class object% (super-new) (field [f 3])) - 'pos - 'neg))) - - (test/spec-passed - 'class/c-first-order-opaque-absent-1 - '(contract (class/c #:opaque (absent (field f))) object% 'pos 'neg)) - - (test/pos-blame - 'class/c-first-order-opaque-absent-2 - '(contract (class/c #:opaque (absent (field f))) - (class object% (super-new) (field [g 0])) - 'pos - 'neg)) - - (test/pos-blame - 'class/c-first-order-opaque-absent-3 - '(contract (class/c #:opaque (absent (field f g))) - (class object% (super-new) (field [g 0])) - 'pos - 'neg)) - - (test/spec-passed - 'class/c-higher-order-init-1 - '(let ([c% (contract (class/c (init [a number?])) - (class object% (super-new) (init a)) - 'pos - 'neg)]) - (new c% [a 3]))) - - (test/neg-blame - 'class/c-higher-order-init-2 - '(let ([c% (contract (class/c (init [a number?])) - (class object% (super-new) (init a)) - 'pos - 'neg)]) - (new c% [a #t]))) - - (test/spec-passed - 'class/c-higher-order-init-3 - '(let* ([c% (class object% (super-new) (init a))] - [d% (contract (class/c (init [a number?] [a string?])) - (class c% (super-new) (init a)) - 'pos - 'neg)]) - (new d% [a 3] [a "foo"]))) - - (test/neg-blame - 'class/c-higher-order-init-4 - '(let* ([c% (class object% (super-new) (init a))] - [d% (contract (class/c (init [a number?] [a string?])) - (class c% (super-new) (init a)) - 'pos - 'neg)]) - (new d% [a 3] [a 4]))) - - (test/neg-blame - 'class/c-higher-order-init-5 - '(let* ([c% (class object% (super-new) (init a))] - [d% (contract (class/c (init [a number?] [a string?])) - (class c% (super-new) (init a)) - 'pos - 'neg)]) - (new d% [a "bar"] [a "foo"]))) - - (test/spec-passed - 'class/c-higher-order-init-6 - '(let* ([c% (class object% (super-new) (init a))] - [d% (class c% (super-new) (init a))] - [d%/c (contract (class/c (init [a integer?] [a string?])) d% 'pos 'neg1)] - [d%/c/c (contract (class/c (init [a number?])) d%/c 'pos1 'neg)]) - (new d%/c/c [a 3] [a "foo"]))) - - (test/neg-blame - 'class/c-higher-order-init-7 - '(let* ([c% (class object% (super-new) (init a))] - [d% (class c% (super-new) (init a))] - [d%/c (contract (class/c (init [a integer?] [a string?])) d% 'pos1 'neg)] - [d%/c/c (contract (class/c (init [a number?])) d%/c 'pos 'neg1)]) - (new d%/c/c [a 3.5] [a "foo"]))) - - (test/neg-blame - 'class/c-higher-order-init-8 - '(let* ([c% (class object% (super-new) (init a))] - [d% (class c% (super-new) (init a))] - [d%/c (contract (class/c (init [a integer?] [a string?])) d% 'pos 'neg)] - [d%/c/c (contract (class/c (init [a number?])) d%/c 'pos 'neg)]) - (new d%/c/c [a #t] [a "foo"]))) - - (test/spec-passed - 'class/c-higher-order-init-field-1 - '(let ([c% (contract (class/c (init-field [f (-> number? number?)])) - (class object% (super-new) (init-field f) (f 3)) - 'pos - 'neg)]) - (new c% [f (lambda (x) x)]))) - - (test/pos-blame - 'class/c-higher-order-init-field-2 - '(let ([c% (contract (class/c (init-field [f (-> number? number?)])) - (class object% (super-new) (init-field f) (f #t)) - 'pos - 'neg)]) - (new c% [f (lambda (x) x)]))) - - (test/neg-blame - 'class/c-higher-order-init-field-3 - '(let ([c% (contract (class/c (init-field [f (-> number? number?)])) - (class object% (super-new) (init-field f) (f 3)) - 'pos - 'neg)]) - (new c% [f (lambda (x) (zero? x))]))) - - ;; Make sure that the original provider of the value is blamed if an - ;; init arg is given an invalid value, and then that is retrieved by - ;; an external client. - (test/neg-blame - 'class/c-higher-order-init-field-4 - '(let* ([c% (contract (class/c (init-field [f (-> number? number?)])) - (class object% (super-new) (init-field f)) - 'pos - 'neg)] - [o (new c% [f (lambda (x) (zero? x))])]) - ((get-field f o) 3))) - - (test/spec-passed - 'class/c-higher-order-method-1 - '(let ([c% (contract (class/c [m (-> any/c number? number?)]) - (class object% (super-new) (define/public (m x) (add1 x))) - 'pos - 'neg)]) - (send (new c%) m 3))) - - (test/neg-blame - 'class/c-higher-order-method-2 - '(let ([c% (contract (class/c [m (-> any/c number? number?)]) - (class object% (super-new) (define/public (m x) (add1 x))) - 'pos - 'neg)]) - (send (new c%) m #f))) - - (test/pos-blame - 'class/c-higher-order-method-3 - '(let ([c% (contract (class/c [m (-> any/c number? number?)]) - (class object% (super-new) (define/public (m x) (zero? x))) - 'pos - 'neg)]) - (send (new c%) m 3))) - - ;; Test that public method contracts are not checked for implication. - ;; Public method contracts do not check behavioral subtyping. - ;; Once interfaces have contracts, those will. - (test/spec-passed - 'class/c-higher-order-method-4 - '(let* ([c% (contract (class/c [m (-> any/c number? number?)]) - (class object% (super-new) (define/public (m x) (zero? x))) - 'pos - 'neg)] - [d% (class c% (super-new) (define/override (m) (super m 5)))]) - (send (new d%) m))) - - (test/spec-passed - 'class/c-higher-order-local-method-1 - '(let () - (define-local-member-name m) - (define c% (contract (class/c [m (-> any/c number? number?)]) - (class object% (super-new) (define/public (m x) (add1 x))) - 'pos - 'neg)) - (send (new c%) m 3))) - - (test/neg-blame - 'class/c-higher-order-local-method-2 - '(let () - (define-local-member-name m) - (define c% (contract (class/c [m (-> any/c number? number?)]) - (class object% (super-new) (define/public (m x) (add1 x))) - 'pos - 'neg)) - (send (new c%) m #f))) - - (test/spec-passed - 'class/c-higher-order-super-1 - '(let* ([c% (contract (class/c [m (-> any/c integer? integer?)] - (super [m (-> any/c number? number?)])) - (class object% (super-new) (define/public (m x) (add1 x))) - 'pos - 'neg)] - [d% (class c% (super-new) (define/override (m x) (+ x (super m 3.5))))]) - (send (new d%) m 4.5))) - - (test/neg-blame - 'class/c-higher-order-super-2 - '(let* ([c% (contract (class/c [m (-> any/c integer? integer?)] - (super [m (-> any/c number? number?)])) - (class object% (super-new) (define/public (m x) (add1 x))) - 'pos - 'neg)] - [d% (class c% (super-new) (define/override (m) (super m #f)))]) - (send (new d%) m))) - - (test/pos-blame - 'class/c-higher-order-super-3 - '(let* ([c% (contract (class/c [m (-> any/c integer? integer?)] - (super [m (-> any/c number? number?)])) - (class object% (super-new) (define/public (m x) (zero? x))) - 'pos - 'neg)] - [d% (class c% (super-new) (define/override (m) (super m 3.5)))]) - (send (new d%) m))) - - (test/spec-passed - 'class/c-higher-order-inner-1 - '(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)])) - (class object% (super-new) (define/pubment (m x) (+ x (inner x m x)))) - 'pos - 'neg)] - [d% (class c% (super-new) (define/augride (m x) (add1 x)))]) - (send (new d%) m 3))) - - (test/neg-blame - 'class/c-higher-order-inner-2 - '(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)])) - (class object% (super-new) (define/pubment (m x) (+ x (inner x m x)))) - 'pos - 'neg)] - [d% (class c% (super-new) (define/augride (m x) (zero? x)))]) - (send (new d%) m 3))) - - (test/pos-blame - 'class/c-higher-order-inner-3 - '(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)])) - (class object% (super-new) (define/pubment (m x) - (+ x (inner x m (zero? x))))) - 'pos - 'neg)] - [d% (class c% (super-new) (define/augride (m x) (add1 x)))]) - (send (new d%) m 3))) - - (test/neg-blame - 'class/c-higher-order-inner-4 - '(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)])) - (class object% (super-new) (define/pubment (m x) (+ x (inner x m x)))) - 'pos - 'neg)] - [d% (class c% (super-new) (define/augride (m x) (add1 x)))] - [e% (class d% (super-new) (define/override (m x) (zero? (super m x))))]) - (send (new e%) m 3))) - - (test/spec-passed - 'class/c-higher-order-inner-5 - '(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)])) - (class object% (super-new) (define/pubment (m x) (+ x (inner x m x)))) - 'pos - 'neg)] - [d% (class c% (super-new) (define/augment (m x) (if (inner x m x) (add1 x) x)))] - [e% (class d% (super-new) (define/augride (m x) (zero? x)))]) - (send (new e%) m 3))) - - ;; Make sure the order of the wrapping is correct in the next two. - (test/neg-blame - 'class/c-higher-order-inner-6 - '(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)])) - (class object% (super-new) (define/pubment (m x) (+ x (inner x m x)))) - 'pos - 'neg1)] - [d% (contract (class/c (inner [m (-> any/c number? number?)])) - c% - 'pos1 - 'neg)] - [e% (class d% (super-new) (define/augride (m x) (zero? x)))]) - (send (new e%) m 3))) - - (test/pos-blame - 'class/c-higher-order-inner-7 - '(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)])) - (class object% (super-new) (define/pubment (m x) (+ x (inner x m #f)))) - 'pos - 'neg1)] - [d% (contract (class/c (inner [m (-> any/c number? number?)])) - c% - 'pos1 - 'neg)] - [e% (class d% (super-new) (define/augride (m x) (add1 x)))]) - (send (new e%) m 3))) - - ;; Test that overriding an augmenting method can still be effected by an inner contract. - (test/neg-blame - 'class/c-higher-order-inner-8 - '(let* ([c% (contract (class/c (inner [m (-> any/c number? number?)])) - (class object% (super-new) (define/pubment (m x) (+ x (inner x m 3)))) - 'pos - 'neg)] - [d% (class c% (super-new) (define/augride (m x) (add1 x)))] - [e% (class d% (super-new) (define/override (m x) (zero? (super m x))))]) - (send (new e%) m 3))) - - ;; The inner contract can be added before the next augmenting method, as seen here. - (test/neg-blame - 'class/c-higher-order-inner-9 - '(let* ([c% (class object% (super-new) (define/pubment (m x) (+ x (inner x m 3))))] - [d% (contract (class/c (inner [m (-> any/c number? number?)])) - (class c% (super-new) (define/augride (m x) (add1 x))) - 'pos - 'neg)] - [e% (class d% (super-new) (define/override (m x) (zero? (super m x))))]) - (send (new e%) m 3))) - - ;; Show both inner and super contracts. - (test/spec-passed - 'class/c-higher-order-inner-10 - '(let* ([c% (class object% (super-new) (define/pubment (m x) (+ x (inner x m 3))))] - [d% (contract (class/c (inner [m (-> any/c number? number?)]) - (super [m (-> any/c number? number?)])) - (class c% (super-new) (define/augride (m x) (add1 x))) - 'pos - 'neg)] - [e% (class d% (super-new) (define/override (m x) (+ x (super m x))))]) - (send (new e%) m 3))) - - (test/pos-blame - 'class/c-higher-order-inner-11 - '(let* ([c% (class object% (super-new) (define/pubment (m x) (+ x (inner x m #f))))] - [d% (contract (class/c (inner [m (-> any/c number? number?)]) - (super [m (-> any/c number? number?)])) - (class c% (super-new) (define/augride (m x) (add1 x))) - 'pos - 'neg)] - [e% (class d% (super-new) (define/override (m x) (+ x (super m x))))]) - (send (new e%) m 3))) - - (test/neg-blame - 'class/c-higher-order-inner-10 - '(let* ([c% (class object% (super-new) (define/pubment (m x) (+ x (inner x m 3))))] - [d% (contract (class/c (inner [m (-> any/c number? number?)]) - (super [m (-> any/c number? number?)])) - (class c% (super-new) (define/augride (m x) (add1 x))) - 'pos - 'neg)] - [e% (class d% (super-new) (define/override (m x) (+ x (super m #f))))]) - (send (new e%) m 3))) - - (test/spec-passed/result - 'class/c-higher-order-field-1 - '(let* ([c% (contract (class/c (field [f number?])) - (class object% (super-new) (field [f 10])) - 'pos - 'neg)]) - (get-field f (new c%))) - 10) - - (test/spec-passed/result - 'class/c-higher-order-field-2 - '(let* ([c% (contract (class/c (field [f number?])) - (class object% (super-new) (field [f 10])) - 'pos - 'neg)] - [o (new c%)]) - (set-field! f o 5) - (get-field f o)) - 5) - - (test/pos-blame - 'class/c-higher-order-field-3 - '(let* ([c% (contract (class/c (field [f number?])) - (class object% (super-new) (field [f #f])) - 'pos - 'neg)] - [o (new c%)]) - (get-field f o))) - - (test/neg-blame - 'class/c-higher-order-field-4 - '(let* ([c% (contract (class/c (field [f number?])) - (class object% (super-new) (field [f 10])) - 'pos - 'neg)] - [o (new c%)]) - (set-field! f o #f))) - - (test/spec-passed - 'class/c-higher-order-field-5 - '(let ([c% (contract (class/c (field f)) - (class object% (super-new) (field [f 10])) - 'pos - 'neg)]) - (get-field f (new c%)))) - - (test/spec-passed/result - 'class/c-higher-order-inherit-field-1 - '(let* ([c% (contract (class/c (inherit-field [f number?])) - (class object% (super-new) (field [f 10])) - 'pos - 'neg)] - [d% (class c% (super-new) - (inherit-field f) - (define/public (m) f))]) - (send (new d%) m)) - 10) - - (test/spec-passed/result - 'class/c-higher-order-inherit-field-2 - '(let* ([c% (contract (class/c (inherit-field [f number?])) - (class object% (super-new) (field [f 10])) - 'pos - 'neg)] - [d% (class c% (super-new) - (inherit-field f) - (define/public (m) (set! f 12)))] - [o (new d%)]) - (send o m) - (get-field f o)) - 12) - - (test/pos-blame - 'class/c-higher-order-inherit-field-3 - '(let* ([c% (contract (class/c (inherit-field [f number?])) - (class object% (super-new) (field [f #f])) - 'pos - 'neg)] - [d% (class c% (super-new) - (inherit-field f) - (define/public (m) f))]) - (send (new d%) m))) - - (test/neg-blame - 'class/c-higher-order-inherit-field-4 - '(let* ([c% (contract (class/c (inherit-field [f number?])) - (class object% (super-new) (field [f 10])) - 'pos - 'neg)] - [d% (class c% (super-new) - (inherit-field f) - (define/public (m) (set! f #f)))]) - (send (new d%) m))) - - (test/spec-passed - 'class/c-higher-order-inherit-field-5 - '(let* ([c% (contract (class/c (inherit-field f)) - (class object% (super-new) (field [f 10])) - 'pos - 'neg)] - [d% (class c% (super-new) - (inherit-field f) - (define/public (m) f))]) - (send (new d%) m))) - - (test/spec-passed - 'class/c-higher-order-override-1 - '(let* ([c% (contract (class/c (override [m (-> any/c integer? integer?)])) - (class object% (super-new) - (define/public (m x) x) - (define/public (f x) (m x))) - 'pos - 'neg)] - [d% (class c% (super-new) - (define/public (g x) (m x)) - (define/override (m x) (add1 (super m x))))]) - (send (new d%) g 3.5))) - - (test/neg-blame - 'class/c-higher-order-override-2 - '(let* ([c% (contract (class/c (override [m (-> any/c number? number?)])) - (class object% (super-new) - (define/public (m x) x) - (define/public (f x) (add1 (m x)))) - 'pos - 'neg)] - [d% (class c% (super-new) (define/override (m x) (zero? (super m x))))]) - (send (new d%) f 3))) - - (test/neg-blame - 'class/c-higher-order-override-3 - '(let* ([c% (contract (class/c (override [m (-> any/c number? number?)])) - (class object% (super-new) - (define/public (m x) (zero? x)) - (define/public (f x) (add1 (m x)))) - 'pos - 'neg)] - [d% (class c% (super-new) (define/override (m x) (super m x)))]) - (send (new d%) f 3))) - - (test/pos-blame - 'class/c-higher-order-override-4 - '(let* ([c% (contract (class/c (override [m (-> any/c number? number?)])) - (class object% (super-new) - (define/public (m x) x) - (define/public (f x) (add1 (m #f)))) - 'pos - 'neg)] - [d% (class c% (super-new) (define/override (m x) (+ x (super m x))))]) - (send (new d%) f 3))) - - (test/pos-blame - 'class/c-higher-order-override-5 - '(let* ([c% (contract (class/c (override [m (-> any/c number? number?)])) - (class object% (super-new) - (define/public (m x) x) - (define/public (f x) (add1 (m #f)))) - 'pos - 'neg1)] - [d% (contract (class/c (override [m (-> any/c string? string?)])) - c% - 'pos1 - 'neg)] - [e% (class d% (super-new) (define/override (m x) (+ x (super m x))))]) - (send (new e%) f 3))) - - (test/spec-passed - 'class/c-higher-order-override-6 - '(let* ([c% (contract (class/c (override [m (-> any/c number? number?)])) - (class object% (super-new) - (define/public (m x) x) - (define/public (f x) (add1 (m 3.5)))) - 'pos - 'neg1)] - [d% (contract (class/c (override [m (-> any/c integer? integer?)])) - (class c% (super-new) (inherit m) (define/public (g x) (add1 (m 3)))) - 'pos1 - 'neg)] - [e% (class d% (super-new) (define/override (m x) (+ x (super m x))))]) - (send (new e%) g 3))) - - (test/pos-blame - 'class/c-higher-order-override-7 - '(let* ([c% (contract (class/c (override [m (-> any/c number? number?)])) - (class object% (super-new) - (define/public (m x) x) - (define/public (f x) (add1 (m #f)))) - 'pos - 'neg1)] - [d% (contract (class/c (override [m (-> any/c integer? integer?)])) - (class c% (super-new) (define/public (g x) (add1 (m 3)))) - 'pos1 - 'neg)] - [e% (class d% (super-new) (define/override (m x) (+ x (super m x))))]) - (send (new e%) f 3))) - - (test/spec-passed - 'class/c-higher-order-augment-1 - '(let* ([c% (contract (class/c (augment [m (-> any/c integer? integer?)])) - (class object% (super-new) - (define/pubment (m x) x) - (define/public (f x) (m (zero? x)))) - 'pos - 'neg)] - [d% (class c% (super-new) (inherit m) (define/public (g x) (m x)))]) - (send (new d%) f 3))) - - (test/neg-blame - 'class/c-higher-order-augment-2 - '(let* ([c% (contract (class/c (augment [m (-> any/c integer? integer?)])) - (class object% (super-new) (define/pubment (m x) x)) - 'pos - 'neg)] - [d% (class c% (super-new) (inherit m) (define/public (g x) (m x)))]) - (send (new d%) g 3.5))) - - (test/pos-blame - 'class/c-higher-order-augment-3 - '(let* ([c% (contract (class/c (augment [m (-> any/c integer? integer?)])) - (class object% (super-new) (define/pubment (m x) #f)) - 'pos - 'neg)] - [d% (class c% (super-new) (inherit m) (define/public (g x) (m x)))]) - (send (new d%) g 3))) - - (test/pos-blame - 'class/c-higher-order-augment-4 - '(let* ([c% (contract (class/c (augment [m (-> any/c number? integer?)])) - (class object% (super-new) (define/pubment (m x) #f)) - 'pos - 'neg1)] - [d% (contract (class/c (augment [m (-> any/c integer? number?)])) - c% - 'pos1 - 'neg)] - [e% (class d% (super-new) (inherit m) (define/public (g x) (m x)))]) - (send (new e%) g 3))) - - (test/neg-blame - 'class/c-higher-order-augment-5 - '(let* ([c% (contract (class/c (augment [m (-> any/c number? integer?)])) - (class object% (super-new) (define/pubment (m x) (floor x))) - 'pos - 'neg1)] - [d% (contract (class/c (augment [m (-> any/c integer? number?)])) - c% - 'pos1 - 'neg)] - [e% (class d% (super-new) (inherit m) (define/public (g x) (m x)))]) - (send (new e%) g 3.5))) - - (test/spec-passed - 'class/c-higher-order-augment-6 - '(let* ([c% (contract (class/c (augment [m (-> any/c number? integer?)])) - (class object% (super-new) (define/pubment (m x) (floor x))) - 'pos - 'neg1)] - [d% (contract (class/c (augment [m (-> any/c integer? number?)])) - (class c% (super-new) (inherit m) (define/public (f x) (m x))) - 'pos1 - 'neg)] - [e% (class d% (super-new) (inherit m) (define/public (g x) (m x)))]) - (send (new e%) f 3.5))) - - (test/spec-passed - 'class/c-higher-order-inherit-1 - '(let* ([c% (contract (class/c (inherit [m (-> any/c number? number?)])) - (class object% (super-new) (define/public (m x) x)) - 'pos - 'neg)] - [d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))]) - (send (new d%) f))) - - (test/neg-blame - 'class/c-higher-order-inherit-2 - '(let* ([c% (contract (class/c (inherit [m (-> any/c number? number?)])) - (class object% (super-new) (define/public (m x) x)) - 'pos - 'neg)] - [d% (class c% (super-new) (inherit m) (define/public (f) (m #f)))]) - (send (new d%) f))) - - (test/pos-blame - 'class/c-higher-order-inherit-3 - '(let* ([c% (contract (class/c (inherit [m (-> any/c number? number?)])) - (class object% (super-new) (define/public (m x) (zero? x))) - 'pos - 'neg)] - [d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))]) - (send (new d%) f))) - - ;; Should not be checked if overridden (i.e. target of dyn disp changes). - (test/spec-passed - 'class/c-higher-order-inherit-4 - '(let* ([c% (contract (class/c (inherit [m (-> any/c number? number?)])) - (class object% (super-new) (define/public (m x) (zero? x))) - 'pos - 'neg)] - [d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))] - [e% (class d% (super-new) (define/override (m x) x))]) - (send (new e%) f))) - - (test/spec-passed - '->m-first-order-1 - '(contract (class/c [m (->m number? number?)]) - (class object% (super-new) (define/public (m x) x)) - 'pos - 'neg)) - - (test/pos-blame - '->m-first-order-2 - '(contract (class/c [m (->m any/c number? number?)]) - (class object% (super-new) (define/public (m x) x)) - 'pos - 'neg)) - - (test/spec-passed - '->m-kwd-first-order-1 - '(contract (class/c [m (->m #:x number? number?)]) - (class object% (super-new) (define/public (m #:x x) x)) - 'pos - 'neg)) - - (test/pos-blame - '->m-kwd-first-order-2 - '(contract (class/c [m (->m #:y number? number?)]) - (class object% (super-new) (define/public (m #:x x) x)) - 'pos - 'neg)) - - (test/spec-passed - '->*m-first-order-1 - '(contract (class/c [m (->*m (number?) (string?) number?)]) - (class object% (super-new) (define/public (m x [f "foo"]) x)) - 'pos - 'neg)) - - (test/pos-blame - '->*m-first-order-2 - '(contract (class/c [m (->*m (any/c number?) (string?) number?)]) - (class object% (super-new) (define/public (m x [f "foo"]) x)) - 'pos - 'neg)) - - (test/spec-passed - '->dm-first-order-1 - '(contract (class/c [pop (->dm () () #:pre-cond (not (send this empty?)) [_ number?])] - [push (->dm ([arg number?]) () [_ void?] #:post-cond (not (send this empty?)))] - [empty? (->m boolean?)]) - (class object% (super-new) - (define stack null) - (define/public (empty?) (null? stack)) - (define/public (push v) (set! stack (cons v stack))) - (define/public (pop) (let ([res (car stack)]) (set! stack (cdr stack)) res))) - 'pos - 'neg)) - - (test/pos-blame - '->dm-first-order-1 - '(contract (class/c [pop (->dm () () #:pre-cond (not (send this empty?)) [_ number?])] - [push (->dm ([arg number?]) () [_ void?] #:post-cond (not (send this empty?)))] - [empty? (->m boolean?)]) - (class object% (super-new) - (define stack null) - (define/public (empty?) (null? stack)) - (define/public (push v) (set! stack (cons v stack))) - (define/public (pop v) (let ([res (car stack)]) (set! stack (cdr stack)) res))) - 'pos - 'neg)) - - (test/spec-passed - '->dm-higher-order-1 - '(let* ([stack% (contract (class/c - [pop (->dm () () #:pre-cond (not (send this empty?)) [_ number?])] - [push (->dm ([arg number?]) () [_ void?] - #:post-cond (not (send this empty?)))] - [empty? (->m boolean?)]) - (class object% (super-new) - (define stack null) - (define/public (empty?) (null? stack)) - (define/public (push v) (set! stack (cons v stack))) - (define/public (pop) - (let ([res (car stack)]) (set! stack (cdr stack)) res))) - 'pos - 'neg)] - [o (new stack%)]) - (send o push 4) - (send o empty?) - (send o pop))) - - (test/pos-blame - '->dm-higher-order-2 - '(let* ([stack% (contract (class/c - [pop (->dm () () #:pre-cond (not (send this empty?)) [_ number?])] - [push (->dm ([arg number?]) () [_ void?] - #:post-cond (not (send this empty?)))] - [empty? (->m boolean?)]) - (class object% (super-new) - (define stack null) - (define/public (empty?) (null? stack)) - (define/public (push v) (void)) - (define/public (pop) - (define res (car stack)) - (set! stack (cdr stack)) - res)) - 'pos - 'neg)] - [o (new stack%)]) - (send o push 4) - (send o empty?) - (send o pop))) - - (test/neg-blame - '->dm-higher-order-3 - '(let* ([stack% (contract - (class/c - [pop (->dm () () #:pre-cond (not (send this empty?)) [_ number?])] - [push (->dm ([arg number?]) () [_ void?] #:post-cond (not (send this empty?)))] - [empty? (->m boolean?)]) - (class object% (super-new) - (define stack null) - (define/public (empty?) (null? stack)) - (define/public (push v) (set! stack (cons v stack))) - (define/public (pop) (let ([res (car stack)]) (set! stack (cdr stack)) res))) - 'pos - 'neg)] - [o (new stack%)]) - (send o pop))) - - (test/spec-passed - 'case->m-first-order-1 - '(contract (class/c [m (case->m (-> number? number?) (-> number? number? number?))]) - (class object% (super-new) (define/public (m x [y 3]) (+ x y))) - 'pos - 'neg)) - - (test/pos-blame - 'case->m-first-order-2 - '(contract (class/c [m (case->m (-> number? number?) (-> number? number? number?))]) - (class object% (super-new) (define/public (m x) (+ x y))) - 'pos - 'neg)) - - (test/spec-passed - 'case->m-higher-order-1 - '(let ([cls% (contract (class/c [m (case->m (-> number? number?) (-> number? number? number?))]) - (class object% (super-new) (define/public (m x [y 3]) (+ x y))) - 'pos - 'neg)]) - (send (new cls%) m 3) - (send (new cls%) m 3 4))) - - (test/neg-blame - 'case->m-higher-order-2 - '(let ([cls% (contract (class/c [m (case->m (-> number? number?) (-> number? number? number?))]) - (class object% (super-new) (define/public (m x [y 3]) (+ x y))) - 'pos - 'neg)]) - (send (new cls%) m #t))) - - (test/neg-blame - 'case->m-higher-order-3 - '(let ([cls% (contract (class/c [m (case->m (-> number? number?) (-> number? number? number?))]) - (class object% (super-new) (define/public (m x [y 3]) (+ x y))) - 'pos - 'neg)]) - (send (new cls%) m 3 #t))) - - (let ([expected-given? - (λ (exn) (and (regexp-match? #rx"callback: contract violation" (exn-message exn)) - (regexp-match? #rx"expected: boolean[?]" (exn-message exn)) - (regexp-match? #rx"given: 1" (exn-message exn))))] - [promised-produced? - (λ (exn) (and (regexp-match? #rx"callback: broke its contract" (exn-message exn)) - (regexp-match? #rx"promised: boolean[?]" (exn-message exn)) - (regexp-match? #rx"produced: 1" (exn-message exn))))]) - (contract-error-test - 'blame-important1 - '(send (new (contract (class/c [callback (->m boolean? void)]) - (class object% - (super-new) - (define/public (callback n) (void))) - 'pos - 'neg)) - callback 1) - expected-given?) - (contract-error-test - 'blame-important2 - '((contract (-> (class/c (callback (->m boolean? any))) - any) - (λ (c%) (send (new c%) callback 1)) - 'pos 'neg) - (class object% - (super-new) - (define/public (callback x) 3))) - expected-given?) - (contract-error-test - 'blame-important3 - '((contract (-> (class/c (callback (->m (-> boolean? void?) any))) - any) - (λ (c%) (send (new c%) callback void)) - 'pos 'neg) - (class object% - (super-new) - (define/public (callback f) (f 1)))) - promised-produced?)) - - -; -; -; ;; ;; ; ;; -; ;; ;; ;; ;; -; ;; ;; ;; -; ;;;; ;; ;;; ;; ;;; ;;;; ;;;;; ;; ;;;; -; ;;;;;; ;;;;;;; ;; ;;;;; ;;;;;; ;;;;; ;; ;;;;;; -; ;;; ;;; ;;; ;;; ;; ;; ;; ;;; ;; ;; ;; ;;; ;; -; ;; ;; ;; ;; ;; ;;;;;;; ;; ;; ;; ;; -; ;; ;; ;; ;; ;; ;;;;;;; ;; ;; ;; ;; -; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; -; ;;; ;;; ;;; ;;; ;; ;;; ;; ;;; ;; ;; ;; ;;; ;; -; ;;;;;; ;;;;;;; ;; ;;;;; ;;;;; ;;;;;; ;;;;; -; ;;;; ;; ;;; ;; ;;; ;;; ;;;;; ;;; -; ;; -; ;;;; -; ;;; - - (test/pos-blame - 'object/c-first-order-object-1 - '(contract (object/c) - 3 - 'pos - 'neg)) - - (test/spec-passed - 'object/c-first-order-object-2 - '(contract (object/c) - (new object%) - 'pos - 'neg)) - - (test/pos-blame - 'object/c-first-order-method-1 - '(contract (object/c [m (-> any/c number? number?)]) - (new object%) - 'pos - 'neg)) - - (test/spec-passed - 'object/c-first-order-method-2 - '(contract (object/c [m (-> any/c number? number?)]) - (new (class object% (super-new) (define/public (m x) (add1 x)))) - 'pos - 'neg)) - - (test/pos-blame - 'object/c-first-order-local-method-1 - '(let () - (define-local-member-name m) - (contract (object/c [m (-> any/c number? number?)]) - (new object%) - 'pos - 'neg))) - - (test/spec-passed - 'object/c-first-order-local-method-2 - '(let () - (define-local-member-name m) - (contract (object/c [m (-> any/c number? number?)]) - (new (class object% (super-new) (define/public (m x) (add1 x)))) - 'pos - 'neg))) - - (test/pos-blame - 'object/c-first-order-field-1 - '(contract (object/c (field [n number?])) - (new object%) - 'pos - 'neg)) - - (test/spec-passed - 'object/c-first-order-field-2 - '(contract (object/c (field [n number?])) - (new (class object% (super-new) (field [n 3]))) - 'pos - 'neg)) - - (test/pos-blame - 'object/c-first-order-local-field-1 - '(let () - (define-local-member-name n) - (contract (object/c (field [n number?])) - (new object%) - 'pos - 'neg))) - - (test/spec-passed - 'object/c-first-order-local-field-2 - '(let () - (define-local-member-name n) - (contract (object/c (field [n number?])) - (new (class object% (super-new) (field [n 3]))) - 'pos - 'neg))) - - (test/spec-passed/result - 'object/c-higher-order-field-1 - '(get-field - n - (contract (object/c (field [n number?])) - (new (class object% (super-new) (field [n 3]))) - 'pos - 'neg)) - 3) - - (test/pos-blame - 'object/c-higher-order-field-2 - '(get-field - n - (contract (object/c (field [n number?])) - (new (class object% (super-new) (field [n #t]))) - 'pos - 'neg))) - - (test/spec-passed/result - 'object/c-higher-order-field-3 - '(let ([o (contract (object/c (field [n number?])) - (new (class object% (super-new) (field [n 3]))) - 'pos - 'neg)]) - (set-field! n o 5) - (get-field n o)) - 5) - - (test/neg-blame - 'object/c-higher-order-field-4 - '(let ([o (contract (object/c (field [n number?])) - (new (class object% (super-new) (field [n 3]))) - 'pos - 'neg)]) - (set-field! n o #t))) - - (test/spec-passed/result - 'object/c-higher-order-field-5 - '(let* ([pre-o (new (class object% (super-new) (field [n 3])))] - [o (contract (object/c (field [n number?])) - pre-o - 'pos - 'neg)]) - (set-field! n pre-o 5) - (get-field n o)) - 5) - - (test/spec-passed/result - 'object/c-higher-order-field-6 - '(let* ([pre-o (new (class object% (super-new) (field [n 3])))] - [o (contract (object/c (field [n number?])) - pre-o - 'pos - 'neg)]) - (set-field! n o 5) - (get-field n pre-o)) - 5) - - (test/neg-blame - 'object/c-higher-order-field-7 - '(let* ([pre-o (new (class object% (super-new) (field [n 3])))] - [o (contract (object/c (field [n number?])) - pre-o - 'pos - 'neg)]) - (set-field! n o #t) - (get-field n pre-o))) - - (test/pos-blame - 'object/c-higher-order-field-8 - '(let* ([pre-o (new (class object% (super-new) (field [n 3])))] - [o (contract (object/c (field [n number?])) - pre-o - 'pos - 'neg)]) - (set-field! n pre-o #t) - (get-field n o))) - - -; -; -; -; ; ;;; -; ; ; -; ; ; -; ; ; -; ; ;; ;;; ;;;; ;;;;; ;;;; ;; ;;; ;;; ;;; ;;; ;;;; -; ;; ;; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ;; ; ;;;;; ; ; ; ;;;;;;; ; ; ; -; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; -; ;;; ;;; ;;; ;;;; ;;; ;;; ;; ;;; ;;; ;;; ;;;; ;;; ;;; -; -; -; -; - - (test/spec-passed - 'instanceof/c-first-order-1 - '(let* ([c% object%] - [c%/c (class/c)]) - (contract (instanceof/c c%/c) (new c%) 'pos 'neg))) - - (test/pos-blame - 'instanceof/c-first-order-2 - '(let* ([c% object%] - [c%/c (class/c (field [f number?]))]) - (contract (instanceof/c c%/c) (new c%) 'pos 'neg))) - - (test/pos-blame - 'instanceof/c-first-order-3 - '(let* ([c% object%] - [c%/c (class/c [m (->m number? number?)])]) - (contract (instanceof/c c%/c) (new c%) 'pos 'neg))) - - (test/spec-passed - 'instanceof/c-first-order-4 - '(let* ([c% (class object% (super-new) (field [f 3]))] - [c%/c (class/c (field [f number?]))]) - (contract (instanceof/c c%/c) (new c%) 'pos 'neg))) - - (test/spec-passed - 'instanceof/c-first-order-5 - '(let* ([c% (class object% (super-new) (define/public (m x) x))] - [c%/c (class/c [m (->m number? number?)])]) - (contract (instanceof/c c%/c) (new c%) 'pos 'neg))) - - (test/spec-passed - 'instanceof/c-first-order-6 - '(let* ([c% (class object% (super-new) (define/public (m x) x))] - [c%/c (class/c [m (->m number? number?)])] - [d%/c (class/c [n (->m number? number?)])]) - (contract (instanceof/c (or/c c%/c d%/c)) (new c%) 'pos 'neg))) - - (test/spec-passed - 'instanceof/c-first-order-7 - '(let* ([d% (class object% (super-new) (define/public (n x) x))] - [c%/c (class/c [m (->m number? number?)])] - [d%/c (class/c [n (->m number? number?)])]) - (contract (instanceof/c (or/c c%/c d%/c)) (new d%) 'pos 'neg))) - - (test/pos-blame - 'instanceof/c-first-order-8 - '(let* ([e% (class object% (super-new) (define/public (p x) x))] - [c%/c (class/c [m (->m number? number?)])] - [d%/c (class/c [n (->m number? number?)])]) - (contract (instanceof/c (or/c c%/c d%/c)) (new e%) 'pos 'neg))) - - (test/spec-passed/result - 'instanceof/c-higher-order-1 - '(let* ([c% (class object% (super-new) (field [f 3]))] - [c%/c (class/c (field [f number?]))] - [o (contract (instanceof/c c%/c) (new c%) 'pos 'neg)]) - (get-field f o)) - 3) - - (test/neg-blame - 'instanceof/c-higher-order-2 - '(let* ([c% (class object% (super-new) (field [f 3]))] - [c%/c (class/c (field [f number?]))] - [o (contract (instanceof/c c%/c) (new c%) 'pos 'neg)]) - (set-field! f o #t))) - - (test/pos-blame - 'instanceof/c-higher-order-3 - '(let* ([c% (class object% (super-new) (define/public (m x) (zero? x)))] - [c%/c (class/c [m (->m number? number?)])] - [o (contract (instanceof/c c%/c) (new c%) 'pos 'neg)]) - (send o m 3))) - - (test/spec-passed - 'instanceof/c-higher-order-4 - '(let* ([c% (class object% (super-new) (define/public (m x) x))] - [c%/c (class/c [m (->m number? number?)])] - [d%/c (class/c [n (->m number? number?)])] - [o (contract (instanceof/c (or/c c%/c d%/c)) (new c%) 'pos 'neg)]) - (send o m 3))) - - (test/pos-blame - 'instanceof/c-higher-order-4 - '(let* ([c% (class object% (super-new) (define/public (m x) #t))] - [c%/c (class/c [m (->m number? number?)])] - [d%/c (class/c [n (->m number? number?)])] - [o (contract (instanceof/c (or/c c%/c d%/c)) (new c%) 'pos 'neg)]) - (send o m 3))) - - (test/neg-blame - 'instanceof/c-higher-order-4 - '(let* ([c% (class object% (super-new) (define/public (m x) x))] - [c%/c (class/c [m (->m number? number?)])] - [d%/c (class/c [n (->m number? number?)])] - [o (contract (instanceof/c (or/c c%/c d%/c)) (new c%) 'pos 'neg)]) - (send o m #t))) - -;; interface contracts - - (test/spec-passed - 'interface-1 - '(interface () [x number?])) - - (test/spec-passed - 'interface-2 - '(interface () [x number?] [y number?])) - - (test/spec-passed - 'interface-3 - '(interface () [get-x (-> integer?)])) - - (contract-syntax-error-test - 'interface-4 - '(interface () [x number?] [x symbol?])) - - (contract-error-test - 'interface-5 - '(interface () [x (λ (x y) x)]) - exn:fail?) - - (contract-error-test - 'interface-6 - '(interface ((interface () x)) x) - exn:fail?) - - (test/spec-passed - 'interface-7 - '(interface ((interface () x)) [x integer?])) - - (test/spec-passed - 'interface-8 - '(interface ((interface () [x number?])) [x integer?])) - - (contract-error-test - 'interface-9 - '(interface ((interface () [x number?])) x) - exn:fail?) - - (test/spec-passed - 'interface-first-order-1 - '(let* ([i<%> (interface () [m (->m number? number?)])] - [c% (class* object% (i<%>) (super-new) (define/public (m x) x))]) - (new c%))) - - (test/spec-failed - 'interface-first-order-2 - '(let* ([i<%> (interface () [m (->m number? number?)])] - [c% (class* object% (i<%>) (super-new) (define/public (m) x))]) - (new c%)) - "(class c%)") - - (test/spec-passed - 'interface-higher-order-1 - '(let* ([i<%> (interface () [m (->m number? number?)])] - [c% (class* object% (i<%>) (super-new) (define/public (m x) x))]) - (send (new c%) m 3))) - - (test/spec-failed - 'interface-higher-order-2 - '(let* ([i<%> (interface () [m (->m number? number?)])] - [c% (class* object% (i<%>) (super-new) (define/public (m x) x))]) - (send (new c%) m "wrong")) - "top-level") - - (test/spec-failed - 'interface-higher-order-3 - '(let* ([i<%> (interface () [m (->m number? number?)])] - [c% (class* object% (i<%>) (super-new) (define/public (m x) "bad"))]) - (send (new c%) m 3)) - "(class c%)") - - (test/spec-failed - 'interface-higher-order-4 - '(let* ([i1<%> (interface () [m (->m number? number?)])] - [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] - [c% (class* object% (i2<%>) (super-new) (define/public (m x) x))]) - (send (new c%) m 3.14)) - "(interface i2<%>)") - - (test/spec-failed - 'interface-higher-order-5 - '(let* ([i1<%> (interface () [m (->m number? number?)])] - [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] - [c% (class* object% (i2<%>) (super-new) (define/public (m x) 3.14))]) - (send (new c%) m 3)) - "(class c%)") - - (test/spec-failed - 'interface-higher-order-6 - '(let* ([i1<%> (interface () [m (->m integer? integer?)])] - [i2<%> (interface (i1<%>) [m (->m number? number?)])] - [c% (class* object% (i2<%>) (super-new) (define/public (m x) 3.14))]) - (send (new c%) m 3)) - "(interface i2<%>)") - - (test/spec-passed - 'interface-higher-order-7 - '(let* ([i1<%> (interface () [m (->m integer? number?)])] - [i2<%> (interface (i1<%>) [m (->m number? integer?)])] - [c% (class* object% (i2<%>) (super-new) (define/public (m x) x))]) - (send (new c%) m 3))) - - (test/spec-failed - 'interface-higher-order-8 - '(let* ([i1<%> (interface () [m (->m integer? number?)])] - [i2<%> (interface (i1<%>) [m (->m number? integer?)])] - [c% (class* object% (i2<%>) (super-new) (define/public (m x) x))]) - (send (new c%) m 3.14)) - "top-level") - - (test/spec-failed - 'interface-higher-order-9 - '(let* ([i1<%> (interface () [m (->m integer? number?)])] - [i2<%> (interface (i1<%>) [m (->m number? integer?)])] - [c% (class* object% (i2<%>) (super-new) (define/public (m x) 3.14))]) - (send (new c%) m 3)) - "(class c%)") - - (test/spec-passed - 'interface-higher-order-10 - '(let* ([i1<%> (interface () [m (->m integer? integer?)])] - [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] - [c% (class* object% (i2<%>) (super-new) (define/public (m x) x))] - [c2% (class c% (super-new))]) - (send (new c2%) m 3))) - - (test/spec-passed - 'interface-higher-order-11 - '(let* ([i1<%> (interface () [m (->m integer? integer?)])] - [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] - [c% (contract (class/c) - (class* object% (i2<%>) (super-new) (define/public (m x) x)) - 'pos - 'neg)]) - (send (new c%) m 3))) - - (test/neg-blame - 'interface-higher-order-12 - '(let* ([i1<%> (interface () [m (->m integer? integer?)])] - [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] - [c% (contract (class/c [m (->m integer? integer?)]) - (class* object% (i2<%>) (super-new) (define/public (m x) x)) - 'pos - 'neg)]) - (send (new c%) m 5.14))) - - (test/spec-failed - 'interface-higher-order-13 - '(let* ([i1<%> (interface () [m (->m integer? integer?)])] - [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] - [c% (contract (class/c m) - (class* object% (i2<%>) (super-new) (define/public (m x) x)) - 'pos - 'neg)]) - (send (new c%) m 5.14)) - "pos") - - (test/spec-failed - 'interface-higher-order-14 - '(let* ([i1<%> (interface () [m (->m integer? integer?)])] - [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] - [c% (contract (class/c) - (class* object% (i2<%>) (super-new) (define/public (m x) x)) - 'pos - 'neg)]) - (send (new c%) m 5.14)) - "top-level") - - (test/spec-passed - 'interface-internal-name-1 - '(let* ([i1<%> (interface () [m (->m integer? integer?)])] - [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] - [c% (class* object% (i2<%>) - (super-new) - (public [n m]) - (define n (λ (x) x)))]) - (send (new c%) m 3))) - - (test/spec-passed - 'interface-internal-name-2 - '(let* ([i1<%> (interface () [m (->m integer? integer?)])] - [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] - [c% (contract - (class/c [m (->m integer? integer?)]) - (class* object% (i2<%>) - (super-new) - (public [n m]) - (define n (λ (x) x))) - 'pos - 'neg)]) - (send (new c%) m 3))) - - (test/spec-passed - 'interface-mixin-1 - '(let* ([i1<%> (interface () [m (->m integer? integer?)])] - [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] - [mixin (λ (cls) - (class* cls (i2<%>) - (super-new) - (define/public (m x) x)))]) - (send (new (mixin object%)) m 3))) - - (test/spec-passed - 'interface-bad-concretization-1 - '(let* ([i1<%> (interface () [m (->m integer? integer?)])] - [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] - [c% (class* object% (i2<%>) (super-new) (define/public (m x) x))] - [c2% (class c% (super-new))]) - (send (new c2%) m 3) - (with-contract region - #:result integer? - (send (new c2%) m 3)))) - - (contract-error-test - 'interface-method-name-1 - #'(begin - (eval '(module imn-bug scheme/base - (require scheme/class) - (define i<%> (interface () [m (->m integer? integer?)])) - (define c% (class* object% (i<%>) (super-new) (define/public (m x) x))) - (send (new c%) m "foo"))) - (eval '(require 'imn-bug))) - (λ (x) - (and (exn:fail:contract:blame? x) - (regexp-match #rx"m: contract violation" (exn-message x))))) - -; -; -; -; ;; ; ;;;; ;;;; -; ;; ;; ;;;; ;;;; -; ;;;;;;; ;;;; ;;;;;;; ;;;; ;;;; ;;;; ;;;;; ;;;;;;; ;;;;;;; ;;;; ;;; -; ;;;; ;;;;;;;;;;;;; ;;;;;;;;;;;;; ;;;; ;;;; ;;;;;; ;;;;;;;; ;;;;;;;; ;;;; ;;;;; -; ;;;; ;;;; ;;; ;;;; ;;;; ;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;;;; ;;;; ;;;; ;; -; ;;;; ;;;; ;;; ;;;; ;;;; ;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;; ;;;; ;;;;;;; -; ;;;; ;;;; ;;; ;;;; ;;;; ;;; ;;;; ;;;; ;;;; ;;;;; ;; ;;;; ;;;;;;;;; ;;;; ;;;;; -; ;;;; ;;;; ;;; ;;;; ;;;; ;;; ;;;; ;;;;;;;;; ;;;;; ;;;;;;;; ;;;;;;;; ;;;; ;;;;;; -; ;;;; ;;;; ;;; ;;;; ;;;; ;;; ;;;; ;;; ;;;; ;;;; ;; ;;;; ;;;;;;; ;;;; ;;;; -; -; -; - - - (test/pos-blame - 'immutable1 - '(let ([ct (contract (listof (boolean? . -> . boolean?)) - #f - 'pos - 'neg)]) - ((car ct) 1))) - - (test/neg-blame - 'immutable2 - '(let ([ct (contract (listof (boolean? . -> . boolean?)) - (list (lambda (x) x)) - 'pos - 'neg)]) - ((car ct) 1))) - - (test/neg-blame - 'immutable3 - '(let ([ct (contract (listof (number? . -> . boolean?)) - (list (lambda (x) 1)) - 'pos - 'neg)]) - ((car ct) #f))) - - (test/pos-blame - 'immutable4 - '(let ([ct (contract (listof (number? . -> . boolean?)) - (list (lambda (x) 1)) - 'pos - 'neg)]) - ((car ct) 1))) - - (test/spec-passed - 'immutable5 - '(let ([ct (contract (listof (number? . -> . boolean?)) - (list (lambda (x) #t)) - 'pos - 'neg)]) - ((car ct) 1))) - - - (test/pos-blame - 'immutable6 - '(contract (cons/c (boolean? . -> . boolean?) (boolean? . -> . boolean?)) - #f - 'pos - 'neg)) - - (test/spec-passed - 'immutable7 - '(let ([ct (contract (non-empty-listof (boolean? . -> . boolean?)) - (list (λ (x) #t)) - 'pos - 'neg)]) - ((car ct) #f))) - - (test/neg-blame - 'immutable8 - '(let ([ct (contract (cons/c (number? . -> . boolean?) (number? . -> . boolean?)) - (cons (lambda (x) 1) (lambda (x) 1)) - 'pos - 'neg)]) - ((car ct) #f))) - - (test/neg-blame - 'immutable9 - '(let ([ct (contract (cons/c (number? . -> . boolean?) (number? . -> . boolean?)) - (cons (lambda (x) 1) (lambda (x) 1)) - 'pos - 'neg)]) - ((cdr ct) #f))) - - (test/pos-blame - 'immutable10 - '(let ([ct (contract (cons/c (number? . -> . boolean?) (number? . -> . boolean?)) - (cons (lambda (x) 1) (lambda (x) 1)) - 'pos - 'neg)]) - ((car ct) 1))) - - (test/pos-blame - 'immutable11 - '(let ([ct (contract (cons/c (number? . -> . boolean?) (number? . -> . boolean?)) - (cons (lambda (x) 1) (lambda (x) 1)) - 'pos - 'neg)]) - ((cdr ct) 1))) - - (test/spec-passed - 'immutable12 - '(let ([ct (contract (cons/c (number? . -> . boolean?) (number? . -> . boolean?)) - (cons (lambda (x) #t) (lambda (x) #t)) - 'pos - 'neg)]) - ((car ct) 1))) - - (test/spec-passed - 'immutable13 - '(let ([ct (contract (cons/c (number? . -> . boolean?) (number? . -> . boolean?)) - (cons (lambda (x) #t) (lambda (x) #t)) - 'pos - 'neg)]) - ((cdr ct) 1))) - - (test/spec-passed/result - 'immutable14 - '(contract (cons/c number? boolean?) - (cons 1 #t) - 'pos - 'neg) - (cons 1 #t)) - - (test/pos-blame - 'immutable15 - '(contract (list/c (number? . -> . boolean?) (number? . -> . boolean?)) - #f - 'pos - 'neg)) - - (test/pos-blame - 'immutable17 - '(contract (list/c (number? . -> . boolean?) (number? . -> . boolean?)) - (list (lambda (x) #t)) - 'pos - 'neg)) - - (test/pos-blame - 'immutable18 - '(contract (list/c (number? . -> . boolean?) (number? . -> . boolean?)) - (list (lambda (x) #t) (lambda (x) #t) (lambda (x) #t)) - 'pos - 'neg)) - - (test/spec-passed - 'immutable19 - '(let ([ctc (contract (list/c (number? . -> . boolean?) (number? . -> . boolean?)) - (list (lambda (x) #t) (lambda (x) #t)) - 'pos - 'neg)]) - (for-each (lambda (x) (x 1)) ctc))) - - (test/pos-blame - 'vector-immutable1 - '(contract (vector-immutableof (boolean? . -> . boolean?)) - #f - 'pos - 'neg)) - - (test/pos-blame - 'vector-immutable2 - '(contract (vector-immutableof (boolean? . -> . boolean?)) - (vector (lambda (x) x)) - 'pos - 'neg)) - - (test/neg-blame - 'vector-immutable3 - '(let ([ct (contract (vector-immutableof (number? . -> . boolean?)) - (vector->immutable-vector (vector (lambda (x) 1))) - 'pos - 'neg)]) - ((vector-ref ct 0) #f))) - - (test/pos-blame - 'vector-immutable4 - '(let ([ct (contract (vector-immutableof (number? . -> . boolean?)) - (vector->immutable-vector (vector (lambda (x) 1))) - 'pos - 'neg)]) - ((vector-ref ct 0) 1))) - - (test/spec-passed - 'vector-immutable5 - '(let ([ct (contract (vector-immutableof (number? . -> . boolean?)) - (vector->immutable-vector (vector (lambda (x) #t))) - 'pos - 'neg)]) - ((vector-ref ct 0) 1))) - - (test/pos-blame - 'vector-immutable6 - '(contract (vector-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) - #f - 'pos - 'neg)) - - (test/pos-blame - 'vector-immutable7 - '(contract (vector-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) - (vector (lambda (x) #t) (lambda (x) #t)) - 'pos - 'neg)) - - (test/pos-blame - 'vector-immutable8 - '(contract (vector-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) - (vector->immutable-vector (vector (lambda (x) #t))) - 'pos - 'neg)) - - (test/pos-blame - 'vector-immutable9 - '(contract (vector-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) - (vector->immutable-vector (vector (lambda (x) #t) (lambda (x) #t) (lambda (x) #t))) - 'pos - 'neg)) - - (test/spec-passed - 'vector-immutable10 - '(let ([ctc (contract (vector-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) - (vector->immutable-vector (vector (lambda (x) #t) (lambda (x) #t))) - 'pos - 'neg)]) - ((vector-ref ctc 0) 1) - ((vector-ref ctc 1) 1))) - - (test/spec-passed/result - 'vector-immutable11 - '(contract (vector-immutable/c number? boolean?) - (vector->immutable-vector (vector 1 #t)) - 'pos - 'neg) - (vector->immutable-vector (vector 1 #t))) - - (test/spec-passed/result - 'vector-immutable12 - '(immutable? (contract (vector-immutable/c number? boolean?) - (vector->immutable-vector (vector 1 #t)) - 'pos - 'neg)) - #t) - - (test/pos-blame - 'box-immutable1 - '(contract (box-immutable/c (number? . -> . boolean?)) - #f - 'pos - 'neg)) - - (test/pos-blame - 'box-immutable2 - '(contract (box-immutable/c (number? . -> . boolean?)) - (box (lambda (x) #t)) - 'pos - 'neg)) - - (test/neg-blame - 'box-immutable3 - '(let ([ctc (contract (box-immutable/c (number? . -> . boolean?)) - (box-immutable (lambda (x) #t)) - 'pos - 'neg)]) - ((unbox ctc) #f))) - - (test/pos-blame - 'box-immutable4 - '(let ([ctc (contract (box-immutable/c (number? . -> . boolean?)) - (box-immutable (lambda (x) 1)) - 'pos - 'neg)]) - ((unbox ctc) 1))) - - (test/spec-passed - 'box-immutable5 - '(let ([ctc (contract (box-immutable/c (number? . -> . boolean?)) - (box-immutable (lambda (x) #t)) - 'pos - 'neg)]) - ((unbox ctc) 1))) - - (test/spec-passed/result - 'box-immutable6 - '(contract (box-immutable/c boolean?) - (box-immutable #t) - 'pos - 'neg) - (box-immutable #t)) - - (test/spec-passed/result - 'box-immutable7 - '(immutable? (contract (box-immutable/c boolean?) - (box-immutable #t) - 'pos - 'neg)) - #t) - - -; -; -; -; ;; ;; -; ;; ;; -; ;;;;;;; ;;; ;;; ;;;; ;;;;;;; ;;;; ;;;;; ;;; ;; ;;;;; -; ;;;;;;;; ;;;;;;; ;;;;;; ;;;;;;;;;;;;; ;;;; ;;;;;; ;;;;; ;; ;;;;;; -; ;;;;;;;;; ;;;; ;; ;;;;;;;; ;;;; ;;; ;;;; ;;;; ;;;; ;;;; ;; ;;;;;;;;; -; ;;;; ;;;; ;;;; ;;;; ;;; ;;;; ;;; ;;;; ;;;; ;;;; ;;;;;;; ;; ;;;; -; ;;;;;;;;; ;;;; ;;;;;;;; ;;;; ;;; ;;;; ;;;; ;;;; ;;;;; ;; ;;;;;;; -; ;;;;;;;; ;;;; ;;;;;; ;;;; ;;; ;;;; ;;;; ;;;;;; ;;;;;; ;; ;;;;;; -; ;;;;;;; ;;;; ;;;; ;;;; ;;; ;;;; ;;;; ;;;;; ;;;; ;; ;;;;; -; ;;;; ;; -; ;;;; -; - - - (test/pos-blame - 'promise/c1 - '(force (contract (promise/c boolean?) - (delay 1) - 'pos - 'neg))) - - (test/spec-passed - 'promise/c2 - '(force (contract (promise/c boolean?) - (delay #t) - 'pos - 'neg))) - - (test/spec-passed/result - 'promise/c3 - '(let ([x 0]) - (contract (promise/c any/c) - (delay (set! x (+ x 1))) - 'pos - 'neg) - x) - 0) - - (test/spec-passed/result - 'promise/c4 - '(let ([x 0]) - (force (contract (promise/c any/c) - (delay (set! x (+ x 1))) - 'pos - 'neg)) - x) - 1) - - (test/spec-passed/result - 'promise/c5 - '(let ([x 0]) - (let ([p (contract (promise/c any/c) - (delay (set! x (+ x 1))) - 'pos - 'neg)]) - (force p) - (force p)) - x) - 1) - - (test/spec-passed/result - 'promise/c5 - '(let ([a (delay 7)]) - (equal? a - (contract (promise/c integer?) - a - 'pos - 'neg))) - #t) - - (test/spec-passed/result - 'promise/c6 - '(let ([a (delay 7)]) - (equal? a - (contract (promise/c (new-∃/c 'α)) - a - 'pos - 'neg))) - #t) - - -; -; -; -; ; ;; -; ;; ;; -; ;;;;; ;;; ;;; ;;;; ;;; ;;;;; ;;;;;;; ;;;; ;;;; ;; ;;;;; -; ;;;;;; ;;; ;;;; ;;;;;;;;; ;;;;;; ;;;;;;;; ;;; ;;; ;; ;;;;;; -; ;;;; ;;;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;;;;;;; -; ;;;; ;;;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;;; ;; ;;;; -; ;;;; ;;;;; ;;;; ;;;; ;;;;; ;; ;;;; ;;;;;;; ;; ;;;;;;; -; ;;;;;; ;;;; ;;;; ;;;; ;;;;; ;;;;;;;; ;;; ;;; ;; ;;;;;; -; ;;;;; ;;;; ;;;; ;;;; ;;;; ;; ;;;; ;;;; ;;;; ;; ;;;;; -; ;;;; ;; -; ;;;; -; - - - (test/pos-blame - 'syntax/c1 - '(contract (syntax/c boolean?) - #'x - 'pos - 'neg)) - - (test/spec-passed - 'syntax/c2 - '(contract (syntax/c symbol?) - #'x - 'pos - 'neg)) - - (test/no-error '(syntax/c (list/c #f))) - (contract-error-test 'syntax/c-non-flat '(syntax/c (vector/c #f)) - (λ (x) (regexp-match? #rx"flat-contract[?]" (exn-message x)))) - - -; -; -; -; ; ; ;; -; ;; ;; ;; -; ;;;;; ;;;;; ;;; ;;; ;;;; ;;;; ;;;;; ;;;;; ;; ;;;;; -; ;;;;;; ;;;;;; ;;;;;;; ;;;; ;;;; ;;;;;; ;;;;;; ;; ;;;;;; -; ;;;; ;;;; ;;;; ;; ;;;; ;;;; ;;;;;;; ;;;; ;;;;;;;;; -; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;; ;;;; -; ;;;; ;;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;;; ;; ;;;;;;; -; ;;;;;; ;;;;; ;;;; ;;;;;;;;; ;;;;;; ;;;;; ;; ;;;;;; -; ;;;;; ;;;; ;;;; ;;; ;;;; ;;;;; ;;;; ;; ;;;;; -; ;; -; -; - - - (test/spec-passed - 'struct/c1 - '(let () - (define-struct s (a)) - (contract (struct/c s integer?) - (make-s 1) - 'pos - 'neg))) - - (test/pos-blame - 'struct/c2 - '(let () - (define-struct s (a)) - (contract (struct/c s integer?) - (make-s #f) - 'pos - 'neg))) - - (test/pos-blame - 'struct/c3 - '(let () - (define-struct s (a)) - (contract (struct/c s integer?) - 1 - 'pos - 'neg))) - - (test/spec-passed - 'struct/c4 - '(let () - (define-struct s (a b)) - (contract (struct/c s integer? (struct/c s integer? boolean?)) - (make-s 1 (make-s 2 #t)) - 'pos - 'neg))) - - (test/pos-blame - 'struct/c5 - '(let () - (define-struct s (a b)) - (contract (struct/c s integer? (struct/c s integer? boolean?)) - (make-s 1 (make-s 2 3)) - 'pos - 'neg))) - - (test/spec-passed - 'struct/c6 - '(let () - (define-struct s (f)) - (let ([v (contract (struct/c s (-> number? number?)) - (make-s values) - 'pos - 'neg)]) - ((s-f v) 3)))) - - (test/neg-blame - 'struct/c7 - '(let () - (define-struct s (f)) - (let ([v (contract (struct/c s (-> number? number?)) - (make-s values) - 'pos - 'neg)]) - ((s-f v) #f)))) - - (test/pos-blame - 'struct/c8 - '(let () - (define-struct s (f)) - (let ([v (contract (struct/c s (-> number? number?)) - (make-s (λ (v) #f)) - 'pos - 'neg)]) - ((s-f v) 3)))) - - (test/spec-passed - 'struct/c9 - '(let () - (define-struct s (a b) #:mutable) - (let ([v (contract (struct/c s integer? boolean?) - (make-s 3 #t) - 'pos - 'neg)]) - (set-s-a! v 4) - (set-s-b! v #t)))) - - (test/neg-blame - 'struct/c10 - '(let () - (define-struct s (a b) #:mutable) - (let ([v (contract (struct/c s integer? boolean?) - (make-s 3 #t) - 'pos - 'neg)]) - (set-s-a! v #f)))) - - (test/neg-blame - 'struct/c11 - '(let () - (define-struct s (a [b #:mutable])) - (let ([v (contract (struct/c s integer? boolean?) - (make-s 3 #t) - 'pos - 'neg)]) - (set-s-b! v 5)))) - - (test/spec-passed/result - 'struct/c12 - '(let () - (define-struct s (a) #:mutable) - (define alpha (new-∃/c 'alpha)) - (define v (make-s 3)) - (let ([v* (contract (struct/c s alpha) v 'pos 'neg)]) - (set-s-a! v* (s-a v*))) - (s-a v)) - 3) - - (test/neg-blame - 'struct/c13 - '(let () - (define-struct s (a) #:mutable) - (define alpha (new-∃/c 'alpha)) - (define v (make-s 3)) - (let ([v* (contract (struct/c s alpha) v 'pos 'neg)]) - (set-s-a! v* 4)))) - - (test/spec-passed/result - 'struct/c14 - '(let () - (struct heap (v)) - (struct heap-node heap ()) - - (heap-v (contract (struct/c heap-node number?) - (heap-node 11) - 'pos - 'neg))) - 11) - - (test/spec-passed/result - 'struct/c15 - '(let () - (struct a (x)) - (struct b a (y)) - (struct c b (z)) - (struct d c (w)) - - (b-y (contract (struct/c d number? number? number? number?) - (d 11 22 33 44) - 'pos - 'neg))) - 22) - - (test/spec-passed/result - 'struct/c16 - '(let () - (struct doll (contents)) - (list ((flat-contract-predicate (struct/c doll 'center)) (doll 'center)) - ((flat-contract-predicate (struct/c doll 'center)) (doll 'not-center-center)))) - '(#t #f)) - - (contract-error-test - 'struct/c17 - #'(let () - (struct foo (v)) - (contract (struct/c foo number?) - #f - 'pos - 'neg)) - (λ (x) - (and (exn:fail:contract:blame? x) - (regexp-match #rx"promised: foo?" (exn-message x))))) - - -; -; -; -; -; ; ; ; ;;; -; ;;; ;;; ; ;;; -; ;;;; ;;;; ;;; ;;;; ;;; ;;; ;;;; ; ;; ;;; ;;; -; ;;; ;; ;;;; ;;;;;;;; ;;; ;;;;; ;;;; ; ;;;;;;; ;;;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ; ;;; ;;; ;;; ;; -; ;;;; ;;; ;;; ;;; ;;; ;;; ;;; ; ;;; ;;; ;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ; ;;; ;;; ;;; ;; -; ;; ;;; ;;;; ;;; ;;;;;;; ;;;;; ;;;; ; ;;;;;;; ;;;;; -; ;;;; ;;; ;;; ;; ;;; ;;; ;;; ; ;; ;;; ;;; -; -; -; -; - - - (test/spec-passed - 'struct/dc-1 - '(let () - (struct s (a b)) - (contract (struct/dc s - [a () number?] - [b (a) boolean?]) - (s 1 #f) - 'pos - 'neg))) - - (test/spec-passed - 'struct/dc-1a - '(let () - (struct s (a b)) - (contract (struct/dc s - [a () number?] - [b (a) #:chaperone boolean?]) - (s 1 #f) - 'pos - 'neg))) - - (test/spec-passed - 'struct/dc-2 - '(let () - (struct s (a b)) - (contract (struct/dc s - [a () number?] - [b (a) (>=/c a)]) - (s 1 2) - 'pos - 'neg))) - - (test/pos-blame - 'struct/dc-3 - '(let () - (struct s (a b)) - (contract (struct/dc s - [a () number?] - [b (a) (>=/c a)]) - (s 2 1) - 'pos - 'neg))) - - (test/spec-passed - 'struct/dc-3b - '(let () - (struct s (a b)) - (contract (struct/dc s - [a () number?] - [b (a) (<=/c a)]) - (s 2 1) - 'pos - 'neg))) - - (test/spec-passed - 'struct/dc-4 - '(let () - (struct s (a b)) - (contract (struct/dc s - [a number?] - [b (a) (>=/c a)]) - (s 1 2) - 'pos - 'neg))) - - - (test/pos-blame - 'struct/dc-5 - '(let () - (struct s (a b)) - (s-b (contract (struct/dc s - [a () number?] - [b (a) (>=/c a)]) - (s 2 1) - 'pos - 'neg)))) - - (test/spec-passed/result - 'struct/dc-6 - '(let () - (struct s (a b)) - (define-opt/c (f z) - (struct/dc s - [a (>=/c z)] - [b (a) #:lazy (f a)])) - - (s-a (contract (f 11) - (s 12 (s 13 #f)) - 'pos - 'neg))) - 12) - - (test/spec-passed/result - 'struct/dc-7 - '(let () - (struct s (a b)) - (define-opt/c (f z) - (struct/dc s - [a (>=/c z)] - [b (a) #:lazy (f a)])) - - (s-a (s-b (contract (f 11) - (s 12 (s 13 #f)) - 'pos - 'neg)))) - 13) - - - (test/pos-blame - 'struct/dc-8 - '(let () - (struct s (a b)) - (define-opt/c (f z) - (struct/dc s - [a (>=/c z)] - [b (a) #:lazy (f a)])) - (s-b (s-b (contract (f 11) - (s 12 (s 13 #f)) - 'pos - 'neg))))) - - - (test/spec-passed/result - 'struct/dc-9 - '(let () - (struct s (a b)) - - (define-opt/c (g z) - (struct/dc s - [a (>=/c z)] - [b (a) #:lazy (>=/c (+ a 1))])) - - (s-a (contract (g 10) - (s 12 (s 14 #f)) - 'pos - 'neg))) - 12) - - (test/spec-passed/result - 'struct/dc-10 - '(let () - (struct s (a b)) - - (define-opt/c (g z) - (struct/dc s - [a (>=/c z)] - [b (a) #:lazy (>=/c (+ a 1))])) - - (s-b (contract (g 10) - (s 12 14) - 'pos - 'neg))) - 14) - - (test/pos-blame - 'struct/dc-11 - '(let () - - (struct s (a b)) - - (define-opt/c (g z) - (struct/dc s - [a (>=/c z)] - [b (a) #:lazy (>=/c (+ a 1))])) - - (s-b (contract (g 11) - (s 12 10) - 'pos - 'neg)))) - - (test/spec-passed/result - 'struct/dc-12 - '(let () - (struct kons (hd tl) #:transparent) - (define (unknown-function a) (=/c a)) - (define-opt/c (f a b) - (or/c not - (struct/dc kons - [hd (unknown-function a)] - [tl () #:lazy (or/c #f (f b a))]))) - (kons-hd (kons-tl (contract (f 1 2) - (kons 1 (kons 2 #f)) - 'pos - 'neg)))) - 2) - - (test/spec-passed - 'struct/dc-13 - '(let () - (struct s (a)) - (contract (struct/dc s - [a #:lazy integer?]) - (s #f) - 'pos - 'neg))) - - (test/spec-passed - 'struct/dc-14 - '(let () - (struct s (a)) - (contract (struct/dc s - [a #:lazy (-> integer? integer?)]) - (s #f) - 'pos - 'neg))) - - (test/pos-blame - 'struct/dc-15 - '(let () - (struct s (a)) - (contract (struct/dc s - [a integer?]) - (s #f) - 'pos - 'neg))) - - (test/pos-blame - 'struct/dc-16 - '(let () - (struct s (a)) - (contract (struct/dc s - [a (-> integer? integer?)]) - (s #f) - 'pos - 'neg))) - - (test/spec-passed - 'struct/dc-17 - '(let () - (struct s (q a)) - (contract (struct/dc s - [q integer?] - [a (q) #:lazy (<=/c q)]) - (s 1 #f) - 'pos - 'neg))) - - (test/pos-blame - 'struct/dc-18 - '(let () - (struct s (q a)) - (contract (struct/dc s - [q integer?] - [a (q) (<=/c q)]) - (s 1 #f) - 'pos - 'neg))) - - (contract-error-test - 'struct/dc-19 - '(let () - (struct s (a b)) - (struct/dc s [a (new-∃/c 'α)] [b integer?])) - exn:fail?) - - (contract-error-test - 'struct/dc-20 - '(let () - (struct s (a b)) - (contract (struct/dc s [a (b) (new-∃/c 'α)] [b integer?]) - (s 1 2) - 'pos 'neg)) - exn:fail?) - - (test/pos-blame - 'struct/dc-new1 - '(let () - (struct s (a)) - (contract (struct/dc s [a integer?]) (s #f) 'pos 'neg))) - - (test/spec-passed - 'struct/dc-new2 - '(let () - (struct s (a)) - (contract (struct/dc s [a #:lazy integer?]) (s #f) 'pos 'neg))) - - (test/pos-blame - 'struct/dc-new3 - '(let () - (struct s (a)) - (s-a (contract (struct/dc s [a #:lazy integer?]) (s #f) 'pos 'neg)))) - - (test/spec-passed - 'struct/dc-new4 - '(let () - (struct s ([a #:mutable])) - (contract (struct/dc s [a integer?]) (s #f) 'pos 'neg))) - - (test/pos-blame - 'struct/dc-new5 - '(let () - (struct s ([a #:mutable])) - (s-a (contract (struct/dc s [a integer?]) (s #f) 'pos 'neg)))) - - (test/neg-blame - 'struct/dc-new6 - '(let () - (struct s ([a #:mutable])) - (set-s-a! (contract (struct/dc s [a integer?]) (s 1) 'pos 'neg) - #f))) - - (test/spec-passed - 'struct/dc-new7 - '(let () - (struct s (a b c)) - (s-c (contract (struct/dc s [a any/c] [b (a) (non-empty-listof real?)] [c (b) (<=/c (car b))]) - (s 3 '(2) 1) - 'pos - 'neg)))) - - - (test/spec-passed - 'struct/dc-new8 - '(let () - (struct s (a b c)) - (s-c (contract (struct/dc s - [a any/c] - [b (a) (non-empty-listof real?)] - [c (a b) (and/c (<=/c a) (<=/c (car b)))]) - (s 3 '(2) 1) - 'pos - 'neg)))) - - (test/spec-passed - 'struct/dc-new9 - '(let () - (struct s (a b c)) - (s-c (contract (struct/dc s - [a any/c] - [b (a) (non-empty-listof real?)] - [c (b a) (and/c (<=/c a) (<=/c (car b)))]) - (s 3 '(2) 1) - 'pos - 'neg)))) - - - (test/spec-passed - 'struct/dc-new10 - '(let () - (struct s (a b c)) - (s-c (contract (struct/dc s - [a (b) (<=/c (car b))] - [b (c) (non-empty-listof real?)] - [c real?]) - (s 1 '(2) 3) - 'pos - 'neg)))) - - (test/spec-passed - 'struct/dc-new11 - '(let () - (struct s (a b c)) - (s-c (contract (struct/dc s - [a (b c) (and/c (<=/c (car b)) (<=/c c))] - [b (c) (non-empty-listof real?)] - [c real?]) - (s 1 '(2) 3) - 'pos - 'neg)))) - - (test/spec-passed - 'struct/dc-new12 - '(let () - (struct s (a b c)) - (s-c (contract (struct/dc s - [a (c b) (and/c (<=/c (car b)) (<=/c c))] - [b (c) (non-empty-listof real?)] - [c real?]) - (s 1 '(2) 3) - 'pos - 'neg)))) - - - (test/pos-blame - 'struct/dc-new13 - '(let () - (struct s (f b)) - (contract (struct/dc s [f (-> integer? integer?)] [b (f) (<=/c (f 1))]) - (s (λ (x) #f) 123) - 'pos - 'neg))) - - (test/spec-failed - 'struct/dc-new14 - '(let () - (struct s (f b)) - (contract (struct/dc s [f (-> integer? integer?)] [b (f) (<=/c (f #f))]) - (s (λ (x) 1) 123) - 'pos - 'neg)) - "top-level") - - (test/pos-blame - 'struct/dc-new15 - '(let () - (struct s (f b)) - (contract (struct/dc s [f (-> integer? integer?)] [b (f) #:lazy (<=/c (f 1))]) - (s (λ (x) #f) 123) - 'pos - 'neg))) - - (test/spec-failed - 'struct/dc-new16 - '(let () - (struct s (f b)) - (contract (struct/dc s [f (-> integer? integer?)] [b (f) #:lazy (<=/c (f #f))]) - (s (λ (x) 1) 123) - 'pos - 'neg)) - "top-level") - - (test/pos-blame - 'struct/dc-new17 - '(let () - (struct s (f b)) - (contract (struct/dc s [f #:lazy (-> integer? integer?)] [b (f) #:lazy (<=/c (f 1))]) - (s (λ (x) #f) 123) - 'pos - 'neg))) - - (test/spec-failed - 'struct/dc-new18 - '(let () - (struct s (f b)) - (contract (struct/dc s [f #:lazy (-> integer? integer?)] [b (f) #:lazy (<=/c (f #f))]) - (s (λ (x) 1) 123) - 'pos - 'neg)) - "top-level") - - (test/spec-passed - 'struct/dc-new19 - '(let () - (struct s (a b c d)) - (contract (struct/dc s - [a integer?] - [b #:lazy symbol?] - [c (a) boolean?] - [d (a c) integer?]) - (s 1 'x #t 5) - 'pos 'neg))) - - (test/spec-passed - 'struct/dc-new20 - '(let () - (struct s (a [b #:mutable] c [d #:mutable])) - (contract (struct/dc s - [a integer?] - [b symbol?] - [c (a) boolean?] - [d (a c) integer?]) - (s 1 'x #t 5) - 'pos 'neg))) - - (test/spec-passed - 'struct/dc-new21 - '(let () - (struct s ([a #:mutable] b)) - (define an-s (contract (struct/dc s [a integer?] [b boolean?]) - (s 1 #f) - 'pos 'neg)) - (set-s-a! an-s 2))) - - (test/neg-blame - 'struct/dc-new22 - '(let () - (struct s ([a #:mutable] b)) - (define an-s (contract (struct/dc s [a integer?] [b boolean?]) - (s 1 #f) - 'pos 'neg)) - (set-s-a! an-s #f))) - - (test/spec-passed - 'struct/dc-new22 - '(let () - (struct s ([a #:mutable] b)) - (contract (struct/dc s [a integer?] [b boolean?]) - (s 'one #f) - 'pos 'neg))) - - (test/pos-blame - 'struct/dc-new23 - '(let () - (struct s ([a #:mutable] b)) - (s-a (contract (struct/dc s [a integer?] [b boolean?]) - (s 'one #f) - 'pos 'neg)))) - - (test/pos-blame - 'struct/dc-new24 - '(let () - (struct s ([a #:mutable] b)) - (define an-s (contract (struct/dc s [a (-> integer? integer?)] [b boolean?]) - (s (λ (x) #f) #f) - 'pos 'neg)) - ((s-a an-s) 1))) - - (test/neg-blame - 'struct/dc-new25 - '(let () - (struct s ([a #:mutable] b)) - (define an-s (contract (struct/dc s [a (-> integer? integer?)] [b boolean?]) - (s (λ (x) #f) #f) - 'pos 'neg)) - (set-s-a! an-s (λ (x) #f)) - ((s-a an-s) 1))) - - (test/pos-blame - 'struct/dc-new26 - '(let () - (struct s ([a #:mutable] b)) - (contract (struct/dc s [a (-> integer? integer?)] [b (a) (<=/c (a 1))]) - (s (λ (x) #f) #f) - 'pos 'neg))) - - (test/pos-blame - 'struct/dc-new27 - '(let () - (struct s ([a #:mutable] b)) - (define an-s (contract (struct/dc s [a (-> integer? integer?)] [b (a) (<=/c (a 1))]) - (s (λ (x) 1) 1) - 'pos 'neg)) - (set-s-a! an-s (λ (x) -2)) - (s-b an-s))) - - (test/neg-blame - 'struct/dc-new28 - '(let () - (struct s ([a #:mutable] b)) - (define an-s (contract (struct/dc s [a (-> integer? integer?)] [b (a) (<=/c (a 1))]) - (s (λ (x) 1) 1) - 'pos 'neg)) - (set-s-a! an-s (λ (x) #f)) - (s-b an-s))) - - (test/pos-blame - 'struct/dc-new29 - '(let () - (struct s ([a #:mutable] b c)) - (define an-s (contract (struct/dc s - [a (-> integer? integer?)] - [b (a) (<=/c (a 1))] - [c (b) (<=/c b)]) - (s (λ (x) 1) -11 1) - 'pos 'neg)) - (set-s-a! an-s (λ (x) -2)) - (s-c an-s))) - - (test/pos-blame - 'struct/dc-new30 - '(let () - (struct s ([a #:mutable] b c)) - (define an-s (contract (struct/dc s - [a (-> integer? integer?)] - [b (a) (<=/c (a 1))] - [c (b) (<=/c b)]) - (s (λ (x) 1) 1 -2) - 'pos 'neg)) - (set-s-a! an-s (λ (x) -2)) - (s-c an-s))) - - (test/neg-blame - 'struct/dc-new31 - '(let () - (struct s ([a #:mutable] [b #:mutable])) - (define an-s (contract (struct/dc s - [a (-> integer? integer?)] - [b (a) (<=/c (a 1))]) - (s (λ (x) 1) 1) - 'pos 'neg)) - (set-s-b! an-s 3))) - - (test/pos-blame - 'struct/dc-new32 - '(let () - (struct s ([a #:mutable] [b #:mutable])) - (define an-s (contract (struct/dc s - [a (-> integer? integer?)] - [b (a) (<=/c (a 1))]) - (s (λ (x) 1) 1) - 'pos 'neg)) - (set-s-a! an-s (λ (x) -1)) - (s-b an-s))) - - (test/spec-failed - 'struct/dc-new33 - '(let () - (struct s (a [b #:mutable] [c #:mutable])) - (define an-s (contract (struct/dc s - [a (-> integer? integer?)] - [b any/c] - [c (a b) (<=/c (a b))]) - (s (λ (x) 1) 1 1) - 'pos 'neg)) - (set-s-b! an-s #f) - (s-c an-s)) - "top-level") - - (contract-error-test - 'struct/dc-new-34 - '(let () - (struct s ([a #:mutable] [b #:mutable])) - (contract (struct/dc s - [a boolean?] - [b (a) - #:flat - (if a - (<=/c 1) - (-> integer? integer?))]) - (s #f 1) - 'pos - 'neg)) - (λ (x) (regexp-match #rx"struct/dc: .*flat" (exn-message x)))) - - (contract-error-test - 'struct/dc-new-35 - '(let () - (struct s ([a #:mutable] [b #:mutable])) - (define an-s (contract (struct/dc s - [a boolean?] - [b (a) - #:flat - (if a - (<=/c 1) - (-> integer? integer?))]) - (s #t 1) - 'pos - 'neg)) - (set-s-a! an-s #f) - (s-b an-s)) - (λ (x) (regexp-match #rx"struct/dc: .*flat" (exn-message x)))) - - (contract-error-test - 'struct/dc-new-36 - '(let () - (struct s ([a #:mutable] b)) - (contract (struct/dc s - [a boolean?] - [b (a) - (if a - (<=/c 1) - (new-∃/c 'α))]) - (s #f 1) - 'pos - 'neg)) - (λ (x) (regexp-match #rx"struct/dc: .*chaperone" (exn-message x)))) - - (contract-error-test - 'struct/dc-new-37 - '(let () - (struct s ([a #:mutable] b)) - (define an-s (contract (struct/dc s - [a boolean?] - [b (a) - (if a - (<=/c 1) - (new-∃/c 'α))]) - (s #t 1) - 'pos - 'neg)) - (set-s-a! an-s #f) - (s-b an-s)) - (λ (x) (regexp-match #rx"struct/dc: .*chaperone" (exn-message x)))) - - (contract-error-test - 'struct/dc-new-38 - '(let () - (struct s ([a #:mutable] b [c #:mutable])) - (define an-s (contract (struct/dc s - [a boolean?] - [b (a) - (if a - (<=/c 1) - (new-∃/c 'α))] - [c (b) integer?]) - (s #t 1 1) - 'pos - 'neg)) - (set-s-a! an-s #f) - (s-c an-s)) - (λ (x) (regexp-match #rx"struct/dc: .*chaperone" (exn-message x)))) - - (test/spec-passed - 'struct/dc-new-39 - '(let () - (struct s (a b)) - (contract (struct/dc s [a integer?] [b integer?]) (s 1 2) 'pos 'neg))) - - (test/spec-passed - 'struct/dc-new40 - '(let () - (struct s (a b)) - (contract (struct/dc s [a (-> integer? integer?)] [b (-> integer? integer?)]) - (s (λ (x) x) (λ (y) y)) - 'pos - 'neg))) - - (test/spec-passed/result - 'struct/dc-new41 - '(let () - (struct s (a [b #:mutable])) - (define α (new-∀/c 'α)) - (s-b ((contract (-> α (struct/dc s [b α])) - (λ (x) (s 11 x)) - 'pos - 'neg) 1))) - 1) - - (test/spec-passed/result - 'struct/dc-new42 - '(let () - (struct s (a [b #:mutable])) - (define α (new-∀/c 'α)) - (s-b ((contract (-> α (struct/dc s [a integer?] [b (a) #:impersonator α])) - (λ (x) (s 11 x)) - 'pos - 'neg) 1))) - 1) - - (test/spec-passed - 'struct/dc-new42 - '(let () - (struct s (a [b #:mutable])) - (contract (struct/dc s [a (-> integer? integer?)] [b (new-∀/c 'α)]) - (s (λ (x) x) 1) - 'pos - 'neg))) - - (test/spec-passed/result - 'struct/dc-new43 - '(let () - (struct a (x)) - (struct b a (y)) - (struct c b (z)) - (struct d c (w)) - - (b-y (contract (struct/dc d - [(x #:parent a) boolean?] - [(y #:parent b) char?] - [(z #:parent c) number?] - [w string?]) - (d #t #\a 3 "x") - 'pos - 'neg))) - #\a) - - (test/spec-passed/result - 'struct/dc-new44 - '(let () - (struct a (x)) - (struct b a (y)) - (struct c b (z)) - (struct d c (w)) - - (b-y (contract (struct/dc d - [(x #:parent a) (w) boolean?] - [(y #:parent b) ((x #:parent a)) char?] - [(z #:parent c) number?] - [w string?]) - (d #t #\a 3 "x") - 'pos - 'neg))) - #\a) - - (test/spec-passed/result - 'struct/dc-pred1 - '(let () - (struct s (a b)) - (define p? (flat-contract-predicate (struct/dc s [a number?] [b (a) #:flat (<=/c a)]))) - (list (p? (s 2 1)) - (p? (s 1 2)))) - '(#t #f)) - - (test/spec-passed/result - 'struct/dc-pred2 - '(let () - (struct s (a b c)) - (define p? (flat-contract-predicate (struct/dc s - [a number?] - [b boolean?] - [c (a b) - #:flat - (if (and (= a 1) b) - any/c - none/c)]))) - - (list (p? (s 1 #t 'whatever)) - (p? (s 11 #f 'whatver)))) - '(#t #f)) - - - - (contract-error-test - 'struct/dc-imp-nondep-runtime-error - #'(let () - (struct s (ernie bert)) - (struct/dc s [ernie integer?] [bert (new-∀/c 'α)])) - (λ (x) - (and (exn:fail? x) - (regexp-match #rx"chaperone-contract[?]" (exn-message x))))) - - (contract-error-test - 'struct/dc-not-a-field - #'(eval '(let () - (struct s (a b)) - (struct/dc s [a integer?] [y integer?]))) - exn:fail:syntax?) - - (contract-error-test - 'struct/dc-circular-dependecies1 - #'(eval '(let () - (struct s (a b)) - (struct/dc s [a (a) integer?] [b (a) integer?]))) - exn:fail:syntax?) - - (contract-error-test - 'struct/dc-circular-dependecies2 - #'(eval '(let () - (struct s (a b c)) - (struct/dc s [a (b) integer?] [b (a) integer?] [c integer?]))) - exn:fail:syntax?) - - (contract-error-test - 'struct/dc-dep-on-lazy - #'(eval '(let () - (struct s (a b)) - (struct/dc s [a #:lazy integer?] [b (a) integer?]))) - exn:fail:syntax?) - - (contract-error-test - 'struct/dc-lazy-mutable - #'(eval '(let () - (struct s (a [b #:mutable])) - (struct/dc s [a integer?] [b #:lazy integer?]))) - exn:fail:syntax?) - - (contract-error-test - 'struct/dc-immutable-impersonator - #'(eval '(let () - (struct s (a b)) - (struct/dc s [a integer?] [b (a) #:impersonator (<=/c a)]))) - (λ (x) (and (exn:fail:syntax? x) (regexp-match #rx"immutable" (exn-message x))))) - - -; -; -; -; ;; -; ;; -; ;;; ;;; ;;; ;;;;; ;;;; ;;;; ;;; ;;; ;;;;; ;;; ;;; ;;; -; ;;;;;;; ;;;;; ;;;;;; ;;;; ;;;; ;;;;;;; ;;;;;; ;;;; ;;; ;;; ;;;;; -; ;;;; ;; ;;;; ;; ;;;;;;; ;;;; ;;;; ;;;; ;; ;;;; ;;;; ;;;;;; ;;;; ;; -; ;;;; ;;;;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;; ;;;;;;; ;;;;; -; ;;;; ;;;;; ;;;;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;; ;;;;; ;;;;; -; ;;;; ;;;;;; ;;;;;; ;;;;;;;;; ;;;; ;;;;;; ;;;; ;;;; ;;;;;; -; ;;;; ;;;; ;;;;; ;;; ;;;; ;;;; ;;;;; ;;;; ;;;; ;;;; -; -; -; -; -; -; -; ; ; -; ;; ;; -; ;;;;; ;;;; ;;;; ;;; ;;;;; ;;; ;;; ;;;;;;; ;;;;; ;;;;; -; ;;;;;; ;;;;;; ;;;;;;;;; ;;;;;; ;;;;;;; ;;;;;;;; ;;;;;; ;;;;;; -; ;;;;;;; ;;;;;;;; ;;;; ;;;; ;;;; ;;;; ;; ;;;; ;;;;;;; ;;;; -; ;;;; ;;;; ;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;; -; ;;;;;;; ;;;;;;;; ;;;; ;;;; ;;;;; ;;;; ;; ;;;; ;;;;;;; ;;;;; -; ;;;;;; ;;;;;; ;;;; ;;;; ;;;;; ;;;; ;;;;;;;; ;;;;;; ;;;;; -; ;;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;; ;;;; ;;;;; ;;;; -; -; -; - - - (test/spec-passed - 'recursive-contract1 - '(letrec ([ctc (-> integer? (recursive-contract ctc))]) - (letrec ([f (λ (x) f)]) - ((((contract ctc f 'pos 'neg) 1) 2) 3)))) - - (test/neg-blame - 'recursive-contract2 - '(letrec ([ctc (-> integer? (recursive-contract ctc))]) - (letrec ([f (λ (x) f)]) - ((contract ctc f 'pos 'neg) #f)))) - - (test/neg-blame - 'recursive-contract3 - '(letrec ([ctc (-> integer? (recursive-contract ctc))]) - (letrec ([f (λ (x) f)]) - ((((contract ctc f 'pos 'neg) 1) 2) #f)))) - - (test/pos-blame - 'recursive-contract4 - '(letrec ([ctc (-> integer? (recursive-contract ctc))]) - (letrec ([c 0] - [f (λ (x) - (set! c (+ c 1)) - (if (= c 2) - 'nope - f))]) - ((((contract ctc f 'pos 'neg) 1) 2) 3)))) - - (test/spec-passed - 'recursive-contract5 - '(contract (recursive-contract #f) - #f - 'pos - 'neg)) - - (test/spec-passed - 'recursive-contract6 - '(letrec ([ctc (or/c number? (cons/c number? (recursive-contract ctc #:flat)))]) - (contract ctc (cons 1 (cons 2 3)) 'pos 'neg))) - - (test/pos-blame - 'recursive-contract7 - '(letrec ([ctc (or/c number? (cons/c number? (recursive-contract ctc #:flat)))]) - (contract ctc (cons 1 (cons 2 #t)) 'pos 'neg))) - - (test/pos-blame - 'recursive-contract8 - '(letrec ([ctc (or/c number? (cons/c number? (recursive-contract ctc #:flat)))]) - (contract ctc (cons 1 (cons #t 3)) 'pos 'neg))) - - (test/spec-passed - 'recursive-contract9 - '(letrec ([ctc (or/c number? (hash/c (recursive-contract ctc #:chaperone) number?))]) - (make-hash (list (cons (make-hash (list (cons 3 4))) 5))))) - - (test/pos-blame - 'recursive-contract10 - '(let () - (struct doll (contents)) - (letrec ([doll-ctc (recursive-contract (or/c 'center (struct/c doll doll-ctc)) #:flat)]) - (contract doll-ctc (doll 3) 'pos 'neg)))) - - (test/pos-blame - 'recursive-contract11 - '(let () - (struct doll (contents)) - (letrec ([doll-ctc2 (or/c 'center (struct/c doll (recursive-contract doll-ctc2 #:flat)))]) - (contract doll-ctc2 (doll 4) 'pos 'neg)))) - - - -; -; -; -; ;;;; ;;; ;; -; ;;;; ;;;; ;; -; ;;;;;;; ;;; ;;;;; ;;;; ;;; ;;; -; ;;;;;;;; ;;;;; ;;;; ;;;; ;;;;;;;;; ;;;;; -; ;;;;;;;;; ;;;; ;; ;;;;;; ;;;; ;;;; ;;;; ;;;; ;; -; ;;;; ;;;; ;;;;;;; ;;;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;;; -; ;;;;;;;;; ;;;;; ;;;; ;;;; ;;;; ;;;; ;;;;; ;;;;; -; ;;;;;;;; ;;;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;; -; ;;;;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; -; -; -; -; -; -; -; ; ; -; ;; ;; -; ;;;;; ;;;; ;;;; ;;; ;;;;; ;;; ;;; ;;;;;;; ;;;;; ;;;;; -; ;;;;;; ;;;;;; ;;;;;;;;; ;;;;;; ;;;;;;; ;;;;;;;; ;;;;;; ;;;;;; -; ;;;;;;; ;;;;;;;; ;;;; ;;;; ;;;; ;;;; ;; ;;;; ;;;;;;; ;;;; -; ;;;; ;;;; ;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;; ;;;;; -; ;;;;;;; ;;;;;;;; ;;;; ;;;; ;;;;; ;;;; ;; ;;;; ;;;;;;; ;;;;; ;;;;; -; ;;;;;; ;;;;;; ;;;; ;;;; ;;;;; ;;;; ;;;;;;;; ;;;;;; ;;;;; -; ;;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;; ;;;; ;;;;; ;;;; -; -; -; -; -; -; -; ; ; -; ;; ;; -; ;;;;; ;;;;; ;;; ;;; ;;;; ;;;; ;;;;; ;;;;; -; ;;;;;; ;;;;;; ;;;;;;; ;;;; ;;;; ;;;;;; ;;;;;; -; ;;;; ;;;; ;;;; ;; ;;;; ;;;; ;;;;;;; ;;;; -; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; -; ;;;; ;;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;;; -; ;;;;;; ;;;;; ;;;; ;;;;;;;;; ;;;;;; ;;;;; -; ;;;;; ;;;; ;;;; ;;; ;;;; ;;;;; ;;;; -; -; -; - - - (contract-eval '(define-contract-struct couple (hd tl))) - (contract-eval '(contract-struct triple (a b c))) - - (test/spec-passed - 'd-c-s-match1 - '(begin - (eval '(module d-c-s-match1 scheme/base - (require scheme/contract - mzlib/match) - - (define-contract-struct foo (bar baz)) - - (match (make-foo #t #f) - [($ foo bar baz) #t] - [_ #f]))) - (eval '(require 'd-c-s-match1)))) - - (test/spec-passed/result - 'd-c-s-match2 - '(begin - (eval '(module d-c-s-match2 scheme/base - (require scheme/contract - mzlib/match) - - (define-contract-struct foo (bar baz)) - - (provide d-c-s-match2-f1) - (define d-c-s-match2-f1 - (match (make-foo 'first 'second) - [($ foo bar baz) (list bar baz)] - [_ #f])))) - (eval '(require 'd-c-s-match2)) - (eval 'd-c-s-match2-f1)) - '(first second)) - - (test/spec-passed/result - 'd-c-s-match3 - '(begin - (eval '(module d-c-s-match3-a scheme/base - - (require scheme/contract) - - (define-struct super (a b c) #:transparent) - (define-struct (sub super) () #:transparent) - - (provide/contract - [struct super ([a number?] [b number?] [c number?])] - [struct (sub super) ([a number?] [b number?] [c number?])]))) - (eval '(module d-c-s-match3-b scheme/base - (require scheme/match) - - (require 'd-c-s-match3-a) - - (provide d-c-s-match3-ans) - (define d-c-s-match3-ans - (match (make-sub 1 2 3) - [(struct sub (a b c)) - (list a b c)])))) - (eval '(require 'd-c-s-match3-b)) - (eval 'd-c-s-match3-ans)) - '(1 2 3)) - - (test/pos-blame 'd-c-s1 - '(begin - (eval '(module d-c-s1 scheme/base - (require scheme/contract) - (define-contract-struct couple (hd tl)) - (contract (couple/c any/c any/c) 1 'pos 'neg))) - (eval '(require 'd-c-s1)))) - - (test/spec-passed 'd-c-s2 - '(contract (couple/c any/c any/c) (make-couple 1 2) 'pos 'neg)) - (test/spec-passed 'd-c-s3 - '(contract (couple/c number? number?) - (make-couple 1 2) - 'pos 'neg)) - (test/spec-passed 'd-c-s4 - '(couple-hd - (contract (couple/c number? number?) - (make-couple 1 2) - 'pos 'neg))) - (test/spec-passed 'd-c-s5 - '(couple-tl - (contract (couple/c number? number?) - (make-couple 1 2) - 'pos 'neg))) - - - (test/pos-blame - 'd-c-s6 - '(couple-tl - (contract (couple/c number? - number?) - (make-couple #f 2) - 'pos 'neg))) - (test/pos-blame - 'd-c-s7 - '(couple-hd - (contract (couple/c number? number?) - (make-couple #f 2) - 'pos 'neg))) - - (test/pos-blame - 'd-c-s8 - '(contract (couple/dc [hd any/c] [tl any/c]) - 1 - 'pos 'neg)) - - (test/pos-blame - 'd-c-s9 - '(contract (couple/dc [hd () any/c] [tl () any/c]) - 1 - 'pos 'neg)) - - - (test/spec-passed 'd-c-s10 - '(contract (couple/dc [hd any/c] [tl any/c]) - (make-couple 1 2) - 'pos 'neg)) - (test/spec-passed 'd-c-s11 - '(contract (couple/dc [hd () any/c] [tl () any/c]) - (make-couple 1 2) - 'pos 'neg)) - - (test/spec-passed 'd-c-s12 - '(contract (couple/dc [hd number?] - [tl number?]) - (make-couple 1 2) - 'pos 'neg)) - (test/spec-passed 'd-c-s13 - '(couple-hd - (contract (couple/dc [hd number?] - [tl number?]) - (make-couple 1 2) - 'pos 'neg))) - (test/spec-passed 'd-c-s14 - '(couple-tl - (contract (couple/dc [hd number?] - [tl number?]) - (make-couple 1 2) - 'pos 'neg))) - - - (test/pos-blame - 'd-c-s15 - '(couple-hd - (contract (couple/dc [hd number?] - [tl number?]) - (make-couple #f 2) - 'pos 'neg))) - - (test/pos-blame - 'd-c-s16 - '(couple-tl - (contract (couple/dc [hd number?] - [tl number?]) - (make-couple #f 2) - 'pos 'neg))) - - (test/spec-passed - 'd-c-s17 - '(couple-hd - (contract (couple/dc [hd number?] - [tl (hd) (>=/c hd)]) - (make-couple 1 2) - 'pos 'neg))) - - (test/pos-blame - 'd-c-s18 - '(couple-hd - (contract (couple/dc [hd number?] - [tl (hd) (>=/c hd)]) - (make-couple 2 1) - 'pos 'neg))) - - (test/spec-passed - 'd-c-s19 - '(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 - '(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 - '(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 - '(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 - '(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 - '(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 - '(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 - '(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 ([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 - '(contract (couple/c number? number?) - (make-couple #f #f) - 'pos 'neg)) - - (test/spec-passed - 'd-c-s29 - '(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 - '(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 ([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 ([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 ([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 ([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 ([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 ([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 - '(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 ([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 ([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 ([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 ([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 ([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 ([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))) - - (contract-eval '(contract-struct no-define (x))) - (test/spec-passed/result - 'd-c-s43 - '(no-define-x (no-define 1)) - '1) - (test/spec-passed/result - 'd-c-s44 - '(no-define? (no-define 1)) - '#t) - - - -; -; -; -; ;;;; ;;; ;; ; ;; -; ;;;; ;;;; ;; ;; ;; -; ;;;;;;; ;;; ;;;;; ;;;; ;;; ;;; ;;;; ;;;;;;; ;;;;; ;; ;;;;; -; ;;;;;;;; ;;;;; ;;;; ;;;; ;;;;;;;;; ;;;;; ;;;;;; ;;;;;;;; ;;;;;; ;; ;;;;;; -; ;;;;;;;;; ;;;; ;; ;;;;;; ;;;; ;;;; ;;;; ;;;; ;; ;;;;;;;; ;;;;;;;;; ;;;; ;;;;;;;;; -; ;;;; ;;;; ;;;;;;; ;;;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;;;;;;; ;;; ;;;; ;;;; ;;;; ;; ;;;; -; ;;;;;;;;; ;;;;; ;;;; ;;;; ;;;; ;;;; ;;;;; ;;;;;;;;;;;;; ;;;;;;;;; ;;;;; ;; ;;;;;;; -; ;;;;;;;; ;;;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;; ;;;;;; ;;;;;;;; ;;;;; ;; ;;;;;; -; ;;;;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;; ;;;;; -; ;;;; ;; -; ;;;; -; - - - (contract-eval '(define-contract-struct node (val obj rank left right) (make-inspector))) - (contract-eval '(define (compute-rank n) - (cond - [(not n) 0] - [else (node-rank n)]))) - - (contract-eval '(define-opt/c (leftist-heap-greater-than/rank/opt n r) - (or/c not - (node/dc [val (>=/c n)] - [obj any/c] - [rank (<=/c r)] - [left (val) (leftist-heap-greater-than/rank/opt val +inf.0)] - [right (val left) - (leftist-heap-greater-than/rank/opt - val - (compute-rank left))])))) - - (contract-eval '(define leftist-heap/c (leftist-heap-greater-than/rank/opt -inf.0 +inf.0))) - - (test/pos-blame 'd-o/c1 '(contract leftist-heap/c 2 'pos 'neg)) - - - (test/spec-passed 'd-o/c2 '(contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)) - (test/spec-passed 'd-o/c3 '(contract leftist-heap/c #f 'pos 'neg)) - (test/spec-passed 'd-o/c4 '(contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)) - (test/spec-passed/result 'd-o/c5 - '(node? (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)) - #t) - - (test/spec-passed/result 'd-o/c6 - '(node-val (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)) - 1) - (test/spec-passed/result 'd-o/c7 - '(node-obj (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)) - 2) - (test/spec-passed/result 'd-o/c8 - '(node-rank (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)) - 3) - (test/spec-passed/result 'd-o/c9 - '(node-left (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)) - #f) - (test/spec-passed/result 'd-o/c10 - '(node-right (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)) - #f) - - (test/spec-passed/result 'd-o/c11 - '(node-val (contract leftist-heap/c - (contract leftist-heap/c - (make-node 1 2 3 #f #f) - 'pos 'neg) - 'pos 'neg)) - 1) - (test/spec-passed/result 'd-o/c12 - '(node-obj (contract leftist-heap/c - (contract leftist-heap/c - (make-node 1 2 3 #f #f) - 'pos 'neg) - 'pos 'neg)) - 2) - (test/spec-passed/result 'd-o/c13 - '(node-rank (contract leftist-heap/c - (contract leftist-heap/c - (make-node 1 2 3 #f #f) - 'pos 'neg) - 'pos 'neg)) - 3) - (test/spec-passed/result 'd-o/c14 - '(node-left (contract leftist-heap/c - (contract leftist-heap/c - (make-node 1 2 3 #f #f) - 'pos 'neg) - 'pos 'neg)) - #f) - (test/spec-passed/result 'd-o/c15 - '(node-right (contract leftist-heap/c - (contract leftist-heap/c - (make-node 1 2 3 #f #f) - 'pos 'neg) - 'pos 'neg)) - #f) - - (test/spec-passed/result 'd-o/c16 - '(let ([h (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)]) - (node-val h) - (node-val h)) - 1) - (test/spec-passed/result 'd-o/c17 - '(let ([h (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)]) - (node-obj h) - (node-obj h)) - 2) - - (test/spec-passed/result 'd-o/c18 - '(let ([h (contract leftist-heap/c (make-node 1 2 3 #f #f)'pos 'neg)]) - (node-rank h) - (node-rank h)) - 3) - (test/spec-passed/result 'd-o/c19 - '(let ([h (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)]) - (node-left h) - (node-left h)) - #f) - (test/spec-passed/result 'd-o/c20 - '(let ([h (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)]) - (node-right h) - (node-right h)) - #f) - - (test/spec-passed/result 'd-o/c21 - '(node-val - (node-right - (contract leftist-heap/c - (make-node 1 2 3 - (make-node 7 8 9 #f #f) - (make-node 4 5 6 #f #f)) - 'pos 'neg))) - 4) - (test/spec-passed/result 'd-o/c22 - '(node-val - (node-left - (contract leftist-heap/c - (make-node 1 2 3 - (make-node 7 8 9 #f #f) - (make-node 4 5 6 #f #f)) - 'pos 'neg))) - 7) - - (test/pos-blame 'd-o/c23 - '(node-val - (node-right - (contract leftist-heap/c - (make-node 5 2 3 - (make-node 7 8 9 #f #f) - (make-node 4 5 6 #f #f)) - 'pos 'neg)))) - - (test/pos-blame 'd-o/c24 - '(node-val - (node-left - (contract leftist-heap/c - (make-node 9 2 3 - (make-node 7 8 9 #f #f) - (make-node 11 5 6 #f #f)) - 'pos 'neg)))) - - (test/neg-blame 'd-o/c25 - '((contract (-> leftist-heap/c any) - (λ (kh) - (node-val - (node-left - kh))) - 'pos 'neg) - (make-node 9 2 3 - (make-node 7 8 9 #f #f) - (make-node 11 5 6 #f #f)))) - - - - (test/spec-passed/result - 'd-o/c26 - '(let ([ai (λ (x) (contract leftist-heap/c x 'pos 'neg))]) - (define (remove-min t) (merge (node-left t) (node-right t))) - - (define (merge t1 t2) - (cond - [(not t1) t2] - [(not t2) t1] - [else - (let ([t1-val (node-val t1)] - [t2-val (node-val t2)]) - (cond - [(<= t1-val t2-val) - (pick t1-val - (node-obj t1) - (node-left t1) - (merge (node-right t1) - t2))] - [else - (pick t2-val - (node-obj t2) - (node-left t2) - (merge t1 - (node-right t2)))]))])) - - (define (pick x obj a b) - (let ([ra (compute-rank a)] - [rb (compute-rank b)]) - (cond - [(>= ra rb) - (make-node x obj (+ rb 1) a b)] - [else - (make-node x obj (+ ra 1) b a)]))) - (node-val - (remove-min (ai (make-node 137 'x 1 - (ai (make-node 178 'y 1 - (make-node 178 'z 1 #f #f) - #f)) - #f))))) - 178) - - (test/spec-passed/result - 'd-o/c27 - '(let () - (define-opt/c (f x) - (and/c (>=/c x) - (g x))) - (define-opt/c (g x) - (<=/c x)) - (contract (f 11) 11 'pos 'neg)) - 11) - - ;; try-one : syntax -> number - ;; evaluates the exp and returns the number of opt/c warnings found - (contract-eval - '(define (eval-and-count-log-messages exp) - (define ans (make-channel)) - (define recv (make-log-receiver (current-logger) 'warning)) - (thread - (λ () - (let loop ([opt/c-msgs 0]) - (define res (sync recv)) - (cond - [(equal? "done" (vector-ref res 1)) - (channel-put ans opt/c-msgs)] - [else - (define opt/c-msg? (regexp-match? #rx"opt/c" (vector-ref res 1))) - (loop (if opt/c-msg? - (+ opt/c-msgs 1) - opt/c-msgs))])))) - (let/ec k - (parameterize ([error-escape-handler k]) - (eval exp))) - (log-warning "done") - (channel-get ans))) - - (ctest 1 eval-and-count-log-messages - '(let () - (struct s (a b)) - (opt/c (struct/dc s [a (-> integer? integer?)] [b (a) integer?])))) - - (ctest 1 eval-and-count-log-messages - '(let () - (struct s (a b)) - (define-opt/c (f x) - (-> integer? integer?)) - (define-opt/c (g x) - (struct/dc s [a (f 1)] [b (a) integer?])) - 1)) - - (ctest 0 eval-and-count-log-messages - '(let () - (struct s (a b)) - (define-opt/c (f x) integer?) - (opt/c (struct/dc s [a (f 1)] [b (a) integer?])))) - - (ctest 0 eval-and-count-log-messages - '(let () - (define-struct h:kons (hd tl) #:transparent) - (define-struct h:node (rank val obj children) #:transparent) - - (define-opt/c (binomial-tree-rank=/sco r v) - (or/c #f - (struct/dc h:node - [rank (=/c r)] - [val (>=/c v)] - [children (rank val) #:lazy (heap-ordered/desc/sco (- rank 1) val)]))) - - (define-opt/c (binomial-tree-rank>/sco r) - (or/c #f - (struct/dc h:node - [rank (>=/c r)] - [val any/c] - [children (rank val) #:lazy (heap-ordered/desc/sco (- rank 1) val)]))) - - (define-opt/c (heap-ordered/desc/sco rank val) - (or/c #f - (struct/dc h:kons - [hd #:lazy (binomial-tree-rank=/sco rank val)] - [tl () #:lazy (heap-ordered/desc/sco (- rank 1) val)]))) - - (define-opt/c (binomial-trees/asc/sco rank) - (or/c #f - (struct/dc h:kons - [hd #:lazy (binomial-tree-rank>/sco rank)] - [tl (hd) #:lazy (binomial-trees/asc/sco (h:node-rank hd))]))) - - (define binomial-heap/sco (binomial-trees/asc/sco -inf.0)) - 1)) - - - ;; - ;; end of define-opt/c - ;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; opt/c and blame - ;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (contract-eval - '(begin - - (define proj:blame/c - (make-contract - #:name 'proj:blame/c - #:projection - (lambda (blame) - (lambda (x) - (if (blame-swapped? blame) 'negative 'positive))))) - - (define call*0 'dummy) - (define (call*1 x0) x0) - (define (call*2 f1 x0) (f1 x0)) - (define (call*3 f2 x1 x0) (f2 x1 x0)))) - - (test/spec-passed/result - 'opt/c-blame-0 - '((contract - (-> (-> (-> proj:blame/c any/c) any/c any/c) (-> any/c any/c) any/c any/c) - call*3 - 'pos - 'neg) - call*2 - call*1 - call*0) - 'negative) - - (test/spec-passed/result - 'opt/c-blame-1 - '((contract - (opt/c (-> (-> (-> proj:blame/c any/c) any/c any/c) (-> any/c any/c) any/c any/c)) - call*3 - 'pos - 'neg) - call*2 - call*1 - call*0) - 'negative) - - (test/spec-passed/result - 'opt/c-blame-2 - '((contract - (-> (opt/c (-> (-> proj:blame/c any/c) any/c any/c)) (-> any/c any/c) any/c any/c) - call*3 - 'pos - 'neg) - call*2 - call*1 - call*0) - 'negative) - - (test/spec-passed/result - 'opt/c-blame-3 - '((contract - (-> (-> (opt/c (-> proj:blame/c any/c)) any/c any/c) (-> any/c any/c) any/c any/c) - call*3 - 'pos - 'neg) - call*2 - call*1 - call*0) - 'negative) - - (test/spec-passed/result - 'opt/c-blame-4 - '((contract - (-> (-> (-> (opt/c proj:blame/c) any/c) any/c any/c) (-> any/c any/c) any/c any/c) - call*3 - 'pos - 'neg) - call*2 - call*1 - call*0) - 'negative) - - ;; NOT YET RELEASED - #; - (test/pos-blame - 'd-c-s/attr-1 - '(let () - (define-contract-struct pr (x y)) - (pr-x - (contract (pr/dc [x integer?] - [y integer?] - where - [x-val x] - [y-val y] - and - (= x-val y-val)) - (make-pr 4 5) - 'pos - 'neg)))) - - ;; NOT YET RELEASED - #; - (test/spec-passed - 'd-c-s/attr-2 - '(let () - (define-contract-struct pr (x y)) - (contract (pr/dc [x integer?] - [y integer?] - where - [x-val x] - [y-val y] - and - (= x-val y-val)) - (make-pr 4 5) - 'pos - 'neg))) - - ;; NOT YET RELEASED - #; - (let () - (define-contract-struct node (n l r) (make-inspector)) - - (define (get-val n attr) - (if (null? n) - 1 - (let ([h (synthesized-value n attr)]) - (if (unknown? h) - h - (+ h 1))))) - - (define (full-bbt lo hi) - (or/c null? - (node/dc [n (between/c lo hi)] - [l (n) (full-bbt lo n)] - [r (n) (full-bbt n hi)] - - where - [lheight (get-val l lheight)] - [rheight (get-val r rheight)] - - and - (<= 0 (- lheight rheight) 1)))) - - (define t (contract (full-bbt -inf.0 +inf.0) - (make-node 0 - (make-node -1 null null) - (make-node 2 - (make-node 1 null null) - (make-node 3 null null))) - 'pos - 'neg)) - (test/spec-passed - 'd-c-s/attr-3 - `(,node-l (,node-l ,t))) - - (test/pos-blame - 'd-c-s/attr-4 - `(,node-r (,node-r (,node-r ,t))))) - - ;; NOT YET RELEASED - #| - -need a test that will revisit a node a second time (when it already has a wrapper) -with a new parent. make sure the new parent is recorded in the parents field -so that propagation occurs. - -|# - - - ;; test the predicate - (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) - - -; -; -; -; -; ;;;;;;; ; ; ; ;;;;; -; ;;; ;;; ;;; ;;; ;;; ;;;;;;; -; ;;;; ;;; ;;;;; ;;;; ;;; ;;; ;;; ;; ;;;; ;;; ;;;;;;; ;;; ;;;; ;; ;;; -; ;;;; ;;; ;;;;;;; ;;;; ;;;;; ;;;;; ;;;;;;; ;;;; ;;;;;;;;;;;; ;;;;; ;;;; ;;;; -; ;;; ;;; ;; ;;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;; ;;; ;;;; -; ;;; ;;; ;;;;; ;;; ;;;;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;; ;;; ;;; ;;; -; ;;; ;;; ;;; ;;; ;;; ;;;;;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; -; ;;; ;;; ;;; ;;; ;;;; ;;;;; ;;;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;;;; ;;;; ;;; -; ;;; ;;; ;;;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;; ;;; ;;; ;;; -; -; -; -; - - (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) - - (ctest #t flat-contract? (-> any/c any/c any)) - - (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?))) - (ctest #t flat-contract? (let () - (define-struct s (a b)) - (struct/c s any/c any/c))) - (ctest #f flat-contract? (let () - (define-struct s (a b) #:mutable) - (struct/c s any/c any/c))) - (ctest #f flat-contract? (let () - (define-struct s (a b) #:mutable) - (struct/c s any/c integer?))) - (ctest #t chaperone-contract? (let () - (define-struct s (a b) #:mutable) - (struct/c s any/c any/c))) - (ctest #f impersonator-contract? (let () - (define-struct s (a b) #:mutable) - (struct/c s any/c any/c))) - (ctest #f flat-contract? (let () - (define-struct s ([a #:mutable] b)) - (struct/c s any/c any/c))) - (ctest #t chaperone-contract? (let () - (define-struct s ([a #:mutable] b)) - (struct/c s any/c any/c))) - (ctest #f impersonator-contract? (let () - (define-struct s ([a #:mutable] b)) - (struct/c s any/c any/c))) - (ctest #f flat-contract? (let () - (define-struct s (a [b #:mutable])) - (struct/c s any/c any/c))) - (ctest #t chaperone-contract? (let () - (define-struct s (a [b #:mutable])) - (struct/c s any/c any/c))) - (ctest #f impersonator-contract? (let () - (define-struct s (a [b #:mutable])) - (struct/c s any/c any/c))) - (ctest #f flat-contract? (let () - (define-struct s (f)) - (struct/c s (-> number? any)))) - (ctest #t chaperone-contract? (let () - (define-struct s (f)) - (struct/c s (-> number? any)))) - (ctest #f impersonator-contract? (let () - (define-struct s (f)) - (struct/c s (-> number? any)))) - - (ctest #f flat-contract? (let () - (define-struct s (a) #:mutable) - (define alpha (new-∃/c 'alpha)) - (struct/c s alpha))) - (ctest #f chaperone-contract? (let () - (define-struct s (a) #:mutable) - (define alpha (new-∃/c 'alpha)) - (struct/c s alpha))) - (ctest #t impersonator-contract? (let () - (define-struct s (a) #:mutable) - (define alpha (new-∃/c 'alpha)) - (struct/c s alpha))) - (ctest #t contract? (let () - (define-struct s (a) #:mutable) - (define alpha (new-∃/c 'alpha)) - (struct/c s alpha))) - - (ctest #t chaperone-contract? - (let () - (struct s (a b)) - (let ([x (struct/dc s [a integer?] [b integer?])]) - (opt/c x)))) - - (ctest #t flat-contract? (set/c integer?)) - (ctest #f flat-contract? (set/c (-> integer? integer?))) - (ctest #t chaperone-contract? (set/c (-> integer? integer?))) - - (ctest #t flat-contract? (list/c integer?)) - (ctest #t chaperone-contract? (list/c (-> integer? integer?))) - - (ctest #t chaperone-contract? (promise/c integer?)) - (ctest #f chaperone-contract? (promise/c (new-∃/c 'alpha))) - - ;; Make sure that impersonators cannot be used as the element contract in set/c. - (contract-error-test - 'contract-error-test-set - '(let ([proxy-ctc - (make-contract - #:name 'proxy-ctc - #:first-order values - #:projection (λ (b) values))]) - (set/c proxy-ctc)) - exn:fail?) - - ;; Hash contracts with flat domain/range contracts - (ctest #t contract? (hash/c any/c any/c #:immutable #f)) - (ctest #t chaperone-contract? (hash/c any/c any/c #:immutable #f)) - (ctest #f impersonator-contract? (hash/c any/c any/c #:immutable #f)) - (ctest #t flat-contract? (hash/c any/c any/c #:immutable #f #:flat? #t)) - - (ctest #t flat-contract? (hash/c any/c any/c #:immutable #t)) - (ctest #t flat-contract? (hash/c any/c any/c #:immutable #t #:flat? #t)) - - (ctest #t contract? (hash/c any/c any/c)) - (ctest #t chaperone-contract? (hash/c any/c any/c)) - (ctest #f impersonator-contract? (hash/c any/c any/c)) - (ctest #t flat-contract? (hash/c any/c any/c #:flat? #t)) - - ;; Hash contracts with chaperone range contracts - (ctest #t contract? (hash/c number? (hash/c number? number?))) - (ctest #t chaperone-contract? (hash/c number? (hash/c number? number?))) - (ctest #f impersonator-contract? (hash/c number? (hash/c number? number?))) - (ctest #f flat-contract? (hash/c number? (hash/c number? number?))) - - ;; Hash contracts with proxy range contracts - (contract-eval - '(define trivial-proxy-ctc - (make-contract - #:name 'trivial-proxy-ctc - #:first-order values - #:projection (λ (b) values)))) - - (ctest #t contract? (hash/c number? trivial-proxy-ctc #:immutable #f)) - (ctest #f chaperone-contract? (hash/c number? trivial-proxy-ctc #:immutable #f)) - (ctest #t impersonator-contract? (hash/c number? trivial-proxy-ctc #:immutable #f)) - (ctest #f flat-contract? (hash/c number? trivial-proxy-ctc #:immutable #f)) - - (ctest #t contract? (hash/c number? trivial-proxy-ctc #:immutable #t)) - (ctest #f chaperone-contract? (hash/c number? trivial-proxy-ctc #:immutable #t)) - (ctest #t impersonator-contract? (hash/c number? trivial-proxy-ctc #:immutable #t)) - (ctest #f flat-contract? (hash/c number? trivial-proxy-ctc #:immutable #t)) - - (ctest #t contract? (hash/c number? trivial-proxy-ctc)) - (ctest #f chaperone-contract? (hash/c number? trivial-proxy-ctc)) - (ctest #t impersonator-contract? (hash/c number? trivial-proxy-ctc)) - (ctest #f flat-contract? (hash/c number? trivial-proxy-ctc)) - - ;; Make sure that proxies cannot be used as the domain contract in hash/c. - (contract-error-test - 'contract-error-test6 - '(let ([proxy-ctc - (make-contract - #:name 'proxy-ctc - #:first-order values - #:projection (λ (b) values))]) - (hash/c proxy-ctc proxy-ctc)) - exn:fail?) - - (ctest #t contract? (box/c number? #:flat? #t)) - (ctest #t chaperone-contract? (box/c number? #:flat? #t)) - (ctest #f impersonator-contract? (box/c number? #:flat? #t)) - (ctest #t flat-contract? (box/c number? #:flat? #t)) - - (ctest #t contract? (box/c number? #:immutable #t)) - (ctest #t chaperone-contract? (box/c number? #:immutable #t)) - (ctest #f impersonator-contract? (box/c number? #:immutable #t)) - (ctest #t flat-contract? (box/c number? #:immutable #t)) - - (ctest #t contract? (box/c number?)) - (ctest #t chaperone-contract? (box/c number?)) - (ctest #f impersonator-contract? (box/c number?)) - (ctest #f flat-contract? (box/c number?)) - - (ctest #t contract? (box/c (box/c number?) #:immutable #t)) - (ctest #t chaperone-contract? (box/c (box/c number?) #:immutable #t)) - (ctest #f impersonator-contract? (box/c (box/c number?) #:immutable #t)) - (ctest #f flat-contract? (box/c (box/c number?) #:immutable #t)) - - (ctest #t contract? (box/c trivial-proxy-ctc)) - (ctest #f chaperone-contract? (box/c trivial-proxy-ctc)) - (ctest #t impersonator-contract? (box/c trivial-proxy-ctc)) - (ctest #f flat-contract? (box/c trivial-proxy-ctc)) - - (ctest #t contract? (box/c trivial-proxy-ctc #:immutable #t)) - (ctest #f chaperone-contract? (box/c trivial-proxy-ctc #:immutable #t)) - (ctest #t impersonator-contract? (box/c trivial-proxy-ctc #:immutable #t)) - (ctest #f flat-contract? (box/c trivial-proxy-ctc #:immutable #t)) - - ;; Test the ability to create different types of contracts with recursive-contract - (ctest #t flat-contract? (letrec ([ctc (or/c number? - (cons/c (recursive-contract ctc #:flat) - (recursive-contract ctc #:flat)))]) - ctc)) - - (ctest #f flat-contract? (letrec ([ctc (or/c number? - (box/c (recursive-contract ctc #:chaperone)))]) - ctc)) - (ctest #t chaperone-contract? (letrec ([ctc (or/c number? - (box/c (recursive-contract ctc #:chaperone)))]) - ctc)) - (ctest #f impersonator-contract? (letrec ([ctc (or/c number? - (box/c (recursive-contract ctc #:chaperone)))]) - ctc)) - - (ctest #t contract? 1) - (ctest #t contract? (-> 1 1)) - - (ctest #t chaperone-contract? (let () - (struct s (a b)) - (struct/dc s [a integer?] [b integer?]))) - (ctest #t flat-contract? (let () - (struct s (a b)) - (struct/dc s [a integer?] [b integer?]))) - (ctest #t flat-contract? (let () - (struct s (a b)) - (struct/dc s [a integer?] [b (a) #:flat (>=/c a)]))) - (contract-error-test - 'struct/dc-not-really-flat-dep-field - #'(let () - (struct s (a b)) - (contract (struct/dc s [a integer?] [b (a) #:flat (-> integer? integer?)]) - (s 1 (λ (x) x)) - 'pos - 'neg)) - exn:fail?) - (ctest #t chaperone-contract? (let () - (struct s (a b)) - (struct/dc s [a integer?] [b (a) (>=/c a)]))) - - (test-flat-contract '(and/c number? integer?) 1 3/2) - (test-flat-contract '(not/c integer?) #t 1) - (test-flat-contract '(=/c 2) 2 3) - (test-flat-contract '(>/c 5) 10 5) - (test-flat-contract '(>=/c 5) 5 0) - (test-flat-contract '(<=/c 5) 5 10) - (test-flat-contract '(/c 5) 10 0+1i) - (test-flat-contract '(>=/c 5) 5 0+1i) - (test-flat-contract '(<=/c 5) 5 0+1i) - (test-flat-contract '( (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)) - - (begin - (contract-eval '(define flat-is-a-test<%> (interface ()))) - (contract-eval '(define flat-is-a-test% (class object% (super-new)))) - (test-flat-contract `(is-a?/c flat-is-a-test<%>) - (contract-eval `(new (class* object% (flat-is-a-test<%>) (super-new)))) - (contract-eval '(new object%))) - (test-flat-contract `(is-a?/c flat-is-a-test%) - (contract-eval `(new flat-is-a-test%)) - (contract-eval '(new object%))) - (test-flat-contract `(or/c #f (is-a?/c flat-is-a-test<%>)) - (contract-eval `(new (class* object% (flat-is-a-test<%>) (super-new)))) - (contract-eval '(new object%))) - (test-flat-contract `(or/c #f (is-a?/c flat-is-a-test%)) - (contract-eval `(new flat-is-a-test%)) - (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 '(vectorof boolean? #:flat? #t) (vector #t #f) (vector #f 3 #t)) - (test-flat-contract '(vectorof any/c #:flat? #t) (vector #t #f) 3) - (test-flat-contract '(vector-immutableof boolean?) - (vector-immutable #t #f) - (vector-immutable #f 3 #t)) - (test-flat-contract '(vector-immutableof any/c) (vector-immutable #t #f) 3) - - (test-flat-contract '(vector/c boolean? (flat-contract integer?) #:flat? #t) - (vector #t 1) - (vector 1 #f)) - (test-flat-contract '(vector/c boolean? (flat-contract integer?) #:flat? #t) (vector #t 1) #f) - (test-flat-contract '(vector-immutable/c boolean? (flat-contract integer?)) - (vector-immutable #t 1) (vector-immutable 1 #f)) - (test-flat-contract '(vector-immutable/c boolean? (flat-contract integer?)) - (vector-immutable #t 1) - #f) - - (test-flat-contract '(cons/c boolean? (flat-contract integer?)) (cons #t 1) (cons 1 #f)) - (test-flat-contract '(cons/c boolean? (flat-contract integer?)) (cons #t 1) #f) - (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) - - (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? #:flat? #t) (box #f) (box 1)) - (test-flat-contract '(box/c (flat-contract boolean?) #:flat? #t) (box #t) #f) - (test-flat-contract '(box-immutable/c boolean?) (box-immutable #f) (box-immutable 1)) - (test-flat-contract '(box-immutable/c (flat-contract boolean?)) (box-immutable #t) #f) - - (test-flat-contract '(flat-rec-contract sexp (cons/c sexp sexp) number?) '(1 2 . 3) '(1 . #f)) - (test-flat-contract '(flat-murec-contract ([even1 (or/c null? (cons/c number? even2))] - [even2 (cons/c number? even1)]) - even1) - '(1 2 3 4) - '(1 2 3)) - - (test-flat-contract '(hash/c symbol? boolean? #:flat? #t) (make-hash) 1) - (test-flat-contract '(hash/c symbol? boolean? #:flat? #t) - (let ([ht (make-hash)]) - (hash-set! ht 'x #t) - ht) - (let ([ht (make-hash)]) - (hash-set! ht 'x 1) - ht)) - (test-flat-contract '(hash/c symbol? boolean? #:flat? #t) - (let ([ht (make-hash)]) - (hash-set! ht 'x #t) - ht) - (let ([ht (make-hash)]) - (hash-set! ht 'x 1) - ht)) - - (test-flat-contract '(between/c 1 10) 3 11) - (test-flat-contract '(between/c 1 10) 4 1+1i) - (test-flat-contract '(<=/c 1) 0 1+1i) - (test-flat-contract '(/c 1) 4 1+1i) - (test-flat-contract '(>=/c 1) 4 1+1i) - - (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)) - - ;; test flat-contract-predicate - (test #t (flat-contract-predicate integer?) 1) - (test #t (flat-contract-predicate #t) #t) - - -; -; -; -; -; ;;; ;;;; ;;; -; ;;; ;;; -; ;;; ;;; ;; ;;;; ;;;; ;;; ;;;; ;; ;;;; ;; ;;; ;;; ;; ;;;;; ;;; ;; ;;; ;;;; -; ;;; ;;;;;;; ;;;; ;; ;;; ;;;;;;;;;; ;; ;;; ;;;;;;; ;;;;;;; ;;;;;;; ;;;;;;;;;;; ;; ;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; -; ;;; ;;; ;;; ;;; ;;;;;;; ;;; ;;; ;;;;;;; ;;; ;;; ;;;;;;; ;;; ;;;;; ;;; ;;; ;;; ;;;;;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; -; ;;; ;;; ;;; ;;; ;;;;;; ;;; ;;; ;;;;;; ;;;;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;; -; ;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;;; ;; ;;; ;;; ;;; ;;;;;; ;;; ;;; ;;; ;;;; -; -; -; -; - - - (contract-eval - '(module contract-test-suite-inferred-name1 racket/base - (require racket/contract) - (define contract-inferred-name-test-contract (-> integer? any)) - (define (contract-inferred-name-test1 x) #t) - (provide/contract (contract-inferred-name-test1 contract-inferred-name-test-contract)) - - (define (contract-inferred-name-test2 x) x) - (provide/contract (contract-inferred-name-test2 (-> number? number?))) - - (define (contract-inferred-name-test2b x) (values x x)) - (provide/contract (contract-inferred-name-test2b (-> number? (values number? number?)))) - - (define (contract-inferred-name-test3 x . y) x) - (provide/contract - (contract-inferred-name-test3 (->* (number?) () #:rest (listof number?) number?))) - - (define (contract-inferred-name-test4) 7) - (provide/contract (contract-inferred-name-test4 (->d () () any))) - - (define (contract-inferred-name-test5) 7) - (provide/contract (contract-inferred-name-test5 (->i () () any))) - )) - (contract-eval '(require 'contract-test-suite-inferred-name1)) - (test 'contract-inferred-name-test1 object-name (contract-eval 'contract-inferred-name-test1)) - (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-name 'integer? (flat-contract integer?)) - (test-name 'boolean? (flat-contract boolean?)) - (test-name 'char? (flat-contract char?)) - (test-name 'any/c any/c) - - (test-name 'mumble (let ([frotz/c integer?] - [bazzle/c boolean?]) - (flat-named-contract 'mumble - (and/c frotz/c - (not/c bazzle/c))))) - - - (test-name '(-> integer? integer?) (-> integer? integer?)) - (test-name '(-> integer? any) (-> integer? any)) - (test-name '(-> integer? (values boolean? char?)) (-> integer? (values boolean? char?))) - (test-name '(-> integer? boolean? (values char? any/c)) - (->* (integer? boolean?) () (values char? any/c))) - (test-name '(-> integer? boolean? any) (->* (integer? boolean?) () any)) - (test-name '(-> integer? boolean? #:x string? any) (-> integer? #:x string? boolean? any)) - - (test-name '(->* (integer?) (string?) #:rest any/c (values char? any/c)) - (->* (integer?) (string?) #:rest any/c (values char? any/c))) - (test-name '(->* (integer? char?) (boolean?) any) (->* (integer? char?) (boolean?) any)) - (test-name '(->* (integer? char? #:z string?) (integer?) any) - (->* (#:z string? integer? char?) (integer?) any)) - (test-name '(->* (integer? char? #:z string?) (boolean? #:i number?) any) - (->* (#:z string? integer? char?) (boolean? #:i number?) any)) - (test-name '(->* (integer? char? #:z string?) (boolean? #:i number?) #:rest (listof integer?) any) - (->* (#:z string? integer? char?) (boolean? #:i number?) #:rest (listof integer?) any)) - (test-name '(->* (integer? char? #:z string?) (boolean? #:i number?) - (values number? boolean? symbol?)) - (->* (#:z string? integer? char?) (boolean? #:i number?) - (values number? boolean? symbol?))) - (test-name '(->* (integer? char? #:z string?) (boolean? #:i number?) #:rest (listof integer?) - (values number? boolean? symbol?)) - (->* (#:z string? integer? char?) (boolean? #:i number?) #:rest (listof integer?) - (values number? boolean? symbol?))) - - (test-name '(->* (integer?) #:pre ... integer?) - (->* (integer?) () #:pre (= 1 2) integer?)) - (test-name '(->* (integer?) integer? #:post ...) - (->* (integer?) () integer? #:post #f)) - (test-name '(->* (integer?) #:pre ... integer? #:post ...) - (->* (integer?) () #:pre (= 1 2) integer? #:post #f)) - - (test-name '(->d () () any) (->d () () any)) - (test-name '(->d ([x ...] #:y [y ...]) ([z ...] #:w [w ...]) any) - (->d ([x integer?] #:y [y integer?]) ([z integer?] #:w [w integer?]) any)) - (test-name '(->d () () (values [x ...] [y ...])) (->d () () (values [x number?] [y number?]))) - (test-name '(->d () () [x ...]) (->d () () [q number?])) - (test-name '(->d () () #:pre ... [x ...]) (->d () () #:pre #t [q number?])) - (test-name '(->d () () #:pre ... [x ...] #:post ...) (->d () () #:pre #t [q number?] #:post #t)) - (test-name '(->d () () [x ...] #:post ...) (->d () () [q number?] #:post #t)) - - (test-name '(->i () any) (->i () () any)) - (test-name '(->i () any) (->i () any)) - (test-name '(->i () [x () ...]) - (->i () () [x () number?])) - (test-name '(->i () [q number?]) - (->i () () [q number?])) - (test-name '(->i () (values [x number?] [y number?])) - (->i () (values [x number?] [y number?]))) - (test-name '(->i () (values [x (y) ...] [y number?])) - (->i () (values [x (y) number?] [y number?]))) - (test-name '(->i ([x integer?] #:y [y integer?]) ([z integer?] #:w [w integer?]) any) - (->i ([x integer?] #:y [y integer?]) ([z integer?] #:w [w integer?]) any)) - (test-name '(->i () #:pre () ... [q number?]) - (->i () #:pre () #t [q number?])) - (test-name '(->i () #:pre () ... [q () ...] #:post () ...) - (->i () #:pre () #t [q () number?] #:post () #t)) - (test-name '(->i ([x integer?]) #:pre (x) ... [q (x) ...] #:post (x) ...) - (->i ([x integer?]) #:pre (x) #t [q (x) number?] #:post (x) #t)) - (test-name '(->i ([x real?]) [_ (x) ...]) - (->i ([x real?]) [_ (x) (>/c x)])) - (test-name '(->i ([x any/c]) #:pre/name (x) "pair" ... #:pre/name (x) "car" ... any) - (->i ([x any/c]) #:pre/name (x) "pair" (pair? x) #:pre/name (x) "car" (car x) any)) - (test-name '(->i ([x any/c]) [y () ...] #:post/name (y) "pair" ... #:post/name (y) "car" ...) - (->i ([x any/c]) [y () any/c] #:post/name (y) "pair" (pair? y) - #:post/name (y) "car" (car y))) - - (test-name '(case->) (case->)) - (test-name '(case-> (-> integer? any) (-> boolean? boolean? any) (-> char? char? char? any)) - (case-> (-> integer? any) (-> boolean? boolean? any) (-> char? char? char? any))) - (test-name '(case-> (-> integer? integer?) (-> integer? integer? integer?)) - (case-> (-> integer? integer?) (-> integer? integer? integer?))) - (test-name '(case-> (-> integer? #:rest any/c any)) (case-> (-> integer? #:rest any/c any))) - (test-name '(case-> (-> integer? #:rest any/c (values boolean? char? number?))) - (case-> (-> integer? #:rest any/c (values boolean? char? number?)))) - (test-name '(case-> (-> integer? (values))) (case-> (-> integer? (values)))) - - (test-name '(unconstrained-domain-> number?) (unconstrained-domain-> number?)) - - (test-name '(or/c) (or/c)) - (test-name '(or/c '()) (or/c '())) - (test-name '(or/c integer? gt0?) (or/c integer? (let ([gt0? (lambda (x) (> x 0))]) gt0?))) - (test-name '(or/c integer? boolean?) - (or/c (flat-contract integer?) - (flat-contract boolean?))) - (test-name '(or/c integer? boolean?) - (or/c integer? boolean?)) - (test-name '(or/c (-> (>=/c 5) (>=/c 5)) boolean?) - (or/c (-> (>=/c 5) (>=/c 5)) boolean?)) - (test-name '(or/c boolean? (-> (>=/c 5) (>=/c 5))) - (or/c boolean? (-> (>=/c 5) (>=/c 5)))) - (test-name '(or/c (-> (>=/c 5) (>=/c 5)) - (-> (<=/c 5) (<=/c 5) (<=/c 5))) - (or/c (-> (>=/c 5) (>=/c 5)) - (-> (<=/c 5) (<=/c 5) (<=/c 5)))) - (test-name '(or/c boolean? - (-> (>=/c 5) (>=/c 5)) - (-> (<=/c 5) (<=/c 5) (<=/c 5))) - (or/c boolean? - (-> (>=/c 5) (>=/c 5)) - (-> (<=/c 5) (<=/c 5) (<=/c 5)))) - - (test-name 'any/c (and/c)) - (test-name '(and/c any/c) (and/c any/c)) - (test-name '(and/c any/c any/c) (and/c any/c any/c)) - (test-name '(and/c number? integer?) (and/c number? integer?)) - (test-name '(and/c number? integer?) (and/c (flat-contract number?) - (flat-contract integer?))) - (test-name '(and/c number? (-> integer? integer?)) (and/c number? (-> integer? integer?))) - (test-name '(and/c (-> boolean? boolean?) (-> integer? integer?)) - (and/c (-> boolean? boolean?) (-> integer? integer?))) - - (test-name '(not/c integer?) (not/c integer?)) - (test-name '(=/c 5) (=/c 5)) - (test-name '(>=/c 5) (>=/c 5)) - (test-name '(<=/c 5) (<=/c 5)) - (test-name '(/c 5) (>/c 5)) - (test-name '(between/c 5 6) (between/c 5 6)) - (test-name '(between/c -inf.0 +inf.0) (between/c -inf.0 +inf.0)) - (test-name '(integer-in 0 10) (integer-in 0 10)) - (test-name '(between/c 1 10) (real-in 1 10)) - (test-name '(string-len/c 3) (string-len/c 3)) - (test-name 'natural-number/c natural-number/c) - (test-name #f false/c) - (test-name #t #t) - (test-name #\a #\a) - (test-name "x" "x") - (test-name ''x 'x) - (test-name #rx"x" #rx"x") - (test-name #rx#"x" #rx#"x") - (test-name 'printable/c printable/c) - (test-name '(or/c 'a 'b 'c) (symbols 'a 'b 'c)) - (test-name '(or/c 1 2 3) (one-of/c 1 2 3)) - (test-name '(or/c '() 'x 1 #f #\a void? undefined?) - (one-of/c '() 'x 1 #f #\a (void) (letrec ([x x]) x))) - - (test-name '(or/c #f #t #\a "x") (or/c #f #t #\a "x")) - (test-name '(or/c #f #t #\a "x" #rx"x" #rx#"x") (or/c #f #t #\a "x" #rx"x" #rx#"x")) - - (test-name '(subclass?/c c%) - (let ([c% (class object% (super-new))]) (subclass?/c c%))) - - (test-name '(implementation?/c i<%>) - (let ([i<%> (interface ())]) - (implementation?/c i<%>))) - - (test-name '(is-a?/c i<%>) - (let ([i<%> (interface ())]) - (is-a?/c i<%>))) - (test-name '(is-a?/c 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)) - (test-name '(listof boolean?) (listof boolean?)) - (test-name '(listof any/c) (listof any/c)) - (test-name '(listof boolean?) (listof boolean?)) - (test-name '(listof (-> boolean? boolean?)) (listof (-> boolean? boolean?))) - - (test-name '(non-empty-listof boolean?) (non-empty-listof boolean?)) - (test-name '(non-empty-listof any/c) (non-empty-listof any/c)) - (test-name '(non-empty-listof boolean?) (non-empty-listof boolean?)) - (test-name '(non-empty-listof any/c) (non-empty-listof any/c)) - (test-name '(non-empty-listof boolean?) (non-empty-listof boolean?)) - (test-name '(non-empty-listof (-> boolean? boolean?)) (non-empty-listof (-> boolean? boolean?))) - - - (test-name '(vectorof boolean?) (vectorof boolean?)) - (test-name '(vectorof any/c) (vectorof any/c)) - - (test-name '(vector/c boolean? integer?) (vector/c boolean? integer?)) - (test-name '(vector/c boolean? integer?) (vector/c boolean? (flat-contract integer?))) - - (test-name '(cons/c boolean? integer?) (cons/c boolean? (flat-contract integer?))) - (test-name '(cons/c boolean? integer?) (cons/c boolean? (flat-contract integer?))) - (test-name '(list/c boolean? integer?) (list/c boolean? (flat-contract integer?))) - (test-name '(list/c boolean? integer?) (list/c boolean? (flat-contract integer?))) - - (test-name '(cons/c boolean? integer?) (cons/c boolean? (flat-contract integer?))) - (test-name '(cons/c boolean? integer?) (cons/c boolean? (flat-contract integer?))) - (test-name '(cons/c boolean? integer?) (cons/c boolean? (flat-contract integer?))) - (test-name '(cons/c (-> boolean? boolean?) integer?) (cons/c (-> boolean? boolean?) integer?)) - - (test-name '(list/c boolean? integer?) - (list/c boolean? (flat-contract integer?))) - (test-name '(list/c boolean? integer?) - (list/c boolean? (flat-contract integer?))) - (test-name '(list/c boolean? integer?) - (list/c boolean? (flat-contract integer?))) - (test-name '(list/c (-> boolean? boolean?) integer?) - (list/c (-> boolean? boolean?) integer?)) - - (test-name '(parameter/c integer?) (parameter/c integer?)) - (test-name '(parameter/c integer? string?) (parameter/c integer? string?)) - - (test-name '(hash/c symbol? boolean?) (hash/c symbol? boolean?)) - (test-name '(hash/c symbol? boolean? #:immutable #t) (hash/c symbol? boolean? #:immutable #t)) - (test-name '(hash/c symbol? boolean? #:immutable #f) (hash/c symbol? boolean? #:immutable #f)) - (test-name '(hash/c symbol? boolean?) (hash/c symbol? boolean? #:immutable 'dont-care)) - - (test-name '(box/c boolean?) (box/c boolean?)) - (test-name '(box/c boolean?) (box/c (flat-contract boolean?))) - (test-name 'the-name (flat-rec-contract the-name)) - - (test-name '(object-contract) (object-contract)) - (test-name '(object-contract (field x integer?)) (object-contract (field x integer?))) - (test-name '(object-contract (m (-> integer? integer?))) - (object-contract (m (-> integer? integer?)))) - (test-name '(object-contract (m (-> integer? any))) - (object-contract (m (-> integer? any)))) - (test-name '(object-contract (m (-> integer? (values integer? integer?)))) - (object-contract (m (-> integer? (values integer? integer?))))) - (test-name '(object-contract (m (case-> (-> integer? integer? integer?) - (-> integer? (values integer? integer?))))) - (object-contract (m (case-> - (-> integer? integer? integer?) - (-> integer? (values integer? integer?)))))) - (test-name - '(object-contract (m (->* (integer?) (boolean? number?) symbol?))) - (object-contract (m (->* (integer?) (boolean? number?) symbol?)))) - - (test-name '(object-contract (m (->d ((x ...)) () (y ...)))) - (object-contract (m (->d ((x number?)) () [result number?])))) - (test-name '(object-contract (m (->d ((x ...) (y ...) (z ...)) () [w ...]))) - (object-contract (m (->d ((x number?) (y boolean?) (z pair?)) () [result number?])))) - (test-name '(object-contract (m (->d ((x ...) (y ...) (z ...)) () #:rest w ... [x0 ...]))) - (object-contract (m (->d ((x number?) (y boolean?) (z pair?)) () - #:rest rest-x any/c [result number?])))) - - (test-name '(object-contract (m (->i ((x number?)) (result number?)))) - (object-contract (m (->i ((x number?)) () [result number?])))) - (test-name '(object-contract (m (->i ((x number?) (y boolean?) (z pair?)) [result number?]))) - (object-contract (m (->i ((x number?) (y boolean?) (z pair?)) () [result number?])))) - (test-name '(object-contract (m (->i ((x number?) (y boolean?) (z pair?)) - #:rest [rest-x any/c] [result number?]))) - (object-contract (m (->i ((x number?) (y boolean?) (z pair?)) () - #:rest [rest-x any/c] [result number?])))) - - (test-name '(promise/c any/c) (promise/c any/c)) - (test-name '(syntax/c any/c) (syntax/c any/c)) - (test-name '(struct/c st integer?) - (let () - (define-struct st (a)) - (struct/c st integer?))) - - (test-name '(recursive-contract (box/c boolean?)) (recursive-contract (box/c boolean?))) - (test-name '(recursive-contract boolean? #:flat) (let ([c (recursive-contract boolean? #:flat)]) - (contract c #f 'pos 'neg) - c)) - (test-name '(recursive-contract x) (let ([x (box/c boolean?)]) (recursive-contract x))) - (test-name '(recursive-contract integeeer?) - (let ([x (box/c boolean?)]) - (let ([c (recursive-contract (flat-named-contract 'integeeer? integer?))]) - (contract c 1 'pos 'neg) - c))) - (test-name '(recursive-contract (or/c (flat-named-contract 'integeeer? integer?) - (listof c))) - (letrec ([c (recursive-contract - (or/c (flat-named-contract 'integeeer? integer?) - (listof c)))]) - c)) - (test-name '(recursive-contract (or/c integeeer? (listof c))) - (letrec ([c (recursive-contract - (or/c (flat-named-contract 'integeeer? integer?) - (listof c)))]) - (contract c 1 'pos 'neg) - c)) - - (test-name '(couple/c any/c any/c) - (couple/c any/c any/c)) - (test-name '(couple/c any/c any/c) - (couple/dc [hd any/c] [tl any/c])) - (test-name '(couple/dc [hd any/c] [tl ...]) - (couple/dc [hd any/c] [tl (hd) any/c])) - - (test-name '(set/c integer?) (set/c integer?)) - (test-name '(set/c boolean? #:cmp 'equal) (set/c boolean? #:cmp 'equal)) - (test-name '(set/c char? #:cmp 'eq) (set/c char? #:cmp 'eq)) - (test-name '(set/c (set/c char?) #:cmp 'eqv) (set/c (set/c char? #:cmp 'dont-care) #:cmp 'eqv)) - (test-name '(set/c (-> char? char?) #:cmp 'equal) (set/c (-> char? char?) #:cmp 'equal)) - - (test-name '(class/c [m (->m integer? integer?)]) (class/c [m (->m integer? integer?)])) - (test-name '(class/c [m (->*m (integer?) (integer?) integer?)]) - (class/c [m (->*m (integer?) (integer?) integer?)])) - (test-name '(class/c [m (case->m (-> integer? integer?) (-> integer? integer? integer?))]) - (class/c [m (case->m (-> integer? integer?) (-> integer? integer? integer?))])) - (test-name '(class/c [m (->dm ((x ...)) () (y ...))]) - (class/c [m (->dm ([d integer?]) () [r integer?])])) - (test-name 'c%/c (let ([c%/c (class/c [m (->m integer? integer?)])]) - c%/c)) - - (test-name '(struct/dc s - [a integer?] - [b symbol?] - [c (a b) ...] - [d (a b c) ...]) - (let () - (struct s (a b c d)) - (struct/dc s - [a integer?] - [b symbol?] - [c (a b) boolean?] - [d (a b c) integer?]))) - - (test-name '(struct/dc s - [a integer?] - [b #:lazy symbol?] - [c (a) ...] - [d (a c) ...]) - (let () - (struct s (a b c d)) - (struct/dc s - [a integer?] - [b #:lazy symbol?] - [c (a) boolean?] - [d (a c) integer?]))) - - ;; NOT YET RELEASED - #; - (test-name '(pr/dc [x integer?] - [y integer?] - where - [x-val ...] - [y-val ...] - and - ...) - (let () - (define-contract-struct pr (x y)) - (pr/dc [x integer?] - [y integer?] - where - [x-val x] - [y-val y] - and - (= x-val y-val)))) - - -; -; -; -; ; -; ;; -; ;;;;; ;;;;; ;;; ;;; ;;;; ;;;; ;;; ;;;;;;; ;;; ;;; ;;; -; ;;;;;; ;;;;;; ;;;;;;; ;;;;;; ;;;;;;;;; ;;;;;;;; ;;;;; ;;;;;;; -; ;;;; ;;;; ;;;; ;; ;;;;;;;; ;;;; ;;;; ;;; ;;;; ;;;; ;; ;;;; ;; -; ;;;; ;;;; ;;;; ;;;; ;;; ;;;; ;;;; ;;;;;;;; ;;;;;;; ;;;; -; ;;;; ;;;;; ;;;; ;;;;;;;; ;;;; ;;;; ;;;;;;; ;;;;; ;;;; -; ;;;;;; ;;;;; ;;;; ;;;;;; ;;;; ;;;; ; ;;;; ;;;;;; ;;;; -; ;;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;;; ;;;; ;;;; -; ;;;;;;;; -; ;;;;;; -; - - (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 #f contract-stronger? - (-> integer? #:x integer? integer?) - (-> integer? #:y integer? integer?)) - (ctest #f contract-stronger? - (-> integer? #:y integer? integer?) - (-> integer? #:x integer? integer?)) - (ctest #t contract-stronger? - (-> integer? #:x integer? integer?) - (-> integer? #:x integer? integer?)) - (ctest #t contract-stronger? (-> #:x (>=/c 3) (>=/c 3)) (-> #:x (>=/c 3) (>=/c 2))) - - (let ([c (contract-eval '(->* () () any))]) - (test #t (contract-eval 'contract-stronger?) c c)) - (let ([c (contract-eval '(->d () () any))]) - (test #t (contract-eval 'contract-stronger?) c c)) - (let ([c (contract-eval '(->i () () any))]) - (test #t (contract-eval 'contract-stronger?) c c)) - - (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?))) - - (ctest #t contract-stronger? number? number?) - (ctest #f contract-stronger? boolean? number?) - - (ctest #t contract-stronger? (parameter/c (between/c 0 5)) (parameter/c (between/c 0 5))) - (ctest #f contract-stronger? (parameter/c (between/c 0 5)) (parameter/c (between/c 1 4))) - (ctest #f contract-stronger? (parameter/c (between/c 1 4)) (parameter/c (between/c 0 5))) - - (ctest #f contract-stronger? (parameter/c (between/c 1 4) (between/c 0 5)) - (parameter/c (between/c 0 5))) - (ctest #t contract-stronger? (parameter/c (between/c 0 5) (between/c 1 4)) - (parameter/c (between/c 1 4))) - (ctest #t contract-stronger? (parameter/c (between/c 0 5)) - (parameter/c (between/c 1 4) (between/c 0 5))) - (ctest #f contract-stronger? (parameter/c (between/c 1 4)) - (parameter/c (between/c 0 5) (between/c 0 5))) - (ctest #t contract-stronger? (parameter/c (between/c 0 5) (between/c 1 4)) - (parameter/c (between/c 1 4) (between/c 0 5))) - (ctest #f contract-stronger? (parameter/c (between/c 1 4) (between/c 0 5)) - (parameter/c (between/c 0 5) (between/c 1 4))) - - (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)) - - (ctest #t contract-stronger? - (or/c (-> (>=/c 3) (>=/c 3)) (-> string?)) - (or/c (-> (>=/c 4) (>=/c 3)) (-> string?))) - (ctest #f contract-stronger? - (or/c (-> string?) (-> integer? integer?)) - (or/c (-> string?) (-> any/c integer?))) - (ctest #f contract-stronger? - (or/c (-> string?) (-> any/c integer?)) - (or/c (-> string?) (-> integer? integer?))) - (ctest #t contract-stronger? - (or/c (-> string?) (-> integer? integer?) integer? boolean?) - (or/c (-> string?) (-> integer? integer?) integer? boolean?)) - (ctest #f contract-stronger? - (or/c (-> string?) (-> integer? integer?) integer? char?) - (or/c (-> string?) (-> integer? integer?) integer? boolean?)) - (ctest #f contract-stronger? - (or/c (-> string?) (-> integer? integer?) integer?) - (or/c (-> string?) (-> integer? integer?) integer? boolean?)) - (ctest #f contract-stronger? - (or/c (-> string?) (-> integer? integer?) integer?) - (or/c (-> integer? integer?) integer?)) - - (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)) - - (letrec ([mk-c - (λ (x) - (triple/dc [a (<=/c x)] - [b any/c] - [c (a b) (or/c #f (mk-c a))]))]) - (,test #t contract-stronger? (mk-c 1) (mk-c 2))))) - - - (contract-eval - `(let () - - (struct s (a b)) - (struct t (a b)) - - (,test #f contract-stronger? - (struct/dc s - [a (>=/c 1)] - [b (>=/c 2)]) - (struct/dc s - [a (>=/c 2)] - [b (>=/c 3)])) - (,test #t contract-stronger? - (struct/dc s - [a (>=/c 2)] - [b (>=/c 3)]) - (struct/dc s - [a (>=/c 1)] - [b (>=/c 2)])) - - (,test #f contract-stronger? - (struct/dc s - [a number?] - [b number?]) - (struct/dc t - [a number?] - [b number?])) - - (,test #f contract-stronger? - (struct/dc t - [a number?] - [b number?]) - (struct/dc s - [a number?] - [b number?])) - - (define (mk c) - (struct/dc s - [a (>=/c c)] - [b (a) (>=/c a)])) - (define one (mk 1)) - (define two (mk 2)) - (,test #f contract-stronger? one two) - (,test #t contract-stronger? two one))) - - - - - -; -; -; -; ;;; ;; ; ;;;; -; ;;;; ;; ;; ;;;; -; ;;;;; ;;; ;;; ;;;;; ;;;;; ;;;; ;;; ;;; ;;;;;;; ;;; ;;; ;;; -; ;;;; ;;;; ;;;;;;; ;;;;;; ;;;;;; ;;;;;; ;;;;;;; ;;;;;;;; ;;;;; ;;;;;;; -; ;;;;;; ;;;; ;;;; ;; ;;;; ;;;; ;;;;;;;; ;;;; ;; ;;;;;;;;; ;;;; ;; ;;;; ;; -; ;;;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;;;; ;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; -; ;;;; ;;;; ;;;; ;;;; ;;;;; ;;;;;;;;;;;;; ;;;; ;;;;;;;;; ;;;;; ;;;; -; ;;;; ;;;; ;;;; ;;;;;; ;;;;; ;;;;;; ;;;; ;;;;;;;; ;;;;;; ;;;; -; ;;;; ;;;; ;;;; ;;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;; -; -; -; - - (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)) - (ctest #f contract-first-order-passes? (-> integer? boolean? #:x integer? integer?) (λ (x y) #t)) - (ctest #t contract-first-order-passes? - (-> integer? boolean? #:x integer? integer?) - (λ (x y #:x z) #t)) - - (ctest #t contract-first-order-passes? - (->* (integer?) () #:rest any/c (values char? any/c)) - (λ (x . y) #f)) - (ctest #f contract-first-order-passes? - (->* (integer?) () #:rest any/c (values char? any/c)) - (λ (x y . z) #f)) - (ctest #f contract-first-order-passes? - (->* (integer?) () #:rest any/c (values char? any/c)) - (λ (x) #f)) - (ctest #t contract-first-order-passes? - (->* (integer?) () #:rest any/c (values char? any/c)) - (λ x #f)) - - (ctest #t contract-first-order-passes? (->d ((z any/c)) () (result any/c)) (λ (x) x)) - (ctest #f contract-first-order-passes? (->d ((z any/c)) () (result any/c)) (λ (x y) x)) - - (ctest #t contract-first-order-passes? (->i ((z any/c)) () (result any/c)) (λ (x) x)) - (ctest #f contract-first-order-passes? (->i ((z any/c)) () (result any/c)) (λ (x y) x)) - - (ctest #t contract-first-order-passes? (listof integer?) (list 1)) - (ctest #f contract-first-order-passes? (listof integer?) #f) - - (ctest #f contract-first-order-passes? (list/c #f #f #t) (list)) - (ctest #t contract-first-order-passes? (list/c #f 'x #t) (list #f 'x #t)) - (ctest #f contract-first-order-passes? (list/c (-> number? number?)) (list (λ (x y) x))) - (ctest #t contract-first-order-passes? (list/c (-> number? number?)) (list (λ (x) x))) - - (ctest #t contract-first-order-passes? (non-empty-listof integer?) (list 1)) - (ctest #f contract-first-order-passes? (non-empty-listof integer?) (list)) - - - (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?) '()) - - (ctest #t contract-first-order-passes? (promise/c integer?) (delay 1)) - (ctest #f contract-first-order-passes? (promise/c integer?) 1) - - (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)) - - (ctest #t contract-first-order-passes? - (cons/c boolean? (-> integer? integer?)) - (list* #t (λ (x) x))) - (ctest #f contract-first-order-passes? - (cons/c boolean? (-> integer? integer?)) - (list* 1 2)) - - (ctest #f contract-first-order-passes? (flat-rec-contract the-name) 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) - - (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) - - (ctest #t contract-first-order-passes? - (or/c (-> integer? integer? integer?) - (-> integer? integer?)) - (λ (x) x)) - (ctest #t contract-first-order-passes? - (or/c (-> integer? integer? integer?) - (-> integer? integer?)) - (λ (x y) x)) - (ctest #f contract-first-order-passes? - (or/c (-> integer? integer? integer?) - (-> integer? integer?)) - (λ () x)) - (ctest #f contract-first-order-passes? - (or/c (-> integer? integer? integer?) - (-> integer? integer?)) - 1) - - (ctest #t contract-first-order-passes? (hash/c any/c any/c) (make-hash)) - (ctest #f contract-first-order-passes? (hash/c any/c any/c) #f) - (ctest #f contract-first-order-passes? (hash/c symbol? boolean?) (let ([ht (make-hash)]) - (hash-set! ht 'x 1) - ht)) - (ctest #f contract-first-order-passes? (hash/c symbol? boolean? #:flat? #t) - (let ([ht (make-hash)]) (hash-set! ht 'x 1) ht)) - (ctest #f contract-first-order-passes? (hash/c symbol? boolean?) (let ([ht (make-hash)]) - (hash-set! ht 1 #f) - ht)) - (ctest #f contract-first-order-passes? (hash/c symbol? boolean? #:flat? #t) - (let ([ht (make-hash)]) (hash-set! ht 1 #f) ht)) - (ctest #t contract-first-order-passes? (hash/c symbol? boolean?) (let ([ht (make-hash)]) - (hash-set! ht 'x #t) - ht)) - - (test-name '(or/c) (or/c)) - (test-name '(or/c integer? gt0?) (or/c integer? (let ([gt0? (lambda (x) (> x 0))]) gt0?))) - (test-name '(or/c integer? boolean?) - (or/c (flat-contract integer?) - (flat-contract boolean?))) - (test-name '(or/c (-> (>=/c 5) (>=/c 5)) boolean?) - (or/c (-> (>=/c 5) (>=/c 5)) boolean?)) - (test-name '(or/c boolean? (-> (>=/c 5) (>=/c 5))) - (or/c boolean? (-> (>=/c 5) (>=/c 5)))) - - - (ctest 1 - length - (let ([f (contract (-> integer? any) - (lambda (x) - (with-continuation-mark 'x 'x - (continuation-mark-set->list (current-continuation-marks) 'x))) - 'pos - 'neg)]) - (with-continuation-mark 'x 'x - (f 1)))) - - (ctest 2 - length - (let ([f (contract (-> integer? list?) - (lambda (x) - (with-continuation-mark 'x 'x - (continuation-mark-set->list (current-continuation-marks) 'x))) - 'pos - 'neg)]) - (with-continuation-mark 'x 'x - (f 1)))) - - (ctest #t contract-first-order-passes? (or/c 'x "x" #rx"x") 'x) - (ctest #t contract-first-order-passes? (or/c 'x "x" #rx"x") "x") - (ctest #t contract-first-order-passes? (or/c 'x "x" #rx"x.") "xy") - (ctest #f contract-first-order-passes? (or/c 'x "x" #rx"x.") "yx") - (ctest #f contract-first-order-passes? (or/c 'x "x" #rx"x.") 'y) - - -; -; -; -; -; ; ;;; ;;; -; ;;; ;;; -; ;;;; ;;;;; ;;; ;;; -; ;;;; ;;;;;;; ;;; ;;; -; ;;; ;; ;;; ;;; ;;; -; ;;; ;;;;; ;;; ;;; -; ;;; ;;; ;;; ;;; ;;; -; ;;;; ;;; ;;; ;;; ;;; -; ;;; ;;;;;; ;;; ;;; -; -; -; -; - - (contract-eval - `(define (counter) - (let ([c 0]) - (case-lambda - [() c] - [(x) (set! c (+ c 1)) #t])))) - - (ctest/rewrite 1 - 'tail-arrow - (let ([c (counter)]) - (letrec ([f - (contract (-> any/c c) - (λ (x) (if (zero? x) x (f (- x 1)))) - 'pos - 'neg)]) - (f 3)) - (c))) - - (ctest/rewrite 1 - 'tail-unconstrained-domain-arrow - (let ([c (counter)]) - (letrec ([f - (contract (unconstrained-domain-> c) - (λ (x) (if (zero? x) x (f (- x 1)))) - 'pos - 'neg)]) - (f 3)) - (c))) - - (ctest/rewrite 2 - 'tail-multiple-value-arrow - (let ([c (counter)]) - (letrec ([f - (contract (-> any/c (values c c)) - (λ (x) (if (zero? x) (values x x) (f (- x 1)))) - 'pos - 'neg)]) - (f 3)) - (c))) - - (ctest/rewrite 2 - 'tail-arrow-star - (let ([c (counter)]) - (letrec ([f - (contract (->* (any/c) () (values c c)) - (λ (x) (if (zero? x) (values x x) (f (- x 1)))) - 'pos - 'neg)]) - (f 3)) - (c))) - - - (ctest/rewrite 1 - 'case->-regular - (let ([c (counter)]) - (letrec ([f - (contract (case-> (-> any/c c) - (-> any/c any/c c)) - (case-lambda - [(x) (if (zero? x) x (f (- x 1)))] - [(x y) (f x)]) - 'pos - 'neg)]) - (f 4 1)) - (c))) - - (ctest/rewrite 1 - 'case->-rest-args - (let ([c (counter)]) - (letrec ([f - (contract (case-> (-> any/c #:rest any/c c) - (-> any/c any/c #:rest any/c c)) - (case-lambda - [(x) (f x 1)] - [(x y . z) (if (zero? x) x (apply f (- x 1) y (list y y)))]) - 'pos - 'neg)]) - (f 4)) - (c))) - - (ctest/rewrite '(1) - 'mut-rec-with-any/c - (let () - (define f - (contract (-> number? any/c) - (lambda (x) - (if (zero? x) - (continuation-mark-set->list (current-continuation-marks) - 'tail-test) - (with-continuation-mark 'tail-test x - (g (- x 1))))) - 'something-that-is-not-pos - 'neg)) - - (define g - (contract (-> number? any/c) - (lambda (x) - (f x)) - 'also-this-is-not-pos - 'neg)) - - (f 3))) - - - (test/pos-blame - 'different-blame=>cannot-drop-check - '((contract (-> integer? integer?) - (λ (x) - ((contract (-> integer? integer?) - (λ (x) #f) - 'pos - 'neg) - x)) - 'abc - 'def) - 5)) - - (test/pos-blame 'free-vars-change-so-cannot-drop-the-check - '(let () - (define f - (contract (->i ([x number?]) () [_ (x) ( number? number?)]) - (test ctc value-contract (contract ctc (λ (x) x) 'pos 'neg))) - (let ([ctc (->* (number?) (number?) number?)]) - (test ctc value-contract (contract ctc (λ (x [y 3]) x) 'pos 'neg))) - (let ([ctc (->d ([x number?]) ([y number?]) [_ number?])]) - (test ctc value-contract (contract ctc (λ (x [y 3]) x) 'pos 'neg))) - (let ([ctc (->i ([x number?]) ([y number?]) [_ number?])]) - (test ctc value-contract (contract ctc (λ (x [y 3]) x) 'pos 'neg))) - (let ([ctc (unconstrained-domain-> number?)]) - (test ctc value-contract (contract ctc (λ (x) 3) 'pos 'neg))) - (let ([ctc (case-> (-> number? number? number?) (-> number? number?))]) - (test ctc value-contract (contract ctc (case-lambda [(x) 3] [(x y) (+ x y)]) 'pos 'neg))) - - (let ([ctc (box/c number?)]) - (test ctc value-contract (contract ctc (box 3) 'pos 'neg))) - (let ([ctc (hash/c number? number?)]) - (test ctc value-contract (contract ctc (make-hash) 'pos 'neg))) - (let ([ctc (vectorof number?)]) - (test ctc value-contract (contract ctc (vector 1 2 3) 'pos 'neg))) - (let ([ctc (vector/c number? number?)]) - (test ctc value-contract (contract ctc (vector 4 5) 'pos 'neg))) - - (let ([ctc (object-contract)]) - (test ctc value-contract (contract ctc (new object%) 'pos 'neg))) - -; -; -; -; -; -; ;;;;;; -; ; ; -; ; ; -; ; ;; ;;;; -; ;;;;;; ; ;;;;;; -; ; ; ;;; -; ; ; ;;; -; ; ;; ;;;;;; -; ;;;;;; ; ;;;; -; -; -; -; - - (test/spec-passed - '∃1 - '(contract (new-∃/c 'pair) - 1 - 'pos - 'neg)) - - (test/neg-blame - '∃2 - '((contract (-> (new-∃/c 'pair) any/c) - (λ (x) x) - 'pos - 'neg) - 1)) - - (test/spec-passed/result - '∃3 - '(let ([pair (new-∃/c 'pair)]) - ((contract (-> (-> pair pair) any/c) - (λ (f) (f 11)) - 'pos - 'neg) - (λ (x) x))) - 11) - - (test/pos-blame - '∀1 - '(contract (new-∀/c 'pair) - 1 - 'pos - 'neg)) - - (test/spec-passed - '∀2 - '((contract (-> (new-∀/c 'pair) any/c) - (λ (x) x) - 'pos - 'neg) - 1)) - - (test/spec-passed/result - '∀3 - '(let ([pair (new-∀/c 'pair)]) - ((contract (-> pair pair) - (λ (x) x) - 'pos - 'neg) - 11)) - 11) - - -; ; -; ; -; ; ; -; ;;;; ;;;; ;;;;;; ; ;;;; -; ; ; ; ; ; ; -; ;; ; ; ; ; ; -; ;; ;;;;;; ; ; ; -; ; ; ; ; ; -; ; ; ; ; ; -; ;;;; ;;;;; ;;; ; ;;;; -; ; -; ; -; - - (test/spec-passed/result - 'set/c1 - '(contract (set/c integer?) - (set 0) - 'pos 'neg) - (contract-eval '(set 0))) - - (test/pos-blame - 'set/c2 - '(contract (set/c integer?) - (set #t) - 'pos 'neg)) - - (test/pos-blame - 'set/c3 - '(contract (set/c integer? #:cmp 'eq) - (set 0) - 'pos 'neg)) - - (test/pos-blame - 'set/c4 - '(contract (set/c integer? #:cmp 'eqv) - (set 0) - 'pos 'neg)) - - (test/pos-blame - 'set/c5 - '(contract (set/c integer? #:cmp 'equal) - (seteq 0) - 'pos 'neg)) - - (test/spec-passed/result - 'set/c6 - '(set-map (contract (set/c integer?) - (set 0) - 'pos 'neg) - values) - (list 0)) - - (test/neg-blame - 'set/c7 - '(let ([s (set-map (contract (set/c (-> integer? integer?)) - (set (λ (x) #f)) - 'pos 'neg) - values)]) - ((car s) #f))) - - (test/pos-blame - 'set/c8 - '(let ([s (set-map (contract (set/c (-> integer? integer?)) - (set (λ (x) #f)) - 'pos 'neg) - values)]) - ((car s) 1))) - - -; -; -; -; -; ; ; -; ;;; ;;; -; ;;; ;;; ;;; ;; ;;;; ;;;; ;;; ;;; ;;;; -; ;;;;; ;;;;; ;;;;;;; ;;;; ;; ;;; ;; ;; ;;;; -; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;; ;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;;; ;;; ;;; -; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;; ;;; -; ;;;;; ;;;;; ;;; ;;; ;;;; ;;;;;; ;; ;; ;;;; -; ;;; ;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; -; -; -; -; - - (contract-eval '(define (extract-context-lines thunk) - (define str - (with-handlers ((exn:fail:contract:blame? exn-message)) - (thunk) - "didn't raise an exception")) - (define m (regexp-match #rx".*\n +in: (.*)$" str)) - (cond - [m - (define without-prefix (list-ref m 1)) - (define m2 (regexp-match #rx"(.*)\n *contract from:" without-prefix)) - (cond - [m2 - (define lines (regexp-split #rx"\n *" (list-ref m2 1))) - ;; drop the lines with the contract (keep lines beginning with an article) - (let loop ([lines (regexp-split #rx"\n *" (list-ref m2 1))]) - (cond - [(null? lines) '()] - [else - (define line (car lines)) - (cond - [(or (regexp-match #rx"^the " line) - (regexp-match #rx"^an " line) - (regexp-match #rx"^a " line)) - (cons line (loop (cdr lines)))] - [else - (loop (cdr lines))])]))] - [else - (string-append "did not find ``contract from:'', so no context in msg: " - str)])] - [else - (string-append "did not find ``in:'', so no context in msg: " - str)]))) - - (define (context-test context expression) - (contract-eval `(,test ',context extract-context-lines (lambda () ,expression))) - (let/ec k - (contract-eval `(,test ',context extract-context-lines (lambda () ,(rewrite expression k)))))) - - (context-test '("the 1st argument of") - '((contract (-> boolean? integer? integer?) - (λ (x y) x) - 'pos - 'neg) - 0 1)) - - (context-test '("the cdr of" "the 1st argument of") - '((contract (-> (cons/c integer? boolean?) integer? integer?) - (λ (x y) x) - 'pos - 'neg) - (cons 1 2) 1)) - - (context-test '("the 3rd element of" "the 2nd argument of") - '((contract (-> integer? (list/c integer? integer? boolean?) integer?) - (λ (x y) x) - 'pos - 'neg) - 1 (list 1 2 3))) - - (context-test '("the range of" "the 4th element of") - '((cadddr (contract (list/c integer? integer? boolean? (-> number? number?)) - (list 1 2 #f (λ (x) #f)) - 'pos - 'neg)) - 1)) - - (context-test '("a disjunct of") - '(contract (or/c 1 (-> number? number?)) - 3 - 'pos - 'neg)) - - (context-test '("the range of" "a disjunct of") - '((contract (or/c 1 (-> number? number?) (-> number? boolean? number?)) - (λ (x) #f) - 'pos - 'neg) - 1)) - - (context-test '("the 2nd conjunct of") - '(contract (and/c procedure? (-> integer? integer?)) - (λ (x y) 1) - 'pos - 'neg)) - - (context-test '("an element of") - '(contract (listof number?) - (list #f) - 'pos - 'neg)) - - (context-test '("the promise from") - '(force (contract (promise/c number?) - (delay #f) - 'pos - 'neg))) - - (context-test '("the parameter of") - '((contract (parameter/c number?) - (make-parameter #f) - 'pos - 'neg))) - (context-test '("the parameter of") - '((contract (parameter/c number?) - (make-parameter 1) - 'pos - 'neg) - #f)) - (context-test '("the #:x argument of") - '((contract (-> #:x number? #:a char? #:w boolean? any) - (λ (#:x x #:a a #:w w) x) - 'pos - 'neg) - #:a #\a #:w #f #:x 'two)) - - (context-test '("the #:a argument of") - '((contract (-> #:x number? #:a char? #:w boolean? any) - (λ (#:x x #:a a #:w w) x) - 'pos - 'neg) - #:a #f #:w #f #:x 2)) - - (context-test '("the #:w argument of") - '((contract (-> #:x number? #:a char? #:w boolean? any) - (λ (#:x x #:a a #:w w) x) - 'pos - 'neg) - #:a #\a #:w 'false #:x 2)) - - (context-test '("the #:x argument of") - '((contract (->* () (#:x number?) any) - (λ (#:x [x 1]) x) - 'pos - 'neg) - #:x #f)) - - (context-test '("the #:x argument of") - '((contract (->* () (#:x number? #:a char? #:w boolean?) any) - (λ (#:x [x 1] #:a [a #\a] #:w [w #f]) x) - 'pos - 'neg) - #:a #\a #:w #f #:x 'two)) - - (context-test '("the #:a argument of") - '((contract (->* () (#:x number? #:a char? #:w boolean?) any) - (λ (#:x [x 1] #:a [a #\a] #:w [w #f]) x) - 'pos - 'neg) - #:a #f #:w #f #:x 2)) - - (context-test '("the #:w argument of") - '((contract (->* () (#:x number? #:a char? #:w boolean?) any) - (λ (#:x [x 1] #:a [a #\a] #:w [w #f]) x) - 'pos - 'neg) - #:a #\a #:w 'false #:x 2)) - - (context-test '("the x argument of") - '((contract (->i ([w integer?] [x boolean?] [a char?]) any) - (λ (w x a) x) - 'pos - 'neg) - 1 'true #\a)) - - (context-test '("the x argument of") - '((contract (->i ([w integer?]) ([x boolean?] [a char?]) any) - (λ (w [x #t] [a #\a]) x) - 'pos - 'neg) - 1 'true #\a)) - - (context-test '("the y result of") - '((contract (->i () (values [x integer?] [y integer?])) - (λ () (values 1 #f)) - 'pos - 'neg))) - - (context-test '("the x result of") - '((contract (->i () (values [x integer?] [y integer?])) - (λ () (values #f 1)) - 'pos - 'neg))) - - (context-test '("the _ result of") - '((contract (->i ([x integer?]) [_ (x) (<=/c x)]) - add1 - 'pos - 'neg) - 1)) - - (context-test '("the a argument of") - '((contract (->i ([a integer?] #:b [b integer?]) ([c integer?] #:d [d integer?]) any) - (λ (a #:b b [c 1] #:d [d 1]) 1) - 'pos - 'neg) - 'one #:b 2 3 #:d 4)) - - (context-test '("the b argument of") - '((contract (->i ([a integer?] #:b [b integer?]) ([c integer?] #:d [d integer?]) any) - (λ (a #:b b [c 1] #:d [d 1]) 1) - 'pos - 'neg) - 1 #:b 'two 3 #:d 4)) - - (context-test '("the c argument of") - '((contract (->i ([a integer?] #:b [b integer?]) ([c integer?] #:d [d integer?]) any) - (λ (a #:b b [c 1] #:d [d 1]) 1) - 'pos - 'neg) - 1 #:b 2 'three #:d 4)) - - (context-test '("the d argument of") - '((contract (->i ([a integer?] #:b [b integer?]) ([c integer?] #:d [d integer?]) any) - (λ (a #:b b [c 1] #:d [d 1]) 1) - 'pos - 'neg) - 1 #:b 2 3 #:d 'four)) - - ;; indy - (context-test '("the 2nd argument of" "the x argument of") - '((contract (->i ([x (-> number? boolean? integer?)] [a (x) (>=/c (x 11 'true))]) any) - (λ (x a) x) - 'pos - 'neg) - (λ (x y) 1) 11)) - - (context-test '("the 2nd argument of" "the x result of") - '((contract - (->i () (values [x (-> number? boolean? integer?)] [a (x) (>=/c (x 11 'true))])) - (λ () (values (λ (x y) x) 1)) - 'pos - 'neg))) - - (context-test '("the x argument of") - '((contract (->i ([x () integer?]) any) - (λ (x) x) - 'pos - 'neg) - #f)) - - (context-test '("the a argument of") - '((contract (->i ([a integer?] [x (a) integer?]) any) - (λ (a x) x) - 'pos - 'neg) - #f 1)) - - (context-test '("the 1st result of") - '((contract (->i () (values [_ integer?] [_ integer?])) - (λ () (values #f 1)) - 'pos - 'neg))) - - (context-test '("the result of") - '((contract (->i () [_ integer?]) - (λ () (values #f)) - 'pos - 'neg))) - - (context-test '("the domain of") - '((contract (->d ([x integer?]) [y integer?]) - (λ (x) #f) - 'pos - 'neg) - #f)) - - (context-test '("the range of") - '((contract (->d ([x integer?]) [y integer?]) - (λ (x) #f) - 'pos - 'neg) - 1)) - - (context-test '("the range of") - '(letrec ([ctc (-> integer? (recursive-contract ctc))]) - (letrec ([f (λ (x) 'not-f)]) - ((contract ctc f 'pos 'neg) 1)))) - - (context-test '("the a field of") - '(let () - (struct s (a b)) - (contract (struct/dc s [a (b) (<=/c b)] [b integer?]) - (s 2 1) - 'pos - 'neg))) - - (context-test '("the a field of") - '(let () - (struct s (a b)) - (contract (struct/dc s [a (<=/c 1)] [b integer?]) - (s 2 1) - 'pos - 'neg))) - - (context-test '("an element of" "the 2nd element of") - '(vector-ref - (vector-ref - (contract (vector/c (vectorof real?) (vectorof number?) (vectorof boolean?)) - (vector (vector 1) (vector 1) (vector 1)) - 'pos - 'neg) - 2) - 0)) - - (context-test '("the 0th element of") - '(vector-ref (contract (vector/c integer?) - (vector #f) - 'pos - 'neg) - 0)) - - (context-test '("the 0th element of") - '(vector-ref (contract (vector/c (-> integer? integer?)) - (vector #f) - 'pos - 'neg) - 0)) - - (context-test '("the 0th element of") - '(vector-ref (contract (vector/c (new-∀/c 'α)) - (vector #f) - 'pos - 'neg) - 0)) - - (context-test '("an element of") - '(vector-ref - (contract (vectorof integer?) - (vector #f) - 'pos - 'neg) - 0)) - - (context-test '("an element of") - '(vector-ref (contract (vectorof (-> integer? integer?)) - (vector #f) - 'pos - 'neg) - 0)) - - (context-test '("an element of") - '(vector-ref (contract (vectorof (new-∀/c 'α)) - (vector #f) - 'pos - 'neg) - 0)) - - (context-test '("the keys of") - '(contract (hash/c integer? (-> integer? integer?)) - (hash #f (λ (x) #f)) - 'pos - 'neg)) - - (context-test '("the range of" "the values of") - '((hash-ref - (contract (hash/c integer? (-> integer? integer?)) - (hash 0 (λ (x) #f)) - 'pos - 'neg) - 0) - 1)) - - (context-test '("an element of" "the rest argument of") - '((contract (->* () #:rest (listof number?) number?) - + - 'pos 'neg) - 1 "a")) - - (context-test '("the 2nd argument of") - '((contract (->* (number? number?) #:rest (listof number?) number?) - + - 'pos 'neg) - 1 "a")) - - (context-test '("an element of" "the rest argument of") - '((contract (->* (number?) #:rest (listof number?) number?) - + - 'pos 'neg) - 1 "a")) - - (context-test '("the range of" "the 2nd case of") - '((contract (case-> (-> real? real? real?) - (-> real? (values real? real?))) - (case-lambda - [(x y) 1] - [(x) 1]) - 'pos 'neg) - 1)) - - (context-test '("the domain of" "the 2nd case of") - '((contract (case-> (-> real? real? real?) - (-> real? (values real? real?))) - (case-lambda - [(x y) 1] - [(x) 1]) - 'pos 'neg) - #f)) - - (context-test '("the 1st argument of" "the save-file method in") - '(send (contract (object/c - (save-file (->m string? string?))) - (new (class object% - (define/public (save-file s . args) #f) - (super-new))) - 'pos - 'neg) - save-file 1)) - - (context-test '("the f field in") - '(get-field - f - (contract (object/c (field [f string?])) - (new (class object% - (field [f 1]) - (super-new))) - 'pos - 'neg))) - - (context-test '("the 1st argument of" "the f field in") - '((get-field - f - (contract (object/c (field [f (-> string? any)])) - (new (class object% - (field [f (λ (x) 1)]) - (super-new))) - 'pos - 'neg)) - #f)) - - - (let* ([blame-pos (contract-eval '(make-blame (srcloc #f #f #f #f #f) - #f - (λ () 'integer?) - 'positive - 'negative - #t))] - [blame-neg (contract-eval `(blame-swap ,blame-pos))]) - (ctest "something ~a" blame-fmt->-string ,blame-neg "something ~a") - (ctest "promised: ~s\n produced: ~e" blame-fmt->-string ,blame-pos '(expected: "~s" given: "~e")) - (ctest "expected: ~s\n given: ~e" blame-fmt->-string ,blame-neg '(expected: "~s" given: "~e")) - (ctest "promised ~s produced ~e" blame-fmt->-string ,blame-pos '(expected "~s" given "~e")) - (ctest "expected ~s given ~e" blame-fmt->-string ,blame-neg '(expected "~s" given "~e"))) - -; -; -; -; ;; -; ;; ;; -; ;; -; ;;;; ;;;; ;;; ;;;; ;;;; ;;;;;;;; ;; ;;;; ;;; -; ;;;;; ;;;;;;;;; ;;;;; ;;;;;;;;;;;;;; ;; ;;;;;;;;;;; -; ;; ;; ;; ;; ;; ;; ;; ;;; ;;;; ;; ;; ;;;;;;;; -; ;; ;; ;; ;; ;; ;; ;; ;;;;;;;; ;; ;; ;;;;;; ;;; -; ;;;;; ;; ;;;;; ;;;;; ;;;;;;;; ;; ;; ;;;;;;;; ;; -; ;;;; ;; ;;; ;;;; ;;;; ;; ;;; ;; ;;;; ;;; -; ;; ;; -; ;; ;; -; - - - (test-obligations '(-> a b) - '((racket/contract:contract (->) ()) - (racket/contract:negative-position a) - (racket/contract:positive-position b))) - (test-obligations '(->i ([x a]) any) - '((racket/contract:contract (->i) ()) - (racket/contract:contract-on-boundary a) - (racket/contract:negative-position a))) - (test-obligations '(->i ([x a]) [res b]) - '((racket/contract:contract (->i) ()) - (racket/contract:contract-on-boundary a) - (racket/contract:contract-on-boundary b) - (racket/contract:negative-position a) - (racket/contract:positive-position b))) - (test-obligations '(->i ([x a]) #:pre () #t [res b] #:post () #t) - '((racket/contract:contract (#:post ->i) (#:pre)) - (racket/contract:contract-on-boundary a) - (racket/contract:contract-on-boundary b) - (racket/contract:negative-position a) - (racket/contract:positive-position b))) - (test-obligations '(listof a) - '((racket/contract:contract (listof) ()) - (racket/contract:positive-position a))) - (test-obligations '(hash/c a b) - '((racket/contract:contract (hash/c) ()) - (racket/contract:negative-position a) - (racket/contract:positive-position b))) - (test-obligations '(box/c a) - '((racket/contract:contract (box/c) ()) - (racket/contract:negative-position a) - (racket/contract:positive-position a))) - (test-obligations '(box-immutable/c a) - '((racket/contract:contract (box-immutable/c) ()) - (racket/contract:positive-position a))) - (test-obligations '(vectorof a) - '((racket/contract:contract (vectorof) ()) - (racket/contract:negative-position a) - (racket/contract:positive-position a))) - (test-obligations '(vector-immutableof a) - '((racket/contract:contract (vector-immutableof) ()) - (racket/contract:positive-position a))) - (test-obligations '(vector/c a b c) - '((racket/contract:contract (vector/c) ()) - (racket/contract:negative-position a) - (racket/contract:negative-position b) - (racket/contract:negative-position c) - (racket/contract:positive-position a) - (racket/contract:positive-position b) - (racket/contract:positive-position c))) - (test-obligations '(vector-immutable/c a b c) - '((racket/contract:contract (vector-immutable/c) ()) - (racket/contract:positive-position a) - (racket/contract:positive-position b) - (racket/contract:positive-position c))) - - -; -; -; -; ;; ;;;; ;; -; ;; ;;;; ;; -; ;;;;;;; ;;; ;;; ;;;; ;;; ;;; ;;;;;;; ;;; ;; -; ;;;;;;;; ;;;;;;; ;;;;;; ;;; ;;; ;;;; ;;;;;;;; ;;;;; ;; -; ;;;;;;;;; ;;;; ;; ;;;;;;;; ;;;;;; ;;;; ;;;;;;;;; ;;;; ;; ;; -; ;;;; ;;;; ;;;; ;;;; ;;; ;;;;;; ;;;; ;;;; ;;;; ;;;;;;; ;; -; ;;;;;;;;; ;;;; ;;;;;;;; ;;;;;; ;;;; ;;;;;;;;; ;;;;; ;; -; ;;;;;;;; ;;;; ;;;;;; ;;;; ;;;; ;;;;;;;; ;;;;;; ;; -; ;;;;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;; -; ;;;; ;; -; ;;;; -; -; -; -; -; ; ; -; ;; ;; -; ;;;;; ;;;; ;;;; ;;; ;;;;; ;;; ;;; ;;;;;;; ;;;;; ;;;;; -; ;;;;;; ;;;;;; ;;;;;;;;; ;;;;;; ;;;;;;; ;;;;;;;; ;;;;;; ;;;;;; -; ;;;;;;; ;;;;;;;; ;;;; ;;;; ;;;; ;;;; ;; ;;;; ;;;;;;; ;;;; -; ;;;; ;;;; ;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;; -; ;;;;;;; ;;;;;;;; ;;;; ;;;; ;;;;; ;;;; ;; ;;;; ;;;;;;; ;;;;; -; ;;;;;; ;;;;;; ;;;; ;;;; ;;;;; ;;;; ;;;;;;;; ;;;;;; ;;;;; -; ;;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;; ;;;; ;;;;; ;;;; -; -; -; - - ;; - ;; (at the end, because they are slow w/out .zo files) - ;; - - (test/spec-passed - 'provide/contract1 - '(let () - (eval '(module contract-test-suite1 scheme/base - (require scheme/contract) - (define x 1) - (provide/contract (x integer?)))) - (eval '(require 'contract-test-suite1)) - (eval 'x))) - - (test/spec-passed - 'provide/contract2 - '(let () - (eval '(module contract-test-suite2 scheme/base - (require scheme/contract) - (provide/contract))) - (eval '(require 'contract-test-suite2)))) - - (test/spec-failed - 'provide/contract3 - '(let () - (eval '(module contract-test-suite3 scheme/base - (require scheme/contract) - (define x #f) - (provide/contract (x integer?)))) - (eval '(require 'contract-test-suite3)) - (eval 'x)) - "contract-test-suite3") - - (test/spec-passed - 'provide/contract4 - '(begin - (eval '(module contract-test-suite4 scheme/base - (require scheme/contract) - (define-struct s (a) #:mutable) - (provide/contract (struct s ((a any/c)))))) - (eval '(require 'contract-test-suite4)) - (eval '(list (make-s 1) - (s-a (make-s 1)) - (s? (make-s 1)) - (set-s-a! (make-s 1) 2))))) - - (test/spec-passed - 'provide/contract4-b - '(begin - (eval '(module contract-test-suite4-b scheme/base - (require scheme/contract) - (define-struct s (a)) - (provide/contract (struct s ((a any/c)))))) - (eval '(require 'contract-test-suite4-b)) - (eval '(list (make-s 1) - (s-a (make-s 1)) - (s? (make-s 1)))))) - - (test/spec-passed/result - 'provide/contract4-c - '(begin - (eval '(module contract-test-suite4-c scheme/base - (require scheme/contract) - (define-struct s (a b) #:mutable) - (provide/contract (struct s ((a any/c) (b any/c)))))) - (eval '(require 'contract-test-suite4-c)) - (eval '(let ([an-s (make-s 1 2)]) - (list (s-a an-s) - (s-b an-s) - (begin (set-s-a! an-s 3) - (s-a an-s)) - (begin (set-s-b! an-s 4) - (s-b an-s)))))) - - (list 1 2 3 4)) - - (test/spec-passed - 'provide/contract5 - '(begin - (eval '(module contract-test-suite5 scheme/base - (require scheme/contract) - (define-struct s (a)) - (define-struct t (a)) - (provide/contract (struct s ((a any/c))) - (struct t ((a any/c)))))) - (eval '(require 'contract-test-suite5)) - (eval '(list (make-s 1) - (s-a (make-s 1)) - (s? (make-s 1)) - (make-t 1) - (t-a (make-t 1)) - (t? (make-t 1)))))) - - (test/spec-passed - 'provide/contract6 - '(begin - (eval '(module contract-test-suite6 scheme/base - (require scheme/contract) - (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/contract6b - '(begin - (eval '(module contract-test-suite6b scheme/base - (require scheme/contract) - (define-struct s_ (a)) - (provide/contract (struct s_ ((a any/c)))))) - (eval '(require 'contract-test-suite6b)) - (eval '(module contract-test-suite6b2 scheme/base - (require 'contract-test-suite6b) - (require scheme/contract) - (define-struct (t_ s_) (b)) - (provide s_-a) - (provide/contract (struct (t_ s_) ((a any/c) (b any/c)))))) - (eval '(require 'contract-test-suite6b2)) - (eval '(define-struct (u_ t_) ())) - (eval '(s_-a (make-u_ 1 2))))) - - (test/spec-passed - 'provide/contract7 - '(begin - (eval '(module contract-test-suite7 scheme/base - (require scheme/contract) - (define-struct s (a b)) - (define-struct (t s) (c d)) - (provide/contract - (struct s ((a any/c) (b any/c))) - (struct (t s) ((a any/c) (b any/c) (c any/c) (d any/c)))))) - (eval '(require 'contract-test-suite7)) - (eval '(let ([x (make-t 1 2 3 4)]) - (s-a x) - (s-b x) - (t-c x) - (t-d x) - (void))))) - - (test/spec-passed - 'provide/contract8 - '(begin - (eval '(module contract-test-suite8 scheme/base - (require scheme/contract) - (define-struct i-s (contents)) - (define (w-f-s? x) #t) - (provide/contract - (struct i-s ((contents (flat-named-contract "integer-set-list" w-f-s?))))))) - (eval '(require 'contract-test-suite8)) - (eval '(i-s-contents (make-i-s 1))))) - - (test/spec-passed - 'provide/contract9 - '(begin - (eval '(module contract-test-suite9 scheme/base - (require scheme/contract) - (define the-internal-name 1) - (provide/contract (rename the-internal-name the-external-name integer?)) - (+ the-internal-name 1))) - (eval '(require 'contract-test-suite9)) - (eval '(+ the-external-name 1)))) - - (test/spec-passed - 'provide/contract10 - '(begin - (eval '(module pc10-m scheme/base - (require scheme/contract) - (define-struct s (a b) #:inspector (make-inspector)) - (provide/contract (struct s ((a number?) (b number?)))))) - (eval '(module pc10-n scheme/base - (require mzlib/struct - 'pc10-m) - (print-struct #t) - (copy-struct s - (make-s 1 2) - [s-a 3]))) - (eval '(require 'pc10-n)))) - - (test/spec-passed - 'provide/contract11 - '(begin - (eval '(module pc11-m scheme/base - (require scheme/contract) - (define x 1) - (provide/contract [rename x y integer?] - [rename x z integer?]))) - (eval '(module pc11-n scheme/base - (require 'pc11-m) - (+ y z))) - (eval '(require 'pc11-n)))) - - ;; this test is broken, not sure why - #| - (test/spec-failed - 'provide/contract11b - '(parameterize ([current-namespace (make-namespace)]) - (eval '(module pc11b-m scheme/base - (require scheme/contract) - (define-struct s (a b) #:inspector (make-inspector)) - (provide/contract (struct s ((a number?) (b number?)))))) - (eval '(module pc11b-n scheme/base - (require mzlib/struct - m) - (print-struct #t) - (copy-struct s - (make-s 1 2) - [s-a #f]))) - (eval '(require 'pc11b-n))) - "n") -|# - - (test/spec-passed - 'provide/contract12 - '(begin - (eval '(module pc12-m scheme/base - (require scheme/contract) - (define-struct (exn2 exn) ()) - (provide/contract (struct (exn2 exn) ((message any/c) (continuation-marks any/c)))))) - (eval '(require 'pc12-m)))) - - (test/spec-passed/result - 'provide/contract13 - '(begin - (eval '(module pc13-common-msg-structs scheme/base - (require scheme/contract) - (define-struct register (name type) #:inspector (make-inspector)) - (provide/contract (struct register ([name any/c] [type any/c]))))) - - (eval '(require 'pc13-common-msg-structs)) - (eval '(require (lib "plt-match.rkt"))) - (eval '(match (make-register 1 2) - [(struct register (name type)) - (list name type)]))) - (list 1 2)) - - (test/spec-passed - 'provide/contract14 - '(begin - (eval '(module pc14-test1 scheme/base - (require scheme/contract) - - (define-struct type (flags)) - (define-struct (type:ptr type) (type)) - - (provide/contract - (struct type - ([flags (listof string?)])) - - (struct (type:ptr type) - ([flags (listof string?)] [type type?]))))) - - (eval '(module pc14-test2 scheme/base - (require mzlib/plt-match) - (require 'pc14-test1) - (match (make-type:ptr '() (make-type '())) - [(struct type:ptr (flags type)) #f]))) - (eval '(require 'pc14-test2)))) - - ;; make sure unbound identifier exception is raised. - (contract-error-test - 'contract-error-test7 - #'(begin - (eval '(module pos scheme/base - (require scheme/contract) - (provide/contract [i any/c])))) - exn:fail:syntax?) - - ;; provide/contract should signal errors without requiring a reference to the variable - ;; this test is bogus, because provide/contract'd variables can be set!'d. - (test/spec-failed - 'provide/contract15 - '(begin - (eval '(module pos scheme/base - (require scheme/contract) - (define i #f) - (provide/contract [i integer?]))) - (eval '(require 'pos))) - "pos") - - ;; this is really a positive violation, but name the module `neg' just for an addl test - (test/spec-failed - 'provide/contract16 - '(begin - (eval '(module neg scheme/base - (require scheme/contract) - (define i #f) - (provide/contract [i integer?]))) - (eval '(require 'neg))) - "neg") - - ;; this test doesn't pass yet ... waiting for support from define-struct - - #; - (test/neg-blame - 'provide/contract17 - '(begin - (eval '(module pos scheme/base - (require scheme/contract) - (define-struct s (a)) - (provide/contract [struct s ((a integer?))]))) - (eval '(module neg scheme/base - (require 'pos) - (define-struct (t s) ()) - (make-t #f))) - (eval '(require 'neg)))) - - (test/spec-passed - 'provide/contract18 - '(begin - (eval '(module pc18-pos scheme/base - (require scheme/contract) - (define-struct s ()) - (provide/contract [struct s ()]))) - (eval '(require 'pc18-pos)) - (eval '(make-s)))) - - (test/spec-passed/result - 'provide/contract19 - '(begin - (eval '(module pc19-a scheme/base - (require scheme/contract) - (define-struct a (x)) - (provide/contract [struct a ([x number?])]))) - - (eval '(module pc19-b scheme/base - (require 'pc19-a - scheme/contract) - (define-struct (b a) (y)) - (provide/contract [struct (b a) ([x number?] [y number?])]))) - - (eval '(module pc19-c scheme/base - (require 'pc19-b - scheme/contract) - - (define-struct (c b) (z)) - (provide/contract [struct (c b) ([x number?] [y number?] [z number?])]))) - - (eval' (module pc19-d scheme/base - (require 'pc19-a 'pc19-c) - (define pc19-ans (a-x (make-c 1 2 3))) - (provide pc19-ans))) - - (eval '(require 'pc19-d)) - (eval 'pc19-ans)) - 1) - - ;; test that unit & contract don't collide over the name `struct' - (test/spec-passed - 'provide/contract20 - '(eval '(module tmp scheme/base - (require scheme/contract - mzlib/unit) - - (define-struct s (a b)) - - (provide/contract - [struct s ([a number?] - [b symbol?])])))) - - (test/spec-passed - 'provide/contract21 - '(begin - (eval '(module provide/contract21a scheme/base - (require scheme/contract) - (provide/contract [f integer?]) - (define f 1))) - (eval '(module provide/contract21b scheme/base - (require (for-syntax 'provide/contract21a) - (for-syntax scheme/base)) - (define-syntax (unit-body stx) - f f - #'1))))) - - (test/spec-passed - 'provide/contract22 - '(begin - (eval '(module provide/contract22a scheme/base - (require scheme/contract) - (provide/contract [make-bound-identifier-mapping integer?]) - (define make-bound-identifier-mapping 1))) - (eval '(module provide/contract22b scheme/base - (require (for-syntax 'provide/contract22a) - (for-syntax scheme/base)) - - (define-syntax (unit-body stx) - make-bound-identifier-mapping) - - (define-syntax (f stx) - make-bound-identifier-mapping))))) - - (test/spec-passed - 'provide/contract23 - '(begin - (eval '(module provide/contract23a scheme/base - (require scheme/contract) - (provide/contract [f integer?]) - (define f 3))) - - (eval '(module provide/contract23b scheme/base - (require 'provide/contract23a) - (#%expression f) - f)) - - (eval '(require 'provide/contract23b)))) - -#| - (test/spec-passed - 'provide/contract24 - '(begin - (eval '(module provide/contract24 scheme/base - (require (prefix-in c: scheme/contract)) - (c:case-> (c:-> integer? integer?) - (c:-> integer? integer? integer?)))))) - |# - - ;; tests that contracts pick up the #%app from the context - ;; instead of always using the scheme/base #%app. - (test/spec-passed - 'provide/contract25 - '(begin - (eval '(module provide/contract25a scheme/base - (require scheme/contract) - (provide/contract [seventeen integer?]) - (define seventeen 17))) - (eval '(module provide/contract25b scheme/base - (require 'provide/contract25a) - (let-syntax ([#%app (syntax-rules () - [(#%app e ...) (list e ...)])]) - (seventeen 18)))) - (eval '(require 'provide/contract25b)))) - - (test/spec-passed/result - 'provide/contract26 - '(begin - (eval '(module provide/contract26 scheme/base - (require scheme/contract) - (define-struct pc26-s (a)) - (provide/contract (struct pc26-s ((a integer?)))))) - (eval '(require 'provide/contract26)) - (eval '(pc26-s-a (make-pc26-s 1)))) - 1) - - (test/spec-passed/result - 'provide/contract27 - '(begin - (eval '(module provide/contract27a scheme/base - (require scheme/contract) - (define-struct person (name) #:transparent) - (provide/contract (struct person ([name string?]))))) - (eval '(module provide/contract27b scheme/base - (require 'provide/contract27a) - (provide (struct-out person)))) - (eval '(module provide/contract27c scheme/base - (require 'provide/contract27b) - (define provide/contract27ans (person-name (make-person "me"))) - (provide provide/contract27ans))) - (eval '(require 'provide/contract27c)) - (eval 'provide/contract27ans)) - "me") - - #; - (test/spec-passed/result - 'provide/contract28 - '(begin - (eval '(module provide/contract28-m1 scheme/base - (require scheme/contract) - (define-struct repair () #:transparent) - (provide/contract [struct repair ()]))) - (eval '(module provide/contract28-m2 scheme/base - (require 'provide/contract28-m1 scheme/contract) - (provide/contract [struct repair ()]))) - (eval '(module provide/contract28-m3 scheme/base - (require 'provide/contract28-m2) - (provide provide/contract28-res) - (define provide/contract28-res (repair? (make-repair))))) - (eval '(require 'provide/contract28-m3)) - (eval 'provide/contract28-res)) - #t) - - #; - (test/spec-passed/result - 'provide/contract29 - '(begin - (eval '(module provide/contract29-m1 scheme/base - (require scheme/contract) - (define-struct q (a b)) - (define-struct (repair q) (c d) #:transparent) - (provide/contract - [struct repair ([a integer?] [b integer?] [c integer?] [d integer?])]))) - (eval '(module provide/contract29-m2 scheme/base - (require 'provide/contract29-m1 scheme/contract) - (provide/contract - [struct repair ([a integer?] [b integer?] [c integer?] [d integer?])]))) - (eval '(module provide/contract29-m3 scheme/base - (require 'provide/contract29-m2) - (provide provide/contract29-res) - (define provide/contract29-res (list (repair? (make-repair 1 2 3 4)) - (repair-c (make-repair 1 2 3 4)))))) - (eval '(require 'provide/contract29-m3)) - (eval 'provide/contract29-res)) - (list #t 3)) - - ;; for this test I have to be able to track back thru the requirees to find the right - ;; name for the negative blame (currently it blames m3, but it should blame m2). - #; - (test/spec-failed - 'provide/contract30 - '(begin - (eval '(module provide/contract30-m1 scheme/base - (require scheme/contract) - (provide/contract [f (-> integer? integer?)]) - (define (f x) x))) - (eval '(module provide/contract30-m2 scheme/base - (require 'provide/contract30-m1) - (provide f))) - (eval '(module provide/contract30-m3 scheme/base - (require 'provide/contract30-m2) - (f #f))) - (eval '(require 'provide/contract30-m3))) - "provide/contract30-m2") - - (test/spec-passed/result - 'provide/contract31 - '(begin - (eval '(module provide/contract31-m1 scheme/base - (require scheme/contract) - (provide/contract - #:∃ x - [f (-> (-> x x) 10)]) - (define (f g) (g 10)))) - - (eval '(module provide/contract31-m2 scheme/base - (require scheme/contract 'provide/contract31-m1) - (provide provide/contract31-x) - (define provide/contract31-x (f (λ (x) x))))) - - (eval '(require 'provide/contract31-m2)) - (eval 'provide/contract31-x)) - 10) - - (test/spec-passed/result - 'provide/contract32 - '(begin - (eval '(module provide/contract32-m1 scheme/base - (require scheme/contract) - (provide/contract - #:exists x - [f (-> (-> x x) 10)]) - (define (f g) (g 10)))) - - (eval '(module provide/contract32-m2 scheme/base - (require scheme/contract 'provide/contract32-m1) - (provide provide/contract32-x) - (define provide/contract32-x (f (λ (x) x))))) - - (eval '(require 'provide/contract32-m2)) - (eval 'provide/contract32-x)) - 10) - - (test/spec-passed/result - 'provide/contract33 - '(begin - (eval '(module provide/contract33-m1 scheme/base - (require scheme/contract) - (provide/contract - #:exists (x) - [f (-> (-> x x) 10)]) - (define (f g) (g 10)))) - - (eval '(module provide/contract33-m2 scheme/base - (require scheme/contract 'provide/contract33-m1) - (provide provide/contract33-x) - (define provide/contract33-x (f (λ (x) x))))) - - (eval '(require 'provide/contract33-m2)) - (eval 'provide/contract33-x)) - 10) - - (test/spec-passed/result - 'provide/contract34 - '(begin - (eval '(module provide/contract34-m1 scheme/base - (require scheme/contract) - (define x integer?) - (define g 11) - (provide/contract - [g x] - #:exists (x) - [f (-> (-> x x) 10)]) - (define (f g) (g 10)))) - - (eval '(module provide/contract34-m2 scheme/base - (require scheme/contract 'provide/contract34-m1) - (provide provide/contract34-x) - (define provide/contract34-x (f (λ (x) x))))) - - (eval '(require 'provide/contract34-m2)) - (eval 'provide/contract34-x)) - 10) - - - ;; The following test is designed to test that source locations for contracts - ;; survive compilation and being saved to disk (and thus aren't recorded by - ;; quoted syntax object constant embedded in the expansion). - (let () - ;; compile/wash : like compile, but reads and writes the data - ;; so that source locations (and other things presumably) get dumped. - (define (compile/wash x) - (let-values ([(in out) (make-pipe)]) - (thread - (λ () (write (contract-compile x) out))) - (parameterize ([read-accept-compiled #t]) - (read in)))) - - ;; drop-var-info : syntax -> syntax - ;; strips the lexical content from the syntax object, but preserves the source locations - (define (drop-var-info stx) - (let loop ([stx stx]) - (cond - [(syntax? stx) - (datum->syntax #f (loop (syntax-e stx)) stx)] - [(pair? stx) - (cons (loop (car stx)) - (loop (cdr stx)))] - [else stx]))) - - ;; WARNING: do not add or remove lines between here-line and the two modules - ;; below it, unless you also revise the expected result of the test case. - (define here-line (syntax-line #'here)) - - (contract-eval - (compile/wash - (drop-var-info - #'(module provide/contract-35/m racket/base - (require racket/contract) - (define (f x) x) - (provide/contract [f (-> integer? integer?)]))))) - - (contract-eval - (compile/wash - (drop-var-info - #'(module provide/contract-35/n racket/base - (require 'provide/contract-35/m) - (f #f))))) - - (test (format "contract-test.rktl:~a.30" - (+ here-line 8)) - 'provide/contract-compiled-source-locs - (with-handlers ((exn:fail? - (λ (x) - (define m - (regexp-match #rx"contract-test.rktl[^ ]*.30" (exn-message x))) - (and m (car m))))) - (contract-eval '(require 'provide/contract-35/n))))) - - ;; test that provide/contract by itself in a module doesn't signal an error - (test/spec-passed/result - 'provide/contract35 - '(begin - (eval '(module provide/contract35-m1 racket - (provide/contract [add1 (-> number? number?)]))) - - (eval '(module provide/contract35-m2 racket/base - (require 'provide/contract35-m1) - (provide provide/contract35-three) - (define provide/contract35-three (add1 2)))) - - (eval '(require 'provide/contract35-m2)) - (eval 'provide/contract35-three)) - 3) - - (test/spec-passed/result - 'provide/contract36 - '(begin - - (eval '(module provide/contract36-m racket/base - (require racket/contract) - (struct a (x)) - (struct b a ()) - (provide/contract - [struct a ((x symbol?))] - [struct (b a) ((x symbol?))]))) - - (eval '(module provide/contract36-n racket/base - (require 'provide/contract36-m) - (provide new-b-x) - (define new-b-x - (a-x - (struct-copy b (b 'x) - [x #:parent a 'y]))))) - - (eval '(require 'provide/contract36-n)) - (eval 'new-b-x)) - 'y) - - (test/spec-failed - 'provide/contract37 - '(begin - - (eval '(module provide/contract37-m racket/base - (require racket/contract) - (struct a (x)) - (struct b a ()) - (provide/contract - [struct a ((x symbol?))] - [struct (b a) ((x symbol?))]))) - - (eval '(module provide/contract37-n racket/base - (require 'provide/contract37-m) - (struct-copy b (b 'x) - [x #:parent a 5]))) - - (eval '(require 'provide/contract37-n))) - "provide/contract37-n") - - (test/spec-passed/result - 'provide/contract38 - '(begin - (eval - '(module provide/contract38-a racket - (define-struct s () #:transparent) - (provide/contract [struct s ()]))) - - (eval - '(module provide/contract38-b racket - (require 'provide/contract38-a) - (define a-struct (make-s)) - (define-values (type _) (struct-info a-struct)) - (provide the-answer) - (define the-answer (eq? type struct:s)))) - - (dynamic-require ''provide/contract38-b 'the-answer)) - #t) - - ;; #:forall contract-out clauses - (test/spec-passed/result - 'provide/contract39 - '(begin - (eval '(module provide/contract39-m1 racket/base - (require racket/contract) - (provide/contract - #:∀ x - [f (-> x (-> x x) x)]) - (define (f x g) (g x)))) - - (eval '(module provide/contract39-m2 racket/base - (require racket/contract 'provide/contract39-m1) - (provide provide/contract39-x) - (define provide/contract39-x (f 10 (λ (x) x))))) - - (eval '(require 'provide/contract39-m2)) - (eval 'provide/contract39-x)) - 10) - - (test/spec-passed/result - 'provide/contract40 - '(begin - (eval '(module provide/contract40-m1 racket/base - (require racket/contract) - (provide/contract - #:forall x - [f (-> x (-> x x) x)]) - (define (f x g) (g x)))) - - (eval '(module provide/contract40-m2 racket/base - (require racket/contract 'provide/contract40-m1) - (provide provide/contract40-x) - (define provide/contract40-x (f 10 (λ (x) x))))) - - (eval '(require 'provide/contract40-m2)) - (eval 'provide/contract40-x)) - 10) - - (test/spec-passed/result - 'provide/contract41 - '(begin - (eval '(module provide/contract41-m1 racket/base - (require racket/contract) - (provide/contract - #:forall (x) - [f (-> x (-> x x) x)]) - (define (f x g) (g x)))) - - (eval '(module provide/contract41-m2 racket/base - (require racket/contract 'provide/contract41-m1) - (provide provide/contract41-x) - (define provide/contract41-x (f 10 (λ (x) x))))) - - (eval '(require 'provide/contract41-m2)) - (eval 'provide/contract41-x)) - 10) - - (test/spec-passed/result - 'provide/contract42 - '(begin - (eval '(module provide/contract42-m1 racket/base - (require racket/contract) - (define x integer?) - (define g 11) - (provide/contract - [g x] - #:forall (x) - [f (-> x (-> x x) x)]) - (define (f x g) (g x)))) - - (eval '(module provide/contract42-m2 racket/base - (require racket/contract 'provide/contract42-m1) - (provide provide/contract42-x) - (define provide/contract42-x (f 10 (λ (x) x))))) - - (eval '(require 'provide/contract42-m2)) - (eval 'provide/contract42-x)) - 10) - - (test/spec-passed/result - 'provide/contract43 - '(begin - (eval '(module provide/contract43-m1 racket/base - (require racket/contract) - (struct spider (legs)) - (provide (contract-out (struct spider ([legs number?])))))) - - (eval '(module provide/contract43-m2 racket/base - (require racket/contract 'provide/contract43-m1) - (provide provide/contract43-x) - (define provide/contract43-x - (spider-legs - (contract (struct/c spider integer?) - (spider 121) - 'pos - 'neg))))) - - (eval '(require 'provide/contract43-m2)) - (eval 'provide/contract43-x)) - 121) - - (test/spec-passed - 'provide/contract44 - '(begin - (eval '(module provide/contract44-m1 racket/base - (require racket/contract) - (struct heap (v) #:transparent) - (provide (rename-out (heap new-heap))))) - - (eval '(module provide/contract44-m2 racket/base - (require racket/contract 'provide/contract44-m1) - (contract (struct/c new-heap any/c) - (new-heap 121) - 'pos - 'neg))) - - (eval '(require 'provide/contract44-m2)))) - - (contract-error-test - 'contract-error-test8 - #'(begin - (eval '(module pce1-bug scheme/base - (require scheme/contract) - (define the-defined-variable1 'five) - (provide/contract [the-defined-variable1 number?]))) - (eval '(require 'pce1-bug))) - (λ (x) - (and (exn:fail:contract:blame? x) - (regexp-match #rx"the-defined-variable1: broke its contract" (exn-message x))))) - - (contract-error-test - 'contract-error-test9 - #'(begin - (eval '(module pce2-bug scheme/base - (require scheme/contract) - (define the-defined-variable2 values) - (provide/contract [the-defined-variable2 (-> number? any)]))) - (eval '(require 'pce2-bug)) - (eval '(the-defined-variable2 #f))) - (λ (x) - (and (exn:fail:contract:blame? x) - (regexp-match #rx"the-defined-variable2: contract violation" (exn-message x))))) - - (contract-error-test - 'contract-error-test10 - #'(begin - (eval '(module pce3-bug scheme/base - (require scheme/contract) - (define the-defined-variable3 (λ (x) #f)) - (provide/contract [the-defined-variable3 (-> any/c number?)]))) - (eval '(require 'pce3-bug)) - (eval '(the-defined-variable3 #f))) - (λ (x) - (and (exn:fail:contract:blame? x) - (regexp-match #rx"the-defined-variable3" (exn-message x))))) - - (contract-error-test - 'contract-error-test11 - #'(begin - (eval '(module pce4-bug scheme/base - (require scheme/contract) - (define the-defined-variable4 (λ (x) #f)) - (provide/contract [the-defined-variable4 (-> any/c number?)]))) - (eval '(require 'pce4-bug)) - (eval '((if #t the-defined-variable4 the-defined-variable4) #f))) - (λ (x) - (and (exn:fail:contract:blame? x) - (regexp-match #rx"^the-defined-variable4" (exn-message x))))) - - (contract-error-test - 'contract-error-test12 - #'(begin - (eval '(module pce5-bug scheme/base - (require scheme/contract) - - (define-struct bad (a b)) - - (provide/contract - [struct bad ((string? a) (string? b))]))) - (eval '(require 'pce5-bug))) - (λ (x) - (and (exn:fail:syntax? x) - (regexp-match #rx"expected field name to be b, but found string?" (exn-message x))))) - - (contract-error-test - 'contract-error-test13 - #'(begin - (eval '(module pce6-bug scheme/base - (require scheme/contract) - - (define-struct bad-parent (a)) - (define-struct (bad bad-parent) (b)) - - (provide/contract - [struct bad ((a string?) (string? b))]))) - (eval '(require 'pce6-bug))) - (λ (x) - (and (exn:fail:syntax? x) - (regexp-match #rx"expected field name to be b, but found string?" (exn-message x))))) - - (contract-error-test - 'contract-error-test14 - #'(begin - (eval '(module pce7-bug scheme/base - (require scheme/contract) - (define x 1) - (provide/contract [x integer?]))) - (eval '(module pce7-bug2 scheme/base - (require 'pce7-bug) - (set! x 5)))) - (λ (x) - (and (exn:fail:syntax? x) - (regexp-match #rx"cannot set!" (exn-message x))))) - - (contract-error-test - 'contract-error-test15 - #'(begin - (eval '(module pce8-bug1 scheme/base - (require scheme/contract) - (define (f x) x) - (provide/contract [f (-> integer? integer? integer?)]))) - (eval '(require 'pce8-bug1))) - (λ (x) - (and (exn:fail:contract:blame? x) - (regexp-match #rx"pce8-bug" (exn-message x))))) - - (contract-error-test - 'contract-error-test16 - #'(begin - (eval '(module pce9-bug scheme - (define (f x) "wrong") - (provide/contract - [rename f g - (-> number? number?)]))) - (eval '(require 'pce9-bug)) - (eval '(g 12))) - (λ (x) - (and (exn:fail:contract:blame? x) - (regexp-match #rx"^g.*contract from: pce9-bug" (exn-message x))))) - - (contract-error-test - 'contract-error-test17 - #'(begin - (eval '(module pce10-bug scheme - (define (f x) "wrong") - (provide/contract - [rename f g - (-> number? number?)]))) - (eval '(require 'pce10-bug)) - (eval '(g 'a))) - (λ (x) - (and (exn:fail:contract:blame? x) - (regexp-match #rx"^g.*contract from: pce10-bug" (exn-message x))))) - - (contract-error-test - 'contract-error-test18 - #'(begin - (eval '(module pce18-bug racket - (struct point (x y)) - (provide (contract-out - (struct point ([x integer?]))))))) - (λ (x) - (and (exn:fail:syntax? x) - ;; testing that the error says "contract-out" and not "provide/contract" - (regexp-match #rx"contract-out: found 2 fields" (exn-message x))))) - - (contract-eval - `(,test - 'pos - (compose blame-positive exn:fail:contract:blame-object) - (with-handlers ((void values)) (contract not #t 'pos 'neg)))) - - - ;; check that `contract-out' contracts can use contracts - ;; defined later in the module - (test/spec-passed/result - 'contract-out1 - '(begin - (eval '(module contract-out1-m racket/base - (require racket/contract) - (provide (contract-out [f (-> ok? ok?)])) - (define (f x) (+ x 1)) - (define (ok? v) (exact-integer? v)))) - (eval '(require 'contract-out1-m)) - (eval '(f 10))) - 11) - - (test/spec-passed/result - 'contract-out2 - '(begin - (eval '(module contract-out2-m racket/base - (require racket/contract) - (provide (contract-out (struct s ([x integer?])))) - (struct s (x)))) - (eval '(require 'contract-out2-m)) - (eval '(s-x (s 11)))) - 11) - - ;; expect the syntax errors in the right order - (contract-syntax-error-test - 'contract-out3 - '(eval '(module contract-out3-m racket/base - (require racket/contract) - (provide (contract-out garbage)) - (λ))) - #rx"contract-out") - - (test/pos-blame - 'contract-struct/c-1 - '(begin - (eval '(module contract-struct/c-1a racket/base - (struct s (field)) - (provide s))) - (eval '(module contract-struct/c-1b racket/base - (require 'contract-struct/c-1a racket/contract) - (contract (struct/c s boolean?) - (s 1) - 'pos 'neg))) - (eval '(require 'contract-struct/c-1b)))) - - (test/spec-passed - 'contract-struct/c-2 - '(begin - (eval '(module contract-struct/c-2a racket/base - (struct s (field)) - (provide s))) - (eval '(module contract-struct/c-2b racket/base - (require 'contract-struct/c-2a racket/contract) - (contract (struct/c s any/c) - (s 1) - 'pos 'neg))) - (eval '(require 'contract-struct/c-2b)))) - - -; -; -; -; -; ;;; ; ;;; ;;;;;;; ;;; -; ;;; ;;; ;;; ;;; -; ;;; ;; ;;; ;;; ;;; ;;; ;;;; ;;; ;;;; ;;; ;;; ;;;; -; ;;;;;;;;;;; ;;; ;;; ;;; ;;;; ;;; ;;;; ;;; ;;; ;; ;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;;; ;;; ;;; ;;;;;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;;; ;;; ;;; ;;; -; ;;; ;;; ;;; ;;;;;;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;;;;; -; ;;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;; -; -; -; -; - - (let () - ;; build-and-run : (listof (cons/c string[filename] - ;; (cons/c string[lang-line] - ;; (listof sexp[body-of-module]))) - ;; -> any - ;; sets up the files named by 'test-case', dynamically requires the first one, deletes the files - ;; and returns/raises-the-exception from the require'd file - (define (build-and-run test-case) - (define dir (make-temporary-file "contract-test~a" 'directory)) - (for ([f (in-list test-case)]) - (call-with-output-file (build-path dir (car f)) - (lambda (port) - (display (cadr f) port) - (newline port) - (for ([sexp (in-list (cddr f))]) - (fprintf port "~s\n" sexp))))) - (dynamic-wind - void - (lambda () (contract-eval `(dynamic-require ,(build-path dir (car (car test-case))) #f))) - (lambda () - (for ([f (in-list test-case)]) - (delete-file (build-path dir (car f)))) - (delete-directory dir)))) - - (define (get-last-part-of-path sexp) - (define str (format "orig-blame: ~s" sexp)) - (define m (regexp-match #rx"[/\\]([-a-z0-9.]*)[^/\\]*$" str)) - (if m (cadr m) str)) - - ;; basic negative blame case - (let ([blame - (exn:fail:contract:blame-object - (with-handlers ((exn:fail:contract:blame? values)) - (build-and-run - (list (list "a.rkt" - "#lang racket/base" - '(require "b.rkt") - '(f #f)) - (list "b.rkt" - "#lang racket/base" - '(require racket/contract) - '(provide/contract [f (-> integer? integer?)]) - '(define (f x) 1))))))]) - (ctest "a.rkt" - 'multi-file-blame1-positive - (,get-last-part-of-path (blame-positive ,blame))) - (ctest "b.rkt" - 'multi-file-blame1-negative - (,get-last-part-of-path (blame-negative ,blame)))) - - ;; basic positive blame case - (let ([blame - (exn:fail:contract:blame-object - (with-handlers ((exn:fail:contract:blame? values)) - (build-and-run - (list (list "a.rkt" - "#lang racket/base" - '(require "b.rkt") - '(f 1)) - (list "b.rkt" - "#lang racket/base" - '(require racket/contract) - '(provide/contract [f (-> integer? integer?)]) - '(define (f x) #f))))))]) - (ctest "b.rkt" - 'multi-file-blame2-positive - (,get-last-part-of-path (blame-positive ,blame))) - (ctest "a.rkt" - 'multi-file-blame2-negative - (,get-last-part-of-path (blame-negative ,blame)))) - - ;; positive blame via a re-provide - (let ([blame - (exn:fail:contract:blame-object - (with-handlers ((exn:fail:contract:blame? values)) - (build-and-run - (list (list "a.rkt" - "#lang racket/base" - '(require "b.rkt") - '(f 1)) - (list "b.rkt" - "#lang racket/base" - '(require "c.rkt") - '(provide f)) - (list "c.rkt" - "#lang racket/base" - '(require racket/contract) - '(provide/contract [f (-> integer? integer?)]) - '(define (f x) #f))))))]) - (ctest "c.rkt" - 'multi-file-blame3-positive - (,get-last-part-of-path (blame-positive ,blame))) - (ctest "a.rkt" - 'multi-file-blame3-negative - (,get-last-part-of-path (blame-negative ,blame)))) - - ;; negative blame via a re-provide - (let ([blame - (exn:fail:contract:blame-object - (with-handlers ((exn:fail:contract:blame? values)) - (build-and-run - (list (list "a.rkt" - "#lang racket/base" - '(require "b.rkt") - '(f #f)) - (list "b.rkt" - "#lang racket/base" - '(require "c.rkt") - '(provide f)) - (list "c.rkt" - "#lang racket/base" - '(require racket/contract) - '(provide/contract [f (-> integer? integer?)]) - '(define (f x) 1))))))]) - (ctest "a.rkt" - 'multi-file-blame4-positive - (,get-last-part-of-path (blame-positive ,blame))) - (ctest "c.rkt" - 'multi-file-blame4-negative - (,get-last-part-of-path (blame-negative ,blame)))) - - ;; have some sharing in the require graph - (let ([blame - (exn:fail:contract:blame-object - (with-handlers ((exn:fail:contract:blame? values)) - (build-and-run - (list (list "client.rkt" - "#lang racket/base" - '(require "server.rkt" "other.rkt") - '(turn-init #f)) - (list "server.rkt" - "#lang racket/base" - '(require racket/contract) - '(provide/contract [turn-init (-> number? any)]) - '(define turn-init void)) - (list "other.rkt" - "#lang racket/base" - '(require "server.rkt"))))))]) - (ctest "client.rkt" - 'multi-file-blame5-positive - (,get-last-part-of-path (blame-positive ,blame))) - (ctest "server.rkt" - 'multi-file-blame5-negative - (,get-last-part-of-path (blame-negative ,blame))))) - - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; Blame Object properties - ;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (contract-eval - '(begin - (module blame-ok/c racket/base - (require racket/contract) - (define (blame-proj name) - (lambda (b) - (unless (blame? b) - (raise-type-error name "a blame object" b)) - (define src (blame-source b)) - (unless (srcloc? src) - (raise-type-error name "a srcloc" src)) - (lambda (x) x))) - (define impersonator-blame-ok/c - (make-contract - #:name 'impersonator-blame-ok/c - #:projection (blame-proj 'impersonator-blame-ok/c))) - (define chaperone-blame-ok/c - (make-chaperone-contract - #:name 'chaperone-blame-ok/c - #:projection (blame-proj 'chaperone-blame-ok/c))) - (define flat-blame-ok/c - (make-flat-contract - #:name 'flat-blame-ok/c - #:projection (blame-proj 'flat-blame-ok/c))) - (provide - impersonator-blame-ok/c - chaperone-blame-ok/c - flat-blame-ok/c)) - (require 'blame-ok/c) - (module blame-ok-dynamic racket/base - (require racket/contract 'blame-ok/c) - (define five 5) - (provide - (contract-out - [rename five impersonator-five impersonator-blame-ok/c] - [rename five chaperone-five chaperone-blame-ok/c] - [rename five flat-five flat-blame-ok/c]))))) - - (begin - (ctest-no-error - 'blame-object/impersonator/contract-out - (dynamic-require ''blame-ok-dynamic 'impersonator-five)) - (ctest-no-error - 'blame-object/chaperone/contract-out - (dynamic-require ''blame-ok-dynamic 'chaperone-five)) - (ctest-no-error - 'blame-object/flat/contract-out - (dynamic-require ''blame-ok-dynamic 'flat-five))) - - (begin - (ctest-no-error - 'blame-object/impersonator/contract - (contract impersonator-blame-ok/c 5 'pos 'neg 'five #',#'location)) - (ctest-no-error - 'blame-object/chaperone/contract - (contract chaperone-blame-ok/c 5 'pos 'neg 'five #',#'location)) - (ctest-no-error - 'blame-object/flat/contract - (contract flat-blame-ok/c 5 'pos 'neg 'five #',#'location))) - - (begin - (ctest-no-error - 'blame-object/impersonator/define/contract - (let () - (define/contract five impersonator-blame-ok/c 5) - five)) - (ctest-no-error - 'blame-object/chaperone/define/contract - (let () - (define/contract five chaperone-blame-ok/c 5) - five)) - (ctest-no-error - 'blame-object/flat/define/contract - (let () - (define/contract five flat-blame-ok/c 5) - five))) - - (begin - (ctest-no-error - 'blame-object/impersonator/with-contract-definition-export - (let () - (with-contract internal-region ([five impersonator-blame-ok/c]) - (define five 5)) - five)) - (ctest-no-error - 'blame-object/chaperone/with-contract-definition-export - (let () - (with-contract internal-region ([five chaperone-blame-ok/c]) - (define five 5)) - five)) - (ctest-no-error - 'blame-object/flat/with-contract-definition-export - (let () - (with-contract internal-region ([five flat-blame-ok/c]) - (define five 5)) - five))) - - (begin - (ctest-no-error - 'blame-object/impersonator/with-contract-definition-import - (let () - (define five 5) - (with-contract internal-region () #:freevar five impersonator-blame-ok/c - (define six (add1 five))) - six)) - (ctest-no-error - 'blame-object/chaperone/with-contract-definition-import - (let () - (define five 5) - (with-contract internal-region () #:freevar five chaperone-blame-ok/c - (define six (add1 five))) - six)) - (ctest-no-error - 'blame-object/flat/with-contract-definition-import - (let () - (define five 5) - (with-contract internal-region () #:freevar five flat-blame-ok/c - (define six (add1 five))) - six))) - - (begin - (ctest-no-error - 'blame-object/impersonator/with-contract-expression-result - (with-contract internal-region #:result impersonator-blame-ok/c - 5)) - (ctest-no-error - 'blame-object/chaperone/with-contract-expression-result - (with-contract internal-region #:result chaperone-blame-ok/c - 5)) - (ctest-no-error - 'blame-object/flat/with-contract-expression-result - (with-contract internal-region #:result flat-blame-ok/c - 5))) - - (begin - (ctest-no-error - 'blame-object/impersonator/with-contract-expression-import - (let () - (define five 5) - (with-contract internal-region #:result any/c #:freevar five impersonator-blame-ok/c - five))) - (ctest-no-error - 'blame-object/chaperone/with-contract-expression-import - (let () - (define five 5) - (with-contract internal-region #:result any/c #:freevar five chaperone-blame-ok/c - five))) - (ctest-no-error - 'blame-object/flat/with-contract-expression-import - (let () - (define five 5) - (with-contract internal-region #:result any/c #:freevar five flat-blame-ok/c - five)))) - - (begin - (ctest-no-error - 'blame-object/impersonator/define-struct/contract - (let () - (define-struct/contract thing ([stuff impersonator-blame-ok/c])) - (thing-stuff (thing 5)))) - (ctest-no-error - 'blame-object/chaperone/define-struct/contract - (let () - (define-struct/contract thing ([stuff chaperone-blame-ok/c])) - (thing-stuff (thing 5)))) - (ctest-no-error - 'blame-object/flat/define-struct/contract - (let () - (define-struct/contract thing ([stuff flat-blame-ok/c])) - (thing-stuff (thing 5))))) - -; -; -; -; -; ;;; -; ;;; -; ;;; ;;;; ;; ;;; ;;;;; ;;; ;;; ;;; -; ;;; ;; ;;; ;;;;;;; ;;;;;;; ;;;;; ;;; ;;; -; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;; ;; ;; -; ;;; ;;;;;;; ;;; ;;; ;;;;; ;;; ;; ;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;; ;; -; ;;; ;;;;;; ;;;;;;; ;;; ;;; ;;;;; ;;; -; ;;; ;;;; ;; ;;; ;;;;;; ;;; ;;; -; ;;; ;;;;; -; ;;;;;; ;;;; -; -; - -; -; -; -; -; ; ; -; ;;; ;;; -; ;;; ;;; ;;; ;; ;;;; ;;;; ;;; ;;;; ;;; ;;; ;;;; ;;; ;;; ;;;;;; -; ;;;;; ;;;;; ;;;;;;; ;;; ;; ;;;; ;;;;;;;; ;;; ;;;;; ;;;; ;;;;; ;;;;;;;; ;; -; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; -; ;;; ;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;; -; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; -; ;;;;; ;;;;; ;;; ;;; ;; ;;; ;;;; ;;; ;;;;;;; ;;;;; ;;;; ;;;;; ;;; ;; ;;; -; ;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;;; -; -; -; -; - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; make-proj-contract - ;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (contract-eval - '(define proj:add1->sub1 - (make-proj-contract - 'proj:add1->sub1 - (lambda (pos neg src name blame) - (lambda (f) - (unless (and (procedure? f) (procedure-arity-includes? f 1)) - (raise-contract-error f src pos name - "expected a unary function, got: ~e" - f)) - (lambda (x) - (unless (and (integer? x) (exact? x)) - (raise-contract-error x src neg name - "expected an integer, got: ~e" - x)) - (let* ([y (f (add1 x))]) - (unless (and (integer? y) (exact? y)) - (raise-contract-error y src pos name - "expected an integer, got: ~e" - y)) - (sub1 y))))) - (lambda (f) - (and (procedure? f) (procedure-arity-includes? f 1)))))) - - (test/spec-passed/result - 'make-proj-contract-1 - '((contract proj:add1->sub1 sqrt 'pos 'neg) 15) - 3) - - (test/pos-blame - 'make-proj-contract-2 - '(contract proj:add1->sub1 'dummy 'pos 'neg)) - - (test/pos-blame - 'make-proj-contract-3 - '((contract proj:add1->sub1 (lambda (x) 'dummy) 'pos 'neg) 2)) - - (test/neg-blame - 'make-proj-contract-4 - '((contract proj:add1->sub1 sqrt 'pos 'neg) 'dummy)) - - ;; errortrace test - (let () - (define sp (open-input-string (format "~s\n" '(-> (λ (a b c) #f) any)))) - (define stx (read-syntax 'whereitsat sp)) - (define exn - (parameterize ([current-namespace (make-base-namespace)]) - (namespace-require 'racket/contract) - (namespace-require 'errortrace) - (with-handlers ((exn:fail? values)) - (eval stx)))) - (define sp2 (open-output-string)) - (parameterize ([current-error-port sp2]) - ((error-display-handler) (exn-message exn) exn)) - (test #t - 'checking-arrow-src-locs - (regexp-match? #rx"whereitsat" (get-output-string sp2)))) - - - (report-errs) - -)) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/all.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/all.rkt new file mode 100644 index 0000000000..b1723ad4a7 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/all.rkt @@ -0,0 +1,69 @@ +#lang racket/base +(require (for-syntax racket/base)) +(define-syntax (this-dir stx) + (define src (syntax-source stx)) + (cond + [(path? src) + (define-values (base name dir?) (split-path src)) + #`'#,base] + [else #f])) + +(define files + (for/list ([file (in-list (directory-list (this-dir)))] + #:when + (and (regexp-match #rx"[.]rkt$" (path->string file)) + (not (member (path->string file) + '("test-util.rkt" "all.rkt"))))) + file)) + +(define (find-deps file) + (define deps #f) + + (define (remove-quote x) + (cond + [(and (pair? x) (eq? (car x) 'quote)) + (cadr x)] + [else + (error 'find-deps "found non-quote in argument to make-basic-contract-namespace in ~a" file)])) + + (let loop ([exp + (parameterize ([read-accept-reader #t]) + (call-with-input-file file read))]) + (cond + [(and (list? exp) + (pair? exp) + (eq? (car exp) 'make-basic-contract-namespace)) + (when deps + (error 'find-deps + "found two calls to make-basic-contract-namespace in ~a" + file)) + (set! deps (map remove-quote (cdr exp)))] + [(list? exp) + (for-each loop exp)] + [else (void)])) + deps) + +(define (depstring file) + (find-deps (build-path (this-dir) file)))) + string<=? + #:key car) + depd ([x integer?]) ([y integer?]) any)) + (test/no-error '(->d ([x integer?]) ([y integer?]) (values [a number?] [b boolean?]))) + (test/no-error '(->d ([x integer?] #:z [z integer?]) ([y integer?] #:w [w integer?]) + (range boolean?))) + (test/no-error '(->d ([x integer?] #:z [z integer?]) ([y integer?] #:w [w integer?]) + #:rest rest any/c (range boolean?))) + (test/no-error '(->d ([x integer?] #:z [z integer?]) #:rest rest any/c (range boolean?))) + + + (test/spec-passed + '->d1 + '((contract (->d () () [x number?]) (lambda () 1) 'pos 'neg))) + + (test/spec-passed + '->d2 + '((contract (->d ([x number?]) () (values [r number?])) (lambda (x) (+ x 1)) 'pos 'neg) 1)) + + (test/pos-blame + '->d3 + '((contract (->d () () [r number?]) 1 'pos 'neg))) + + (test/pos-blame + '->d4 + '((contract (->d () () [r number?]) (lambda (x) x) 'pos 'neg))) + + (test/neg-blame + '->d5 + '((contract (->d ([x number?]) () any) (lambda (x) (+ x 1)) 'pos 'neg) #f)) + + (test/pos-blame + '->d6 + '((contract (->d ([x number?]) () [r (<=/c x)]) (lambda (x) (+ x 1)) 'pos 'neg) 1)) + + (test/spec-passed + '->d7 + '((contract (->d ([x number?] [y (<=/c x)]) () [r (<=/c x)]) + (lambda (x y) (- x 1)) 'pos 'neg) 1 0)) + + (test/neg-blame + '->d8 + '((contract (->d ([x number?] [y (<=/c x)]) () [r (<=/c x)]) + (lambda (x y) (+ x 1)) 'pos 'neg) 1 2)) + + (test/spec-passed + '->d9 + '((contract (->d ([y (<=/c x)] [x number?]) () [r (<=/c x)]) + (lambda (y x) (- x 1)) 'pos 'neg) 1 2)) + + (test/neg-blame + '->d10 + '((contract (->d ([y (<=/c x)] [x number?]) () [r (<=/c x)]) + (lambda (y x) (+ x 1)) 'pos 'neg) 1 0)) + + (test/spec-passed + '->d11 + '((contract (->d () () #:rest rest any/c [r number?]) (lambda x 1) 'pos 'neg))) + + (test/spec-passed + '->d12 + '((contract (->d ([x number?]) () #:rest rest any/c [r number?]) + (lambda (x . y) (+ x 1)) 'pos 'neg) 1)) + + (test/pos-blame + '->d13 + '((contract (->d () () #:rest rest any/c [r number?]) 1 'pos 'neg))) + + (test/pos-blame + '->d14 + '((contract (->d () () #:rest rest any/c [r number?]) (lambda (x) x) 'pos 'neg))) + + (test/neg-blame + '->d15 + '((contract (->d ([x number?]) () #:rest rest any/c any) (lambda (x . y) (+ x 1)) 'pos 'neg) #f)) + + (test/pos-blame + '->d16 + '((contract (->d ([x number?]) () #:rest rest any/c [r (<=/c x)]) + (lambda (x . y) (+ x 1)) 'pos 'neg) 1)) + + (test/spec-passed + '->d17 + '((contract (->d ([x number?] [y (<=/c x)]) () #:rest rest any/c [r (<=/c x)]) + (lambda (x y . z) (- x 1)) 'pos 'neg) 1 0)) + + (test/neg-blame + '->d18 + '((contract (->d ([x number?] [y (<=/c x)]) () #:rest rest any/c [r (<=/c x)]) + (lambda (x y . z) (+ x 1)) 'pos 'neg) 1 2)) + + (test/spec-passed + '->d19 + '((contract (->d ([y (<=/c x)] [x number?]) () #:rest rest any/c [r (<=/c x)]) + (lambda (y x . z) (- x 1)) 'pos 'neg) 1 2)) + + (test/neg-blame + '->d20 + '((contract (->d ([y (<=/c x)] [x number?]) () #:rest rest any/c [r (<=/c x)]) + (lambda (y x . z) (+ x 1)) 'pos 'neg) 1 0)) + + (test/spec-passed + '->d21 + '((contract (->d () () #:rest rst (listof number?) [r any/c]) (lambda w 1) 'pos 'neg) 1)) + + (test/neg-blame + '->d22 + '((contract (->d () () #:rest rst (listof number?) [r any/c]) (lambda w 1) 'pos 'neg) #f)) + + (test/spec-passed + '->d-any1 + '((contract (->d () () any) (lambda () 1) 'pos 'neg))) + + (test/spec-passed + '->d-any2 + '((contract (->d ([x number?]) () any) (lambda (x) (+ x 1)) 'pos 'neg) 1)) + + (test/pos-blame + '->d-any3 + '((contract (->d () () any) 1 'pos 'neg))) + + (test/pos-blame + '->d-any4 + '((contract (->d () () any) (lambda (x) x) 'pos 'neg))) + + (test/neg-blame + '->d-any5 + '((contract (->d ([x number?]) () any) (lambda (x) (+ x 1)) 'pos 'neg) #f)) + + (test/spec-passed + '->d-any6 + '((contract (->d ([x number?] [y (<=/c x)]) () any) (lambda (x y) (- x 1)) 'pos 'neg) 1 0)) + + (test/neg-blame + '->d-any7 + '((contract (->d ([x number?] [y (<=/c x)]) () any) (lambda (x y) (+ x 1)) 'pos 'neg) 1 2)) + + (test/spec-passed + '->d-any8 + '((contract (->d ([y (<=/c x)] [x number?]) () any) (lambda (y x) (- x 1)) 'pos 'neg) 1 2)) + + (test/neg-blame + '->d-any9 + '((contract (->d ([y (<=/c x)] [x number?]) () any) (lambda (y x) (+ x 1)) 'pos 'neg) 1 0)) + + (test/spec-passed + '->d-any10 + '((contract (->d () () #:rest rest any/c any) (lambda x 1) 'pos 'neg))) + + (test/spec-passed + '->d-any11 + '((contract (->d ([x number?]) () #:rest rest any/c any) (lambda (x . y) (+ x 1)) 'pos 'neg) 1)) + + (test/pos-blame + '->d-any12 + '((contract (->d () () #:rest rest any/c any) 1 'pos 'neg))) + + (test/pos-blame + '->d-any13 + '((contract (->d () () #:rest rest any/c any) (lambda (x) x) 'pos 'neg))) + + (test/neg-blame + '->d-any14 + '((contract (->d ([x number?]) () #:rest rest any/c any) (lambda (x . y) (+ x 1)) 'pos 'neg) #f)) + + (test/spec-passed + '->d-any15 + '((contract (->d ([x number?] [y (<=/c x)]) () #:rest rest any/c any) + (lambda (x y . z) (- x 1)) 'pos 'neg) 1 0)) + + (test/neg-blame + '->d-any16 + '((contract (->d ([x number?] [y (<=/c x)]) () #:rest rest any/c any) + (lambda (x y . z) (+ x 1)) 'pos 'neg) 1 2)) + + (test/spec-passed + '->d-any17 + '((contract (->d ([y (<=/c x)] [x number?]) () #:rest rest any/c any) + (lambda (y x . z) (- x 1)) 'pos 'neg) 1 2)) + + (test/neg-blame + '->d-any18 + '((contract (->d ([y (<=/c x)] [x number?]) () #:rest rest any/c any) + (lambda (y x . z) (+ x 1)) 'pos 'neg) 1 0)) + + (test/spec-passed + '->d-any19 + '((contract (->d () () #:rest rst (listof number?) any) (lambda w 1) 'pos 'neg) 1)) + + (test/neg-blame + '->d-any20 + '((contract (->d () () #:rest rst (listof number?) any) (lambda w 1) 'pos 'neg) #f)) + + (test/spec-passed + '->d-values1 + '((contract (->d () () (values [x boolean?] [y number?])) (lambda () (values #t 1)) 'pos 'neg))) + + (test/spec-passed + '->d-values2 + '((contract (->d ([x number?]) () (values [z boolean?] [y number?])) + (lambda (x) (values #t (+ x 1))) 'pos 'neg) 1)) + + (test/pos-blame + '->d-values3 + '((contract (->d () () (values [x boolean?] [y number?])) 1 'pos 'neg))) + + (test/pos-blame + '->d-values4 + '((contract (->d () () (values [x boolean?] [y number?])) (lambda (x) x) 'pos 'neg))) + + (test/neg-blame + '->d-values5 + '((contract (->d ([x number?]) () (values [y boolean?] [z (<=/c x)])) + (lambda (x) (+ x 1)) 'pos 'neg) #f)) + + (test/pos-blame + '->d-values6 + '((contract (->d ([x number?]) () (values [y boolean?] [z (<=/c x)])) + (lambda (x) (values #t (+ x 1))) 'pos 'neg) 1)) + + (test/spec-passed + '->d-values7 + '((contract (->d ([x number?] [y (<=/c x)]) () (values [z boolean?] [w (<=/c x)])) + (lambda (x y) (values #t (- x 1))) + 'pos + 'neg) + 1 + 0)) + + (test/neg-blame + '->d-values8 + '((contract (->d ([x number?] [y (<=/c x)]) () (values [z boolean?] [w (<=/c x)])) + (lambda (x y) (values #f (+ x 1))) + 'pos + 'neg) + 1 + 2)) + + (test/spec-passed + '->d-values9 + '((contract (->d ([y (<=/c x)] [x number?]) () (values [z boolean?] [w (<=/c x)])) + (lambda (y x) (values #f (- x 1))) + 'pos + 'neg) + 1 + 2)) + + (test/neg-blame + '->d-values10 + '((contract (->d ([y (<=/c x)] [x number?]) () (values [z boolean?] [w (<=/c x)])) + (lambda (y x) (values #f (+ x 1))) 'pos 'neg) + 1 0)) + + (test/spec-passed + '->d-values11 + '((contract (->d () () #:rest rest any/c (values [z boolean?] [w number?])) + (lambda x (values #f 1)) 'pos 'neg))) + + (test/spec-passed + '->d-values12 + '((contract (->d ([x number?]) () #:rest rest any/c (values [z boolean?] [w number?])) + (lambda (x . y) (values #f (+ x 1))) + 'pos + 'neg) + 1)) + + (test/pos-blame + '->d-values13 + '((contract (->d () () #:rest rest any/c (values [z boolean?] [w number?])) 1 'pos 'neg))) + + (test/pos-blame + '->d-values14 + '((contract (->d () () #:rest rest any/c (values [z boolean?] [w number?])) + (lambda (x) x) 'pos 'neg))) + + (test/neg-blame + '->d-values15 + '((contract (->d ([x number?]) () #:rest rest any/c (values [z boolean?] [w (<=/c x)])) + (lambda (x . y) (+ x 1)) 'pos 'neg) + #f)) + + (test/pos-blame + '->d-values16 + '((contract (->d ([x number?]) () #:rest rest any/c (values [z boolean?] [w (<=/c x)])) + (lambda (x . y) (values #f (+ x 1))) 'pos 'neg) + 1)) + + (test/spec-passed + '->d-values17 + '((contract (->d ([x number?] [y (<=/c x)]) () #:rest rest any/c + (values [z boolean?] [w (<=/c x)])) + (lambda (x y . z) (values #f (- x 1))) 'pos 'neg) + 1 0)) + + (test/neg-blame + '->d-values18 + '((contract (->d ([x number?] [y (<=/c x)]) () #:rest rest any/c + (values [z boolean?] [w (<=/c x)])) + (lambda (x y . z) (values #f (+ x 1))) 'pos 'neg) + 1 2)) + + (test/spec-passed + '->d-values19 + '((contract (->d ([y (<=/c x)] [x number?]) () #:rest rest any/c + (values [z boolean?] [w (<=/c x)])) + (lambda (y x . z) (values #f (- x 1))) 'pos 'neg) + 1 2)) + + (test/neg-blame + '->d-values20 + '((contract (->d ([y (<=/c x)] [x number?]) () #:rest rest any/c + (values [z boolean?] [w (<=/c x)])) + (lambda (y x . z) (values #f (+ x 1))) 'pos 'neg) + 1 0)) + + (test/spec-passed + '->d-values21 + '((contract (->d () () #:rest rst (listof number?) (values [z boolean?] [w any/c])) + (lambda w (values #f 1)) 'pos 'neg) 1)) + + (test/neg-blame + '->d-values22 + '((contract (->d () () #:rest rst (listof number?) (values [z boolean?] [w any/c])) + (lambda w (values #f 1)) 'pos 'neg) #f)) + + (test/spec-passed + '->d-values23 + '((contract (->d () () (values [x number?] [y (>=/c x)])) (lambda () (values 1 2)) 'pos 'neg))) + + (test/pos-blame + '->d-values24 + '((contract (->d () () (values [x number?] [y (>=/c x)])) (lambda () (values 2 1)) 'pos 'neg))) + + (test/spec-passed + '->d-values25 + '((contract (->d ([x number?]) () (values [z number?] [y (>=/c x)])) + (lambda (x) (values 1 2)) 'pos 'neg) 1)) + + (test/pos-blame + '->d-values26 + '((contract (->d ([x number?]) () (values [z number?] [y (>=/c x)])) + (lambda (x) (values 2 1)) 'pos 'neg) 4)) + + (test/spec-passed/result + '->d23 + '((contract (->d ((i number?) (j (and/c number? (>=/c i)))) () [r number?]) + (λ (i j) 1) + 'pos + 'neg) + 1 + 2) + 1) + + (test/spec-passed/result + '->d24 + '((contract (->d ((i number?) (j (and/c number? (>=/c i)))) () any) + (λ (i j) 1) + 'pos + 'neg) + 1 + 2) + 1) + + (test/spec-passed/result + '->d25 + '(call-with-values + (λ () + ((contract (->d ((i number?) (j (and/c number? (>=/c i)))) () (values [x number?] [y number?])) + (λ (i j) (values 1 2)) + 'pos + 'neg) + 1 + 2)) + list) + '(1 2)) + + (test/spec-passed/result + '->d26 + '((contract (->d ((i number?) (j (and/c number? (>=/c i)))) () #:rest rest-args any/c [r number?]) + (λ (i j . z) 1) + 'pos + 'neg) + 1 + 2) + 1) + + (test/spec-passed/result + '->d27 + '((contract (->d ((i number?) (j (and/c number? (>=/c i)))) () #:rest rest-args any/c any) + (λ (i j . z) 1) + 'pos + 'neg) + 1 + 2) + 1) + + (test/spec-passed/result + '->d28 + '(call-with-values + (λ () + ((contract (->d ((i number?) (j (and/c number? (>=/c i)))) () + #:rest rest-args any/c + (values [x number?] [y number?])) + (λ (i j . z) (values 1 2)) + 'pos + 'neg) + 1 + 2)) + list) + '(1 2)) + + (test/neg-blame + '->d30 + '((contract (->d ([x number?]) () #:rest rst number? any) + (λ (x . rst) (values 4 5)) + 'pos + 'neg) + #f)) + + (test/pos-blame + '->d-arity1 + '(contract (->d ([x number?]) () any) (λ () 1) 'pos 'neg)) + + (test/pos-blame + '->d-arity2 + '(contract (->d ([x number?]) () any) (λ (x #:y y) 1) 'pos 'neg)) + + (test/spec-passed + '->d-arity3 + '(contract (->d ([x number?] #:y [y integer?]) () any) (λ (x #:y y) 1) 'pos 'neg)) + + (test/pos-blame + '->d-arity4 + '(contract (->d () ([x integer?]) any) (λ (x) 1) 'pos 'neg)) + + (test/pos-blame + '->d-arity5 + '(contract (->d () ([x integer?]) any) (λ () 1) 'pos 'neg)) + + (test/spec-passed + '->d-arity6 + '(contract (->d () ([x integer?]) any) (λ ([x 1]) 1) 'pos 'neg)) + + (test/pos-blame + '->d-arity7 + '(contract (->d () (#:x [x integer?]) any) (λ ([x 1]) 1) 'pos 'neg)) + + (test/pos-blame + '->d-arity8 + '(contract (->d () (#:x [x integer?]) any) (λ () 1) 'pos 'neg)) + + (test/pos-blame + '->d-arity8 + '(contract (->d () (#:x [x integer?]) any) (λ (#:x x) 1) 'pos 'neg)) + + (test/spec-passed + '->d-arity10 + '(contract (->d () (#:x [x integer?]) any) (λ (#:x [x 1]) 1) 'pos 'neg)) + + (test/spec-passed + '->d-pp0 + '((contract (->d ([x number?]) () #:pre (= x 1) [result number?] #:post (= x 1)) + (λ (x) x) + 'pos + 'neg) + 1)) + + (test/pos-blame + '->d-pp1 + '((contract (->d ([x number?]) () #:pre-cond (= x 1) [result number?] #:post-cond (= x 2)) + (λ (x) x) + 'pos + 'neg) + 1)) + + (test/neg-blame + '->d-pp2 + '((contract (->d ([x number?]) () #:pre-cond (= x 1) [result number?] #:post-cond (= x 2)) + (λ (x) x) + 'pos + 'neg) + 2)) + + (test/pos-blame + '->d-pp3 + '((contract (->d ([x number?]) () #:pre-cond (= x 1) [result number?] #:post-cond (= result 2)) + (λ (x) x) + 'pos + 'neg) + 1)) + + (test/spec-passed + '->d-pp3.5 + '((contract (->d ([x number?]) () #:pre-cond (= x 1) [result number?] #:post-cond (= result 2)) + (λ (x) 2) + 'pos + 'neg) + 1)) + + (test/neg-blame + '->d-pp4 + '((contract (->d ([x number?]) () #:pre-cond (= x 1) any) + (λ (x) x) + 'pos + 'neg) + 2)) + + (test/neg-blame + '->d-pp5 + '((contract (->d ([x number?]) () #:pre-cond (= x 1) (values [z number?] [y number?]) + #:post-cond (= x y z 3)) + (λ (x) (values 4 5)) + 'pos + 'neg) + 2)) + + (test/pos-blame + '->d-pp6 + '((contract (->d ([x number?]) () #:pre-cond (= x 1) (values [z number?] [y number?]) + #:post-cond (= z y 3)) + (λ (x) (values 4 5)) + 'pos + 'neg) + 1)) + + (test/pos-blame + '->d-pp-r1 + '((contract (->d ([x number?]) () #:rest rst any/c #:pre-cond (= x 1) [result number?] + #:post-cond (= x 2)) + (λ (x . rst) x) + 'pos + 'neg) + 1)) + + (test/neg-blame + '->d-pp-r2 + '((contract (->d ([x number?]) () #:rest rst any/c #:pre-cond (= x 1) [result number?] + #:post-cond (= x 2)) + (λ (x . rst) x) + 'pos + 'neg) + 2)) + + (test/pos-blame + '->d-pp-r3 + '((contract (->d ([x number?]) () #:rest rst any/c #:pre-cond (= x 1) [result number?] + #:post-cond (= result 2)) + (λ (x . rst) x) + 'pos + 'neg) + 1)) + + (test/spec-passed + '->d-pp-r3.5 + '((contract (->d ([x number?]) () #:rest rst any/c #:pre-cond (= x 1) [result number?] + #:post-cond (= result 2)) + (λ (x . rst) 2) + 'pos + 'neg) + 1)) + + (test/neg-blame + '->d-pp-r4 + '((contract (->d ([x number?]) () #:rest rst any/c #:pre-cond (= x 1) any) + (λ (x . rst) x) + 'pos + 'neg) + 2)) + + (test/neg-blame + '->d-pp-r5 + '((contract (->d ([x number?]) () #:rest rst any/c + #:pre-cond (= x 1) (values [z number?] [y number?]) + #:post-cond (= x y z 3)) + (λ (x . rst) (values 4 5)) + 'pos + 'neg) + 2)) + + (test/pos-blame + '->d-pp-r6 + '((contract (->d ([x number?]) () #:rest rst any/c + #:pre-cond (= x 1) (values [z number?] [y number?]) + #:post-cond (= z x y 3)) + (λ (x . rst) (values 4 5)) + 'pos + 'neg) + 1)) + + (test/neg-blame + '->d-protect-shared-state + '(let ([x 1]) + ((contract (let ([save #f]) + (-> (->d () () #:pre-cond (set! save x) [range any/c] #:post-cond (= save x)) + any)) + (λ (t) (t)) + 'pos + 'neg) + (lambda () (set! x 2))))) + + + (test/spec-passed + '->d-optopt1 + '((contract (->d ([x number?]) any) + (λ (x) x) + 'pos 'neg) + 1)) + + (test/spec-passed + '->d-optopt2 + '((contract (->d ([x number?]) #:rest rst any/c any) + (λ (x . y) x) + 'pos 'neg) + 1)) + + (test/spec-passed + '->d-optopt3 + '((contract (->d ([x number?]) #:pre-cond #t any) + (λ (x) x) + 'pos 'neg) + 1)) + + (test/spec-passed + '->d-optopt4 + '((contract (->d ([x number?]) #:rest rst any/c #:pre-cond #t any) + (λ (x . y) x) + 'pos 'neg) + 1)) + + (test/spec-passed + '->d-optopt5 + '((contract (->d ([x number?]) #:rest rst any/c #:pre-cond #t [res any/c] #:post-cond #t) + (λ (x . y) x) + 'pos 'neg) + 1)) + + (test/spec-passed + '->d-optopt6 + '((contract (->d ([x number?]) #:rest rst any/c [res any/c] #:post-cond #t) + (λ (x . y) x) + 'pos 'neg) + 1)) + + (test/spec-passed + '->d-optopt7 + '((contract (->d ([x number?]) #:pre-cond #t [res any/c] #:post-cond #t) + (λ (x . y) x) + 'pos 'neg) + 1)) + + (test/spec-passed + '->d-optopt8 + '((contract (->d ([x number?]) [res any/c] #:post-cond #t) + (λ (x . y) x) + 'pos 'neg) + 1)) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; make sure the variables are all bound properly + ;; + + (test/spec-passed + '->d-binding1 + '((contract (->d ([x number?]) () #:rest rest any/c [range any/c] + #:post-cond (equal? rest '(2 3 4))) + (λ (x . y) y) + 'pos + 'neg) + 1 2 3 4)) + + (test/spec-passed + '->d-binding2 + '((contract (->d ([x number?]) () #:rest rest any/c [range any/c] #:post-cond (equal? x 1)) + (λ (x . y) y) + 'pos + 'neg) + 1 2 3 4)) + + (test/spec-passed + '->d-binding3 + '(let ([p 'p] + [q 'q] + [r 'r]) + ((contract (->d ([x number?] [y number?] #:z [z number?] #:w [w number?]) + ([a number?] [b number?] #:c [c number?] #:d [d number?]) + #:rest rest any/c + #:pre-cond (equal? (list x y z w a b c d rest p q r) + (list 1 2 3 4 5 6 7 8 '(z) 'p 'q 'r)) + (values [p number?] [q number?] [r number?])) + (λ (x y #:z z #:w w [a 101] [b 102] #:c [c 103] #:d [d 104] . rest) + (values 11 12 13)) + 'pos + 'neg) + 1 2 #:z 3 #:w 4 5 6 #:c 7 #:d 8 'z))) + + (test/spec-passed + '->d-binding4 + '((contract (->d ([x number?] [y number?] #:z [z number?] #:w [w number?]) + ([a number?] [b number?] #:c [c number?] #:d [d number?]) + #:rest rest any/c + (values [p number?] [q number?] [r number?]) + #:post-cond (equal? (list x y z w a b c d rest p q r) + (list 1 2 3 4 5 6 7 8 '(z) 11 12 13))) + (λ (x y #:z z #:w w [a 101] [b 102] #:c [c 103] #:d [d 104] . rest) + (values 11 12 13)) + 'pos + 'neg) + 1 2 #:z 3 #:w 4 5 6 #:c 7 #:d 8 'z)) + + (test/spec-passed + '->d-binding5 + '(let ([p 'p] + [q 'q] + [r 'r]) + ((contract (->d ([x number?] [y number?] #:z [z number?] #:w [w number?]) + ([a number?] [b number?] #:c [c number?] #:d [d number?]) + #:rest rest any/c + #:pre-cond (equal? (list x y z w a b c d rest p q r) + (list 1 2 3 4 + the-unsupplied-arg the-unsupplied-arg + the-unsupplied-arg the-unsupplied-arg + '() 'p 'q 'r)) + (values [p number?] [q number?] [r number?])) + (λ (x y #:z z #:w w [a 101] [b 102] #:c [c 103] #:d [d 104] . rest) + (values 11 12 13)) + 'pos + 'neg) + 1 2 #:z 3 #:w 4))) + + (test/spec-passed + '->d-binding6 + '((contract (->d ([x number?] [y number?] #:z [z number?] #:w [w number?]) + ([a number?] [b number?] #:c [c number?] #:d [d number?]) + #:rest rest any/c + (values [p number?] [q number?] [r number?]) + #:post-cond (equal? (list x y z w a b c d rest p q r) + (list 1 2 3 4 + the-unsupplied-arg the-unsupplied-arg + the-unsupplied-arg the-unsupplied-arg + '() 11 12 13))) + (λ (x y #:z z #:w w [a 101] [b 102] #:c [c 103] #:d [d 104] . rest) + (values 11 12 13)) + 'pos + 'neg) + 1 2 #:z 3 #:w 4)) + + ;; test that the rest parameter is right when there aren't + ;; enough arguments to even make it to the rest parameter + (test/spec-passed + '->d-binding7 + '((contract (->d () + ([a number?]) + #:rest rest any/c + [_ any/c] + #:post-cond (equal? (list a rest) (list the-unsupplied-arg '()))) + (λ ([a 1] . rest) 1) + 'pos + 'neg))) + + (test/pos-blame + '->d-underscore1 + '((contract (->d ([b (box/c integer?)]) + () + [_ (let ([old (unbox b)]) + (and/c + void? + (λ (new) + (= old (unbox b)))))]) + (λ (b) + (set-box! b (+ (unbox b) 1))) + 'pos + 'neg) + (box 1))) + + (test/spec-passed/result + '->d-underscore2 + '(let ([x '()]) + ((contract (->d () () [_ (begin (set! x (cons 'ctc x)) any/c)]) + (λ () (set! x (cons 'body x))) + 'pos + 'neg)) + x) + '(body ctc)) + + (test/spec-passed/result + '->d-underscore3 + '(let ([x '()]) + ((contract (->d () () [res (begin (set! x (cons 'ctc x)) any/c)]) + (λ () (set! x (cons 'body x))) + 'pos + 'neg)) + x) + '(ctc body)) + + (test/spec-passed/result + '->d-underscore4 + '((contract (->d ([str any/c]) () #:rest rest (listof any/c) [_ any/c]) + (λ (x . y) (cons x y)) + 'pos 'neg) + 1 2 3) + '(1 2 3)) + + (test/spec-passed/result + '->d-underscore5 + '((contract (->d ([str any/c]) () #:rest rest (listof any/c) [_ any/c]) + (λ (x . y) (cons x y)) + 'pos 'neg) + 1 2 3 4 5) + '(1 2 3 4 5))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow-i.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow-i.rkt new file mode 100644 index 0000000000..92a0a9fda4 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow-i.rkt @@ -0,0 +1,1352 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace)]) + (define exn:fail:contract:blame? (contract-eval 'exn:fail:contract:blame?)) + + (test/no-error '(->i ([x integer?]) ([y integer?]) any)) + (test/no-error '(->i ([x integer?]) ([y integer?]) (values [a number?] [b boolean?]))) + (test/no-error '(->i ([x integer?] #:z [z integer?]) ([y integer?] #:w [w integer?]) + (range boolean?))) + (test/no-error '(->i ([x integer?] #:z [z integer?]) ([y integer?] #:w [w integer?]) + #:rest [rest any/c] (range boolean?))) + (test/no-error '(->i ([x integer?] #:z [z integer?]) #:rest [rest any/c] (range boolean?))) + + + (test/spec-passed + '->i-stx-1 + '(->i ([x (y) number?] + [y number?]) + any)) + + (test/spec-passed + '->i-stx-2 + '(->i () + (values [x (y) number?] + [y number?]))) + + (test/spec-passed + '->i-stx-3 + '(->i () + #:rest [x number?] + [y (x) number?])) + + (contract-syntax-error-test + '->i-stx4 + '(->i (#:kwd1 [x number?] + #:kwd2 [x number?]) + (values [y number?] + [z number?]))) + + (contract-syntax-error-test + '->i-stx5 + #'(->i (#:kwd1 [w number?] + #:kwd1 [x number?]) + (values [y number?] + [z number?]))) + + (contract-syntax-error-test + '->i-stx6 + #'(->i (#:kwd1 [w number?] + #:kwd2 [x number?]) + (values [y number?] + [w number?]))) + + (contract-syntax-error-test + '->i-stx7 + #'(->i (#:kwd1 [w number?] + #:kwd2 [x number?]) + (values [y number?] + [y number?]))) + + (contract-syntax-error-test + '->i-stx8 + #'(->i (#:kwd1 [w number?] + #:kwd2 [x number?]) + (values [y number?] + [w number?]))) + + (contract-syntax-error-test + '->i-stx10 + #'(->i (#:kwd1 [x number?] + #:kwd2 [y number?]) + [x number?])) + + (contract-syntax-error-test + '->i-stx11 + #'(->i (#:kwd1 [x number?] + #:kwd2 [y number?]) + #:rest [x any/c] + any)) + + (contract-syntax-error-test + '->i-stx12 + #'(let ([c integer?]) + (->i ((arg any/c)) () (values (_ (arg) c) (x (arg) c) (_ (arg) c))))) + + (contract-syntax-error-test + '->i-stx13 + #'(->i ([x (y) number?]) + any)) + + (contract-syntax-error-test + '->i-stx14 + #'(->i ([x number?]) #:pre (y) #t any)) + + (contract-syntax-error-test + '->i-stx15 + #'(->i ([x number?]) #:pre (x) #t [res any/c] #:post (y) #t)) + + (contract-syntax-error-test + '->i-stx16 + #'(->i ([x (y) number?]) + [y number?])) + + (contract-syntax-error-test + '->i-stx17 + #'(->i () + #:rest [x (y) number?] + [y number?])) + + (contract-syntax-error-test + '->i-stx18 + #'(->i ([x number?]) #:pre (res) #t [res any/c] #:post (x) #t)) + + (contract-syntax-error-test + '->i-stx19 + #'(->i ([x (x) number?]) + any)) + + (contract-syntax-error-test + '->i-stx20 + #'(->i ([x (y) number?] + [y (x) number?]) + any)) + + (contract-syntax-error-test + '->i-stx21 + #'(->i ([in number?]) + (values [x (y) number?] + [y (z) number?] + [z (x) number?]))) + + (contract-syntax-error-test + '->i-stx22 + #'(->i () + #:rest [x (x) number?] + any)) + + (test/spec-passed + '->i1 + '((contract (->i () () [x number?]) (lambda () 1) 'pos 'neg))) + + (test/spec-passed + '->i2 + '((contract (->i ([x number?]) () (values [r number?])) (lambda (x) (+ x 1)) 'pos 'neg) 1)) + + (test/pos-blame + '->i3 + '((contract (->i () () [r number?]) 1 'pos 'neg))) + + (test/pos-blame + '->i4 + '((contract (->i () () [r number?]) (lambda (x) x) 'pos 'neg))) + + (test/neg-blame + '->i5 + '((contract (->i ([x number?]) () any) (lambda (x) (+ x 1)) 'pos 'neg) #f)) + + (test/pos-blame + '->i6 + '((contract (->i ([x number?]) () [r (x) (<=/c x)]) (lambda (x) (+ x 1)) 'pos 'neg) 1)) + + (test/spec-passed + '->i7 + '((contract (->i ([x number?] [y (x) (<=/c x)]) () [r (x) (<=/c x)]) + (lambda (x y) (- x 1)) 'pos 'neg) 1 0)) + + (test/neg-blame + '->i8 + '((contract (->i ([x number?] [y (x) (<=/c x)]) () [r (x) (<=/c x)]) + (lambda (x y) (+ x 1)) 'pos 'neg) 1 2)) + + (test/spec-passed + '->i9 + '((contract (->i ([y (x) (<=/c x)] [x number?]) () [r (x) (<=/c x)]) + (lambda (y x) (- x 1)) 'pos 'neg) 1 2)) + + (test/neg-blame + '->i10 + '((contract (->i ([y (x) (<=/c x)] [x number?]) () [r (x) (<=/c x)]) + (lambda (y x) (+ x 1)) 'pos 'neg) 1 0)) + + (test/spec-passed + '->i11 + '((contract (->i () () #:rest [rest any/c] [r number?]) (lambda x 1) 'pos 'neg))) + + (test/spec-passed + '->i12 + '((contract (->i ([x number?]) () #:rest [rest any/c] [r number?]) + (lambda (x . y) (+ x 1)) 'pos 'neg) 1)) + + (test/pos-blame + '->i13 + '((contract (->i () () #:rest [rest any/c] [r number?]) 1 'pos 'neg))) + + (test/pos-blame + '->i14 + '((contract (->i () () #:rest [rest any/c] [r number?]) (lambda (x) x) 'pos 'neg))) + + (test/neg-blame + '->i15 + '((contract (->i ([x number?]) () #:rest [rest any/c] any) (lambda (x . y) (+ x 1)) 'pos 'neg) #f)) + + (test/pos-blame + '->i16 + '((contract (->i ([x number?]) () #:rest [rest any/c] [r (x) (<=/c x)]) + (lambda (x . y) (+ x 1)) 'pos 'neg) 1)) + + (test/spec-passed + '->i17 + '((contract (->i ([x number?] [y (x) (<=/c x)]) () #:rest [rest any/c] [r (x) (<=/c x)]) + (lambda (x y . z) (- x 1)) 'pos 'neg) 1 0)) + + (test/neg-blame + '->i18 + '((contract (->i ([x number?] [y (x) (<=/c x)]) () #:rest [rest any/c] [r (x) (<=/c x)]) + (lambda (x y . z) (+ x 1)) 'pos 'neg) 1 2)) + + (test/spec-passed + '->i19 + '((contract (->i ([y (x) (<=/c x)] [x number?]) () #:rest [rest any/c] [r (x) (<=/c x)]) + (lambda (y x . z) (- x 1)) 'pos 'neg) 1 2)) + + (test/neg-blame + '->i20 + '((contract (->i ([y (x) (<=/c x)] [x number?]) () #:rest [rest any/c] [r (x) (<=/c x)]) + (lambda (y x . z) (+ x 1)) 'pos 'neg) 1 0)) + + (test/spec-passed + '->i21 + '((contract (->i () () #:rest [rst (listof number?)] [r any/c]) (lambda w 1) 'pos 'neg) 1)) + + (test/neg-blame + '->i22 + '((contract (->i () () #:rest [rst (listof number?)] [r any/c]) (lambda w 1) 'pos 'neg) #f)) + + (test/spec-passed/result + '->i23 + '((contract (->i ([x any/c] #:y [y any/c]) ([z any/c]) any) + (let () + (define (m x #:y y [z 1]) x) + m) + 'pos + 'neg) + 1 #:y 2) + 1) + + (test/spec-passed/result + '->i24 + '((contract (->i ([x any/c]) ([y any/c]) any) + (let () + (define (m x [y 1]) x) + m) + 'pos + 'neg) + 1) + 1) + + + (test/spec-passed/result + '->i28 + '((contract (->i ([x real?]) + #:rest [rest (x) (listof (>=/c x))] + any) + (λ (x . rest) + (cons x rest)) + 'pos + 'neg) + 1 + 2 + 3) + '(1 2 3)) + + (test/neg-blame + '->i29 + '((contract (->i ([x real?]) + #:rest [rest (x) (listof (>=/c x))] + any) + (λ (x . rest) + (cons x rest)) + 'pos + 'neg) + 1 + -2 + -3)) + + (test/spec-passed + '->i-any1 + '((contract (->i () () any) (lambda () 1) 'pos 'neg))) + + (test/spec-passed + '->i-any2 + '((contract (->i ([x number?]) () any) (lambda (x) (+ x 1)) 'pos 'neg) 1)) + + (test/pos-blame + '->i-any3 + '((contract (->i () () any) 1 'pos 'neg))) + + (test/pos-blame + '->i-any4 + '((contract (->i () () any) (lambda (x) x) 'pos 'neg))) + + (test/neg-blame + '->i-any5 + '((contract (->i ([x number?]) () any) (lambda (x) (+ x 1)) 'pos 'neg) #f)) + + (test/spec-passed + '->i-any6 + '((contract (->i ([x number?] [y (x) (<=/c x)]) () any) (lambda (x y) (- x 1)) 'pos 'neg) 1 0)) + + (test/neg-blame + '->i-any7 + '((contract (->i ([x number?] [y (x) (<=/c x)]) () any) (lambda (x y) (+ x 1)) 'pos 'neg) 1 2)) + + (test/spec-passed + '->i-any8 + '((contract (->i ([y (x) (<=/c x)] [x number?]) () any) (lambda (y x) (- x 1)) 'pos 'neg) 1 2)) + + (test/neg-blame + '->i-any9 + '((contract (->i ([y (x) (<=/c x)] [x number?]) () any) (lambda (y x) (+ x 1)) 'pos 'neg) 1 0)) + + (test/spec-passed + '->i-any10 + '((contract (->i () () #:rest [rest any/c] any) (lambda x 1) 'pos 'neg))) + + (test/spec-passed + '->i-any11 + '((contract (->i ([x number?]) () #:rest [rest any/c] any) (lambda (x . y) (+ x 1)) 'pos 'neg) 1)) + + (test/pos-blame + '->i-any12 + '((contract (->i () () #:rest [rest any/c] any) 1 'pos 'neg))) + + (test/pos-blame + '->i-any13 + '((contract (->i () () #:rest [rest any/c] any) (lambda (x) x) 'pos 'neg))) + + (test/neg-blame + '->i-any14 + '((contract (->i ([x number?]) () #:rest [rest any/c] any) (lambda (x . y) (+ x 1)) 'pos 'neg) #f)) + + (test/spec-passed + '->i-any15 + '((contract (->i ([x number?] [y (x) (<=/c x)]) () #:rest [rest any/c] any) + (lambda (x y . z) (- x 1)) 'pos 'neg) 1 0)) + + (test/neg-blame + '->i-any16 + '((contract (->i ([x number?] [y (x) (<=/c x)]) () #:rest [rest any/c] any) + (lambda (x y . z) (+ x 1)) 'pos 'neg) 1 2)) + + (test/spec-passed + '->i-any17 + '((contract (->i ([y (x) (<=/c x)] [x number?]) () #:rest [rest any/c] any) + (lambda (y x . z) (- x 1)) 'pos 'neg) 1 2)) + + (test/neg-blame + '->i-any18 + '((contract (->i ([y (x) (<=/c x)] [x number?]) () #:rest [rest any/c] any) + (lambda (y x . z) (+ x 1)) 'pos 'neg) 1 0)) + + (test/spec-passed + '->i-any19 + '((contract (->i () () #:rest [rst (listof number?)] any) (lambda w 1) 'pos 'neg) 1)) + + (test/neg-blame + '->i-any20 + '((contract (->i () () #:rest [rst (listof number?)] any) (lambda w 1) 'pos 'neg) #f)) + + (test/spec-passed + '->i-values1 + '((contract (->i () () (values [x boolean?] [y number?])) (lambda () (values #t 1)) 'pos 'neg))) + + (test/spec-passed + '->i-values2 + '((contract (->i ([x number?]) () (values [z boolean?] [y number?])) + (lambda (x) (values #t (+ x 1))) 'pos 'neg) 1)) + + (test/pos-blame + '->i-values3 + '((contract (->i () () (values [x boolean?] [y number?])) 1 'pos 'neg))) + + (test/pos-blame + '->i-values4 + '((contract (->i () () (values [x boolean?] [y number?])) (lambda (x) x) 'pos 'neg))) + + (test/neg-blame + '->i-values5 + '((contract (->i ([x number?]) () (values [y boolean?] [z (x) (<=/c x)])) + (lambda (x) (+ x 1)) 'pos 'neg) #f)) + + (test/pos-blame + '->i-values6 + '((contract (->i ([x number?]) () (values [y boolean?] [z (x) (<=/c x)])) + (lambda (x) (values #t (+ x 1))) 'pos 'neg) 1)) + + (test/spec-passed + '->i-values7 + '((contract (->i ([x number?] [y (x) (<=/c x)]) () (values [z boolean?] [w (x) (<=/c x)])) + (lambda (x y) (values #t (- x 1))) + 'pos + 'neg) + 1 + 0)) + + (test/neg-blame + '->i-values8 + '((contract (->i ([x number?] [y (x) (<=/c x)]) () (values [z boolean?] [w (x) (<=/c x)])) + (lambda (x y) (values #f (+ x 1))) + 'pos + 'neg) + 1 + 2)) + + (test/spec-passed + '->i-values9 + '((contract (->i ([y (x) (<=/c x)] [x number?]) () (values [z boolean?] [w (x) (<=/c x)])) + (lambda (y x) (values #f (- x 1))) + 'pos + 'neg) + 1 + 2)) + + (test/neg-blame + '->i-values10 + '((contract (->i ([y (x) (<=/c x)] [x number?]) () (values [z boolean?] [w (x) (<=/c x)])) + (lambda (y x) (values #f (+ x 1))) 'pos 'neg) + 1 0)) + + (test/spec-passed + '->i-values11 + '((contract (->i () () #:rest [rest any/c] (values [z boolean?] [w number?])) + (lambda x (values #f 1)) 'pos 'neg))) + + (test/spec-passed + '->i-values12 + '((contract (->i ([x number?]) () #:rest [rest any/c] (values [z boolean?] [w number?])) + (lambda (x . y) (values #f (+ x 1))) + 'pos + 'neg) + 1)) + + (test/pos-blame + '->i-values13 + '((contract (->i () () #:rest [rest any/c] (values [z boolean?] [w number?])) 1 'pos 'neg))) + + (test/pos-blame + '->i-values14 + '((contract (->i () () #:rest [rest any/c] (values [z boolean?] [w number?])) + (lambda (x) x) 'pos 'neg))) + + (test/neg-blame + '->i-values15 + '((contract (->i ([x number?]) () #:rest [rest any/c] (values [z boolean?] [w (x) (<=/c x)])) + (lambda (x . y) (+ x 1)) 'pos 'neg) + #f)) + + (test/pos-blame + '->i-values16 + '((contract (->i ([x number?]) () #:rest [rest any/c] (values [z boolean?] [w (x) (<=/c x)])) + (lambda (x . y) (values #f (+ x 1))) 'pos 'neg) + 1)) + + (test/spec-passed + '->i-values17 + '((contract (->i ([x number?] [y (x) (<=/c x)]) () #:rest [rest any/c] + (values [z boolean?] [w (x) (<=/c x)])) + (lambda (x y . z) (values #f (- x 1))) 'pos 'neg) + 1 0)) + + (test/neg-blame + '->i-values18 + '((contract (->i ([x number?] [y (x) (<=/c x)]) () #:rest [rest any/c] + (values [z boolean?] [w (x) (<=/c x)])) + (lambda (x y . z) (values #f (+ x 1))) 'pos 'neg) + 1 2)) + + (test/spec-passed + '->i-values19 + '((contract (->i ([y (x) (<=/c x)] [x number?]) () #:rest [rest any/c] + (values [z boolean?] [w (x) (<=/c x)])) + (lambda (y x . z) (values #f (- x 1))) 'pos 'neg) + 1 2)) + + (test/neg-blame + '->i-values20 + '((contract (->i ([y (x) (<=/c x)] [x number?]) () #:rest [rest any/c] + (values [z boolean?] [w (x) (<=/c x)])) + (lambda (y x . z) (values #f (+ x 1))) 'pos 'neg) + 1 0)) + + (test/spec-passed + '->i-values21 + '((contract (->i () () #:rest [rst (listof number?)] (values [z boolean?] [w any/c])) + (lambda w (values #f 1)) 'pos 'neg) 1)) + + (test/neg-blame + '->i-values22 + '((contract (->i () () #:rest [rst (listof number?)] (values [z boolean?] [w any/c])) + (lambda w (values #f 1)) 'pos 'neg) #f)) + + (test/spec-passed + '->i-values23 + '((contract (->i () () (values [x number?] [y (x) (>=/c x)])) (lambda () (values 1 2)) 'pos 'neg))) + + (test/pos-blame + '->i-values24 + '((contract (->i () () (values [x number?] [y (x) (>=/c x)])) (lambda () (values 2 1)) 'pos 'neg))) + + (test/spec-passed + '->i-values25 + '((contract (->i ([x number?]) () (values [z number?] [y (x) (>=/c x)])) + (lambda (x) (values 1 2)) 'pos 'neg) 1)) + + (test/pos-blame + '->i-values26 + '((contract (->i ([x number?]) () (values [z number?] [y (x) (>=/c x)])) + (lambda (x) (values 2 1)) 'pos 'neg) 4)) + + (test/spec-passed/result + '->i23 + '((contract (->i ((i number?) (j (i) (and/c number? (>=/c i)))) () [r number?]) + (λ (i j) 1) + 'pos + 'neg) + 1 + 2) + 1) + + (test/spec-passed/result + '->i24 + '((contract (->i ([i number?] [j (i) (and/c number? (>=/c i))]) () any) + (λ (i j) 1) + 'pos + 'neg) + 1 + 2) + 1) + + (test/spec-passed/result + '->i25 + '(call-with-values + (λ () + ((contract (->i ((i number?) (j (i) (and/c number? (>=/c i)))) () + (values [x number?] [y number?])) + (λ (i j) (values 1 2)) + 'pos + 'neg) + 1 + 2)) + list) + '(1 2)) + + (test/spec-passed/result + '->i26 + '((contract (->i ((i number?) (j (i) (and/c number? (>=/c i)))) () + #:rest [rest-args any/c] [r number?]) + (λ (i j . z) 1) + 'pos + 'neg) + 1 + 2) + 1) + + (test/spec-passed/result + '->i27 + '((contract (->i ((i number?) (j (i) (and/c number? (>=/c i)))) () #:rest [rest-args any/c] any) + (λ (i j . z) 1) + 'pos + 'neg) + 1 + 2) + 1) + + (test/spec-passed/result + '->i28 + '(call-with-values + (λ () + ((contract (->i ((i number?) (j (i) (and/c number? (>=/c i)))) () + #:rest [rest-args any/c] + (values [x number?] [y number?])) + (λ (i j . z) (values 1 2)) + 'pos + 'neg) + 1 + 2)) + list) + '(1 2)) + + (test/neg-blame + '->i30 + '((contract (->i ([x number?]) () #:rest [rst number?] any) + (λ (x . rst) (values 4 5)) + 'pos + 'neg) + #f)) + + (test/spec-passed/result + '->i34 + '((contract (->i ([x number?] + [y (x z) (between/c x z)] + [z number?]) + any) + (λ (x y z) (+ x y z)) + 'pos 'neg) + 1 2 3) + 6) + + (test/neg-blame + '->i35 + '((contract (->i ([x number?]) #:pre () (= 1 2) any) + (λ (x) 1) + 'pos 'neg) 2)) + + (test/neg-blame + '->i35-b + '((contract (->i ([x number?]) #:pre () #t #:pre () (= 1 2) any) + (λ (x) 1) + 'pos 'neg) 2)) + + (test/neg-blame + '->i35-c + '((contract (->i ([x number?]) #:pre (x) (even? x) #:pre (x) (positive? x) any) + (λ (x) 1) + 'pos 'neg) 3)) + + (test/neg-blame + '->i35-d + '((contract (->i ([x number?]) #:pre (x) (even? x) #:pre (x) (positive? x) any) + (λ (x) 1) + 'pos 'neg) -2)) + + (test/neg-blame + '->i35-e + '((contract (->i ([x any/c]) #:pre (x) (pair? x) #:pre (x) (car x) any) + (λ (x) 1) + 'pos 'neg) + (cons #f 1))) + + (test/neg-blame + '->i35-f + '((contract (->i ([x any/c]) #:pre/name (x) "pair" (pair? x) #:pre/name (x) "car" (car x) any) + (λ (x) 1) + 'pos 'neg) + (cons #f 1))) + + (test/spec-passed/result + '->i36 + '((contract (->i ([f (-> number? number?)]) [res number?]) + (λ (f) (f 1)) + 'pos 'neg) + (λ (n) (+ n 1))) + 2) + + (test/pos-blame + '->i37 + '((contract (->i ([f (-> number? number?)]) [res number?]) + (λ (f) #f) + 'pos 'neg) + (λ (n) (+ n 1)))) + + (test/spec-passed/result + '->i38 + '((contract (->i ([x integer?]) () #:rest [rst (listof number?)] [r any/c]) (lambda w w) 'pos 'neg) + 1 2) + '(1 2)) + + (test/spec-passed/result + '->i39 + '((contract (->i (#:x [x integer?]) () #:rest [rst (listof number?)] [r any/c]) + (lambda (#:x x . w) (cons x w)) 'pos 'neg) #:x 1 2) + '(1 2)) + + (test/spec-passed/result + '->i40 + '((contract (->i () ([x integer?]) #:rest [rst (listof number?)] [r any/c]) + (lambda w w) 'pos 'neg) 1 2) + '(1 2)) + + (test/spec-passed/result + '->i41 + '((contract (->i () (#:x [x integer?]) #:rest [rst (listof number?)] [r any/c]) + (lambda (#:x [x 1] . w) (cons x w)) 'pos 'neg) #:x 2 3) + '(2 3)) + + (test/spec-passed/result + '->i42 + '((contract (->i () (#:x [x integer?]) #:rest [rst (listof number?)] [r any/c]) + (lambda (#:x [x 1] . w) (cons x w)) 'pos 'neg) 2 3) + '(1 2 3)) + + (test/spec-passed/result + '->i43 + '(let ([b (box '())]) + ((contract (->i ([i (box/c (listof integer?))]) + (values [_ (i) + (begin + (set-box! i (cons 1 (unbox i))) + (λ (x) + (set-box! i (cons 4 (unbox i))) + #t))] + [_ (i) + (begin + (set-box! i (cons 2 (unbox i))) + (λ (x) + (set-box! i (cons 5 (unbox i))) + #t))])) + (λ (i) + (set-box! i (cons 3 (unbox i))) + (values 2 2)) + (quote pos) + (quote neg)) + b) + (unbox b)) + '(5 4 3 2 1)) + + (test/spec-passed/result + '->i44 + '((contract (->i ([x () any/c]) + [y any/c] + #:post (x) x) + (lambda (x) x) + 'pos + 'neg) + #t) + '#t) + + (test/pos-blame + '->i45 + '((contract (->i ([x () any/c]) + [y any/c] + #:post (x) x) + (lambda (x) x) + 'pos + 'neg) + #f)) + + (test/spec-passed/result + '->i46 + '((contract (->i ([x any/c]) + [y () any/c] + #:post (y) y) + (lambda (x) x) + 'pos + 'neg) + #t) + '#t) + + (test/pos-blame + '->i47 + '((contract (->i ([x any/c]) + [y () any/c] + #:post (y) y) + (lambda (x) x) + 'pos + 'neg) + #f)) + + (test/pos-blame + '->i47-b + '((contract (->i ([x any/c]) + [y () any/c] + #:post (y) (even? y) + #:post (y) (positive? y)) + (lambda (x) x) + 'pos + 'neg) + -2)) + + (test/pos-blame + '->i47-c + '((contract (->i ([x any/c]) + [y () any/c] + #:post (y) (even? y) + #:post (y) (positive? y)) + (lambda (x) x) + 'pos + 'neg) + 3)) + + (test/pos-blame + '->i47-d + '((contract (->i ([x any/c]) + [y () any/c] + #:post (y) (pair? y) + #:post (y) (car y)) + (lambda (x) x) + 'pos + 'neg) + (cons #f 1))) + + (test/pos-blame + '->i47-e + '((contract (->i ([x any/c]) + [y () any/c] + #:post/name (y) "pair" (pair? y) + #:post/name (y) "car" (car y)) + (lambda (x) x) + 'pos + 'neg) + (cons #f 1))) + + (test/spec-passed/result + '->i48 + '(let ([x '()]) + ((contract (->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)]) + [res () (begin + (set! x (cons 'res-eval x)) + (λ (res) + (set! x (cons 'res-check x))))]) + (λ (arg) + (set! x (cons 'body x))) + 'pos + 'neg) + 1) + x) + '(res-check res-eval body arg-eval)) + + (test/spec-passed/result + '->i49 + '(let ([x '()]) + ((contract (->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)]) + [_ () (begin + (set! x (cons 'res-eval x)) + (λ (res) + (set! x (cons 'res-check x))))]) + (λ (arg) + (set! x (cons 'body x))) + 'pos + 'neg) + 1) + x) + '(res-check body res-eval arg-eval)) + + (test/spec-passed/result + '->i50 + '(let ([x '()]) + ((contract (->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)]) + [res (begin + (set! x (cons 'res-eval x)) + (λ (res) + (set! x (cons 'res-check x))))]) + (λ (arg) + (set! x (cons 'body x))) + 'pos + 'neg) + 1) + x) + '(res-check body res-eval arg-eval)) + + (test/spec-passed/result + '->i51 + '(let ([x '()]) + ((contract (->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)]) + [_ (begin + (set! x (cons 'res-eval x)) + (λ (res) + (set! x (cons 'res-check x))))]) + (λ (arg) + (set! x (cons 'body x))) + 'pos + 'neg) + 1) + x) + '(res-check body res-eval arg-eval)) + + (test/spec-passed/result + '->i52 + '((contract (->i () + ([x integer?]) + any) + (λ ([x 'qq]) x) + 'pos + 'neg)) + 'qq) + + (test/pos-blame + '->i-arity1 + '(contract (->i ([x number?]) () any) (λ () 1) 'pos 'neg)) + + (test/pos-blame + '->i-arity2 + '(contract (->i ([x number?]) () any) (λ (x #:y y) 1) 'pos 'neg)) + + (test/spec-passed + '->i-arity3 + '(contract (->i ([x number?] #:y [y integer?]) () any) (λ (x #:y y) 1) 'pos 'neg)) + + (test/pos-blame + '->i-arity4 + '(contract (->i () ([x integer?]) any) (λ (x) 1) 'pos 'neg)) + + (test/pos-blame + '->i-arity5 + '(contract (->i () ([x integer?]) any) (λ () 1) 'pos 'neg)) + + (test/spec-passed + '->i-arity6 + '(contract (->i () ([x integer?]) any) (λ ([x 1]) 1) 'pos 'neg)) + + (test/pos-blame + '->i-arity7 + '(contract (->i () (#:x [x integer?]) any) (λ ([x 1]) 1) 'pos 'neg)) + + (test/pos-blame + '->i-arity8 + '(contract (->i () (#:x [x integer?]) any) (λ () 1) 'pos 'neg)) + + (test/pos-blame + '->i-arity8 + '(contract (->i () (#:x [x integer?]) any) (λ (#:x x) 1) 'pos 'neg)) + + (test/spec-passed + '->i-arity10 + '(contract (->i () (#:x [x integer?]) any) (λ (#:x [x 1]) 1) 'pos 'neg)) + + (test/pos-blame + '->i-pp1 + '((contract (->i ([x number?]) () #:pre (x) (= x 1) [result number?] #:post (x) (= x 2)) + (λ (x) x) + 'pos + 'neg) + 1)) + + (test/neg-blame + '->i-pp2 + '((contract (->i ([x number?]) () #:pre (x) (= x 1) [result number?] #:post (x) (= x 2)) + (λ (x) x) + 'pos + 'neg) + 2)) + + (test/pos-blame + '->i-pp3 + '((contract (->i ([x number?]) () #:pre (x) (= x 1) [result number?] #:post (result) (= result 2)) + (λ (x) x) + 'pos + 'neg) + 1)) + + (test/spec-passed + '->i-pp3.5 + '((contract (->i ([x number?]) () #:pre (x) (= x 1) [result number?] #:post (result) (= result 2)) + (λ (x) 2) + 'pos + 'neg) + 1)) + + (test/neg-blame + '->i-pp4 + '((contract (->i ([x number?]) () #:pre (x) (= x 1) any) + (λ (x) x) + 'pos + 'neg) + 2)) + + (test/neg-blame + '->i-pp5 + '((contract (->i ([x number?]) () #:pre (x) (= x 1) (values [z number?] [y number?]) + #:post (x y z) (= x y z 3)) + (λ (x) (values 4 5)) + 'pos + 'neg) + 2)) + + (test/pos-blame + '->i-pp6 + '((contract (->i ([x number?]) () #:pre (x) (= x 1) (values [z number?] [y number?]) + #:post (z y) (= z y 3)) + (λ (x) (values 4 5)) + 'pos + 'neg) + 1)) + + (test/pos-blame + '->i-pp-r1 + '((contract (->i ([x number?]) () #:rest [rst any/c] #:pre (x) (= x 1) [result number?] + #:post (x) (= x 2)) + (λ (x . rst) x) + 'pos + 'neg) + 1)) + + (test/neg-blame + '->i-pp-r2 + '((contract (->i ([x number?]) () #:rest [rst any/c] + #:pre (x) (= x 1) [result number?] + #:post (x) (= x 2)) + (λ (x . rst) x) + 'pos + 'neg) + 2)) + + (test/pos-blame + '->i-pp-r3 + '((contract (->i ([x number?]) () #:rest [rst any/c] + #:pre (x) (= x 1) [result number?] + #:post (result) (= result 2)) + (λ (x . rst) x) + 'pos + 'neg) + 1)) + + (test/spec-passed + '->i-pp-r3.5 + '((contract (->i ([x number?]) () #:rest [rst any/c] + #:pre (x) (= x 1) [result number?] + #:post (result) (= result 2)) + (λ (x . rst) 2) + 'pos + 'neg) + 1)) + + (test/neg-blame + '->i-pp-r4 + '((contract (->i ([x number?]) () #:rest [rst any/c] #:pre (x) (= x 1) any) + (λ (x . rst) x) + 'pos + 'neg) + 2)) + + (test/neg-blame + '->i-pp-r5 + '((contract (->i ([x number?]) () #:rest [rst any/c] + #:pre (x) (= x 1) (values [z number?] [y number?]) + #:post (x y z) (= x y z 3)) + (λ (x . rst) (values 4 5)) + 'pos + 'neg) + 2)) + + (test/pos-blame + '->i-pp-r6 + '((contract (->i ([x number?]) () #:rest [rst any/c] + #:pre (x) (= x 1) (values [z number?] [y number?]) + #:post (x y z) (= z x y 3)) + (λ (x . rst) (values 4 5)) + 'pos + 'neg) + 1)) + + + ;; test to make sure the values are in the error messages + (contract-error-test + '->i-contract-error-test1 + '((contract (->i ([x number?]) #:pre (x) #f any) + (λ (x) x) + 'pos + 'neg) + 123456789) + (λ (x) + (and (exn:fail:contract:blame? x) + (regexp-match #rx"x: 123456789" (exn-message x))))) + (contract-error-test + '->i-contract-error-test2 + '((contract (->i ([|x y| number?]) #:pre (|x y|) #f any) + (λ (x) x) + 'pos + 'neg) + 123456789) + (λ (x) + (and (exn:fail:contract:blame? x) + (regexp-match (regexp-quote "|x y|: 123456789") (exn-message x))))) + + ;; test to make sure the collects directories are appropriately prefixed + (contract-error-test + '->i-contract-error-test3 + '(contract symbol? "not a symbol" 'pos 'neg 'not-a-symbol + (datum->syntax + #f + 'here + (vector (collection-file-path "base.rkt" "racket") + 1 1 1 1))) + (lambda (x) + (and (exn:fail:contract:blame? x) + (let ([msg (exn-message x)]) + (define ans (regexp-match? #px"" msg)) + (unless ans + (printf "msg: ~s\n" msg)) + ans)))) + + ;; make sure that ->i checks its arguments + (contract-error-test + '->i-contract-error-test4 + '(->i ([x (λ (x y z) #f)]) any) + exn:fail?) + + (contract-error-test + '->i-contract-error-test5 + '(->i () (values [x (λ (x y z) #f)][y 5])) + exn:fail?) + + (test/neg-blame + '->i-protect-shared-state + '(let ([x 1]) + ((contract (let ([save #f]) + (-> (->i () () #:pre () (set! save x) [range any/c] #:post () (= save x)) + any)) + (λ (t) (t)) + 'pos + 'neg) + (lambda () (set! x 2))))) + + + (test/spec-passed + '->i-optopt1 + '((contract (->i ([x number?]) any) + (λ (x) x) + 'pos 'neg) + 1)) + + (test/spec-passed + '->i-optopt2 + '((contract (->i ([x number?]) #:rest [rst any/c] any) + (λ (x . y) x) + 'pos 'neg) + 1)) + + (test/spec-passed + '->i-optopt3 + '((contract (->i ([x number?]) #:pre () #t any) + (λ (x) x) + 'pos 'neg) + 1)) + + (test/spec-passed + '->i-optopt4 + '((contract (->i ([x number?]) #:rest [rst any/c] #:pre () #t any) + (λ (x . y) x) + 'pos 'neg) + 1)) + + (test/spec-passed + '->i-optopt5 + '((contract (->i ([x number?]) #:rest [rst any/c] #:pre () #t [res any/c] #:post () #t) + (λ (x . y) x) + 'pos 'neg) + 1)) + + (test/spec-passed + '->i-optopt6 + '((contract (->i ([x number?]) #:rest [rst any/c] [res any/c] #:post () #t) + (λ (x . y) x) + 'pos 'neg) + 1)) + + (test/spec-passed + '->i-optopt7 + '((contract (->i ([x number?]) #:pre () #t [res any/c] #:post () #t) + (λ (x . y) x) + 'pos 'neg) + 1)) + + (test/spec-passed + '->i-optopt8 + '((contract (->i ([x number?]) [res any/c] #:post () #t) + (λ (x . y) x) + 'pos 'neg) + 1)) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; make sure the variables are all bound properly + ;; + + (test/spec-passed + '->i-binding1 + '((contract (->i ([x number?]) () + #:rest [rest any/c] [range any/c] + #:post (rest) (equal? rest '(2 3 4))) + (λ (x . y) y) + 'pos + 'neg) + 1 2 3 4)) + + (test/spec-passed + '->i-binding2 + '((contract (->i ([x number?]) () #:rest [rest any/c] [range any/c] #:post (x) (equal? x 1)) + (λ (x . y) y) + 'pos + 'neg) + 1 2 3 4)) + + (test/spec-passed + '->i-binding3 + '(let ([p 'p] + [q 'q] + [r 'r]) + ((contract (->i ([x number?] [y number?] #:z [z number?] #:w [w number?]) + ([a number?] [b number?] #:c [c number?] #:d [d number?]) + #:rest [rest any/c] + #:pre (x y z w a b c d rest) + (equal? (list x y z w a b c d rest p q r) + (list 1 2 3 4 5 6 7 8 '(z) 'p 'q 'r)) + (values [p number?] [q number?] [r number?])) + (λ (x y #:z z #:w w [a 101] [b 102] #:c [c 103] #:d [d 104] . rest) + (values 11 12 13)) + 'pos + 'neg) + 1 2 #:z 3 #:w 4 5 6 #:c 7 #:d 8 'z))) + + (test/spec-passed + '->i-binding4 + '((contract (->i ([x number?] [y number?] #:z [z number?] #:w [w number?]) + ([a number?] [b number?] #:c [c number?] #:d [d number?]) + #:rest [rest any/c] + (values [p number?] [q number?] [r number?]) + #:post (x y z w a b c d rest p q r) + (equal? (list x y z w a b c d rest p q r) + (list 1 2 3 4 5 6 7 8 '(z) 11 12 13))) + (λ (x y #:z z #:w w [a 101] [b 102] #:c [c 103] #:d [d 104] . rest) + (values 11 12 13)) + 'pos + 'neg) + 1 2 #:z 3 #:w 4 5 6 #:c 7 #:d 8 'z)) + + (test/spec-passed + '->i-binding5 + '(let ([p 'p] + [q 'q] + [r 'r]) + ((contract (->i ([x number?] [y number?] #:z [z number?] #:w [w number?]) + ([a number?] [b number?] #:c [c number?] #:d [d number?]) + #:rest [rest any/c] + #:pre (x y z w a b c d rest) + (equal? (list x y z w a b c d rest p q r) + (list 1 2 3 4 + the-unsupplied-arg the-unsupplied-arg + the-unsupplied-arg the-unsupplied-arg + '() 'p 'q 'r)) + (values [p number?] [q number?] [r number?])) + (λ (x y #:z z #:w w [a 101] [b 102] #:c [c 103] #:d [d 104] . rest) + (values 11 12 13)) + 'pos + 'neg) + 1 2 #:z 3 #:w 4))) + + (test/spec-passed + '->i-binding6 + '((contract (->i ([x number?] [y number?] #:z [z number?] #:w [w number?]) + ([a number?] [b number?] #:c [c number?] #:d [d number?]) + #:rest [rest any/c] + (values [p number?] [q number?] [r number?]) + #:post (x y z w a b c d rest p q r) + (equal? (list x y z w a b c d rest p q r) + (list 1 2 3 4 + the-unsupplied-arg the-unsupplied-arg + the-unsupplied-arg the-unsupplied-arg + '() 11 12 13))) + (λ (x y #:z z #:w w [a 101] [b 102] #:c [c 103] #:d [d 104] . rest) + (values 11 12 13)) + 'pos + 'neg) + 1 2 #:z 3 #:w 4)) + + ;; test that the rest parameter is right when there aren't + ;; enough arguments to even make it to the rest parameter + (test/spec-passed + '->i-binding7 + '((contract (->i () + ([a number?]) + #:rest [rest any/c] + [_ any/c] + #:post (a rest) (equal? (list a rest) (list the-unsupplied-arg '()))) + (λ ([a 1] . rest) 1) + 'pos + 'neg))) + + (test/pos-blame + '->i-underscore1 + '((contract (->i ([b (box/c integer?)]) + () + [_ (b) + (let ([old (unbox b)]) + (and/c + void? + (λ (new) + (= old (unbox b)))))]) + (λ (b) + (set-box! b (+ (unbox b) 1))) + 'pos + 'neg) + (box 1))) + + (test/spec-passed/result + '->i-underscore2 + '(let ([x '()]) + ((contract (->i () () [_ (begin (set! x (cons 'ctc x)) any/c)]) + (λ () (set! x (cons 'body x))) + 'pos + 'neg)) + x) + '(body ctc)) + + (test/spec-passed/result + '->i-underscore3 + '(let ([x '()]) + ((contract (->i () () [res (begin (set! x (cons 'ctc x)) any/c)]) + (λ () (set! x (cons 'body x))) + 'pos + 'neg)) + x) + '(body ctc)) + + (test/spec-passed/result + '->i-underscore4 + '((contract (->i ([str any/c]) () #:rest [rest (listof any/c)] [_ any/c]) + (λ (x . y) (cons x y)) + 'pos 'neg) + 1 2 3) + '(1 2 3)) + + (test/spec-passed/result + '->i-underscore5 + '((contract (->i ([str any/c]) () #:rest [rest (listof any/c)] [_ any/c]) + (λ (x . y) (cons x y)) + 'pos 'neg) + 1 2 3 4 5) + '(1 2 3 4 5)) + + (test/spec-passed/result + '->i-underscore6 + '(let ([x '()]) + ((contract (->i ([a integer?]) () [_ (a) (begin (set! x (cons 'ctc x)) any/c)]) + (λ (a) (set! x (cons 'body x))) + 'pos + 'neg) + 11) + x) + '(body ctc)) + + (test/pos-blame + '->i-bad-number-of-result-values1 + '((contract (->i ((x any/c)) (result (x) any/c)) + (λ (x) (values 1 2)) + 'pos + 'neg) + 1)) + + (test/pos-blame + '->i-bad-number-of-result-values2 + '((contract (->i ((giraffe any/c)) (elephant any/c)) + (λ (x) (values 1 2)) + 'pos + 'neg) + 1)) + + ;; this used to cause a runtime error in the code that parses ->i + (test/no-error '(->i ([x () any/c] [y (x) any/c]) any))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow-star.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow-star.rkt new file mode 100644 index 0000000000..9dd2790c09 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow-star.rkt @@ -0,0 +1,577 @@ +#lang racket/base + +(require "test-util.rkt") +(parameterize ([current-contract-namespace + (make-basic-contract-namespace)]) + + (test/no-error '(->* (integer?) () (values integer?))) + (test/no-error '(->* (integer?) () #:rest integer? integer?)) + (test/no-error '(->* (integer?) () #:rest integer? any)) + (test/no-error '(->* ((flat-contract integer?)) () (flat-contract integer?))) + (test/no-error '(->* ((flat-contract integer?)) () #:rest (flat-contract integer?) + (flat-contract integer?))) + (test/no-error '(->* ((flat-contract integer?)) () #:rest (flat-contract integer?) + (values (flat-contract integer?) (flat-contract boolean?)))) + (test/no-error '(->* ((flat-contract integer?)) () #:rest (flat-contract integer?) any)) + (test/no-error '(->* ((flat-contract integer?)) () #:pre #t (flat-contract integer?) #:post #t)) + + + + (test/spec-passed + 'contract-arrow-star0a + '(contract (->* (integer?) () integer?) + (lambda (x) x) + 'pos + 'neg)) + + (test/neg-blame + 'contract-arrow-star0b + '((contract (->* (integer?) () integer?) + (lambda (x) x) + 'pos + 'neg) + #f)) + + (test/pos-blame + 'contract-arrow-star0c + '((contract (->* (integer?) () integer?) + (lambda (x) #f) + 'pos + 'neg) + 1)) + + (test/spec-passed + 'contract-arrow-star1 + '(let-values ([(a b) ((contract (->* (integer?) () (values integer? integer?)) + (lambda (x) (values x x)) + 'pos + 'neg) + 2)]) + 1)) + + (test/neg-blame + 'contract-arrow-star2 + '((contract (->* (integer?) () (values integer? integer?)) + (lambda (x) (values x x)) + 'pos + 'neg) + #f)) + + (test/pos-blame + 'contract-arrow-star3 + '((contract (->* (integer?) () (values integer? integer?)) + (lambda (x) (values 1 #t)) + 'pos + 'neg) + 1)) + + (test/pos-blame + 'contract-arrow-star4 + '((contract (->* (integer?) () (values integer? integer?)) + (lambda (x) (values #t 1)) + 'pos + 'neg) + 1)) + + + (test/spec-passed + 'contract-arrow-star5 + '(let-values ([(a b) ((contract (->* (integer?) () + #:rest (listof integer?) + (values integer? integer?)) + (lambda (x . y) (values x x)) + 'pos + 'neg) + 2)]) + 1)) + + (test/neg-blame + 'contract-arrow-star6 + '((contract (->* (integer?) () #:rest (listof integer?) (values integer? integer?)) + (lambda (x . y) (values x x)) + 'pos + 'neg) + #f)) + + (test/pos-blame + 'contract-arrow-star7 + '((contract (->* (integer?) () #:rest (listof integer?) (values integer? integer?)) + (lambda (x . y) (values 1 #t)) + 'pos + 'neg) + 1)) + + (test/pos-blame + 'contract-arrow-star8 + '((contract (->* (integer?) () #:rest (listof integer?) (values integer? integer?)) + (lambda (x) (values #t 1)) + 'pos + 'neg) + 1)) + + (test/spec-passed + 'contract-arrow-star9 + '((contract (->* (integer?) () #:rest (listof integer?) integer?) + (lambda (x . y) 1) + 'pos + 'neg) + 1 2)) + + (test/neg-blame + 'contract-arrow-star10 + '((contract (->* (integer?) () #:rest (listof integer?) integer?) + (lambda (x . y) 1) + 'pos + 'neg) + 1 2 'bad)) + + (test/spec-passed + 'contract-arrow-star11 + '(let-values ([(a b) ((contract (->* (integer?) () + #:rest (listof integer?) + any) + (lambda (x . y) (values x x)) + 'pos + 'neg) + 2)]) + 1)) + + (test/pos-blame + 'contract-arrow-star11b + '(let-values ([(a b) ((contract (->* (integer?) () + #:rest (listof integer?) + any) + (lambda (x) (values x x)) + 'pos + 'neg) + 2)]) + 1)) + + (test/neg-blame + 'contract-arrow-star12 + '((contract (->* (integer?) () #:rest (listof integer?) any) + (lambda (x . y) (values x x)) + 'pos + 'neg) + #f)) + + (test/spec-passed + 'contract-arrow-star13 + '((contract (->* (integer?) () #:rest (listof integer?) any) + (lambda (x . y) 1) + 'pos + 'neg) + 1 2)) + + (test/neg-blame + 'contract-arrow-star14 + '((contract (->* (integer?) () #:rest (listof integer?) any) + (lambda (x . y) 1) + 'pos + 'neg) + 1 2 'bad)) + + (test/spec-passed + 'contract-arrow-star15 + '(let-values ([(a b) ((contract (->* (integer?) () any) + (lambda (x) (values x x)) + 'pos + 'neg) + 2)]) + 1)) + + (test/spec-passed + 'contract-arrow-star16 + '((contract (->* (integer?) () any) + (lambda (x) x) + 'pos + 'neg) + 2)) + + (test/neg-blame + 'contract-arrow-star17 + '((contract (->* (integer?) () any) + (lambda (x) (values x x)) + 'pos + 'neg) + #f)) + + (test/pos-blame + 'contract-arrow-star-arity-check1 + '(contract (->* (integer?) () #:rest (listof integer?) (values integer? integer?)) + (lambda (x) (values 1 #t)) + 'pos + 'neg)) + + (test/pos-blame + 'contract-arrow-star-arity-check2 + '(contract (->* (integer?) () #:rest (listof integer?) (values integer? integer?)) + (lambda (x y) (values 1 #t)) + 'pos + 'neg)) + + (test/pos-blame + 'contract-arrow-star-arity-check3 + '(contract (->* (integer?) () #:rest (listof integer?) (values integer? integer?)) + (case-lambda [(x y) #f] [(x y . z) #t]) + 'pos + 'neg)) + + (test/spec-passed + 'contract-arrow-star-arity-check4 + '(contract (->* (integer?) () #:rest (listof integer?) (values integer? integer?)) + (case-lambda [(x y) #f] [(x y . z) #t] [(x) #f]) + 'pos + 'neg)) + + (test/pos-blame + 'contract-arrow-star-keyword1 + '(contract (->* (integer?) () #:rest (listof integer?) (values integer?)) + (λ (x #:y y . args) x) + 'pos + 'neg)) + + (test/pos-blame + 'contract-arrow-star-keyword2 + '(contract (->* (integer?) () #:rest (listof integer?) any) + (λ (x #:y y . args) x) + 'pos + 'neg)) + + (test/spec-passed + 'contract-arrow-star-keyword3 + '(contract (->* (integer? #:y integer?) () #:rest (listof integer?) (values integer? integer?)) + (λ (x #:y y . args) x) + 'pos + 'neg)) + + (test/spec-passed + 'contract-arrow-star-keyword4 + '(contract (->* (integer? #:y integer?) () #:rest (listof integer?) any) + (λ (x #:y y . args) x) + 'pos + 'neg)) + + (test/neg-blame + 'contract-arrow-star-keyword5 + '((contract (->* (integer? #:y integer?) () #:rest (listof integer?) (values integer? integer?)) + (λ (x #:y y . args) x) + 'pos + 'neg) + 1 #:y #t)) + + (test/neg-blame + 'contract-arrow-star-keyword6 + '((contract (->* (integer? #:y integer?) () #:rest (listof integer?) any) + (λ (x #:y y . args) x) + 'pos + 'neg) + 1 #:y #t)) + + (test/neg-blame + 'contract-arrow-star-keyword7 + '((contract (->* (integer? #:y integer?) () #:rest (listof integer?) (values integer? integer?)) + (λ (x #:y y . args) x) + 'pos + 'neg) + #t #:y 1)) + + (test/neg-blame + 'contract-arrow-star-keyword8 + '((contract (->* (integer? #:y integer?) () #:rest (listof integer?) any) + (λ (x #:y y . args) x) + 'pos + 'neg) + #t #:y 1)) + + (test/spec-passed + 'contract-arrow-star-keyword9 + '((contract (->* (integer? #:y integer?) () #:rest (listof integer?) (values integer? integer?)) + (λ (x #:y y . args) (values x x)) + 'pos + 'neg) + 2 #:y 1)) + + (test/spec-passed + 'contract-arrow-star-keyword10 + '((contract (->* (integer? #:y integer?) () #:rest (listof integer?) any) + (λ (x #:y y . args) (values x x)) + 'pos + 'neg) + 2 #:y 1)) + + (test/spec-passed + 'contract-arrow-star-optional1 + '(contract (->* (#:x boolean?) (#:y string? #:z char? integer?) any) + (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) + (list x s c i)) + 'pos 'neg)) + + (test/pos-blame + 'contract-arrow-star-optional2 + '(contract (->* (#:x boolean?) (#:y string? #:z char? integer?) any) + (λ (#:x x #:z [c #\c] [i 5]) + (list x s c i)) + 'pos 'neg)) + + (test/spec-passed + 'contract-arrow-star-optional3 + '(contract (->* (#:x boolean?) (#:z char? integer?) any) + (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) + (list x s c i)) + 'pos 'neg)) + + (test/pos-blame + 'contract-arrow-star-optional4 + '(contract (->* (#:x boolean?) (#:y string? #:z char? integer?) any) + (λ (#:x x #:y [s "s"] #:z [c #\c]) + (list x s c i)) + 'pos 'neg)) + + (test/spec-passed/result + 'contract-arrow-star-optional5 + '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) any) + (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) + (list x s c i)) + 'pos 'neg) + #:x #t #:y "" #:z #\d 6) + '(#t "" #\d 6)) + + (test/spec-passed/result + 'contract-arrow-star-optional6 + '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) any) + (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) + (list x s c i)) + 'pos 'neg) + #:x #t) + '(#t "s" #\c 5)) + + (test/neg-blame + 'contract-arrow-star-optional7 + '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) any) + (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) + (list x s c i)) + 'pos 'neg) + #:x #t #:y 'x #:z #\d 6)) + + (test/neg-blame + 'contract-arrow-star-optional8 + '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) any) + (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) + (list x s c i)) + 'pos 'neg) + #:x #t #:y "" #:z 'x 6)) + + (test/neg-blame + 'contract-arrow-star-optional9 + '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) any) + (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) + (list x s c i)) + 'pos 'neg) + #:x #t #:y "" #:z #\d 'x)) + + (test/pos-blame + 'contract-arrow-star-optional10 + '(contract (->* (#:x boolean?) (#:y string?) any) + (λ (#:x [x #f] #:y s) + (list x s c i)) + 'pos 'neg)) + + (test/spec-passed + 'contract-arrow-star-optional11 + '(contract (->* (#:x boolean?) (#:y string? #:z char? integer?) + (list/c boolean? string? char? integer?)) + (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) + (list x s c i)) + 'pos 'neg)) + + (test/pos-blame + 'contract-arrow-star-optional12 + '(contract (->* (#:x boolean?) (#:y string? #:z char? integer?) + (list/c boolean? string? char? integer?)) + (λ (#:x x #:z [c #\c] [i 5]) + (list x s c i)) + 'pos 'neg)) + + (test/spec-passed + 'contract-arrow-star-optional13 + '(contract (->* (#:x boolean?) (#:z char? integer?) (list/c boolean? string? char? integer?)) + (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) + (list x s c i)) + 'pos 'neg)) + + (test/pos-blame + 'contract-arrow-star-optional14 + '(contract (->* (#:x boolean?) (#:y string? #:z char? integer?) + (list/c boolean? string? char? integer?)) + (λ (#:x x #:y [s "s"] #:z [c #\c]) + (list x s c i)) + 'pos 'neg)) + + (test/spec-passed/result + 'contract-arrow-star-optional15 + '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) + (list/c boolean? string? char? integer?)) + (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) + (list x s c i)) + 'pos 'neg) + #:x #t #:y "" #:z #\d 6) + '(#t "" #\d 6)) + + (test/spec-passed/result + 'contract-arrow-star-optional16 + '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) + (list/c boolean? string? char? integer?)) + (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) + (list x s c i)) + 'pos 'neg) + #:x #t) + '(#t "s" #\c 5)) + + (test/neg-blame + 'contract-arrow-star-optional17 + '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) + (list/c boolean? string? char? integer?)) + (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) + (list x s c i)) + 'pos 'neg) + #:x #t #:y 'x #:z #\d 6)) + + (test/neg-blame + 'contract-arrow-star-optional18 + '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) + (list/c boolean? string? char? integer?)) + (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) + (list x s c i)) + 'pos 'neg) + #:x #t #:y "" #:z 'x 6)) + + (test/neg-blame + 'contract-arrow-star-optional19 + '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) + (list/c boolean? string? char? integer?)) + (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5]) + (list x s c i)) + 'pos 'neg) + #:x #t #:y "" #:z #\d 'x)) + + (test/pos-blame + 'contract-arrow-star-optional20 + '(contract (->* (#:x boolean?) (#:y string?) (list/c boolean? string? char? integer?)) + (λ (#:x [x #f] #:y s) + (list x s c i)) + 'pos 'neg)) + + (test/spec-passed + 'contract-arrow-star-optional21 + '((contract (->* () () (values)) + (λ () (values)) + 'pos 'neg))) + + (test/spec-passed + 'contract-arrow-star-optional22 + '((contract (->* () () (values integer? char?)) + (λ () (values 1 #\c)) + 'pos 'neg))) + + (test/pos-blame + 'contract-arrow-star-optional23 + '((contract (->* () () (values integer? char?)) + (λ () (values 1 2)) + 'pos 'neg))) + + (test/spec-passed + 'contract-arrow-star-optional24 + '(let () + (define (statement? s) + (and (string? s) + (> (string-length s) 3))) + (define statement/c (flat-contract statement?)) + + (define new-statement + (make-keyword-procedure + (λ (kws kw-args . statement) + (format "kws=~s kw-args=~s statement=~s" kws kw-args statement)))) + + (contract (->* (statement/c) (#:s string?) statement/c) + new-statement + 'pos 'neg))) + + (test/spec-passed + 'contract-arrow-star-keyword-ordering + '((contract (->* (integer? #:x boolean?) (string? #:y char?) any) + (λ (x #:x b [s ""] #:y [c #\c]) + (list x b s c)) + 'pos + 'neg) + 1 "zz" #:x #f #:y #\d)) + + + (test/spec-passed + '->*-pre/post-1 + '((contract (->* () () integer? #:post #t) + (λ () 1) + 'pos + 'neg))) + + (test/pos-blame + '->*-pre/post-2 + '((contract (->* () () integer? #:post #t) + (λ () 'not-an-int) + 'pos + 'neg))) + + (test/spec-passed + '->*-pre/post-3 + '((contract (->* () () (values integer? boolean?) #:post #t) + (λ () (values 1 #t)) + 'pos + 'neg))) + + (test/pos-blame + '->*-pre/post-4 + '((contract (->* () () (values integer? boolean?) #:post #t) + (λ () (values 1 'not-a-boolean)) + 'pos + 'neg))) + + (test/neg-blame + '->*-pre/post-5 + '((contract (->* () () #:pre #f integer? #:post #t) + (λ () 1) + 'pos + 'neg))) + + (test/pos-blame + '->*-pre/post-6 + '((contract (->* () () #:pre #t integer? #:post #f) + (λ () 1) + 'pos + 'neg))) + + (test/neg-blame + '->*-pre/post-7 + '((contract (->* () () #:pre #f integer? #:post #f) + (λ () 1) + 'pos + 'neg))) + + (test/spec-passed + '->*-opt-optional1 + '((contract (->* () integer?) (lambda () 1) 'pos 'neg))) + + (test/spec-passed + '->*-opt-optional2 + '((contract (->* () (values boolean? integer?)) (lambda () (values #t 1)) 'pos 'neg))) + + (test/spec-passed + '->*-opt-optional3 + '((contract (->* () #:rest any/c integer?) (lambda x 1) 'pos 'neg))) + + (test/spec-passed + '->*-opt-optional4 + '((contract (->* () #:pre #t integer?) (lambda x 1) 'pos 'neg))) + + (test/spec-passed + '->*-opt-optional5 + '((contract (->* () integer? #:post #t) (lambda x 1) 'pos 'neg)))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow.rkt new file mode 100644 index 0000000000..9a36d0d081 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow.rkt @@ -0,0 +1,340 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace (make-basic-contract-namespace)]) + (define exn:fail:contract:blame? (contract-eval 'exn:fail:contract:blame?)) + + (test/no-error '(-> integer? integer?)) + (test/no-error '(-> (flat-contract integer?) (flat-contract integer?))) + (test/no-error '(-> integer? any)) + (test/no-error '(-> (flat-contract integer?) any)) + + (test/spec-passed + 'contract-arrow-values1 + '(let-values ([(a b) ((contract (-> integer? (values integer? integer?)) + (lambda (x) (values x x)) + 'pos + 'neg) + 2)]) + 1)) + + (test/neg-blame + 'contract-arrow-values2 + '((contract (-> integer? (values integer? integer?)) + (lambda (x) (values x x)) + 'pos + 'neg) + #f)) + + (test/pos-blame + 'contract-arrow-values3 + '((contract (-> integer? (values integer? integer?)) + (lambda (x) (values 1 #t)) + 'pos + 'neg) + 1)) + + (test/pos-blame + 'contract-arrow-values4 + '((contract (-> integer? (values integer? integer?)) + (lambda (x) (values #t 1)) + 'pos + 'neg) + 1)) + + (test/pos-blame + 'contract-arrow-values5 + '((contract (-> integer? (values integer? integer?)) + (lambda (x) x) + 'pos + 'neg) + 1)) + + + (test/pos-blame + 'contract-arrow-keyword1 + '(contract (-> integer? any) + (λ (x #:y y) x) + 'pos + 'neg)) + + (test/pos-blame + 'contract-arrow-keyword1b + '(contract (-> integer? #:y integer? any) + (λ (x) x) + 'pos + 'neg)) + + (test/spec-passed + 'contract-arrow-keyword2 + '(contract (-> integer? #:y boolean? any) + (λ (x #:y y) x) + 'pos + 'neg)) + + (test/spec-passed + 'contract-arrow-keyword2b + '(contract (-> #:x boolean? #:y boolean? any) + (λ (#:x x #:y y) x) + 'pos + 'neg)) + + (test/spec-passed + 'contract-arrow-keyword2c + '(contract (-> #:y boolean? #:x boolean? any) + (λ (#:x x #:y y) x) + 'pos + 'neg)) + + (test/spec-passed + 'contract-arrow-keyword2d + '(contract (-> #:y boolean? #:x boolean? any) + (λ (#:y y #:x x) x) + 'pos + 'neg)) + + (test/spec-passed + 'contract-arrow-keyword2e + '(contract (-> #:x boolean? #:y boolean? any) + (λ (#:y y #:x x) x) + 'pos + 'neg)) + + (test/neg-blame + 'contract-arrow-keyword3 + '((contract (-> integer? #:y boolean? any) + (λ (x #:y y) x) + 'pos + 'neg) + 1 #:y 1)) + + (test/neg-blame + 'contract-arrow-keyword4 + '((contract (-> integer? #:y boolean? any) + (λ (x #:y y) x) + 'pos + 'neg) + #t #:y #t)) + + (test/spec-passed + 'contract-arrow-keyword5 + '((contract (-> integer? #:y boolean? any) + (λ (x #:y y) x) + 'pos + 'neg) + 1 #:y #t)) + + (test/pos-blame + 'contract-arrow-keyword6 + '(contract (-> integer? integer?) + (λ (x #:y y) x) + 'pos + 'neg)) + + (test/spec-passed + 'contract-arrow-keyword7 + '(contract (-> integer? #:y boolean? integer?) + (λ (x #:y y) x) + 'pos + 'neg)) + + (test/neg-blame + 'contract-arrow-keyword8 + '((contract (-> integer? #:y boolean? integer?) + (λ (x #:y y) x) + 'pos + 'neg) + 1 #:y 1)) + + (test/neg-blame + 'contract-arrow-keyword9 + '((contract (-> integer? #:y boolean? integer?) + (λ (x #:y y) x) + 'pos + 'neg) + #t #:y #t)) + + (test/spec-passed + 'contract-arrow-keyword10 + '((contract (-> integer? #:y boolean? integer?) + (λ (x #:y y) x) + 'pos + 'neg) + 1 #:y #t)) + + (test/pos-blame + 'contract-arrow-keyword11 + '(contract (-> integer? (values integer? integer?)) + (λ (x #:y y) x) + 'pos + 'neg)) + + (test/spec-passed + 'contract-arrow-keyword12 + '(contract (-> integer? #:y boolean? (values integer? integer?)) + (λ (x #:y y) x) + 'pos + 'neg)) + + (test/neg-blame + 'contract-arrow-keyword13 + '((contract (-> integer? #:y boolean? (values integer? integer?)) + (λ (x #:y y) x) + 'pos + 'neg) + 1 #:y 1)) + + (test/neg-blame + 'contract-arrow-keyword14 + '((contract (-> integer? #:y boolean? (values integer? integer?)) + (λ (x #:y y) x) + 'pos + 'neg) + #t #:y #t)) + + (test/spec-passed + 'contract-arrow-keyword15 + '((contract (-> integer? #:y boolean? (values integer? integer?)) + (λ (x #:y y) (values x x)) + 'pos + 'neg) + 1 #:y #t)) + + (test/spec-passed + 'contract-arrow-keyword16 + '((contract (-> integer? integer?) + (λ (x #:y [y #f]) x) + 'pos + 'neg) + 1)) + + (test/neg-blame + 'contract-arrow-keyword17 + '((contract (-> integer? integer?) + (λ (x #:y [y #f]) x) + 'pos + 'neg) + #f)) + + (test/pos-blame + 'contract-arrow-keyword18 + '((contract (-> integer? integer?) + (λ (x #:y [y #f]) y) + 'pos + 'neg) + 1)) + + (test/neg-blame + 'contract-arrow-keyword19 + '((contract (-> boolean?) + (λ (#:x [x #f]) x) + 'pos + 'neg) + #:x 1)) + + (test/spec-passed + 'contract-arrow1 + '(contract (integer? . -> . integer?) (lambda (x) x) 'pos 'neg)) + + ;; make sure we skip the optimizations + (test/spec-passed + 'contract-arrow1b + '(contract (-> integer? integer? integer? integer? integer? + integer? integer? integer? integer? integer? + integer?) + (lambda (x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) x1) 'pos 'neg)) + + (test/pos-blame + 'contract-arrow2 + '(contract (integer? . -> . integer?) (lambda (x y) x) 'pos 'neg)) + + (test/neg-blame + 'contract-arrow3 + '((contract (integer? . -> . integer?) (lambda (x) #f) 'pos 'neg) #t)) + + (test/pos-blame + 'contract-arrow4 + '((contract (integer? . -> . integer?) (lambda (x) #f) 'pos 'neg) 1)) + + (test/neg-blame + 'contract-arrow-arity1 + '((contract (-> number? number? number?) + (λ (x . r) x) + 'pos 'neg) + 1)) + + (test/spec-passed + 'contract-arrow-any1 + '(contract (integer? . -> . any) (lambda (x) x) 'pos 'neg)) + + (test/pos-blame + 'contract-arrow-any2 + '(contract (integer? . -> . any) (lambda (x y) x) 'pos 'neg)) + + (test/neg-blame + 'contract-arrow-any3 + '((contract (integer? . -> . any) (lambda (x) #f) 'pos 'neg) #t)) + + (test/spec-passed + 'contract-arrow-all-anys1 + '((contract (-> any) (lambda () #f) 'pos 'neg))) + + (test/pos-blame + 'contract-arrow-all-anys2 + '((contract (-> any) (lambda (x) #f) 'pos 'neg))) + + (test/spec-passed + 'contract-arrow-all-anys3 + '((contract (-> any) (lambda ([x #f]) #f) 'pos 'neg))) + + (test/spec-passed + 'contract-arrow-all-kwds + '(contract (-> #:a string? string?) + (make-keyword-procedure void) + 'pos 'neg)) + + (test/pos-blame + 'contract-arrow-non-function + '(contract (-> any/c any) 1 'pos 'neg)) + + (test/spec-passed + 'contract-arrow-all-kwds2 + '((contract (-> #:a string? void?) + (make-keyword-procedure void) + 'pos 'neg) + #:a "abcdef")) + + (contract-error-test + 'contract-arrow-kwd-name-in-message + '((contract + (-> #:a any/c #:the-missing-keyword-arg-b any/c any) + (λ (#:a [a 0] #:the-missing-keyword-arg-b [b 0]) b) + 'pos + 'neg) + #:a 0) + (λ (x) + (and (exn:fail:contract:blame? x) + (regexp-match #rx"expected keyword argument #:the-missing-keyword-arg-b" + (exn-message x))))) + + (test/pos-blame + 'predicate/c1 + '(contract predicate/c 1 'pos 'neg)) + (test/pos-blame + 'predicate/c2 + '(contract predicate/c (λ (x y) 1) 'pos 'neg)) + (test/pos-blame + 'predicate/c3 + '((contract predicate/c (λ (x) 1) 'pos 'neg) 12)) + (test/spec-passed + 'predicate/c4 + '((contract predicate/c (λ (x) #t) 'pos 'neg) 12)) + + ;; this test ensures that no contract wrappers + ;; are created for struct predicates + (test/spec-passed/result + 'predicate/c5 + '(let () + (struct x (a)) + (eq? (contract predicate/c x? 'pos 'neg) x?)) + #t)) \ No newline at end of file diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/blame.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/blame.rkt new file mode 100644 index 0000000000..5615cee462 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/blame.rkt @@ -0,0 +1,153 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace 'racket/contract + )]) + + (contract-eval + '(begin + (module blame-ok/c racket/base + (require racket/contract) + (define (blame-proj name) + (lambda (b) + (unless (blame? b) + (raise-type-error name "a blame object" b)) + (define src (blame-source b)) + (unless (srcloc? src) + (raise-type-error name "a srcloc" src)) + (lambda (x) x))) + (define impersonator-blame-ok/c + (make-contract + #:name 'impersonator-blame-ok/c + #:projection (blame-proj 'impersonator-blame-ok/c))) + (define chaperone-blame-ok/c + (make-chaperone-contract + #:name 'chaperone-blame-ok/c + #:projection (blame-proj 'chaperone-blame-ok/c))) + (define flat-blame-ok/c + (make-flat-contract + #:name 'flat-blame-ok/c + #:projection (blame-proj 'flat-blame-ok/c))) + (provide + impersonator-blame-ok/c + chaperone-blame-ok/c + flat-blame-ok/c)) + (require 'blame-ok/c) + (module blame-ok-dynamic racket/base + (require racket/contract 'blame-ok/c) + (define five 5) + (provide + (contract-out + [rename five impersonator-five impersonator-blame-ok/c] + [rename five chaperone-five chaperone-blame-ok/c] + [rename five flat-five flat-blame-ok/c]))))) + + (begin + (test/no-error + '(dynamic-require ''blame-ok-dynamic 'impersonator-five)) + (test/no-error + '(dynamic-require ''blame-ok-dynamic 'chaperone-five)) + (test/no-error + '(dynamic-require ''blame-ok-dynamic 'flat-five))) + + (begin + (test/no-error + '(contract impersonator-blame-ok/c 5 'pos 'neg 'five #',#'location)) + (test/no-error + '(contract chaperone-blame-ok/c 5 'pos 'neg 'five #',#'location)) + (test/no-error + '(contract flat-blame-ok/c 5 'pos 'neg 'five #',#'location))) + + (begin + (test/no-error + '(let () + (define/contract five impersonator-blame-ok/c 5) + five)) + (test/no-error + '(let () + (define/contract five chaperone-blame-ok/c 5) + five)) + (test/no-error + '(let () + (define/contract five flat-blame-ok/c 5) + five))) + + (begin + (test/no-error + '(let () + (with-contract internal-region ([five impersonator-blame-ok/c]) + (define five 5)) + five)) + (test/no-error + '(let () + (with-contract internal-region ([five chaperone-blame-ok/c]) + (define five 5)) + five)) + (test/no-error + '(let () + (with-contract internal-region ([five flat-blame-ok/c]) + (define five 5)) + five))) + + (begin + (test/no-error + '(let () + (define five 5) + (with-contract internal-region () #:freevar five impersonator-blame-ok/c + (define six (add1 five))) + six)) + (test/no-error + '(let () + (define five 5) + (with-contract internal-region () #:freevar five chaperone-blame-ok/c + (define six (add1 five))) + six)) + (test/no-error + '(let () + (define five 5) + (with-contract internal-region () #:freevar five flat-blame-ok/c + (define six (add1 five))) + six))) + + (begin + (test/no-error + '(with-contract internal-region #:result impersonator-blame-ok/c + 5)) + (test/no-error + '(with-contract internal-region #:result chaperone-blame-ok/c + 5)) + (test/no-error + '(with-contract internal-region #:result flat-blame-ok/c + 5))) + + (begin + (test/no-error + '(let () + (define five 5) + (with-contract internal-region #:result any/c #:freevar five impersonator-blame-ok/c + five))) + (test/no-error + '(let () + (define five 5) + (with-contract internal-region #:result any/c #:freevar five chaperone-blame-ok/c + five))) + (test/no-error + '(let () + (define five 5) + (with-contract internal-region #:result any/c #:freevar five flat-blame-ok/c + five)))) + + (begin + (test/no-error + '(let () + (define-struct/contract thing ([stuff impersonator-blame-ok/c])) + (thing-stuff (thing 5)))) + (test/no-error + '(let () + (define-struct/contract thing ([stuff chaperone-blame-ok/c])) + (thing-stuff (thing 5)))) + (test/no-error + '(let () + (define-struct/contract thing ([stuff flat-blame-ok/c])) + (thing-stuff (thing 5)))))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/box.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/box.rkt new file mode 100644 index 0000000000..b86467f34f --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/box.rkt @@ -0,0 +1,8 @@ +#lang racket/base +(require "test-util.rkt") +(parameterize ([current-contract-namespace (make-basic-contract-namespace)]) + (test/no-error + '(let ([v (chaperone-box (box-immutable 1) + (λ (box v) v) + (λ (box v) v))]) + (contract (box/c any/c) v 'pos 'neg)))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/case-arrow.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/case-arrow.rkt new file mode 100644 index 0000000000..66bca58ac3 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/case-arrow.rkt @@ -0,0 +1,195 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace )]) + (test/spec-passed + 'contract-case->0a + '(contract (case->) + (lambda (x) x) + 'pos + 'neg)) + + (test/spec-passed + 'contract-case->0b + '(contract (case->) + (lambda () 1) + 'pos + 'neg)) + + (test/pos-blame + 'contract-case->0c + '(contract (case->) + 1 + 'pos + 'neg)) + + (test/spec-passed + 'contract-case->0d + '(contract (case->) + (case-lambda) + 'pos + 'neg)) + + + (test/pos-blame + 'contract-case->1 + '(contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?)) + (lambda (x) x) + 'pos + 'neg)) + + (test/pos-blame + 'contract-case->2 + '((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?)) + (case-lambda + [(x y) 'case1] + [(x) 'case2]) + 'pos + 'neg) + 1 2)) + + (test/pos-blame + 'contract-case->3 + '((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?)) + (case-lambda + [(x y) 'case1] + [(x) 'case2]) + 'pos + 'neg) + 1)) + + (test/neg-blame + 'contract-case->4 + '((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?)) + (case-lambda + [(x y) 'case1] + [(x) 'case2]) + 'pos + 'neg) + 'a 2)) + + (test/neg-blame + 'contract-case->5 + '((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?)) + (case-lambda + [(x y) 'case1] + [(x) 'case2]) + 'pos + 'neg) + 2 'a)) + + (test/neg-blame + 'contract-case->6 + '((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?)) + (case-lambda + [(x y) 'case1] + [(x) 'case2]) + 'pos + 'neg) + #t)) + + (test/pos-blame + 'contract-case->7 + '((contract (case-> (integer? integer? . -> . integer?) (-> integer? #:rest any/c boolean?)) + (lambda x #\a) + 'pos + 'neg) + 1 2)) + + + (test/pos-blame + 'contract-case->8 + '((contract (case-> (integer? integer? . -> . integer?) (-> integer? #:rest any/c boolean?)) + (lambda x #t) + 'pos + 'neg) + 1 2)) + + (test/spec-passed + 'contract-case->8 + '((contract (case-> (integer? integer? . -> . integer?) (-> integer? #:rest any/c boolean?)) + (lambda x 1) + 'pos + 'neg) + 1 2)) + + (test/spec-passed/result + 'contract-case->9 + '((contract (case-> (-> integer? any)) + (lambda (x) 1) + 'pos + 'neg) + 1) + 1) + + (test/neg-blame + 'contract-case->10 + '((contract (case-> (-> integer? any)) + (lambda (x) 1) + 'pos + 'neg) + #f)) + + (test/pos-blame + 'contract-case->11 + '(contract (case-> (-> integer? any) (-> integer? integer? any)) + (lambda (x) 1) + 'pos + 'neg)) + + (test/neg-blame + 'contract-case->12 + '((contract (case-> (-> integer? any) (-> integer? integer? any)) + (case-lambda [(x) 1] [(x y) 1]) + 'pos + 'neg) + #f)) + + (test/spec-passed/result + 'contract-case->13 + '((contract (case-> (-> integer? any) (-> integer? integer? any)) + (case-lambda [(x) 1] [(x y) 1]) + 'pos + 'neg) + 1) + 1) + + (test/spec-passed/result + 'contract-case->14 + '(let ([f + (contract (case-> (-> char?) (-> integer? boolean?) (-> symbol? input-port? string?)) + (case-lambda + [() #\a] + [(x) (= x 0)] + [(sym port) + (string-append + (symbol->string sym) + (read port))]) + 'pos + 'neg)]) + (list (f) + (f 1) + (f 'x (open-input-string (format "~s" "string"))))) + (list #\a #f "xstring")) + + (test/pos-blame + 'contract-case->15 + '((contract (case-> (-> real? real? real?) + (-> real? (values real? real?))) + (case-lambda + [(x y) 1] + [(x) 1]) + 'pos 'neg) + 1)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; ;; + ;; case-> arity checking tests ;; + ;; ;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (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)))) \ No newline at end of file diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/class.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/class.rkt new file mode 100644 index 0000000000..12b9cafd5b --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/class.rkt @@ -0,0 +1,1751 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace + 'racket/class + 'racket/contract)]) +(test/pos-blame + 'class/c-first-order-class-1 + '(contract (class/c) + 3 + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-class-2 + '(contract (class/c) + object% + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-opaque-class-1 + '(contract (class/c #:opaque) + object% + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-opaque-class-2 + '(contract (class/c #:opaque) + (class object% (super-new) (define/public (m x) (add1 x))) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-method-1 + '(contract (class/c [m (-> any/c number? number?)]) + object% + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-method-2 + '(contract (class/c [m (-> any/c number? number?)]) + (class object% (super-new) (define/public (m x) (add1 x))) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-method-3 + '(contract (class/c [m (-> any/c number? number?)]) + (class object% (super-new) (define/public (m) 3)) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-method-4 + '(contract (class/c m) + object% + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-method-5 + '(contract (class/c m) + (class object% (super-new) (define/public (m) 3)) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-method-6 + '(contract (class/c [m (-> any/c number? number?)]) + (class object% (super-new) (define/public (m) 3)) + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-local-method-1 + '(let () + (define-local-member-name m) + (contract (class/c [m (->m number? number?)]) + (class object% (super-new) (define/public (m x) 3)) + 'pos + 'neg))) + +(test/pos-blame + 'class/c-first-order-local-method-2 + '(let () + (define-local-member-name m) + (contract (class/c [m (->m number? number? number?)]) + (class object% (super-new) (define/public (m x) 3)) + 'pos + 'neg))) + +(test/pos-blame + 'class/c-first-order-local-method-3 + '(let () + (define-local-member-name m) + (contract (class/c [m (->m number? number? number?)]) + (class object% (super-new)) + 'pos + 'neg))) + +(test/spec-passed + 'class/c-first-order-opaque-method-1 + '(contract (class/c #:opaque [m (-> any/c number? number?)]) + (class object% (super-new) (define/public (m x) 3)) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-opaque-method-2 + '(contract (class/c #:opaque [m (-> any/c number? number?)]) + (class object% (super-new) (define/public (m x) 3) (define/public (n) 4)) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-opaque-method-3 + '(let () + (define-local-member-name n) + (contract (class/c #:opaque [m (-> any/c number? number?)]) + (class object% (super-new) (define/public (m x) 3) (define/public (n) 4)) + 'pos + 'neg))) + +(test/pos-blame + 'class/c-first-order-opaque-method-4 + '(contract + (class/c #:opaque [m (-> any/c number? number?)]) + (let () + (define-local-member-name n) + (class object% (super-new) (define/public (m x) 3) (define/public (n) 4))) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-opaque-method-5 + '(contract + (class/c #:opaque [m (-> any/c number? number?)] [n (-> any/c number?)]) + (let () + (define-local-member-name n) + (class object% (super-new) (define/public (m x) 3) (define/public (n) 4))) + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-opaque-method-6 + '(let () + (define-local-member-name n) + (contract (class/c #:opaque [m (-> any/c number? number?)] [n (-> any/c number?)]) + (class object% (super-new) (define/public (m x) 3) (define/public (n) 4)) + 'pos + 'neg))) + +(test/pos-blame + 'class/c-first-order-field-1 + '(contract (class/c (field [n number?])) + object% + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-field-2 + '(contract (class/c (field [n number?])) + (class object% (super-new) (field [n 3])) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-field-3 + '(contract (class/c (field n)) + object% + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-field-4 + '(contract (class/c (field n)) + (class object% (super-new) (field [n 3])) + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-local-field-1 + '(let () + (define-local-member-name n) + (contract (class/c (field n)) + (class object% (super-new) (field [n 3])) + 'pos + 'neg))) + +(test/spec-passed + 'class/c-first-order-local-field-2 + '(let () + (define-local-member-name n) + (contract (class/c (field [n integer?])) + (class object% (super-new) (field [n 3])) + 'pos + 'neg))) + +(test/pos-blame + 'class/c-first-order-local-field-3 + '(let () + (define-local-member-name n) + (contract (class/c (field [n integer?])) + (class object% (super-new)) + 'pos + 'neg))) + +(test/spec-passed + 'class/c-first-order-opaque-field-1 + '(contract (class/c #:opaque (field n)) + (class object% (super-new) (field [n 3])) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-opaque-field-2 + '(contract (class/c #:opaque (field n)) + (class object% (super-new) (field [m 5] [n 3])) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-opaque-field-2 + '(contract (class/c #:opaque (field [m number?])) + (let () + (define-local-member-name n) + (class object% (super-new) (field [m 5] [n 3]))) + 'pos + 'neg)) + +;; No true first-order tests here, other than just to make +;; sure they're accepted. For init-field, we can at least +;; make sure the given field is public (which happens +;; naturally by splitting an init-field into init and field). +(test/spec-passed + 'class/c-first-order-init-1 + '(contract (class/c (init [a number?])) + (class object% (super-new) (init a)) + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-init-field-1 + '(contract (class/c (init-field [a number?])) + (class object% (super-new) (init-field a)) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-init-field-2 + '(contract (class/c (init-field [a number?])) + object% + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-inherit-field-1 + '(contract (class/c (inherit-field [n number?])) + object% + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-inherit-field-2 + '(contract (class/c (inherit-field [n number?])) + (class object% (super-new) (field [n 3])) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-inherit-field-3 + '(contract (class/c (inherit-field f)) + object% + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-inherit-field-4 + '(contract (class/c (inherit-field f)) + (class object% (super-new) (field [f 10])) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-super-1 + '(contract (class/c (super [m (-> any/c number? number?)])) + object% + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-super-2 + '(contract (class/c (super [m (-> any/c number? number?)])) + (class object% (super-new) (define/pubment (m x) (add1 x))) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-super-3 + '(contract (class/c (super [m (-> any/c number? number?)])) + (class object% (super-new) (define/public-final (m x) (add1 x))) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-super-4 + '(contract (class/c (super [m (-> any/c number? number?)])) + (let ([c% (class object% (super-new) (define/public (m x) (add1 x)))]) + (class c% (super-new) (define/overment (m x) (add1 x)))) + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-super-5 + '(contract (class/c (super [m (-> any/c number? number?)])) + (class object% (super-new) (define/public (m x) (add1 x))) + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-super-6 + '(contract (class/c (super [m (-> any/c number? number?)])) + (let ([c% (class object% (super-new) (define/pubment (m x) (inner x m x)))]) + (class c% (super-new) (define/augride (m x) (add1 x)))) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-super-7 + '(contract (class/c (super m)) + object% + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-super-8 + '(contract (class/c (super m)) + (class object% (super-new) (define/public (m) 3)) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-super-9 + '(contract (class/c (super [m (-> any/c number? number?)])) + (class object% (super-new) (define/public (m) 3)) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-opaque-super-1 + '(contract (class/c #:opaque (super m)) + (class (class object% (super-new) (define/public (m) 3)) (super-new)) + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-opaque-super-2 + '(contract (class/c #:opaque (super m) m) + (class (class object% (super-new) (define/public (m) 3)) (super-new)) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-opaque-super-3 + '(contract (class/c #:opaque) + (class (let () + (define-local-member-name m) + (class object% (super-new) (define/public (m) 3))) + (super-new)) + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-opaque-super-4 + '(contract (class/c #:opaque (super m) m) + (class (class object% (super-new) (define/public (m) 3)) (super-new)) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-inner-1 + '(contract (class/c (inner [m (-> any/c number? number?)])) + object% + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-inner-2 + '(contract (class/c (inner [m (-> any/c number? number?)])) + (class object% (super-new) (define/pubment (m x) (inner x m x))) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-inner-3 + '(contract (class/c (inner [m (-> any/c number? number?)])) + (class object% (super-new) (define/public (m x) (add1 x))) + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-inner-4 + '(contract (class/c (inner [m (-> any/c number? number?)])) + (let ([c% (class object% (super-new) (define/pubment (m x) (inner x m x)))]) + (class c% (super-new) (define/augride (m x) (add1 x)))) + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-inner-5 + '(contract (class/c (inner [m (-> any/c number? number?)])) + (let ([c% (class object% (super-new) (define/public (m x) (add1 x)))]) + (class c% (super-new) (define/overment (m x) (+ (super m x) (inner x m x))))) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-inner-6 + '(contract (class/c (inner [m (-> any/c number? number?)])) + (let* ([c% (class object% (super-new) (define/pubment (m x) (inner x m x)))] + [d% (class c% (super-new) (define/augride (m x) (add1 x)))]) + (class d% (super-new) (define/override-final (m x) (add1 x)))) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-inner-7 + '(contract (class/c (inner m)) + object% + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-inner-8 + '(let* ([c% (contract (class/c (inner m)) + (class object% (super-new) (define/pubment (m) (inner 3 m))) + 'pos + 'neg)]) + (class c% (super-new) (define/augment (m) 5)))) + +(test/neg-blame + 'class/c-first-order-inner-9 + '(let* ([c% (contract (class/c (inner [m (-> any/c number? number?)])) + (class object% (super-new) (define/pubment (m x) (inner x m x))) + 'pos + 'neg)]) + (class c% (super-new) (define/augment (m) 5)))) + +(test/pos-blame + 'class/c-first-order-opaque-inner-1 + '(contract (class/c #:opaque (inner m)) + (let ([c% (class object% (super-new) (define/pubment (m x) (inner x m x)))]) + (class c% (super-new) (define/augride (m x) (add1 x)))) + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-opaque-inner-2 + '(contract (class/c #:opaque (inner m) m) + (let ([c% (class object% (super-new) (define/pubment (m x) (inner x m x)))]) + (class c% (super-new) (define/augride (m x) (add1 x)))) + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-local-inner-1 + '(let () + (define-local-member-name m) + (contract (class/c (inner m) m) + (let ([c% (class object% (super-new) (define/pubment (m x) (inner x m x)))]) + (class c% (super-new) (define/augride (m x) (add1 x)))) + 'pos + 'neg))) + +(test/pos-blame + 'class/c-first-order-local-inner-2 + '(let () + (define-local-member-name m) + (contract (class/c (inner m)) + object% + 'pos + 'neg))) + +(test/pos-blame + 'class/c-first-order-override-1 + '(contract (class/c (override [m (-> any/c number? number?)])) + object% + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-override-2 + '(contract (class/c (override [m (-> any/c number? number?)])) + (class object% (super-new) (define/public (m x) (add1 x))) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-override-3 + '(contract (class/c (override [m (-> any/c number? number?)])) + (class object% (super-new) (define/pubment (m x) (add1 x))) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-override-4 + '(contract (class/c (override [m (-> any/c number? number?)])) + (let ([c% (class object% (super-new) (define/public (m x) (add1 x)))]) + (class c% (super-new) (define/overment (m x) (+ (super m x) (inner x m x))))) + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-override-5 + '(contract (class/c (override [m (-> any/c number? number?)])) + (let ([c% (class object% (super-new) (define/public (m x) (add1 x)))]) + (class c% (super-new) (define/override (m x) (add1 (super m x))))) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-override-6 + '(contract (class/c (override [m (-> any/c number? number?)])) + (let* ([c% (class object% (super-new) (define/public (m x) (add1 x)))] + [d% (class c% (super-new) (define/overment (m x) + (+ (super m x) (inner x m x))))]) + (class d% (super-new) (define/augride (m x) x))) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-override-7 + '(contract (class/c (override m)) + object% + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-override-8 + '(let ([c% (contract (class/c (override m)) + (class object% (super-new) (define/public (m) 3)) + 'pos + 'neg)]) + (class c% (super-new) (define/override (m) 5)))) + +(test/neg-blame + 'class/c-first-order-override-9 + '(let ([c% (contract (class/c (override [m (-> any/c number? number?)])) + (class object% (super-new) (define/public (m x) 3)) + 'pos + 'neg)]) + (class c% (super-new) (define/override (m) 5)))) + +(test/pos-blame + 'class/c-first-order-opaque-override-1 + '(contract (class/c #:opaque (override m)) + (let ([c% (class object% (super-new) (define/public (m x) (add1 x)))]) + (class c% (super-new) (define/override (m x) (add1 (super m x))))) + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-opaque-override-2 + '(contract (class/c #:opaque (override m) m) + (let ([c% (class object% (super-new) (define/public (m x) (add1 x)))]) + (class c% (super-new) (define/override (m x) (add1 (super m x))))) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-local-override-1 + '(let () + (define-local-member-name m) + (contract (class/c (override m)) + object% + 'pos + 'neg))) + +(test/spec-passed + 'class/c-first-order-local-override-2 + '(let () + (define-local-member-name m) + (define c% (contract (class/c (override m)) + (class object% (super-new) (define/public (m) 3)) + 'pos + 'neg)) + (class c% (super-new) (define/override (m) 5)))) + +(test/pos-blame + 'class/c-first-order-augment-1 + '(contract (class/c (augment [m (-> any/c number? number?)])) + object% + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-augment-2 + '(contract (class/c (augment [m (-> any/c number? number?)])) + (class object% (super-new) (define/pubment (m x) (add1 x))) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-augment-3 + '(contract (class/c (augment [m (-> any/c number? number?)])) + (class object% (super-new) (define/public (m x) (add1 x))) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-augment-4 + '(contract (class/c (augment [m (-> any/c number? number?)])) + (let ([c% (class object% (super-new) (define/pubment (m x) (inner x m x)))]) + (class c% (super-new) (define/augride (m x) (add1 x)))) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-augment-5 + '(contract (class/c (augment [m (-> any/c number? number?)])) + (let ([c% (class object% (super-new) (define/public (m x) (add1 x)))]) + (class c% (super-new) (define/override (m x) (add1 (super m x))))) + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-augment-6 + '(contract (class/c (augment [m (-> any/c number? number?)])) + (let* ([c% (class object% (super-new) (define/public (m x) (add1 x)))] + [d% (class c% (super-new) (define/overment (m x) + (+ (super m x) (inner x m x))))]) + (class d% (super-new) (define/augment (m x) x))) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-augment-7 + '(contract (class/c (augment m)) + object% + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-augment-8 + '(let ([c% (contract (class/c (augment m)) + (class object% (super-new) (define/pubment (m) 3)) + 'pos + 'neg)]) + (class c% (super-new) (inherit m)))) + +(test/pos-blame + 'class/c-first-order-augment-9 + '(let ([c% (contract (class/c (augment [m (-> any/c number? number?)])) + (class object% (super-new) (define/pubment (m) 3)) + 'pos + 'neg)]) + (class c% (super-new) (inherit m)))) + +(test/pos-blame + 'class/c-first-order-opaque-augment-1 + '(contract (class/c #:opaque (augment m)) + (class object% (super-new) (define/pubment (m x) (add1 x))) + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-opaque-augment-2 + '(contract (class/c #:opaque (augment m) m) + (class object% (super-new) (define/pubment (m x) (add1 x))) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-local-augment-1 + '(let () + (define-local-member-name m) + (contract (class/c (augment m)) + object% + 'pos + 'neg))) + +(test/spec-passed + 'class/c-first-order-local-augment-2 + '(let () + (define-local-member-name m) + (define c% (contract (class/c (augment m)) + (class object% (super-new) (define/pubment (m) 3)) + 'pos + 'neg)) + (class c% (super-new) (inherit m)))) + +(test/pos-blame + 'class/c-first-order-augride-1 + '(contract (class/c (augride [m (-> any/c number? number?)])) + object% + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-augride-2 + '(contract (class/c (augride [m (-> any/c number? number?)])) + (class object% (super-new) (define/pubment (m x) (add1 x))) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-augride-4 + '(contract (class/c (augride [m (-> any/c number? number?)])) + (class object% (super-new) (define/public (m x) (add1 x))) + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-augride-5 + '(contract (class/c (augride [m (-> any/c number? number?)])) + (let ([c% (class object% (super-new) (define/pubment (m x) (inner x m x)))]) + (class c% (super-new) (define/augride (m x) (add1 x)))) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-augride-5 + '(contract (class/c (augride [m (-> any/c number? number?)])) + (let ([c% (class object% (super-new) (define/public (m x) (add1 x)))]) + (class c% (super-new) (define/override (m x) (add1 (super m x))))) + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-augride-6 + '(contract (class/c (augride [m (-> any/c number? number?)])) + (let* ([c% (class object% (super-new) (define/public (m x) (add1 x)))] + [d% (class c% (super-new) (define/overment (m x) + (+ (super m x) (inner x m x))))]) + (class d% (super-new) (define/augride (m x) x))) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-augride-7 + '(contract (class/c (augride m)) + object% + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-augride-8 + '(let ([c% (contract (class/c (augride m)) + (class (class object% (super-new) (define/pubment (m) 3)) + (super-new) (define/augride (m) 4)) + 'pos + 'neg)]) + (class c% (super-new) (inherit m)))) + +(test/pos-blame + 'class/c-first-order-augride-9 + '(let ([c% (contract (class/c (augride [m (-> any/c number? number?)])) + (class (class object% (super-new) (define/pubment (m) 3)) + (super-new) (define/augride (m) 4)) + 'pos + 'neg)]) + (class c% (super-new) (inherit m)))) + +(test/pos-blame + 'class/c-first-order-opaque-augride-1 + '(contract (class/c #:opaque (augride m)) + (let ([c% (class object% (super-new) (define/pubment (m x) (inner x m x)))]) + (class c% (super-new) (define/augride (m x) (add1 x)))) + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-opaque-augride-2 + '(contract (class/c #:opaque (augride m) m) + (let ([c% (class object% (super-new) (define/pubment (m x) (inner x m x)))]) + (class c% (super-new) (define/augride (m x) (add1 x)))) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-local-augride-1 + '(let () + (define-local-member-name m) + (contract (class/c (augride m)) + object% + 'pos + 'neg))) + +(test/spec-passed + 'class/c-first-order-local-augride-2 + '(let () + (define-local-member-name m) + (define c% (contract (class/c (augride m)) + (class (class object% (super-new) (define/pubment (m) 3)) + (super-new) (define/augride (m) 4)) + 'pos + 'neg)) + (class c% (super-new) (inherit m)))) + +(test/pos-blame + 'class/c-first-order-inherit-1 + '(let* ([c% (contract (class/c (inherit [m (-> any/c number? number?)])) + object% + 'pos + 'neg)] + [d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))]) + (send (new d%) f))) + +(test/spec-passed + 'class/c-first-order-inherit-2 + '(let* ([c% (contract (class/c (inherit [m (-> any/c number? number?)])) + (class object% (super-new) (define/public (m x) x)) + 'pos + 'neg)] + [d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))]) + (send (new d%) f))) + +(test/pos-blame + 'class/c-first-order-inherit-3 + '(let* ([c% (contract (class/c (inherit [m (-> any/c number? number?)])) + (class object% (super-new) (define/public (m) 3)) + 'pos + 'neg)] + [d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))]) + (send (new d%) f))) + +(test/pos-blame + 'class/c-first-order-opaque-inherit-1 + '(let* ([c% (contract (class/c #:opaque (inherit [m (-> any/c number? number?)])) + (class object% (super-new) (define/public (m x) x)) + 'pos + 'neg)] + [d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))]) + (send (new d%) f))) + +(test/spec-passed + 'class/c-first-order-opaque-inherit-2 + '(let* ([c% (contract (class/c #:opaque m (inherit [m (-> any/c number? number?)])) + (class object% (super-new) (define/public (m x) x)) + 'pos + 'neg)] + [d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))]) + (send (new d%) f))) + +(test/pos-blame + 'class/c-first-order-local-inherit-1 + '(let () + (define-local-member-name m) + (define c% (contract (class/c (inherit [m (-> any/c number? number?)])) + object% + 'pos + 'neg)) + (define d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))) + (send (new d%) f))) + +(test/spec-passed + 'class/c-first-order-local-inherit-2 + '(let () + (define-local-member-name m) + (define c% (contract (class/c (inherit [m (-> any/c number? number?)])) + (class object% (super-new) (define/public (m x) x)) + 'pos + 'neg)) + (define d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))) + (send (new d%) f))) + +(test/spec-passed + 'class/c-first-order-absent-1 + '(contract (class/c (absent m)) object% 'pos 'neg)) + +(test/pos-blame + 'class/c-first-order-absent-2 + '(contract (class/c (absent m)) + (class object% (super-new) (define/public (m) 3)) + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-absent-3 + '(contract (class/c (absent (field f))) object% 'pos 'neg)) + +(test/pos-blame + 'class/c-first-order-absent-4 + '(contract (class/c (absent (field f))) + (class object% (super-new) (field [f 3])) + 'pos + 'neg)) + +(test/spec-passed + 'class/c-first-order-local-absent-1 + '(let () + (define-local-member-name f) + (contract (class/c (absent (field f))) object% 'pos 'neg))) + +(test/pos-blame + 'class/c-first-order-local-absent-2 + '(let () + (define-local-member-name f) + (contract (class/c (absent (field f))) + (class object% (super-new) (field [f 3])) + 'pos + 'neg))) + +(test/spec-passed + 'class/c-first-order-opaque-absent-1 + '(contract (class/c #:opaque (absent (field f))) object% 'pos 'neg)) + +(test/pos-blame + 'class/c-first-order-opaque-absent-2 + '(contract (class/c #:opaque (absent (field f))) + (class object% (super-new) (field [g 0])) + 'pos + 'neg)) + +(test/pos-blame + 'class/c-first-order-opaque-absent-3 + '(contract (class/c #:opaque (absent (field f g))) + (class object% (super-new) (field [g 0])) + 'pos + 'neg)) + +(test/spec-passed + 'class/c-higher-order-init-1 + '(let ([c% (contract (class/c (init [a number?])) + (class object% (super-new) (init a)) + 'pos + 'neg)]) + (new c% [a 3]))) + +(test/neg-blame + 'class/c-higher-order-init-2 + '(let ([c% (contract (class/c (init [a number?])) + (class object% (super-new) (init a)) + 'pos + 'neg)]) + (new c% [a #t]))) + +(test/spec-passed + 'class/c-higher-order-init-3 + '(let* ([c% (class object% (super-new) (init a))] + [d% (contract (class/c (init [a number?] [a string?])) + (class c% (super-new) (init a)) + 'pos + 'neg)]) + (new d% [a 3] [a "foo"]))) + +(test/neg-blame + 'class/c-higher-order-init-4 + '(let* ([c% (class object% (super-new) (init a))] + [d% (contract (class/c (init [a number?] [a string?])) + (class c% (super-new) (init a)) + 'pos + 'neg)]) + (new d% [a 3] [a 4]))) + +(test/neg-blame + 'class/c-higher-order-init-5 + '(let* ([c% (class object% (super-new) (init a))] + [d% (contract (class/c (init [a number?] [a string?])) + (class c% (super-new) (init a)) + 'pos + 'neg)]) + (new d% [a "bar"] [a "foo"]))) + +(test/spec-passed + 'class/c-higher-order-init-6 + '(let* ([c% (class object% (super-new) (init a))] + [d% (class c% (super-new) (init a))] + [d%/c (contract (class/c (init [a integer?] [a string?])) d% 'pos 'neg1)] + [d%/c/c (contract (class/c (init [a number?])) d%/c 'pos1 'neg)]) + (new d%/c/c [a 3] [a "foo"]))) + +(test/neg-blame + 'class/c-higher-order-init-7 + '(let* ([c% (class object% (super-new) (init a))] + [d% (class c% (super-new) (init a))] + [d%/c (contract (class/c (init [a integer?] [a string?])) d% 'pos1 'neg)] + [d%/c/c (contract (class/c (init [a number?])) d%/c 'pos 'neg1)]) + (new d%/c/c [a 3.5] [a "foo"]))) + +(test/neg-blame + 'class/c-higher-order-init-8 + '(let* ([c% (class object% (super-new) (init a))] + [d% (class c% (super-new) (init a))] + [d%/c (contract (class/c (init [a integer?] [a string?])) d% 'pos 'neg)] + [d%/c/c (contract (class/c (init [a number?])) d%/c 'pos 'neg)]) + (new d%/c/c [a #t] [a "foo"]))) + +(test/spec-passed + 'class/c-higher-order-init-field-1 + '(let ([c% (contract (class/c (init-field [f (-> number? number?)])) + (class object% (super-new) (init-field f) (f 3)) + 'pos + 'neg)]) + (new c% [f (lambda (x) x)]))) + +(test/pos-blame + 'class/c-higher-order-init-field-2 + '(let ([c% (contract (class/c (init-field [f (-> number? number?)])) + (class object% (super-new) (init-field f) (f #t)) + 'pos + 'neg)]) + (new c% [f (lambda (x) x)]))) + +(test/neg-blame + 'class/c-higher-order-init-field-3 + '(let ([c% (contract (class/c (init-field [f (-> number? number?)])) + (class object% (super-new) (init-field f) (f 3)) + 'pos + 'neg)]) + (new c% [f (lambda (x) (zero? x))]))) + +;; Make sure that the original provider of the value is blamed if an +;; init arg is given an invalid value, and then that is retrieved by +;; an external client. +(test/neg-blame + 'class/c-higher-order-init-field-4 + '(let* ([c% (contract (class/c (init-field [f (-> number? number?)])) + (class object% (super-new) (init-field f)) + 'pos + 'neg)] + [o (new c% [f (lambda (x) (zero? x))])]) + ((get-field f o) 3))) + +(test/spec-passed + 'class/c-higher-order-method-1 + '(let ([c% (contract (class/c [m (-> any/c number? number?)]) + (class object% (super-new) (define/public (m x) (add1 x))) + 'pos + 'neg)]) + (send (new c%) m 3))) + +(test/neg-blame + 'class/c-higher-order-method-2 + '(let ([c% (contract (class/c [m (-> any/c number? number?)]) + (class object% (super-new) (define/public (m x) (add1 x))) + 'pos + 'neg)]) + (send (new c%) m #f))) + +(test/pos-blame + 'class/c-higher-order-method-3 + '(let ([c% (contract (class/c [m (-> any/c number? number?)]) + (class object% (super-new) (define/public (m x) (zero? x))) + 'pos + 'neg)]) + (send (new c%) m 3))) + +;; Test that public method contracts are not checked for implication. +;; Public method contracts do not check behavioral subtyping. +;; Once interfaces have contracts, those will. +(test/spec-passed + 'class/c-higher-order-method-4 + '(let* ([c% (contract (class/c [m (-> any/c number? number?)]) + (class object% (super-new) (define/public (m x) (zero? x))) + 'pos + 'neg)] + [d% (class c% (super-new) (define/override (m) (super m 5)))]) + (send (new d%) m))) + +(test/spec-passed + 'class/c-higher-order-local-method-1 + '(let () + (define-local-member-name m) + (define c% (contract (class/c [m (-> any/c number? number?)]) + (class object% (super-new) (define/public (m x) (add1 x))) + 'pos + 'neg)) + (send (new c%) m 3))) + +(test/neg-blame + 'class/c-higher-order-local-method-2 + '(let () + (define-local-member-name m) + (define c% (contract (class/c [m (-> any/c number? number?)]) + (class object% (super-new) (define/public (m x) (add1 x))) + 'pos + 'neg)) + (send (new c%) m #f))) + +(test/spec-passed + 'class/c-higher-order-super-1 + '(let* ([c% (contract (class/c [m (-> any/c integer? integer?)] + (super [m (-> any/c number? number?)])) + (class object% (super-new) (define/public (m x) (add1 x))) + 'pos + 'neg)] + [d% (class c% (super-new) (define/override (m x) (+ x (super m 3.5))))]) + (send (new d%) m 4.5))) + +(test/neg-blame + 'class/c-higher-order-super-2 + '(let* ([c% (contract (class/c [m (-> any/c integer? integer?)] + (super [m (-> any/c number? number?)])) + (class object% (super-new) (define/public (m x) (add1 x))) + 'pos + 'neg)] + [d% (class c% (super-new) (define/override (m) (super m #f)))]) + (send (new d%) m))) + +(test/pos-blame + 'class/c-higher-order-super-3 + '(let* ([c% (contract (class/c [m (-> any/c integer? integer?)] + (super [m (-> any/c number? number?)])) + (class object% (super-new) (define/public (m x) (zero? x))) + 'pos + 'neg)] + [d% (class c% (super-new) (define/override (m) (super m 3.5)))]) + (send (new d%) m))) + +(test/spec-passed + 'class/c-higher-order-inner-1 + '(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)])) + (class object% (super-new) (define/pubment (m x) (+ x (inner x m x)))) + 'pos + 'neg)] + [d% (class c% (super-new) (define/augride (m x) (add1 x)))]) + (send (new d%) m 3))) + +(test/neg-blame + 'class/c-higher-order-inner-2 + '(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)])) + (class object% (super-new) (define/pubment (m x) (+ x (inner x m x)))) + 'pos + 'neg)] + [d% (class c% (super-new) (define/augride (m x) (zero? x)))]) + (send (new d%) m 3))) + +(test/pos-blame + 'class/c-higher-order-inner-3 + '(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)])) + (class object% (super-new) (define/pubment (m x) + (+ x (inner x m (zero? x))))) + 'pos + 'neg)] + [d% (class c% (super-new) (define/augride (m x) (add1 x)))]) + (send (new d%) m 3))) + +(test/neg-blame + 'class/c-higher-order-inner-4 + '(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)])) + (class object% (super-new) (define/pubment (m x) (+ x (inner x m x)))) + 'pos + 'neg)] + [d% (class c% (super-new) (define/augride (m x) (add1 x)))] + [e% (class d% (super-new) (define/override (m x) (zero? (super m x))))]) + (send (new e%) m 3))) + +(test/spec-passed + 'class/c-higher-order-inner-5 + '(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)])) + (class object% (super-new) (define/pubment (m x) (+ x (inner x m x)))) + 'pos + 'neg)] + [d% (class c% (super-new) (define/augment (m x) (if (inner x m x) (add1 x) x)))] + [e% (class d% (super-new) (define/augride (m x) (zero? x)))]) + (send (new e%) m 3))) + +;; Make sure the order of the wrapping is correct in the next two. +(test/neg-blame + 'class/c-higher-order-inner-6 + '(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)])) + (class object% (super-new) (define/pubment (m x) (+ x (inner x m x)))) + 'pos + 'neg1)] + [d% (contract (class/c (inner [m (-> any/c number? number?)])) + c% + 'pos1 + 'neg)] + [e% (class d% (super-new) (define/augride (m x) (zero? x)))]) + (send (new e%) m 3))) + +(test/pos-blame + 'class/c-higher-order-inner-7 + '(let* ([c% (contract (class/c (inner [m (-> any/c integer? integer?)])) + (class object% (super-new) (define/pubment (m x) (+ x (inner x m #f)))) + 'pos + 'neg1)] + [d% (contract (class/c (inner [m (-> any/c number? number?)])) + c% + 'pos1 + 'neg)] + [e% (class d% (super-new) (define/augride (m x) (add1 x)))]) + (send (new e%) m 3))) + +;; Test that overriding an augmenting method can still be effected by an inner contract. +(test/neg-blame + 'class/c-higher-order-inner-8 + '(let* ([c% (contract (class/c (inner [m (-> any/c number? number?)])) + (class object% (super-new) (define/pubment (m x) (+ x (inner x m 3)))) + 'pos + 'neg)] + [d% (class c% (super-new) (define/augride (m x) (add1 x)))] + [e% (class d% (super-new) (define/override (m x) (zero? (super m x))))]) + (send (new e%) m 3))) + +;; The inner contract can be added before the next augmenting method, as seen here. +(test/neg-blame + 'class/c-higher-order-inner-9 + '(let* ([c% (class object% (super-new) (define/pubment (m x) (+ x (inner x m 3))))] + [d% (contract (class/c (inner [m (-> any/c number? number?)])) + (class c% (super-new) (define/augride (m x) (add1 x))) + 'pos + 'neg)] + [e% (class d% (super-new) (define/override (m x) (zero? (super m x))))]) + (send (new e%) m 3))) + +;; Show both inner and super contracts. +(test/spec-passed + 'class/c-higher-order-inner-10 + '(let* ([c% (class object% (super-new) (define/pubment (m x) (+ x (inner x m 3))))] + [d% (contract (class/c (inner [m (-> any/c number? number?)]) + (super [m (-> any/c number? number?)])) + (class c% (super-new) (define/augride (m x) (add1 x))) + 'pos + 'neg)] + [e% (class d% (super-new) (define/override (m x) (+ x (super m x))))]) + (send (new e%) m 3))) + +(test/pos-blame + 'class/c-higher-order-inner-11 + '(let* ([c% (class object% (super-new) (define/pubment (m x) (+ x (inner x m #f))))] + [d% (contract (class/c (inner [m (-> any/c number? number?)]) + (super [m (-> any/c number? number?)])) + (class c% (super-new) (define/augride (m x) (add1 x))) + 'pos + 'neg)] + [e% (class d% (super-new) (define/override (m x) (+ x (super m x))))]) + (send (new e%) m 3))) + +(test/neg-blame + 'class/c-higher-order-inner-10 + '(let* ([c% (class object% (super-new) (define/pubment (m x) (+ x (inner x m 3))))] + [d% (contract (class/c (inner [m (-> any/c number? number?)]) + (super [m (-> any/c number? number?)])) + (class c% (super-new) (define/augride (m x) (add1 x))) + 'pos + 'neg)] + [e% (class d% (super-new) (define/override (m x) (+ x (super m #f))))]) + (send (new e%) m 3))) + +(test/spec-passed/result + 'class/c-higher-order-field-1 + '(let* ([c% (contract (class/c (field [f number?])) + (class object% (super-new) (field [f 10])) + 'pos + 'neg)]) + (get-field f (new c%))) + 10) + +(test/spec-passed/result + 'class/c-higher-order-field-2 + '(let* ([c% (contract (class/c (field [f number?])) + (class object% (super-new) (field [f 10])) + 'pos + 'neg)] + [o (new c%)]) + (set-field! f o 5) + (get-field f o)) + 5) + +(test/pos-blame + 'class/c-higher-order-field-3 + '(let* ([c% (contract (class/c (field [f number?])) + (class object% (super-new) (field [f #f])) + 'pos + 'neg)] + [o (new c%)]) + (get-field f o))) + +(test/neg-blame + 'class/c-higher-order-field-4 + '(let* ([c% (contract (class/c (field [f number?])) + (class object% (super-new) (field [f 10])) + 'pos + 'neg)] + [o (new c%)]) + (set-field! f o #f))) + +(test/spec-passed + 'class/c-higher-order-field-5 + '(let ([c% (contract (class/c (field f)) + (class object% (super-new) (field [f 10])) + 'pos + 'neg)]) + (get-field f (new c%)))) + +(test/spec-passed/result + 'class/c-higher-order-inherit-field-1 + '(let* ([c% (contract (class/c (inherit-field [f number?])) + (class object% (super-new) (field [f 10])) + 'pos + 'neg)] + [d% (class c% (super-new) + (inherit-field f) + (define/public (m) f))]) + (send (new d%) m)) + 10) + +(test/spec-passed/result + 'class/c-higher-order-inherit-field-2 + '(let* ([c% (contract (class/c (inherit-field [f number?])) + (class object% (super-new) (field [f 10])) + 'pos + 'neg)] + [d% (class c% (super-new) + (inherit-field f) + (define/public (m) (set! f 12)))] + [o (new d%)]) + (send o m) + (get-field f o)) + 12) + +(test/pos-blame + 'class/c-higher-order-inherit-field-3 + '(let* ([c% (contract (class/c (inherit-field [f number?])) + (class object% (super-new) (field [f #f])) + 'pos + 'neg)] + [d% (class c% (super-new) + (inherit-field f) + (define/public (m) f))]) + (send (new d%) m))) + +(test/neg-blame + 'class/c-higher-order-inherit-field-4 + '(let* ([c% (contract (class/c (inherit-field [f number?])) + (class object% (super-new) (field [f 10])) + 'pos + 'neg)] + [d% (class c% (super-new) + (inherit-field f) + (define/public (m) (set! f #f)))]) + (send (new d%) m))) + +(test/spec-passed + 'class/c-higher-order-inherit-field-5 + '(let* ([c% (contract (class/c (inherit-field f)) + (class object% (super-new) (field [f 10])) + 'pos + 'neg)] + [d% (class c% (super-new) + (inherit-field f) + (define/public (m) f))]) + (send (new d%) m))) + +(test/spec-passed + 'class/c-higher-order-override-1 + '(let* ([c% (contract (class/c (override [m (-> any/c integer? integer?)])) + (class object% (super-new) + (define/public (m x) x) + (define/public (f x) (m x))) + 'pos + 'neg)] + [d% (class c% (super-new) + (define/public (g x) (m x)) + (define/override (m x) (add1 (super m x))))]) + (send (new d%) g 3.5))) + +(test/neg-blame + 'class/c-higher-order-override-2 + '(let* ([c% (contract (class/c (override [m (-> any/c number? number?)])) + (class object% (super-new) + (define/public (m x) x) + (define/public (f x) (add1 (m x)))) + 'pos + 'neg)] + [d% (class c% (super-new) (define/override (m x) (zero? (super m x))))]) + (send (new d%) f 3))) + +(test/neg-blame + 'class/c-higher-order-override-3 + '(let* ([c% (contract (class/c (override [m (-> any/c number? number?)])) + (class object% (super-new) + (define/public (m x) (zero? x)) + (define/public (f x) (add1 (m x)))) + 'pos + 'neg)] + [d% (class c% (super-new) (define/override (m x) (super m x)))]) + (send (new d%) f 3))) + +(test/pos-blame + 'class/c-higher-order-override-4 + '(let* ([c% (contract (class/c (override [m (-> any/c number? number?)])) + (class object% (super-new) + (define/public (m x) x) + (define/public (f x) (add1 (m #f)))) + 'pos + 'neg)] + [d% (class c% (super-new) (define/override (m x) (+ x (super m x))))]) + (send (new d%) f 3))) + +(test/pos-blame + 'class/c-higher-order-override-5 + '(let* ([c% (contract (class/c (override [m (-> any/c number? number?)])) + (class object% (super-new) + (define/public (m x) x) + (define/public (f x) (add1 (m #f)))) + 'pos + 'neg1)] + [d% (contract (class/c (override [m (-> any/c string? string?)])) + c% + 'pos1 + 'neg)] + [e% (class d% (super-new) (define/override (m x) (+ x (super m x))))]) + (send (new e%) f 3))) + +(test/spec-passed + 'class/c-higher-order-override-6 + '(let* ([c% (contract (class/c (override [m (-> any/c number? number?)])) + (class object% (super-new) + (define/public (m x) x) + (define/public (f x) (add1 (m 3.5)))) + 'pos + 'neg1)] + [d% (contract (class/c (override [m (-> any/c integer? integer?)])) + (class c% (super-new) (inherit m) (define/public (g x) (add1 (m 3)))) + 'pos1 + 'neg)] + [e% (class d% (super-new) (define/override (m x) (+ x (super m x))))]) + (send (new e%) g 3))) + +(test/pos-blame + 'class/c-higher-order-override-7 + '(let* ([c% (contract (class/c (override [m (-> any/c number? number?)])) + (class object% (super-new) + (define/public (m x) x) + (define/public (f x) (add1 (m #f)))) + 'pos + 'neg1)] + [d% (contract (class/c (override [m (-> any/c integer? integer?)])) + (class c% (super-new) (define/public (g x) (add1 (m 3)))) + 'pos1 + 'neg)] + [e% (class d% (super-new) (define/override (m x) (+ x (super m x))))]) + (send (new e%) f 3))) + +(test/spec-passed + 'class/c-higher-order-augment-1 + '(let* ([c% (contract (class/c (augment [m (-> any/c integer? integer?)])) + (class object% (super-new) + (define/pubment (m x) x) + (define/public (f x) (m (zero? x)))) + 'pos + 'neg)] + [d% (class c% (super-new) (inherit m) (define/public (g x) (m x)))]) + (send (new d%) f 3))) + +(test/neg-blame + 'class/c-higher-order-augment-2 + '(let* ([c% (contract (class/c (augment [m (-> any/c integer? integer?)])) + (class object% (super-new) (define/pubment (m x) x)) + 'pos + 'neg)] + [d% (class c% (super-new) (inherit m) (define/public (g x) (m x)))]) + (send (new d%) g 3.5))) + +(test/pos-blame + 'class/c-higher-order-augment-3 + '(let* ([c% (contract (class/c (augment [m (-> any/c integer? integer?)])) + (class object% (super-new) (define/pubment (m x) #f)) + 'pos + 'neg)] + [d% (class c% (super-new) (inherit m) (define/public (g x) (m x)))]) + (send (new d%) g 3))) + +(test/pos-blame + 'class/c-higher-order-augment-4 + '(let* ([c% (contract (class/c (augment [m (-> any/c number? integer?)])) + (class object% (super-new) (define/pubment (m x) #f)) + 'pos + 'neg1)] + [d% (contract (class/c (augment [m (-> any/c integer? number?)])) + c% + 'pos1 + 'neg)] + [e% (class d% (super-new) (inherit m) (define/public (g x) (m x)))]) + (send (new e%) g 3))) + +(test/neg-blame + 'class/c-higher-order-augment-5 + '(let* ([c% (contract (class/c (augment [m (-> any/c number? integer?)])) + (class object% (super-new) (define/pubment (m x) (floor x))) + 'pos + 'neg1)] + [d% (contract (class/c (augment [m (-> any/c integer? number?)])) + c% + 'pos1 + 'neg)] + [e% (class d% (super-new) (inherit m) (define/public (g x) (m x)))]) + (send (new e%) g 3.5))) + +(test/spec-passed + 'class/c-higher-order-augment-6 + '(let* ([c% (contract (class/c (augment [m (-> any/c number? integer?)])) + (class object% (super-new) (define/pubment (m x) (floor x))) + 'pos + 'neg1)] + [d% (contract (class/c (augment [m (-> any/c integer? number?)])) + (class c% (super-new) (inherit m) (define/public (f x) (m x))) + 'pos1 + 'neg)] + [e% (class d% (super-new) (inherit m) (define/public (g x) (m x)))]) + (send (new e%) f 3.5))) + +(test/spec-passed + 'class/c-higher-order-inherit-1 + '(let* ([c% (contract (class/c (inherit [m (-> any/c number? number?)])) + (class object% (super-new) (define/public (m x) x)) + 'pos + 'neg)] + [d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))]) + (send (new d%) f))) + +(test/neg-blame + 'class/c-higher-order-inherit-2 + '(let* ([c% (contract (class/c (inherit [m (-> any/c number? number?)])) + (class object% (super-new) (define/public (m x) x)) + 'pos + 'neg)] + [d% (class c% (super-new) (inherit m) (define/public (f) (m #f)))]) + (send (new d%) f))) + +(test/pos-blame + 'class/c-higher-order-inherit-3 + '(let* ([c% (contract (class/c (inherit [m (-> any/c number? number?)])) + (class object% (super-new) (define/public (m x) (zero? x))) + 'pos + 'neg)] + [d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))]) + (send (new d%) f))) + +;; Should not be checked if overridden (i.e. target of dyn disp changes). +(test/spec-passed + 'class/c-higher-order-inherit-4 + '(let* ([c% (contract (class/c (inherit [m (-> any/c number? number?)])) + (class object% (super-new) (define/public (m x) (zero? x))) + 'pos + 'neg)] + [d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))] + [e% (class d% (super-new) (define/override (m x) x))]) + (send (new e%) f))) + +(test/spec-passed + '->m-first-order-1 + '(contract (class/c [m (->m number? number?)]) + (class object% (super-new) (define/public (m x) x)) + 'pos + 'neg)) + +(test/pos-blame + '->m-first-order-2 + '(contract (class/c [m (->m any/c number? number?)]) + (class object% (super-new) (define/public (m x) x)) + 'pos + 'neg)) + +(test/spec-passed + '->m-kwd-first-order-1 + '(contract (class/c [m (->m #:x number? number?)]) + (class object% (super-new) (define/public (m #:x x) x)) + 'pos + 'neg)) + +(test/pos-blame + '->m-kwd-first-order-2 + '(contract (class/c [m (->m #:y number? number?)]) + (class object% (super-new) (define/public (m #:x x) x)) + 'pos + 'neg)) + +(test/spec-passed + '->*m-first-order-1 + '(contract (class/c [m (->*m (number?) (string?) number?)]) + (class object% (super-new) (define/public (m x [f "foo"]) x)) + 'pos + 'neg)) + +(test/pos-blame + '->*m-first-order-2 + '(contract (class/c [m (->*m (any/c number?) (string?) number?)]) + (class object% (super-new) (define/public (m x [f "foo"]) x)) + 'pos + 'neg)) + +(test/spec-passed + '->dm-first-order-1 + '(contract (class/c [pop (->dm () () #:pre-cond (not (send this empty?)) [_ number?])] + [push (->dm ([arg number?]) () [_ void?] #:post-cond (not (send this empty?)))] + [empty? (->m boolean?)]) + (class object% (super-new) + (define stack null) + (define/public (empty?) (null? stack)) + (define/public (push v) (set! stack (cons v stack))) + (define/public (pop) (let ([res (car stack)]) (set! stack (cdr stack)) res))) + 'pos + 'neg)) + +(test/pos-blame + '->dm-first-order-1 + '(contract (class/c [pop (->dm () () #:pre-cond (not (send this empty?)) [_ number?])] + [push (->dm ([arg number?]) () [_ void?] #:post-cond (not (send this empty?)))] + [empty? (->m boolean?)]) + (class object% (super-new) + (define stack null) + (define/public (empty?) (null? stack)) + (define/public (push v) (set! stack (cons v stack))) + (define/public (pop v) (let ([res (car stack)]) (set! stack (cdr stack)) res))) + 'pos + 'neg)) + +(test/spec-passed + '->dm-higher-order-1 + '(let* ([stack% (contract (class/c + [pop (->dm () () #:pre-cond (not (send this empty?)) [_ number?])] + [push (->dm ([arg number?]) () [_ void?] + #:post-cond (not (send this empty?)))] + [empty? (->m boolean?)]) + (class object% (super-new) + (define stack null) + (define/public (empty?) (null? stack)) + (define/public (push v) (set! stack (cons v stack))) + (define/public (pop) + (let ([res (car stack)]) (set! stack (cdr stack)) res))) + 'pos + 'neg)] + [o (new stack%)]) + (send o push 4) + (send o empty?) + (send o pop))) + +(test/pos-blame + '->dm-higher-order-2 + '(let* ([stack% (contract (class/c + [pop (->dm () () #:pre-cond (not (send this empty?)) [_ number?])] + [push (->dm ([arg number?]) () [_ void?] + #:post-cond (not (send this empty?)))] + [empty? (->m boolean?)]) + (class object% (super-new) + (define stack null) + (define/public (empty?) (null? stack)) + (define/public (push v) (void)) + (define/public (pop) + (define res (car stack)) + (set! stack (cdr stack)) + res)) + 'pos + 'neg)] + [o (new stack%)]) + (send o push 4) + (send o empty?) + (send o pop))) + +(test/neg-blame + '->dm-higher-order-3 + '(let* ([stack% (contract + (class/c + [pop (->dm () () #:pre-cond (not (send this empty?)) [_ number?])] + [push (->dm ([arg number?]) () [_ void?] #:post-cond (not (send this empty?)))] + [empty? (->m boolean?)]) + (class object% (super-new) + (define stack null) + (define/public (empty?) (null? stack)) + (define/public (push v) (set! stack (cons v stack))) + (define/public (pop) (let ([res (car stack)]) (set! stack (cdr stack)) res))) + 'pos + 'neg)] + [o (new stack%)]) + (send o pop))) + +(test/spec-passed + 'case->m-first-order-1 + '(contract (class/c [m (case->m (-> number? number?) (-> number? number? number?))]) + (class object% (super-new) (define/public (m x [y 3]) (+ x y))) + 'pos + 'neg)) + +(test/pos-blame + 'case->m-first-order-2 + '(contract (class/c [m (case->m (-> number? number?) (-> number? number? number?))]) + (class object% (super-new) (define/public (m x) (+ x y))) + 'pos + 'neg)) + +(test/spec-passed + 'case->m-higher-order-1 + '(let ([cls% (contract (class/c [m (case->m (-> number? number?) (-> number? number? number?))]) + (class object% (super-new) (define/public (m x [y 3]) (+ x y))) + 'pos + 'neg)]) + (send (new cls%) m 3) + (send (new cls%) m 3 4))) + +(test/neg-blame + 'case->m-higher-order-2 + '(let ([cls% (contract (class/c [m (case->m (-> number? number?) (-> number? number? number?))]) + (class object% (super-new) (define/public (m x [y 3]) (+ x y))) + 'pos + 'neg)]) + (send (new cls%) m #t))) + +(test/neg-blame + 'case->m-higher-order-3 + '(let ([cls% (contract (class/c [m (case->m (-> number? number?) (-> number? number? number?))]) + (class object% (super-new) (define/public (m x [y 3]) (+ x y))) + 'pos + 'neg)]) + (send (new cls%) m 3 #t))) + +(let ([expected-given? + (λ (exn) (and (regexp-match? #rx"callback: contract violation" (exn-message exn)) + (regexp-match? #rx"expected: boolean[?]" (exn-message exn)) + (regexp-match? #rx"given: 1" (exn-message exn))))] + [promised-produced? + (λ (exn) (and (regexp-match? #rx"callback: broke its contract" (exn-message exn)) + (regexp-match? #rx"promised: boolean[?]" (exn-message exn)) + (regexp-match? #rx"produced: 1" (exn-message exn))))]) + (contract-error-test + 'blame-important1 + '(send (new (contract (class/c [callback (->m boolean? void)]) + (class object% + (super-new) + (define/public (callback n) (void))) + 'pos + 'neg)) + callback 1) + expected-given?) + (contract-error-test + 'blame-important2 + '((contract (-> (class/c (callback (->m boolean? any))) + any) + (λ (c%) (send (new c%) callback 1)) + 'pos 'neg) + (class object% + (super-new) + (define/public (callback x) 3))) + expected-given?) + (contract-error-test + 'blame-important3 + '((contract (-> (class/c (callback (->m (-> boolean? void?) any))) + any) + (λ (c%) (send (new c%) callback void)) + 'pos 'neg) + (class object% + (super-new) + (define/public (callback f) (f 1)))) + promised-produced?))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/context.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/context.rkt new file mode 100644 index 0000000000..6ce113484f --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/context.rkt @@ -0,0 +1,453 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace + 'racket/promise + 'racket/contract + 'racket/class + 'racket/contract/private/blame)]) + + (contract-eval '(define (extract-context-lines thunk) + (define str + (with-handlers ((exn:fail:contract:blame? exn-message)) + (thunk) + "didn't raise an exception")) + (define m (regexp-match #rx".*\n +in: (.*)$" str)) + (cond + [m + (define without-prefix (list-ref m 1)) + (define m2 (regexp-match #rx"(.*)\n *contract from:" without-prefix)) + (cond + [m2 + (define lines (regexp-split #rx"\n *" (list-ref m2 1))) + ;; drop the lines with the contract (keep lines beginning with an article) + (let loop ([lines (regexp-split #rx"\n *" (list-ref m2 1))]) + (cond + [(null? lines) '()] + [else + (define line (car lines)) + (cond + [(or (regexp-match #rx"^the " line) + (regexp-match #rx"^an " line) + (regexp-match #rx"^a " line)) + (cons line (loop (cdr lines)))] + [else + (loop (cdr lines))])]))] + [else + (string-append "did not find ``contract from:'', so no context in msg: " + str)])] + [else + (string-append "did not find ``in:'', so no context in msg: " + str)]))) + + (define (context-test context expression) + (contract-eval `(,test ',context extract-context-lines (lambda () ,expression))) + (let/ec k + (contract-eval + `(,test ',context extract-context-lines (lambda () ,(rewrite-to-add-opt/c expression k)))))) + + (context-test '("the 1st argument of") + '((contract (-> boolean? integer? integer?) + (λ (x y) x) + 'pos + 'neg) + 0 1)) + + (context-test '("the cdr of" "the 1st argument of") + '((contract (-> (cons/c integer? boolean?) integer? integer?) + (λ (x y) x) + 'pos + 'neg) + (cons 1 2) 1)) + + (context-test '("the 3rd element of" "the 2nd argument of") + '((contract (-> integer? (list/c integer? integer? boolean?) integer?) + (λ (x y) x) + 'pos + 'neg) + 1 (list 1 2 3))) + + (context-test '("the range of" "the 4th element of") + '((cadddr (contract (list/c integer? integer? boolean? (-> number? number?)) + (list 1 2 #f (λ (x) #f)) + 'pos + 'neg)) + 1)) + + (context-test '("a disjunct of") + '(contract (or/c 1 (-> number? number?)) + 3 + 'pos + 'neg)) + + (context-test '("the range of" "a disjunct of") + '((contract (or/c 1 (-> number? number?) (-> number? boolean? number?)) + (λ (x) #f) + 'pos + 'neg) + 1)) + + (context-test '("the 2nd conjunct of") + '(contract (and/c procedure? (-> integer? integer?)) + (λ (x y) 1) + 'pos + 'neg)) + + (context-test '("an element of") + '(contract (listof number?) + (list #f) + 'pos + 'neg)) + + (context-test '("the promise from") + '(force (contract (promise/c number?) + (delay #f) + 'pos + 'neg))) + + (context-test '("the parameter of") + '((contract (parameter/c number?) + (make-parameter #f) + 'pos + 'neg))) + (context-test '("the parameter of") + '((contract (parameter/c number?) + (make-parameter 1) + 'pos + 'neg) + #f)) + (context-test '("the #:x argument of") + '((contract (-> #:x number? #:a char? #:w boolean? any) + (λ (#:x x #:a a #:w w) x) + 'pos + 'neg) + #:a #\a #:w #f #:x 'two)) + + (context-test '("the #:a argument of") + '((contract (-> #:x number? #:a char? #:w boolean? any) + (λ (#:x x #:a a #:w w) x) + 'pos + 'neg) + #:a #f #:w #f #:x 2)) + + (context-test '("the #:w argument of") + '((contract (-> #:x number? #:a char? #:w boolean? any) + (λ (#:x x #:a a #:w w) x) + 'pos + 'neg) + #:a #\a #:w 'false #:x 2)) + + (context-test '("the #:x argument of") + '((contract (->* () (#:x number?) any) + (λ (#:x [x 1]) x) + 'pos + 'neg) + #:x #f)) + + (context-test '("the #:x argument of") + '((contract (->* () (#:x number? #:a char? #:w boolean?) any) + (λ (#:x [x 1] #:a [a #\a] #:w [w #f]) x) + 'pos + 'neg) + #:a #\a #:w #f #:x 'two)) + + (context-test '("the #:a argument of") + '((contract (->* () (#:x number? #:a char? #:w boolean?) any) + (λ (#:x [x 1] #:a [a #\a] #:w [w #f]) x) + 'pos + 'neg) + #:a #f #:w #f #:x 2)) + + (context-test '("the #:w argument of") + '((contract (->* () (#:x number? #:a char? #:w boolean?) any) + (λ (#:x [x 1] #:a [a #\a] #:w [w #f]) x) + 'pos + 'neg) + #:a #\a #:w 'false #:x 2)) + + (context-test '("the x argument of") + '((contract (->i ([w integer?] [x boolean?] [a char?]) any) + (λ (w x a) x) + 'pos + 'neg) + 1 'true #\a)) + + (context-test '("the x argument of") + '((contract (->i ([w integer?]) ([x boolean?] [a char?]) any) + (λ (w [x #t] [a #\a]) x) + 'pos + 'neg) + 1 'true #\a)) + + (context-test '("the y result of") + '((contract (->i () (values [x integer?] [y integer?])) + (λ () (values 1 #f)) + 'pos + 'neg))) + + (context-test '("the x result of") + '((contract (->i () (values [x integer?] [y integer?])) + (λ () (values #f 1)) + 'pos + 'neg))) + + (context-test '("the _ result of") + '((contract (->i ([x integer?]) [_ (x) (<=/c x)]) + add1 + 'pos + 'neg) + 1)) + + (context-test '("the a argument of") + '((contract (->i ([a integer?] #:b [b integer?]) ([c integer?] #:d [d integer?]) any) + (λ (a #:b b [c 1] #:d [d 1]) 1) + 'pos + 'neg) + 'one #:b 2 3 #:d 4)) + + (context-test '("the b argument of") + '((contract (->i ([a integer?] #:b [b integer?]) ([c integer?] #:d [d integer?]) any) + (λ (a #:b b [c 1] #:d [d 1]) 1) + 'pos + 'neg) + 1 #:b 'two 3 #:d 4)) + + (context-test '("the c argument of") + '((contract (->i ([a integer?] #:b [b integer?]) ([c integer?] #:d [d integer?]) any) + (λ (a #:b b [c 1] #:d [d 1]) 1) + 'pos + 'neg) + 1 #:b 2 'three #:d 4)) + + (context-test '("the d argument of") + '((contract (->i ([a integer?] #:b [b integer?]) ([c integer?] #:d [d integer?]) any) + (λ (a #:b b [c 1] #:d [d 1]) 1) + 'pos + 'neg) + 1 #:b 2 3 #:d 'four)) + + ;; indy + (context-test '("the 2nd argument of" "the x argument of") + '((contract (->i ([x (-> number? boolean? integer?)] [a (x) (>=/c (x 11 'true))]) any) + (λ (x a) x) + 'pos + 'neg) + (λ (x y) 1) 11)) + + (context-test '("the 2nd argument of" "the x result of") + '((contract + (->i () (values [x (-> number? boolean? integer?)] [a (x) (>=/c (x 11 'true))])) + (λ () (values (λ (x y) x) 1)) + 'pos + 'neg))) + + (context-test '("the x argument of") + '((contract (->i ([x () integer?]) any) + (λ (x) x) + 'pos + 'neg) + #f)) + + (context-test '("the a argument of") + '((contract (->i ([a integer?] [x (a) integer?]) any) + (λ (a x) x) + 'pos + 'neg) + #f 1)) + + (context-test '("the 1st result of") + '((contract (->i () (values [_ integer?] [_ integer?])) + (λ () (values #f 1)) + 'pos + 'neg))) + + (context-test '("the result of") + '((contract (->i () [_ integer?]) + (λ () (values #f)) + 'pos + 'neg))) + + (context-test '("the domain of") + '((contract (->d ([x integer?]) [y integer?]) + (λ (x) #f) + 'pos + 'neg) + #f)) + + (context-test '("the range of") + '((contract (->d ([x integer?]) [y integer?]) + (λ (x) #f) + 'pos + 'neg) + 1)) + + (context-test '("the range of") + '(letrec ([ctc (-> integer? (recursive-contract ctc))]) + (letrec ([f (λ (x) 'not-f)]) + ((contract ctc f 'pos 'neg) 1)))) + + (context-test '("the a field of") + '(let () + (struct s (a b)) + (contract (struct/dc s [a (b) (<=/c b)] [b integer?]) + (s 2 1) + 'pos + 'neg))) + + (context-test '("the a field of") + '(let () + (struct s (a b)) + (contract (struct/dc s [a (<=/c 1)] [b integer?]) + (s 2 1) + 'pos + 'neg))) + + (context-test '("an element of" "the 2nd element of") + '(vector-ref + (vector-ref + (contract (vector/c (vectorof real?) (vectorof number?) (vectorof boolean?)) + (vector (vector 1) (vector 1) (vector 1)) + 'pos + 'neg) + 2) + 0)) + + (context-test '("the 0th element of") + '(vector-ref (contract (vector/c integer?) + (vector #f) + 'pos + 'neg) + 0)) + + (context-test '("the 0th element of") + '(vector-ref (contract (vector/c (-> integer? integer?)) + (vector #f) + 'pos + 'neg) + 0)) + + (context-test '("the 0th element of") + '(vector-ref (contract (vector/c (new-∀/c 'α)) + (vector #f) + 'pos + 'neg) + 0)) + + (context-test '("an element of") + '(vector-ref + (contract (vectorof integer?) + (vector #f) + 'pos + 'neg) + 0)) + + (context-test '("an element of") + '(vector-ref (contract (vectorof (-> integer? integer?)) + (vector #f) + 'pos + 'neg) + 0)) + + (context-test '("an element of") + '(vector-ref (contract (vectorof (new-∀/c 'α)) + (vector #f) + 'pos + 'neg) + 0)) + + (context-test '("the keys of") + '(contract (hash/c integer? (-> integer? integer?)) + (hash #f (λ (x) #f)) + 'pos + 'neg)) + + (context-test '("the range of" "the values of") + '((hash-ref + (contract (hash/c integer? (-> integer? integer?)) + (hash 0 (λ (x) #f)) + 'pos + 'neg) + 0) + 1)) + + (context-test '("an element of" "the rest argument of") + '((contract (->* () #:rest (listof number?) number?) + + + 'pos 'neg) + 1 "a")) + + (context-test '("the 2nd argument of") + '((contract (->* (number? number?) #:rest (listof number?) number?) + + + 'pos 'neg) + 1 "a")) + + (context-test '("an element of" "the rest argument of") + '((contract (->* (number?) #:rest (listof number?) number?) + + + 'pos 'neg) + 1 "a")) + + (context-test '("the range of" "the 2nd case of") + '((contract (case-> (-> real? real? real?) + (-> real? (values real? real?))) + (case-lambda + [(x y) 1] + [(x) 1]) + 'pos 'neg) + 1)) + + (context-test '("the domain of" "the 2nd case of") + '((contract (case-> (-> real? real? real?) + (-> real? (values real? real?))) + (case-lambda + [(x y) 1] + [(x) 1]) + 'pos 'neg) + #f)) + + (context-test '("the 1st argument of" "the save-file method in") + '(send (contract (object/c + (save-file (->m string? string?))) + (new (class object% + (define/public (save-file s . args) #f) + (super-new))) + 'pos + 'neg) + save-file 1)) + + (context-test '("the f field in") + '(get-field + f + (contract (object/c (field [f string?])) + (new (class object% + (field [f 1]) + (super-new))) + 'pos + 'neg))) + + (context-test '("the 1st argument of" "the f field in") + '((get-field + f + (contract (object/c (field [f (-> string? any)])) + (new (class object% + (field [f (λ (x) 1)]) + (super-new))) + 'pos + 'neg)) + #f)) + + + (let* ([blame-pos (contract-eval '(make-blame (srcloc #f #f #f #f #f) + #f + (λ () 'integer?) + 'positive + 'negative + #t))] + [blame-neg (contract-eval `(blame-swap ,blame-pos))]) + (ctest "something ~a" blame-fmt->-string ,blame-neg "something ~a") + (ctest "promised: ~s\n produced: ~e" blame-fmt->-string ,blame-pos '(expected: "~s" given: "~e")) + (ctest "expected: ~s\n given: ~e" blame-fmt->-string ,blame-neg '(expected: "~s" given: "~e")) + (ctest "promised ~s produced ~e" blame-fmt->-string ,blame-pos '(expected "~s" given "~e")) + (ctest "expected ~s given ~e" blame-fmt->-string ,blame-neg '(expected "~s" given "~e")))) \ No newline at end of file diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/continuation-mark.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/continuation-mark.rkt new file mode 100644 index 0000000000..04abc9a9fb --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/continuation-mark.rkt @@ -0,0 +1,161 @@ +#lang racket/base + +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace)]) + + (test/spec-passed + 'continuation-mark-key/c-fo-1 + '(contract (continuation-mark-key/c string?) + (make-continuation-mark-key) + 'pos 'neg)) + + (test/pos-blame + 'continuation-mark-key/c-fo-2 + '(contract (continuation-mark-key/c string?) 5 'pos 'neg)) + + (test/neg-blame + 'continuation-mark-key/c-ho-1 + '(let ([mark (contract (continuation-mark-key/c number?) + (make-continuation-mark-key) + 'pos + 'neg)]) + (with-continuation-mark mark "bad" + 42))) + + (test/spec-passed + 'continuation-mark-key/c-ho-2 + '(let ([mark (contract (continuation-mark-key/c number?) + (make-continuation-mark-key) + 'pos + 'neg)]) + (with-continuation-mark mark 5 + (continuation-mark-set-first + (current-continuation-marks) mark)))) + + (test/neg-blame + 'continuation-mark-key/c-ho-3 + '(let ([mark (contract (continuation-mark-key/c number?) + (make-continuation-mark-key) + 'pos + 'neg)]) + (with-continuation-mark mark "bad" + (continuation-mark-set-first + (current-continuation-marks) mark)))) + + (test/neg-blame + 'continuation-mark-key/c-ho-4 + '(let* ([mark (make-continuation-mark-key)] + [do-mark (contract (-> (-> (continuation-mark-key/c (-> number? number?)) + number?) + number?) + (lambda (f) + (with-continuation-mark mark (lambda (x) (+ x 1)) + (f mark))) + 'pos + 'neg)]) + (do-mark + (lambda (mark) + ((continuation-mark-set-first + (current-continuation-marks) mark) + "bad"))))) + + (test/pos-blame + 'continuation-mark-key/c-ho-5 + '(let* ([mark (make-continuation-mark-key)] + [do-mark (contract (-> (-> (continuation-mark-key/c (-> number? number?)) + number?) + number?) + (lambda (f) + (with-continuation-mark mark (lambda (x) "bad") + (f mark))) + 'pos + 'neg)]) + (do-mark + (lambda (mark) + ((continuation-mark-set-first + (current-continuation-marks) mark) + 0))))) + + (test/spec-passed + 'continuation-mark-key/c-ho-6 + '(let* ([mark (make-continuation-mark-key)] + [do-mark (contract (-> (-> (continuation-mark-key/c (-> number? number?)) + number?) + number?) + (lambda (f) + (with-continuation-mark mark (lambda (x) (+ x 1)) + (f mark))) + 'pos + 'neg)]) + (do-mark + (lambda (mark) + ((continuation-mark-set-first + (current-continuation-marks) mark) + 0))))) + + (test/neg-blame + 'continuation-mark-key/c-ho-7 + '(let ([mark (contract (continuation-mark-key/c (-> number? number?)) + (make-continuation-mark-key) + 'pos + 'neg)]) + (with-continuation-mark mark (lambda (x) "bad") + ((continuation-mark-set-first + (current-continuation-marks) mark) + 5)))) + + (test/spec-passed + 'continuation-mark-key/c-ho-8 + '(let ([mark (contract (continuation-mark-key/c (-> number? number?)) + (make-continuation-mark-key) + 'pos + 'neg)]) + (with-continuation-mark mark (lambda (x) (+ x 1)) + ((continuation-mark-set-first + (current-continuation-marks) mark) + 0)))) + + (test/pos-blame + 'continuation-mark-key/c-ho-9 + '(let* ([mark (make-continuation-mark-key)] + [do-mark (contract (-> (continuation-mark-key/c (-> number? number?)) + number?) + (lambda (mark) + ((continuation-mark-set-first + (current-continuation-marks) mark) + "bad")) + 'pos + 'neg)]) + (with-continuation-mark mark (lambda (x) (+ x 1)) + (do-mark mark)))) + + (test/pos-blame + 'continuation-mark-key/c-ho-10 + '(let* ([mark (make-continuation-mark-key)] + [ctc-mark (contract (continuation-mark-key/c number?) + mark + 'pos + 'neg)]) + (with-continuation-mark mark "not a number" + (+ 1 (continuation-mark-set-first #f ctc-mark))))) + + (test/spec-passed + 'continuation-mark-key/c-ho-11 + '(let* ([mark (make-continuation-mark-key)] + [ctc-mark (contract (continuation-mark-key/c number?) + mark + 'pos + 'neg)]) + (continuation-mark-set-first #f ctc-mark))) + + (test/spec-passed/result + 'continuation-mark-key/c-has-contract + '(let* ([mark (make-continuation-mark-key)] + [ctc-mark (contract (continuation-mark-key/c number?) + mark + 'pos + 'neg)]) + (has-contract? ctc-mark)) + #t)) \ No newline at end of file diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/contract-out.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/contract-out.rkt new file mode 100644 index 0000000000..9aa10456bf --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/contract-out.rkt @@ -0,0 +1,1109 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace 'racket/contract)]) + + (define exn:fail:contract:blame-object + (contract-eval 'exn:fail:contract:blame-object)) + (define exn:fail:contract:blame? + (contract-eval 'exn:fail:contract:blame?)) + + (test/spec-passed + 'provide/contract1 + '(let () + (eval '(module contract-test-suite1 scheme/base + (require scheme/contract) + (define x 1) + (provide/contract (x integer?)))) + (eval '(require 'contract-test-suite1)) + (eval 'x))) + + (test/spec-passed + 'provide/contract2 + '(let () + (eval '(module contract-test-suite2 scheme/base + (require scheme/contract) + (provide/contract))) + (eval '(require 'contract-test-suite2)))) + + (test/spec-failed + 'provide/contract3 + '(let () + (eval '(module contract-test-suite3 scheme/base + (require scheme/contract) + (define x #f) + (provide/contract (x integer?)))) + (eval '(require 'contract-test-suite3)) + (eval 'x)) + "contract-test-suite3") + + (test/spec-passed + 'provide/contract4 + '(begin + (eval '(module contract-test-suite4 scheme/base + (require scheme/contract) + (define-struct s (a) #:mutable) + (provide/contract (struct s ((a any/c)))))) + (eval '(require 'contract-test-suite4)) + (eval '(list (make-s 1) + (s-a (make-s 1)) + (s? (make-s 1)) + (set-s-a! (make-s 1) 2))))) + + (test/spec-passed + 'provide/contract4-b + '(begin + (eval '(module contract-test-suite4-b scheme/base + (require scheme/contract) + (define-struct s (a)) + (provide/contract (struct s ((a any/c)))))) + (eval '(require 'contract-test-suite4-b)) + (eval '(list (make-s 1) + (s-a (make-s 1)) + (s? (make-s 1)))))) + + (test/spec-passed/result + 'provide/contract4-c + '(begin + (eval '(module contract-test-suite4-c scheme/base + (require scheme/contract) + (define-struct s (a b) #:mutable) + (provide/contract (struct s ((a any/c) (b any/c)))))) + (eval '(require 'contract-test-suite4-c)) + (eval '(let ([an-s (make-s 1 2)]) + (list (s-a an-s) + (s-b an-s) + (begin (set-s-a! an-s 3) + (s-a an-s)) + (begin (set-s-b! an-s 4) + (s-b an-s)))))) + + (list 1 2 3 4)) + + (test/spec-passed + 'provide/contract5 + '(begin + (eval '(module contract-test-suite5 scheme/base + (require scheme/contract) + (define-struct s (a)) + (define-struct t (a)) + (provide/contract (struct s ((a any/c))) + (struct t ((a any/c)))))) + (eval '(require 'contract-test-suite5)) + (eval '(list (make-s 1) + (s-a (make-s 1)) + (s? (make-s 1)) + (make-t 1) + (t-a (make-t 1)) + (t? (make-t 1)))))) + + (test/spec-passed + 'provide/contract6 + '(begin + (eval '(module contract-test-suite6 scheme/base + (require scheme/contract) + (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/contract6b + '(begin + (eval '(module contract-test-suite6b scheme/base + (require scheme/contract) + (define-struct s_ (a)) + (provide/contract (struct s_ ((a any/c)))))) + (eval '(require 'contract-test-suite6b)) + (eval '(module contract-test-suite6b2 scheme/base + (require 'contract-test-suite6b) + (require scheme/contract) + (define-struct (t_ s_) (b)) + (provide s_-a) + (provide/contract (struct (t_ s_) ((a any/c) (b any/c)))))) + (eval '(require 'contract-test-suite6b2)) + (eval '(define-struct (u_ t_) ())) + (eval '(s_-a (make-u_ 1 2))))) + + (test/spec-passed + 'provide/contract7 + '(begin + (eval '(module contract-test-suite7 scheme/base + (require scheme/contract) + (define-struct s (a b)) + (define-struct (t s) (c d)) + (provide/contract + (struct s ((a any/c) (b any/c))) + (struct (t s) ((a any/c) (b any/c) (c any/c) (d any/c)))))) + (eval '(require 'contract-test-suite7)) + (eval '(let ([x (make-t 1 2 3 4)]) + (s-a x) + (s-b x) + (t-c x) + (t-d x) + (void))))) + + (test/spec-passed + 'provide/contract8 + '(begin + (eval '(module contract-test-suite8 scheme/base + (require scheme/contract) + (define-struct i-s (contents)) + (define (w-f-s? x) #t) + (provide/contract + (struct i-s ((contents (flat-named-contract "integer-set-list" w-f-s?))))))) + (eval '(require 'contract-test-suite8)) + (eval '(i-s-contents (make-i-s 1))))) + + (test/spec-passed + 'provide/contract9 + '(begin + (eval '(module contract-test-suite9 scheme/base + (require scheme/contract) + (define the-internal-name 1) + (provide/contract (rename the-internal-name the-external-name integer?)) + (void (+ the-internal-name 1)))) + (eval '(require 'contract-test-suite9)) + (eval '(+ the-external-name 1)))) + + (test/spec-passed + 'provide/contract10 + '(begin + (eval '(module pc10-m scheme/base + (require scheme/contract) + (define-struct s (a b) #:inspector (make-inspector)) + (provide/contract (struct s ((a number?) (b number?)))))) + (eval '(module pc10-n scheme/base + (require mzlib/struct + 'pc10-m) + (print-struct #t) + (void + (copy-struct s + (make-s 1 2) + [s-a 3])))) + (eval '(require 'pc10-n)))) + + (test/spec-passed + 'provide/contract11 + '(begin + (eval '(module pc11-m scheme/base + (require scheme/contract) + (define x 1) + (provide/contract [rename x y integer?] + [rename x z integer?]))) + (eval '(module pc11-n scheme/base + (require 'pc11-m) + (void (+ y z)))) + (eval '(require 'pc11-n)))) + + ;; this test is broken, not sure why + #| + (test/spec-failed + 'provide/contract11b + '(parameterize ([current-namespace (make-namespace)]) + (eval '(module pc11b-m scheme/base + (require scheme/contract) + (define-struct s (a b) #:inspector (make-inspector)) + (provide/contract (struct s ((a number?) (b number?)))))) + (eval '(module pc11b-n scheme/base + (require mzlib/struct + m) + (print-struct #t) + (copy-struct s + (make-s 1 2) + [s-a #f]))) + (eval '(require 'pc11b-n))) + "n") +|# + + (test/spec-passed + 'provide/contract12 + '(begin + (eval '(module pc12-m scheme/base + (require scheme/contract) + (define-struct (exn2 exn) ()) + (provide/contract (struct (exn2 exn) ((message any/c) (continuation-marks any/c)))))) + (eval '(require 'pc12-m)))) + + (test/spec-passed/result + 'provide/contract13 + '(begin + (eval '(module pc13-common-msg-structs scheme/base + (require scheme/contract) + (define-struct register (name type) #:inspector (make-inspector)) + (provide/contract (struct register ([name any/c] [type any/c]))))) + + (eval '(require 'pc13-common-msg-structs)) + (eval '(require (lib "plt-match.rkt"))) + (eval '(match (make-register 1 2) + [(struct register (name type)) + (list name type)]))) + (list 1 2)) + + (test/spec-passed + 'provide/contract14 + '(begin + (eval '(module pc14-test1 scheme/base + (require scheme/contract) + + (define-struct type (flags)) + (define-struct (type:ptr type) (type)) + + (provide/contract + (struct type + ([flags (listof string?)])) + + (struct (type:ptr type) + ([flags (listof string?)] [type type?]))))) + + (eval '(module pc14-test2 scheme/base + (require mzlib/plt-match) + (require 'pc14-test1) + (void + (match (make-type:ptr '() (make-type '())) + [(struct type:ptr (flags type)) #f])))) + (eval '(require 'pc14-test2)))) + + ;; make sure unbound identifier exception is raised. + (contract-error-test + 'contract-error-test7 + #'(begin + (eval '(module pos scheme/base + (require scheme/contract) + (provide/contract [i any/c])))) + exn:fail:syntax?) + + ;; provide/contract should signal errors without requiring a reference to the variable + ;; this test is bogus, because provide/contract'd variables can be set!'d. + (test/spec-failed + 'provide/contract15 + '(begin + (eval '(module pos scheme/base + (require scheme/contract) + (define i #f) + (provide/contract [i integer?]))) + (eval '(require 'pos))) + "pos") + + ;; this is really a positive violation, but name the module `neg' just for an addl test + (test/spec-failed + 'provide/contract16 + '(begin + (eval '(module neg scheme/base + (require scheme/contract) + (define i #f) + (provide/contract [i integer?]))) + (eval '(require 'neg))) + "neg") + + ;; this test doesn't pass yet ... waiting for support from define-struct + + #; + (test/neg-blame + 'provide/contract17 + '(begin + (eval '(module pos scheme/base + (require scheme/contract) + (define-struct s (a)) + (provide/contract [struct s ((a integer?))]))) + (eval '(module neg scheme/base + (require 'pos) + (define-struct (t s) ()) + (make-t #f))) + (eval '(require 'neg)))) + + (test/spec-passed + 'provide/contract18 + '(begin + (eval '(module pc18-pos scheme/base + (require scheme/contract) + (define-struct s ()) + (provide/contract [struct s ()]))) + (eval '(require 'pc18-pos)) + (eval '(make-s)))) + + (test/spec-passed/result + 'provide/contract19 + '(begin + (eval '(module pc19-a scheme/base + (require scheme/contract) + (define-struct a (x)) + (provide/contract [struct a ([x number?])]))) + + (eval '(module pc19-b scheme/base + (require 'pc19-a + scheme/contract) + (define-struct (b a) (y)) + (provide/contract [struct (b a) ([x number?] [y number?])]))) + + (eval '(module pc19-c scheme/base + (require 'pc19-b + scheme/contract) + + (define-struct (c b) (z)) + (provide/contract [struct (c b) ([x number?] [y number?] [z number?])]))) + + (eval' (module pc19-d scheme/base + (require 'pc19-a 'pc19-c) + (define pc19-ans (a-x (make-c 1 2 3))) + (provide pc19-ans))) + + (eval '(require 'pc19-d)) + (eval 'pc19-ans)) + 1) + + ;; test that unit & contract don't collide over the name `struct' + (test/spec-passed + 'provide/contract20 + '(eval '(module tmp scheme/base + (require scheme/contract + mzlib/unit) + + (define-struct s (a b)) + + (provide/contract + [struct s ([a number?] + [b symbol?])])))) + + (test/spec-passed + 'provide/contract21 + '(begin + (eval '(module provide/contract21a scheme/base + (require scheme/contract) + (provide/contract [f integer?]) + (define f 1))) + (eval '(module provide/contract21b scheme/base + (require (for-syntax 'provide/contract21a) + (for-syntax scheme/base)) + (define-syntax (unit-body stx) + f f + #'1))))) + + (test/spec-passed + 'provide/contract22 + '(begin + (eval '(module provide/contract22a scheme/base + (require scheme/contract) + (provide/contract [make-bound-identifier-mapping integer?]) + (define make-bound-identifier-mapping 1))) + (eval '(module provide/contract22b scheme/base + (require (for-syntax 'provide/contract22a) + (for-syntax scheme/base)) + + (define-syntax (unit-body stx) + make-bound-identifier-mapping) + + (define-syntax (f stx) + make-bound-identifier-mapping))))) + + (test/spec-passed + 'provide/contract23 + '(begin + (eval '(module provide/contract23a scheme/base + (require scheme/contract) + (provide/contract [f void?]) + (define f (void)))) + + (eval '(module provide/contract23b scheme/base + (require 'provide/contract23a) + (#%expression f) + f)) + + (eval '(require 'provide/contract23b)))) + + #| + (test/spec-passed + 'provide/contract24 + '(begin + (eval '(module provide/contract24 scheme/base + (require (prefix-in c: scheme/contract)) + (c:case-> (c:-> integer? integer?) + (c:-> integer? integer? integer?)))))) + |# + + ;; tests that contracts pick up the #%app from the context + ;; instead of always using the scheme/base #%app. + (test/spec-passed + 'provide/contract25 + '(begin + (eval '(module provide/contract25a scheme/base + (require scheme/contract) + (provide/contract [seventeen integer?]) + (define seventeen 17))) + (eval '(module provide/contract25b scheme/base + (require 'provide/contract25a) + (void (let-syntax ([#%app (syntax-rules () + [(#%app e ...) (list e ...)])]) + (seventeen 18))))) + (eval '(require 'provide/contract25b)))) + + (test/spec-passed/result + 'provide/contract26 + '(begin + (eval '(module provide/contract26 scheme/base + (require scheme/contract) + (define-struct pc26-s (a)) + (provide/contract (struct pc26-s ((a integer?)))))) + (eval '(require 'provide/contract26)) + (eval '(pc26-s-a (make-pc26-s 1)))) + 1) + + (test/spec-passed/result + 'provide/contract27 + '(begin + (eval '(module provide/contract27a scheme/base + (require scheme/contract) + (define-struct person (name) #:transparent) + (provide/contract (struct person ([name string?]))))) + (eval '(module provide/contract27b scheme/base + (require 'provide/contract27a) + (provide (struct-out person)))) + (eval '(module provide/contract27c scheme/base + (require 'provide/contract27b) + (define provide/contract27ans (person-name (make-person "me"))) + (provide provide/contract27ans))) + (eval '(require 'provide/contract27c)) + (eval 'provide/contract27ans)) + "me") + + #; + (test/spec-passed/result + 'provide/contract28 + '(begin + (eval '(module provide/contract28-m1 scheme/base + (require scheme/contract) + (define-struct repair () #:transparent) + (provide/contract [struct repair ()]))) + (eval '(module provide/contract28-m2 scheme/base + (require 'provide/contract28-m1 scheme/contract) + (provide/contract [struct repair ()]))) + (eval '(module provide/contract28-m3 scheme/base + (require 'provide/contract28-m2) + (provide provide/contract28-res) + (define provide/contract28-res (repair? (make-repair))))) + (eval '(require 'provide/contract28-m3)) + (eval 'provide/contract28-res)) + #t) + + #; + (test/spec-passed/result + 'provide/contract29 + '(begin + (eval '(module provide/contract29-m1 scheme/base + (require scheme/contract) + (define-struct q (a b)) + (define-struct (repair q) (c d) #:transparent) + (provide/contract + [struct repair ([a integer?] [b integer?] [c integer?] [d integer?])]))) + (eval '(module provide/contract29-m2 scheme/base + (require 'provide/contract29-m1 scheme/contract) + (provide/contract + [struct repair ([a integer?] [b integer?] [c integer?] [d integer?])]))) + (eval '(module provide/contract29-m3 scheme/base + (require 'provide/contract29-m2) + (provide provide/contract29-res) + (define provide/contract29-res (list (repair? (make-repair 1 2 3 4)) + (repair-c (make-repair 1 2 3 4)))))) + (eval '(require 'provide/contract29-m3)) + (eval 'provide/contract29-res)) + (list #t 3)) + + ;; for this test I have to be able to track back thru the requirees to find the right + ;; name for the negative blame (currently it blames m3, but it should blame m2). + #; + (test/spec-failed + 'provide/contract30 + '(begin + (eval '(module provide/contract30-m1 scheme/base + (require scheme/contract) + (provide/contract [f (-> integer? integer?)]) + (define (f x) x))) + (eval '(module provide/contract30-m2 scheme/base + (require 'provide/contract30-m1) + (provide f))) + (eval '(module provide/contract30-m3 scheme/base + (require 'provide/contract30-m2) + (f #f))) + (eval '(require 'provide/contract30-m3))) + "provide/contract30-m2") + + (test/spec-passed/result + 'provide/contract31 + '(begin + (eval '(module provide/contract31-m1 scheme/base + (require scheme/contract) + (provide/contract + #:∃ x + [f (-> (-> x x) 10)]) + (define (f g) (g 10)))) + + (eval '(module provide/contract31-m2 scheme/base + (require scheme/contract 'provide/contract31-m1) + (provide provide/contract31-x) + (define provide/contract31-x (f (λ (x) x))))) + + (eval '(require 'provide/contract31-m2)) + (eval 'provide/contract31-x)) + 10) + + (test/spec-passed/result + 'provide/contract32 + '(begin + (eval '(module provide/contract32-m1 scheme/base + (require scheme/contract) + (provide/contract + #:exists x + [f (-> (-> x x) 10)]) + (define (f g) (g 10)))) + + (eval '(module provide/contract32-m2 scheme/base + (require scheme/contract 'provide/contract32-m1) + (provide provide/contract32-x) + (define provide/contract32-x (f (λ (x) x))))) + + (eval '(require 'provide/contract32-m2)) + (eval 'provide/contract32-x)) + 10) + + (test/spec-passed/result + 'provide/contract33 + '(begin + (eval '(module provide/contract33-m1 scheme/base + (require scheme/contract) + (provide/contract + #:exists (x) + [f (-> (-> x x) 10)]) + (define (f g) (g 10)))) + + (eval '(module provide/contract33-m2 scheme/base + (require scheme/contract 'provide/contract33-m1) + (provide provide/contract33-x) + (define provide/contract33-x (f (λ (x) x))))) + + (eval '(require 'provide/contract33-m2)) + (eval 'provide/contract33-x)) + 10) + + (test/spec-passed/result + 'provide/contract34 + '(begin + (eval '(module provide/contract34-m1 scheme/base + (require scheme/contract) + (define x integer?) + (define g 11) + (provide/contract + [g x] + #:exists (x) + [f (-> (-> x x) 10)]) + (define (f g) (g 10)))) + + (eval '(module provide/contract34-m2 scheme/base + (require scheme/contract 'provide/contract34-m1) + (provide provide/contract34-x) + (define provide/contract34-x (f (λ (x) x))))) + + (eval '(require 'provide/contract34-m2)) + (eval 'provide/contract34-x)) + 10) + + + ;; The following test is designed to test that source locations for contracts + ;; survive compilation and being saved to disk (and thus aren't recorded by + ;; quoted syntax object constant embedded in the expansion). + (let () + ;; compile/wash : like compile, but reads and writes the data + ;; so that source locations (and other things presumably) get dumped. + (define (compile/wash x) + (let-values ([(in out) (make-pipe)]) + (thread + (λ () (write (contract-compile x) out))) + (parameterize ([read-accept-compiled #t]) + (read in)))) + + ;; drop-var-info : syntax -> syntax + ;; strips the lexical content from the syntax object, but preserves the source locations + (define (drop-var-info stx) + (let loop ([stx stx]) + (cond + [(syntax? stx) + (datum->syntax #f (loop (syntax-e stx)) stx)] + [(pair? stx) + (cons (loop (car stx)) + (loop (cdr stx)))] + [else stx]))) + + ;; WARNING: do not add or remove lines between here-line and the two modules + ;; below it, unless you also revise the expected result of the test case. + (define here-line (syntax-line #'here)) + + (contract-eval + (compile/wash + (drop-var-info + #'(module provide/contract-35/m racket/base + (require racket/contract) + (define (f x) x) + (provide/contract [f (-> integer? integer?)]))))) + + (contract-eval + (compile/wash + (drop-var-info + #'(module provide/contract-35/n racket/base + (require 'provide/contract-35/m) + (f #f))))) + + (test (format "contract-out.rkt:~a.30" + (+ here-line 8)) + 'provide/contract-compiled-source-locs + (with-handlers ((exn:fail? + (λ (x) + (define m + (regexp-match #rx"contract-out[.]rkt[^ ]*.30" (exn-message x))) + (and m (car m))))) + (contract-eval '(require 'provide/contract-35/n))))) + + ;; test that provide/contract by itself in a module doesn't signal an error + (test/spec-passed/result + 'provide/contract35 + '(begin + (eval '(module provide/contract35-m1 racket + (provide/contract [add1 (-> number? number?)]))) + + (eval '(module provide/contract35-m2 racket/base + (require 'provide/contract35-m1) + (provide provide/contract35-three) + (define provide/contract35-three (add1 2)))) + + (eval '(require 'provide/contract35-m2)) + (eval 'provide/contract35-three)) + 3) + + (test/spec-passed/result + 'provide/contract36 + '(begin + + (eval '(module provide/contract36-m racket/base + (require racket/contract) + (struct a (x)) + (struct b a ()) + (provide/contract + [struct a ((x symbol?))] + [struct (b a) ((x symbol?))]))) + + (eval '(module provide/contract36-n racket/base + (require 'provide/contract36-m) + (provide new-b-x) + (define new-b-x + (a-x + (struct-copy b (b 'x) + [x #:parent a 'y]))))) + + (eval '(require 'provide/contract36-n)) + (eval 'new-b-x)) + 'y) + + (test/spec-failed + 'provide/contract37 + '(begin + + (eval '(module provide/contract37-m racket/base + (require racket/contract) + (struct a (x)) + (struct b a ()) + (provide/contract + [struct a ((x symbol?))] + [struct (b a) ((x symbol?))]))) + + (eval '(module provide/contract37-n racket/base + (require 'provide/contract37-m) + (struct-copy b (b 'x) + [x #:parent a 5]))) + + (eval '(require 'provide/contract37-n))) + "provide/contract37-n") + + (test/spec-passed/result + 'provide/contract38 + '(begin + (eval + '(module provide/contract38-a racket + (define-struct s () #:transparent) + (provide/contract [struct s ()]))) + + (eval + '(module provide/contract38-b racket + (require 'provide/contract38-a) + (define a-struct (make-s)) + (define-values (type _) (struct-info a-struct)) + (provide the-answer) + (define the-answer (eq? type struct:s)))) + + (dynamic-require ''provide/contract38-b 'the-answer)) + #t) + + ;; #:forall contract-out clauses + (test/spec-passed/result + 'provide/contract39 + '(begin + (eval '(module provide/contract39-m1 racket/base + (require racket/contract) + (provide/contract + #:∀ x + [f (-> x (-> x x) x)]) + (define (f x g) (g x)))) + + (eval '(module provide/contract39-m2 racket/base + (require racket/contract 'provide/contract39-m1) + (provide provide/contract39-x) + (define provide/contract39-x (f 10 (λ (x) x))))) + + (eval '(require 'provide/contract39-m2)) + (eval 'provide/contract39-x)) + 10) + + (test/spec-passed/result + 'provide/contract40 + '(begin + (eval '(module provide/contract40-m1 racket/base + (require racket/contract) + (provide/contract + #:forall x + [f (-> x (-> x x) x)]) + (define (f x g) (g x)))) + + (eval '(module provide/contract40-m2 racket/base + (require racket/contract 'provide/contract40-m1) + (provide provide/contract40-x) + (define provide/contract40-x (f 10 (λ (x) x))))) + + (eval '(require 'provide/contract40-m2)) + (eval 'provide/contract40-x)) + 10) + + (test/spec-passed/result + 'provide/contract41 + '(begin + (eval '(module provide/contract41-m1 racket/base + (require racket/contract) + (provide/contract + #:forall (x) + [f (-> x (-> x x) x)]) + (define (f x g) (g x)))) + + (eval '(module provide/contract41-m2 racket/base + (require racket/contract 'provide/contract41-m1) + (provide provide/contract41-x) + (define provide/contract41-x (f 10 (λ (x) x))))) + + (eval '(require 'provide/contract41-m2)) + (eval 'provide/contract41-x)) + 10) + + (test/spec-passed/result + 'provide/contract42 + '(begin + (eval '(module provide/contract42-m1 racket/base + (require racket/contract) + (define x integer?) + (define g 11) + (provide/contract + [g x] + #:forall (x) + [f (-> x (-> x x) x)]) + (define (f x g) (g x)))) + + (eval '(module provide/contract42-m2 racket/base + (require racket/contract 'provide/contract42-m1) + (provide provide/contract42-x) + (define provide/contract42-x (f 10 (λ (x) x))))) + + (eval '(require 'provide/contract42-m2)) + (eval 'provide/contract42-x)) + 10) + + (test/spec-passed/result + 'provide/contract43 + '(begin + (eval '(module provide/contract43-m1 racket/base + (require racket/contract) + (struct spider (legs)) + (provide (contract-out (struct spider ([legs number?])))))) + + (eval '(module provide/contract43-m2 racket/base + (require racket/contract 'provide/contract43-m1) + (provide provide/contract43-x) + (define provide/contract43-x + (spider-legs + (contract (struct/c spider integer?) + (spider 121) + 'pos + 'neg))))) + + (eval '(require 'provide/contract43-m2)) + (eval 'provide/contract43-x)) + 121) + + (test/spec-passed + 'provide/contract44 + '(begin + (eval '(module provide/contract44-m1 racket/base + (require racket/contract) + (struct heap (v) #:transparent) + (provide (rename-out (heap new-heap))))) + + (eval '(module provide/contract44-m2 racket/base + (require racket/contract 'provide/contract44-m1) + (void (contract (struct/c new-heap any/c) + (new-heap 121) + 'pos + 'neg)))) + + (eval '(require 'provide/contract44-m2)))) + + (contract-error-test + 'contract-error-test8 + #'(begin + (eval '(module pce1-bug scheme/base + (require scheme/contract) + (define the-defined-variable1 'five) + (provide/contract [the-defined-variable1 number?]))) + (eval '(require 'pce1-bug))) + (λ (x) + (and (exn:fail:contract:blame? x) + (regexp-match #rx"the-defined-variable1: broke its contract" (exn-message x))))) + + (contract-error-test + 'contract-error-test9 + #'(begin + (eval '(module pce2-bug scheme/base + (require scheme/contract) + (define the-defined-variable2 values) + (provide/contract [the-defined-variable2 (-> number? any)]))) + (eval '(require 'pce2-bug)) + (eval '(the-defined-variable2 #f))) + (λ (x) + (and (exn:fail:contract:blame? x) + (regexp-match #rx"the-defined-variable2: contract violation" (exn-message x))))) + + (contract-error-test + 'contract-error-test10 + #'(begin + (eval '(module pce3-bug scheme/base + (require scheme/contract) + (define the-defined-variable3 (λ (x) #f)) + (provide/contract [the-defined-variable3 (-> any/c number?)]))) + (eval '(require 'pce3-bug)) + (eval '(the-defined-variable3 #f))) + (λ (x) + (and (exn:fail:contract:blame? x) + (regexp-match #rx"the-defined-variable3" (exn-message x))))) + + (contract-error-test + 'contract-error-test11 + #'(begin + (eval '(module pce4-bug scheme/base + (require scheme/contract) + (define the-defined-variable4 (λ (x) #f)) + (provide/contract [the-defined-variable4 (-> any/c number?)]))) + (eval '(require 'pce4-bug)) + (eval '((if #t the-defined-variable4 the-defined-variable4) #f))) + (λ (x) + (and (exn:fail:contract:blame? x) + (regexp-match #rx"^the-defined-variable4" (exn-message x))))) + + (contract-error-test + 'contract-error-test12 + #'(begin + (eval '(module pce5-bug scheme/base + (require scheme/contract) + + (define-struct bad (a b)) + + (provide/contract + [struct bad ((string? a) (string? b))]))) + (eval '(require 'pce5-bug))) + (λ (x) + (and (exn:fail:syntax? x) + (regexp-match #rx"expected field name to be b, but found string?" (exn-message x))))) + + (contract-error-test + 'contract-error-test13 + #'(begin + (eval '(module pce6-bug scheme/base + (require scheme/contract) + + (define-struct bad-parent (a)) + (define-struct (bad bad-parent) (b)) + + (provide/contract + [struct bad ((a string?) (string? b))]))) + (eval '(require 'pce6-bug))) + (λ (x) + (and (exn:fail:syntax? x) + (regexp-match #rx"expected field name to be b, but found string?" (exn-message x))))) + + (contract-error-test + 'contract-error-test14 + #'(begin + (eval '(module pce7-bug scheme/base + (require scheme/contract) + (define x 1) + (provide/contract [x integer?]))) + (eval '(module pce7-bug2 scheme/base + (require 'pce7-bug) + (set! x 5)))) + (λ (x) + (and (exn:fail:syntax? x) + (regexp-match #rx"cannot set!" (exn-message x))))) + + (contract-error-test + 'contract-error-test15 + #'(begin + (eval '(module pce8-bug1 scheme/base + (require scheme/contract) + (define (f x) x) + (provide/contract [f (-> integer? integer? integer?)]))) + (eval '(require 'pce8-bug1))) + (λ (x) + (and (exn:fail:contract:blame? x) + (regexp-match #rx"pce8-bug" (exn-message x))))) + + (contract-error-test + 'contract-error-test16 + #'(begin + (eval '(module pce9-bug scheme + (define (f x) "wrong") + (provide/contract + [rename f g + (-> number? number?)]))) + (eval '(require 'pce9-bug)) + (eval '(g 12))) + (λ (x) + (and (exn:fail:contract:blame? x) + (regexp-match #rx"^g.*contract from: pce9-bug" (exn-message x))))) + + (contract-error-test + 'contract-error-test17 + #'(begin + (eval '(module pce10-bug scheme + (define (f x) "wrong") + (provide/contract + [rename f g + (-> number? number?)]))) + (eval '(require 'pce10-bug)) + (eval '(g 'a))) + (λ (x) + (and (exn:fail:contract:blame? x) + (regexp-match #rx"^g.*contract from: pce10-bug" (exn-message x))))) + + (contract-error-test + 'contract-error-test18 + #'(begin + (eval '(module pce18-bug racket + (struct point (x y)) + (provide (contract-out + (struct point ([x integer?]))))))) + (λ (x) + (and (exn:fail:syntax? x) + ;; testing that the error says "contract-out" and not "provide/contract" + (regexp-match #rx"contract-out: found 2 fields" (exn-message x))))) + + (contract-eval + `(,test + 'pos + (compose blame-positive exn:fail:contract:blame-object) + (with-handlers ((void values)) (contract not #t 'pos 'neg)))) + + + ;; check that `contract-out' contracts can use contracts + ;; defined later in the module + (test/spec-passed/result + 'contract-out1 + '(begin + (eval '(module contract-out1-m racket/base + (require racket/contract) + (provide (contract-out [f (-> ok? ok?)])) + (define (f x) (+ x 1)) + (define (ok? v) (exact-integer? v)))) + (eval '(require 'contract-out1-m)) + (eval '(f 10))) + 11) + + (test/spec-passed/result + 'contract-out2 + '(begin + (eval '(module contract-out2-m racket/base + (require racket/contract) + (provide (contract-out (struct s ([x integer?])))) + (struct s (x)))) + (eval '(require 'contract-out2-m)) + (eval '(s-x (s 11)))) + 11) + + ;; expect the syntax errors in the right order + (contract-syntax-error-test + 'contract-out3 + '(eval '(module contract-out3-m racket/base + (require racket/contract) + (provide (contract-out garbage)) + (λ))) + #rx"contract-out") + + (test/pos-blame + 'contract-struct/c-1 + '(begin + (eval '(module contract-struct/c-1a racket/base + (struct s (field)) + (provide s))) + (eval '(module contract-struct/c-1b racket/base + (require 'contract-struct/c-1a racket/contract) + (void (contract (struct/c s boolean?) + (s 1) + 'pos 'neg)))) + (eval '(require 'contract-struct/c-1b)))) + + (test/spec-passed + 'contract-struct/c-2 + '(begin + (eval '(module contract-struct/c-2a racket/base + (struct s (field)) + (provide s))) + (eval '(module contract-struct/c-2b racket/base + (require 'contract-struct/c-2a racket/contract) + (void (contract (struct/c s any/c) + (s 1) + 'pos 'neg)))) + (eval '(require 'contract-struct/c-2b)))) + + + + (contract-eval + '(module contract-test-suite-inferred-name1 racket/base + (require racket/contract) + (define contract-inferred-name-test-contract (-> integer? any)) + (define (contract-inferred-name-test1 x) #t) + (provide/contract (contract-inferred-name-test1 contract-inferred-name-test-contract)) + + (define (contract-inferred-name-test2 x) x) + (provide/contract (contract-inferred-name-test2 (-> number? number?))) + + (define (contract-inferred-name-test2b x) (values x x)) + (provide/contract (contract-inferred-name-test2b (-> number? (values number? number?)))) + + (define (contract-inferred-name-test3 x . y) x) + (provide/contract + (contract-inferred-name-test3 (->* (number?) () #:rest (listof number?) number?))) + + (define (contract-inferred-name-test4) 7) + (provide/contract (contract-inferred-name-test4 (->d () () any))) + + (define (contract-inferred-name-test5) 7) + (provide/contract (contract-inferred-name-test5 (->i () () any))) + )) + (contract-eval '(require 'contract-test-suite-inferred-name1)) + (test 'contract-inferred-name-test1 object-name (contract-eval 'contract-inferred-name-test1)) + (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))) \ No newline at end of file diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/define-contract-struct.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/define-contract-struct.rkt new file mode 100644 index 0000000000..5ffdebe478 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/define-contract-struct.rkt @@ -0,0 +1,444 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace + 'racket/contract)]) +(contract-eval '(define-contract-struct couple (hd tl))) +(contract-eval '(contract-struct triple (a b c))) + +(test/spec-passed + 'd-c-s-match1 + '(begin + (eval '(module d-c-s-match1 scheme/base + (require scheme/contract + mzlib/match) + + (define-contract-struct foo (bar baz)) + + (void + (match (make-foo #t #f) + [($ foo bar baz) #t] + [_ #f])))) + (eval '(require 'd-c-s-match1)))) + +(test/spec-passed/result + 'd-c-s-match2 + '(begin + (eval '(module d-c-s-match2 scheme/base + (require scheme/contract + mzlib/match) + + (define-contract-struct foo (bar baz)) + + (provide d-c-s-match2-f1) + (define d-c-s-match2-f1 + (match (make-foo 'first 'second) + [($ foo bar baz) (list bar baz)] + [_ #f])))) + (eval '(require 'd-c-s-match2)) + (eval 'd-c-s-match2-f1)) + '(first second)) + +(test/spec-passed/result + 'd-c-s-match3 + '(begin + (eval '(module d-c-s-match3-a scheme/base + + (require scheme/contract) + + (define-struct super (a b c) #:transparent) + (define-struct (sub super) () #:transparent) + + (provide/contract + [struct super ([a number?] [b number?] [c number?])] + [struct (sub super) ([a number?] [b number?] [c number?])]))) + (eval '(module d-c-s-match3-b scheme/base + (require scheme/match) + + (require 'd-c-s-match3-a) + + (provide d-c-s-match3-ans) + (define d-c-s-match3-ans + (match (make-sub 1 2 3) + [(struct sub (a b c)) + (list a b c)])))) + (eval '(require 'd-c-s-match3-b)) + (eval 'd-c-s-match3-ans)) + '(1 2 3)) + +(test/pos-blame 'd-c-s1 + '(begin + (eval '(module d-c-s1 scheme/base + (require scheme/contract) + (define-contract-struct couple (hd tl)) + (contract (couple/c any/c any/c) 1 'pos 'neg))) + (eval '(require 'd-c-s1)))) + +(test/spec-passed 'd-c-s2 + '(contract (couple/c any/c any/c) (make-couple 1 2) 'pos 'neg)) +(test/spec-passed 'd-c-s3 + '(contract (couple/c number? number?) + (make-couple 1 2) + 'pos 'neg)) +(test/spec-passed 'd-c-s4 + '(couple-hd + (contract (couple/c number? number?) + (make-couple 1 2) + 'pos 'neg))) +(test/spec-passed 'd-c-s5 + '(couple-tl + (contract (couple/c number? number?) + (make-couple 1 2) + 'pos 'neg))) + + +(test/pos-blame + 'd-c-s6 + '(couple-tl + (contract (couple/c number? + number?) + (make-couple #f 2) + 'pos 'neg))) +(test/pos-blame + 'd-c-s7 + '(couple-hd + (contract (couple/c number? number?) + (make-couple #f 2) + 'pos 'neg))) + +(test/pos-blame + 'd-c-s8 + '(contract (couple/dc [hd any/c] [tl any/c]) + 1 + 'pos 'neg)) + +(test/pos-blame + 'd-c-s9 + '(contract (couple/dc [hd () any/c] [tl () any/c]) + 1 + 'pos 'neg)) + + +(test/spec-passed 'd-c-s10 + '(contract (couple/dc [hd any/c] [tl any/c]) + (make-couple 1 2) + 'pos 'neg)) +(test/spec-passed 'd-c-s11 + '(contract (couple/dc [hd () any/c] [tl () any/c]) + (make-couple 1 2) + 'pos 'neg)) + +(test/spec-passed 'd-c-s12 + '(contract (couple/dc [hd number?] + [tl number?]) + (make-couple 1 2) + 'pos 'neg)) +(test/spec-passed 'd-c-s13 + '(couple-hd + (contract (couple/dc [hd number?] + [tl number?]) + (make-couple 1 2) + 'pos 'neg))) +(test/spec-passed 'd-c-s14 + '(couple-tl + (contract (couple/dc [hd number?] + [tl number?]) + (make-couple 1 2) + 'pos 'neg))) + + +(test/pos-blame + 'd-c-s15 + '(couple-hd + (contract (couple/dc [hd number?] + [tl number?]) + (make-couple #f 2) + 'pos 'neg))) + +(test/pos-blame + 'd-c-s16 + '(couple-tl + (contract (couple/dc [hd number?] + [tl number?]) + (make-couple #f 2) + 'pos 'neg))) + +(test/spec-passed + 'd-c-s17 + '(couple-hd + (contract (couple/dc [hd number?] + [tl (hd) (>=/c hd)]) + (make-couple 1 2) + 'pos 'neg))) + +(test/pos-blame + 'd-c-s18 + '(couple-hd + (contract (couple/dc [hd number?] + [tl (hd) (>=/c hd)]) + (make-couple 2 1) + 'pos 'neg))) + +(test/spec-passed + 'd-c-s19 + '(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 + '(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 + '(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 + '(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 + '(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 + '(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 + '(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 + '(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 ([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 + '(contract (couple/c number? number?) + (make-couple #f #f) + 'pos 'neg)) + +(test/spec-passed + 'd-c-s29 + '(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 + '(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 ([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 ([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 ([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 ([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 ([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 ([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 + '(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 ([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 ([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 ([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 ([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 ([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 ([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))) + +(contract-eval '(contract-struct no-define (x))) +(test/spec-passed/result + 'd-c-s43 + '(no-define-x (no-define 1)) + '1) +(test/spec-passed/result + 'd-c-s44 + '(no-define? (no-define 1)) + '#t) + +) \ No newline at end of file diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/define-contract.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/define-contract.rkt new file mode 100644 index 0000000000..a26e61a8b0 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/define-contract.rkt @@ -0,0 +1,349 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace 'racket/contract)]) + (test/spec-passed + 'define/contract1 + '(let () + (define/contract i integer? 1) + i)) + + (test/spec-failed + 'define/contract2 + '(let () + (define/contract i integer? #t) + i) + "(definition i)") + + (test/spec-failed + 'define/contract3 + '(let () + (define/contract i (-> integer? integer?) (lambda (x) #t)) + (i 1)) + "(definition i)") + + (test/spec-failed + 'define/contract4 + '(let () + (define/contract i (-> integer? integer?) (lambda (x) 1)) + (i #f)) + "top-level") + + (test/spec-failed + 'define/contract5 + '(let () + (define/contract (i x) (-> integer? integer?) 1) + (i #f)) + "top-level") + + (test/spec-passed + 'define/contract6 + '(let () + (define/contract (i x) (-> integer? integer?) + (cond + [(not (integer? x)) 1] + [else (i #f)])) + (i 1))) + + (test/spec-passed + 'define/contract7 + '(let () + (define/contract (contracted-func label t) + (string? string? . -> . string?) + t) + (contracted-func + "I'm a string constant with side effects" + "ans"))) + + (test/spec-passed + 'define/contract8 + '(let () + (eval '(module contract-test-suite-define1 scheme/base + (require scheme/contract) + (define/contract x string? "a") + (void x))) + (eval '(require 'contract-test-suite-define1)))) + + (test/spec-failed + 'define/contract9 + '(let () + (define/contract (a n) + (-> number? number?) + (define/contract (b m) + (-> number? number?) + (+ m 1)) + (b (zero? n))) + (a 5)) + "(function a)") + + (test/spec-failed + 'define/contract10 + '(let () + (define/contract (a n) + (-> number? number?) + (define/contract (b m) + (-> number? number?) + #t) + (b (add1 n))) + (a 5)) + "(function b)") + + (test/spec-passed + 'define/contract11 + '(let () + (define/contract (f n) + (-> number? number?) + (+ n 1)) + (define/contract (g b m) + (-> boolean? number? number?) + (if b (f m) (f #t))) + (g #t 3))) + + ;; For some of the following tests, it may not be clear + ;; why the blame is what it is. The contract(s) entered + ;; into via with-contract are between the contracting + ;; region and its context. If the context allows the + ;; value to flow into other regions without contracts + ;; that protect it from misuses in those regions, it's + ;; the context's fault. + (test/spec-failed + 'define/contract12 + '(let () + (define/contract (f n) + (-> number? number?) + (+ n 1)) + (define/contract (g b m) + (-> boolean? number? number?) + (if b (f m) (f #t))) + (g #f 3)) + "top-level") + + (test/spec-failed + 'define/contract13 + '(begin + (eval '(module foo-dc13 scheme/base + (require scheme/contract) + (define/contract (foo-dc13 n) + (-> number? number?) + (+ n 1)) + (foo-dc13 #t))) + (eval '(require 'foo-dc13))) + "foo-dc13") + + (test/spec-failed + 'define/contract14 + '(begin + (eval '(module foo-dc14 scheme/base + (require scheme/contract) + (provide foo-dc14) + (define/contract (foo-dc14 n) + (-> number? number?) + (+ n 1)))) + (eval '(module bar-dc14 scheme/base + (require 'foo-dc14) + (foo-dc14 #t))) + (eval '(require 'bar-dc14))) + "foo-dc14") + + (test/spec-failed + 'define/contract15 + '(begin + (eval '(module foo-dc15 scheme/base + (require scheme/contract) + (provide foo-dc15) + (define/contract (foo-dc15 n) + (-> number? number?) + (+ n 1)))) + (eval '(require 'foo-dc15)) + (eval '(foo-dc15 #t))) + "foo-dc15") + + ;; Let's see how units + define/contract interact + + (test/spec-failed + 'define/contract16 + '(begin + (eval '(module foo-dc16 scheme/base + (require scheme/contract) + (require scheme/unit) + (let () + (define/contract (foo n) + (-> number? number?) + (define-signature U^ + ((contracted [x (-> number? number?)]))) + (define-unit U@ + (import) + (export U^) + (define (x n) #t)) + (define-values/invoke-unit U@ + (import) + (export U^)) + (x n)) + (foo 3)))) + (eval '(require 'foo-dc16))) + "(unit U@)") + + (test/spec-failed + 'define/contract16a + '(begin + (eval '(module foo-dc16a scheme/base + (require scheme/contract) + (require scheme/unit) + (let () + (define/contract (foo n) + (-> number? number?) + (define-signature U^ + (x)) + (define-unit/contract U@ + (import) + (export (U^ [x (-> number? number?)])) + (define (x n) #t)) + (define-values/invoke-unit U@ + (import) + (export U^)) + (x n)) + (foo 3)))) + (eval '(require 'foo-dc16a))) + "(unit U@)") + + (test/spec-failed + 'define/contract17 + '(begin + (eval '(module foo-dc17 scheme/base + (require scheme/contract) + (require scheme/unit) + (let () + (define/contract (foo n) + (-> number? number?) + (define-signature U^ + ((contracted [x (-> number? number?)]))) + (define-unit U@ + (import) + (export U^) + (define (x n) 3)) + (define-values/invoke-unit U@ + (import) + (export U^)) + (x (zero? n))) + (foo 3)))) + (eval '(require 'foo-dc17))) + "(function foo)") + + (test/spec-failed + 'define/contract18 + '(begin + (eval '(module foo-dc18 scheme/base + (require scheme/contract) + (require scheme/unit) + (let () + (define-signature U^ + ((contracted [x (-> number? number?)]))) + (define-unit U@ + (import) + (export U^) + ;; Can't define/contract x directly because + ;; x ends up bound to a transformer and thus + ;; is syntax. + (define/contract (y n) + (-> number? boolean?) #t) + (define x y)) + (define-values/invoke-unit U@ + (import) + (export U^)) + (x 3)))) + (eval '(require 'foo-dc18))) + "(unit U@)") + + (test/spec-failed + 'define/contract19 + '(let () + (define y 3) + (define/contract (f n) + (-> number? number?) + #:freevar y (-> number? boolean?) + 3) + 1) + "top-level") + + (test/spec-passed + 'define/contract20 + '(let () + (define y (lambda (n) 4)) + (define/contract (f n) + (-> number? number?) + #:freevar y (-> number? boolean?) + 3) + 1)) + + (test/spec-passed + 'define/contract21 + '(let () + (define y (lambda (n) 4)) + (define/contract (f n) + (-> number? number?) + #:freevar y (-> number? boolean?) + (if (y n) 3 1)) + 1)) + + (test/spec-failed + 'define/contract22 + '(let () + (define y 4) + (define/contract (f n) + (-> number? number?) + #:freevar y (-> number? boolean?) + 3) + 1) + "top-level") + + (test/spec-failed + 'define/contract23 + '(let () + (define y (lambda (n) #t)) + (define/contract (f n) + (-> number? number?) + #:freevar y (-> number? number?) + (y n)) + (f 5)) + "top-level") + + (test/spec-failed + 'define/contract24 + '(let () + (define y (lambda (n) 4)) + (define/contract (f n) + (-> number? number?) + #:freevar y (-> number? boolean?) + (if (y #t) 3 1)) + (f 5)) + "(function f)") + + (test/spec-failed + 'define/contract25 + '(let () + (define y #t) + (define z 3) + (define/contract f + number? + #:freevars ([y number?] [z number?]) + (+ y z)) + 1) + "top-level") + + (test/spec-passed + 'define/contract + '(let () + (define/contract (f x #:y [y 3]) + (->* (integer?) (#:y integer?) integer?) + x) + (f 3 #:y 7))) + + (test/spec-failed + 'define/contract + '(let () + (define/contract (f x #:y [y 3]) + (->* (integer?) (#:y integer?) integer?) + x) + (f 3 #:y #f)) + "top-level")) \ No newline at end of file diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/define-opt-c.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/define-opt-c.rkt new file mode 100644 index 0000000000..45ccd56364 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/define-opt-c.rkt @@ -0,0 +1,293 @@ +#lang racket/base +(require "test-util.rkt") +(parameterize ([current-contract-namespace + (make-basic-contract-namespace 'racket/contract)]) + + (contract-eval '(define-contract-struct node (val obj rank left right) (make-inspector))) + (contract-eval '(define (compute-rank n) + (cond + [(not n) 0] + [else (node-rank n)]))) + + (contract-eval '(define-opt/c (leftist-heap-greater-than/rank/opt n r) + (or/c not + (node/dc [val (>=/c n)] + [obj any/c] + [rank (<=/c r)] + [left (val) (leftist-heap-greater-than/rank/opt val +inf.0)] + [right (val left) + (leftist-heap-greater-than/rank/opt + val + (compute-rank left))])))) + + (contract-eval '(define leftist-heap/c (leftist-heap-greater-than/rank/opt -inf.0 +inf.0))) + + (test/pos-blame 'd-o/c1 '(contract leftist-heap/c 2 'pos 'neg)) + + + (test/spec-passed 'd-o/c2 '(contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)) + (test/spec-passed 'd-o/c3 '(contract leftist-heap/c #f 'pos 'neg)) + (test/spec-passed 'd-o/c4 '(contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)) + (test/spec-passed/result 'd-o/c5 + '(node? (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)) + #t) + + (test/spec-passed/result 'd-o/c6 + '(node-val (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)) + 1) + (test/spec-passed/result 'd-o/c7 + '(node-obj (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)) + 2) + (test/spec-passed/result 'd-o/c8 + '(node-rank (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)) + 3) + (test/spec-passed/result 'd-o/c9 + '(node-left (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)) + #f) + (test/spec-passed/result 'd-o/c10 + '(node-right (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)) + #f) + + (test/spec-passed/result 'd-o/c11 + '(node-val (contract leftist-heap/c + (contract leftist-heap/c + (make-node 1 2 3 #f #f) + 'pos 'neg) + 'pos 'neg)) + 1) + (test/spec-passed/result 'd-o/c12 + '(node-obj (contract leftist-heap/c + (contract leftist-heap/c + (make-node 1 2 3 #f #f) + 'pos 'neg) + 'pos 'neg)) + 2) + (test/spec-passed/result 'd-o/c13 + '(node-rank (contract leftist-heap/c + (contract leftist-heap/c + (make-node 1 2 3 #f #f) + 'pos 'neg) + 'pos 'neg)) + 3) + (test/spec-passed/result 'd-o/c14 + '(node-left (contract leftist-heap/c + (contract leftist-heap/c + (make-node 1 2 3 #f #f) + 'pos 'neg) + 'pos 'neg)) + #f) + (test/spec-passed/result 'd-o/c15 + '(node-right (contract leftist-heap/c + (contract leftist-heap/c + (make-node 1 2 3 #f #f) + 'pos 'neg) + 'pos 'neg)) + #f) + + (test/spec-passed/result 'd-o/c16 + '(let ([h (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)]) + (node-val h) + (node-val h)) + 1) + (test/spec-passed/result 'd-o/c17 + '(let ([h (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)]) + (node-obj h) + (node-obj h)) + 2) + + (test/spec-passed/result 'd-o/c18 + '(let ([h (contract leftist-heap/c (make-node 1 2 3 #f #f)'pos 'neg)]) + (node-rank h) + (node-rank h)) + 3) + (test/spec-passed/result 'd-o/c19 + '(let ([h (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)]) + (node-left h) + (node-left h)) + #f) + (test/spec-passed/result 'd-o/c20 + '(let ([h (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)]) + (node-right h) + (node-right h)) + #f) + + (test/spec-passed/result 'd-o/c21 + '(node-val + (node-right + (contract leftist-heap/c + (make-node 1 2 3 + (make-node 7 8 9 #f #f) + (make-node 4 5 6 #f #f)) + 'pos 'neg))) + 4) + (test/spec-passed/result 'd-o/c22 + '(node-val + (node-left + (contract leftist-heap/c + (make-node 1 2 3 + (make-node 7 8 9 #f #f) + (make-node 4 5 6 #f #f)) + 'pos 'neg))) + 7) + + (test/pos-blame 'd-o/c23 + '(node-val + (node-right + (contract leftist-heap/c + (make-node 5 2 3 + (make-node 7 8 9 #f #f) + (make-node 4 5 6 #f #f)) + 'pos 'neg)))) + + (test/pos-blame 'd-o/c24 + '(node-val + (node-left + (contract leftist-heap/c + (make-node 9 2 3 + (make-node 7 8 9 #f #f) + (make-node 11 5 6 #f #f)) + 'pos 'neg)))) + + (test/neg-blame 'd-o/c25 + '((contract (-> leftist-heap/c any) + (λ (kh) + (node-val + (node-left + kh))) + 'pos 'neg) + (make-node 9 2 3 + (make-node 7 8 9 #f #f) + (make-node 11 5 6 #f #f)))) + + + + (test/spec-passed/result + 'd-o/c26 + '(let ([ai (λ (x) (contract leftist-heap/c x 'pos 'neg))]) + (define (remove-min t) (merge (node-left t) (node-right t))) + + (define (merge t1 t2) + (cond + [(not t1) t2] + [(not t2) t1] + [else + (let ([t1-val (node-val t1)] + [t2-val (node-val t2)]) + (cond + [(<= t1-val t2-val) + (pick t1-val + (node-obj t1) + (node-left t1) + (merge (node-right t1) + t2))] + [else + (pick t2-val + (node-obj t2) + (node-left t2) + (merge t1 + (node-right t2)))]))])) + + (define (pick x obj a b) + (let ([ra (compute-rank a)] + [rb (compute-rank b)]) + (cond + [(>= ra rb) + (make-node x obj (+ rb 1) a b)] + [else + (make-node x obj (+ ra 1) b a)]))) + (node-val + (remove-min (ai (make-node 137 'x 1 + (ai (make-node 178 'y 1 + (make-node 178 'z 1 #f #f) + #f)) + #f))))) + 178) + + (test/spec-passed/result + 'd-o/c27 + '(let () + (define-opt/c (f x) + (and/c (>=/c x) + (g x))) + (define-opt/c (g x) + (<=/c x)) + (contract (f 11) 11 'pos 'neg)) + 11) + + ;; try-one : syntax -> number + ;; evaluates the exp and returns the number of opt/c warnings found + (contract-eval + '(define (eval-and-count-log-messages exp) + (define ans (make-channel)) + (define recv (make-log-receiver (current-logger) 'warning)) + (thread + (λ () + (let loop ([opt/c-msgs 0]) + (define res (sync recv)) + (cond + [(equal? "done" (vector-ref res 1)) + (channel-put ans opt/c-msgs)] + [else + (define opt/c-msg? (regexp-match? #rx"opt/c" (vector-ref res 1))) + (loop (if opt/c-msg? + (+ opt/c-msgs 1) + opt/c-msgs))])))) + (let/ec k + (parameterize ([error-escape-handler k]) + (eval exp))) + (log-warning "done") + (channel-get ans))) + + (ctest 1 eval-and-count-log-messages + '(let () + (struct s (a b)) + (opt/c (struct/dc s [a (-> integer? integer?)] [b (a) integer?])))) + + (ctest 1 eval-and-count-log-messages + '(let () + (struct s (a b)) + (define-opt/c (f x) + (-> integer? integer?)) + (define-opt/c (g x) + (struct/dc s [a (f 1)] [b (a) integer?])) + 1)) + + (ctest 0 eval-and-count-log-messages + '(let () + (struct s (a b)) + (define-opt/c (f x) integer?) + (opt/c (struct/dc s [a (f 1)] [b (a) integer?])))) + + (ctest 0 eval-and-count-log-messages + '(let () + (define-struct h:kons (hd tl) #:transparent) + (define-struct h:node (rank val obj children) #:transparent) + + (define-opt/c (binomial-tree-rank=/sco r v) + (or/c #f + (struct/dc h:node + [rank (=/c r)] + [val (>=/c v)] + [children (rank val) #:lazy (heap-ordered/desc/sco (- rank 1) val)]))) + + (define-opt/c (binomial-tree-rank>/sco r) + (or/c #f + (struct/dc h:node + [rank (>=/c r)] + [val any/c] + [children (rank val) #:lazy (heap-ordered/desc/sco (- rank 1) val)]))) + + (define-opt/c (heap-ordered/desc/sco rank val) + (or/c #f + (struct/dc h:kons + [hd #:lazy (binomial-tree-rank=/sco rank val)] + [tl () #:lazy (heap-ordered/desc/sco (- rank 1) val)]))) + + (define-opt/c (binomial-trees/asc/sco rank) + (or/c #f + (struct/dc h:kons + [hd #:lazy (binomial-tree-rank>/sco rank)] + [tl (hd) #:lazy (binomial-trees/asc/sco (h:node-rank hd))]))) + + (define binomial-heap/sco (binomial-trees/asc/sco -inf.0)) + 1))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/define-struct-contract.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/define-struct-contract.rkt new file mode 100644 index 0000000000..648cf6cd81 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/define-struct-contract.rkt @@ -0,0 +1,204 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace 'racket/contract + 'racket/match)]) + (test/spec-passed + 'define-struct/contract1 + '(let () + (define-struct/contract foo ([x number?] [y number?])) + 1)) + + (test/spec-passed + 'define-struct/contract2 + '(let () + (define-struct/contract foo ([x number?] [y number?])) + (make-foo 1 2))) + + (test/spec-failed + 'define-struct/contract3 + '(let () + (define-struct/contract foo ([x number?] [y number?])) + (make-foo 1 #t)) + "top-level") + + (test/spec-passed + 'define-struct/contract4 + '(let () + (define-struct/contract foo ([x number?] [y number?])) + (foo-y (make-foo 2 3)))) + + (test/spec-failed + 'define-struct/contract5 + '(let () + (define-struct/contract foo ([x number?] [y number?])) + (foo-y 1)) + "top-level") + + (test/spec-passed + 'define-struct/contract6 + '(let () + (define-struct/contract foo ([x number?] [y number?]) #:mutable) + (set-foo-y! (make-foo 1 2) 3) + (set-foo-x! (make-foo 1 2) 3))) + + (test/spec-failed + 'define-struct/contract7 + '(let () + (define-struct/contract foo ([x number?] [y number?]) #:mutable) + (set-foo-y! (make-foo 1 2) #f)) + "top-level") + + (test/spec-passed + 'define-struct/contract8 + '(let () + (define-struct/contract foo ([(x #:mutable) number?] [y number?])) + (set-foo-x! (make-foo 1 2) 4))) + + (test/spec-failed + 'define-struct/contract9 + '(let () + (define-struct/contract foo ([(x #:mutable) number?] [y number?])) + (set-foo-x! (make-foo 1 2) #f)) + "top-level") + + (test/spec-failed + 'define-struct/contract10 + '(let () + (define-struct/contract foo ([x number?] [(y #:auto) number?])) + (make-foo 1)) + "(struct foo)") + + (test/spec-passed + 'define-struct/contract11 + '(let () + (define-struct/contract foo ([x number?] [(y #:auto) number?]) #:auto-value 3) + (make-foo 1))) + + (test/spec-passed + 'define-struct/contract12 + '(let () + (define-struct/contract foo ([x number?] [(y #:auto #:mutable) number?]) #:auto-value 3) + (set-foo-y! (make-foo 1) 3))) + + (test/spec-failed + 'define-struct/contract13 + '(let () + (define-struct/contract foo ([x number?] [(y #:auto #:mutable) number?]) #:auto-value 3) + (set-foo-y! (make-foo 1) #t)) + "top-level") + + (test/spec-passed + 'define-struct/contract14 + '(let () + (define-struct/contract foo ([x number?] [y number?]) #:transparent) + 1)) + + (test/spec-passed + 'define-struct/contract15 + '(let () + (define-struct foo (x)) + (define-struct/contract (bar foo) ([z string?])) + (make-bar 2 "x"))) + + (test/spec-failed + 'define-struct/contract16 + '(let () + (define-struct foo (x)) + (define-struct/contract (bar foo) ([z string?])) + (make-bar 2 #f)) + "top-level") + + (test/spec-passed + 'define-struct/contract17 + '(let () + (define-struct foo (x)) + (define-struct/contract (bar foo) ([z string?]) #:mutable) + (set-bar-z! (make-bar 2 "x") "y"))) + + (test/spec-failed + 'define-struct/contract18 + '(let () + (define-struct foo (x)) + (define-struct/contract (bar foo) ([z string?]) #:mutable) + (set-bar-z! (make-bar 2 "x") #f)) + "top-level") + + (test/spec-passed + 'define-struct/contract19 + '(let () + (define-struct foo (x)) + (define-struct/contract (bar foo) ([z string?])) + (define-struct/contract (baz bar) ([x number?])) + (make-baz 2 "x" 5))) + + (test/spec-failed + 'define-struct/contract20 + '(let () + (define-struct foo (x)) + (define-struct/contract (bar foo) ([z string?])) + (define-struct/contract (baz bar) ([x number?])) + (make-baz 2 "x" #f)) + "top-level") + + (test/spec-failed + 'define-struct/contract21 + '(let () + (define-struct foo (x)) + (define-struct/contract (bar foo) ([z string?])) + (define-struct/contract (baz bar) ([x number?])) + (make-baz 2 #f 3)) + "top-level") + + (test/spec-passed + 'define-struct/contract21 + '(let () + (define-struct foo (x) #:mutable) + (define-struct/contract (bar foo) ([z string?])) + (set-foo-x! (make-bar 2 "x") #f))) + + (test/spec-passed + 'define-struct/contract22 + '(define-struct/contract foo ([x number?] [y number?]) #:mutable #:transparent)) + + (test/spec-passed + 'define-struct/contract23 + '(define-struct/contract foo ([x number?] [y number?]) + #:mutable #:transparent + #:property prop:custom-write + (lambda (a b c) (void)))) + + (test/spec-passed/result + 'define-struct/contract24 + '(let () + (define-struct/contract point + ([x number?] [y number?]) + #:transparent) + (define-struct/contract (color-point point) + ([c symbol?]) + #:transparent) + + (match (make-color-point 1 2 'red) + [(struct color-point [dx dy color]) + (list dx dy color)] + [(struct point [dx dy]) (list dx dy)] + [v (box v)])) + (list 1 2 'red)) + + (test/spec-passed + 'define-struct/contract25 + '(let () + (define-struct/contract point + ([x number?] [y number?]) + #:transparent) + (point 1 2))) + + (test/spec-failed + 'define-struct/contract26 + '(let () + (define-struct/contract point + ([x number?] [y number?]) + #:transparent) + (point 1 #t)) + "top-level")) \ No newline at end of file diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/errortrace.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/errortrace.rkt new file mode 100644 index 0000000000..f942fc9623 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/errortrace.rkt @@ -0,0 +1,18 @@ +#lang racket/base +(require "test-util.rkt") +;; errortrace test +(parameterize ([current-contract-namespace + (make-basic-contract-namespace + 'racket/contract + 'errortrace)]) + (define sp (open-input-string (format "~s\n" '(-> (λ (a b c) #f) any)))) + (define stx (read-syntax 'whereitsat sp)) + (define exn + (with-handlers ((exn:fail? values)) + (contract-eval stx))) + (define sp2 (open-output-string)) + (parameterize ([current-error-port sp2]) + ((error-display-handler) (exn-message exn) exn)) + (test #t + 'checking-arrow-src-locs + (regexp-match? #rx"whereitsat" (get-output-string sp2)))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/exists.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/exists.rkt new file mode 100644 index 0000000000..f146d6ce96 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/exists.rkt @@ -0,0 +1,55 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace 'racket/contract)]) + + (test/spec-passed + '∃1 + '(contract (new-∃/c 'pair) + 1 + 'pos + 'neg)) + + (test/neg-blame + '∃2 + '((contract (-> (new-∃/c 'pair) any/c) + (λ (x) x) + 'pos + 'neg) + 1)) + + (test/spec-passed/result + '∃3 + '(let ([pair (new-∃/c 'pair)]) + ((contract (-> (-> pair pair) any/c) + (λ (f) (f 11)) + 'pos + 'neg) + (λ (x) x))) + 11) + + (test/pos-blame + '∀1 + '(contract (new-∀/c 'pair) + 1 + 'pos + 'neg)) + + (test/spec-passed + '∀2 + '((contract (-> (new-∀/c 'pair) any/c) + (λ (x) x) + 'pos + 'neg) + 1)) + + (test/spec-passed/result + '∀3 + '(let ([pair (new-∀/c 'pair)]) + ((contract (-> pair pair) + (λ (x) x) + 'pos + 'neg) + 11)) + 11)) \ No newline at end of file diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/first-order.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/first-order.rkt new file mode 100644 index 0000000000..d99d3eb0ff --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/first-order.rkt @@ -0,0 +1,174 @@ +#lang racket/base + +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace + 'racket/contract + 'racket/promise)]) + + (contract-eval '(define-contract-struct couple (hd tl))) + + (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)) + (ctest #f contract-first-order-passes? (-> integer? boolean? #:x integer? integer?) (λ (x y) #t)) + (ctest #t contract-first-order-passes? + (-> integer? boolean? #:x integer? integer?) + (λ (x y #:x z) #t)) + + (ctest #t contract-first-order-passes? + (->* (integer?) () #:rest any/c (values char? any/c)) + (λ (x . y) #f)) + (ctest #f contract-first-order-passes? + (->* (integer?) () #:rest any/c (values char? any/c)) + (λ (x y . z) #f)) + (ctest #f contract-first-order-passes? + (->* (integer?) () #:rest any/c (values char? any/c)) + (λ (x) #f)) + (ctest #t contract-first-order-passes? + (->* (integer?) () #:rest any/c (values char? any/c)) + (λ x #f)) + + (ctest #t contract-first-order-passes? (->d ((z any/c)) () (result any/c)) (λ (x) x)) + (ctest #f contract-first-order-passes? (->d ((z any/c)) () (result any/c)) (λ (x y) x)) + + (ctest #t contract-first-order-passes? (->i ((z any/c)) () (result any/c)) (λ (x) x)) + (ctest #f contract-first-order-passes? (->i ((z any/c)) () (result any/c)) (λ (x y) x)) + + (ctest #t contract-first-order-passes? (listof integer?) (list 1)) + (ctest #f contract-first-order-passes? (listof integer?) #f) + + (ctest #f contract-first-order-passes? (list/c #f #f #t) (list)) + (ctest #t contract-first-order-passes? (list/c #f 'x #t) (list #f 'x #t)) + (ctest #f contract-first-order-passes? (list/c (-> number? number?)) (list (λ (x y) x))) + (ctest #t contract-first-order-passes? (list/c (-> number? number?)) (list (λ (x) x))) + + (ctest #t contract-first-order-passes? (non-empty-listof integer?) (list 1)) + (ctest #f contract-first-order-passes? (non-empty-listof integer?) (list)) + + + (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?) '()) + + (ctest #t contract-first-order-passes? (promise/c integer?) (delay 1)) + (ctest #f contract-first-order-passes? (promise/c integer?) 1) + + (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)) + + (ctest #t contract-first-order-passes? + (cons/c boolean? (-> integer? integer?)) + (list* #t (λ (x) x))) + (ctest #f contract-first-order-passes? + (cons/c boolean? (-> integer? integer?)) + (list* 1 2)) + + (ctest #f contract-first-order-passes? (flat-rec-contract the-name) 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) + + (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) + + (ctest #t contract-first-order-passes? + (or/c (-> integer? integer? integer?) + (-> integer? integer?)) + (λ (x) x)) + (ctest #t contract-first-order-passes? + (or/c (-> integer? integer? integer?) + (-> integer? integer?)) + (λ (x y) x)) + (ctest #f contract-first-order-passes? + (or/c (-> integer? integer? integer?) + (-> integer? integer?)) + (λ () x)) + (ctest #f contract-first-order-passes? + (or/c (-> integer? integer? integer?) + (-> integer? integer?)) + 1) + + (ctest #t contract-first-order-passes? (hash/c any/c any/c) (make-hash)) + (ctest #f contract-first-order-passes? (hash/c any/c any/c) #f) + (ctest #f contract-first-order-passes? (hash/c symbol? boolean?) (let ([ht (make-hash)]) + (hash-set! ht 'x 1) + ht)) + (ctest #f contract-first-order-passes? (hash/c symbol? boolean? #:flat? #t) + (let ([ht (make-hash)]) (hash-set! ht 'x 1) ht)) + (ctest #f contract-first-order-passes? (hash/c symbol? boolean?) (let ([ht (make-hash)]) + (hash-set! ht 1 #f) + ht)) + (ctest #f contract-first-order-passes? (hash/c symbol? boolean? #:flat? #t) + (let ([ht (make-hash)]) (hash-set! ht 1 #f) ht)) + (ctest #t contract-first-order-passes? (hash/c symbol? boolean?) (let ([ht (make-hash)]) + (hash-set! ht 'x #t) + ht)) + + + (ctest 1 + length + (let ([f (contract (-> integer? any) + (lambda (x) + (with-continuation-mark 'x 'x + (continuation-mark-set->list (current-continuation-marks) 'x))) + 'pos + 'neg)]) + (with-continuation-mark 'x 'x + (f 1)))) + + (ctest 2 + length + (let ([f (contract (-> integer? list?) + (lambda (x) + (with-continuation-mark 'x 'x + (continuation-mark-set->list (current-continuation-marks) 'x))) + 'pos + 'neg)]) + (with-continuation-mark 'x 'x + (f 1)))) + + (ctest #t contract-first-order-passes? (or/c 'x "x" #rx"x") 'x) + (ctest #t contract-first-order-passes? (or/c 'x "x" #rx"x") "x") + (ctest #t contract-first-order-passes? (or/c 'x "x" #rx"x.") "xy") + (ctest #f contract-first-order-passes? (or/c 'x "x" #rx"x.") "yx") + (ctest #f contract-first-order-passes? (or/c 'x "x" #rx"x.") 'y)) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/flat-contracts.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/flat-contracts.rkt new file mode 100644 index 0000000000..5e4cfcaf9a --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/flat-contracts.rkt @@ -0,0 +1,197 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace + 'racket/class)]) + + (define (test-flat-contract contract pass fail) + (contract-eval `(,test #t flat-contract? ,contract)) + (define (run-two-tests maybe-rewrite) + (let ([name (if (pair? contract) + (car contract) + contract)]) + (let/ec k + (test/spec-failed (format "~a fail" name) + (maybe-rewrite `(contract ,contract ',fail 'pos 'neg) k) + 'pos)) + (let/ec k + (test/spec-passed/result + (format "~a pass" name) + (maybe-rewrite `(contract ,contract ',pass 'pos 'neg) k) + pass)))) + (run-two-tests (λ (x k) x)) + (run-two-tests rewrite-to-add-opt/c)) + + (define flat-contract-predicate (contract-eval 'flat-contract-predicate)) + + (test-flat-contract '(and/c number? integer?) 1 3/2) + (test-flat-contract '(not/c integer?) #t 1) + (test-flat-contract '(=/c 2) 2 3) + (test-flat-contract '(>/c 5) 10 5) + (test-flat-contract '(>=/c 5) 5 0) + (test-flat-contract '(<=/c 5) 5 10) + (test-flat-contract '(/c 5) 10 0+1i) + (test-flat-contract '(>=/c 5) 5 0+1i) + (test-flat-contract '(<=/c 5) 5 0+1i) + (test-flat-contract '( (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)) + + (begin + (contract-eval '(define flat-is-a-test<%> (interface ()))) + (contract-eval '(define flat-is-a-test% (class object% (super-new)))) + (test-flat-contract `(is-a?/c flat-is-a-test<%>) + (contract-eval `(new (class* object% (flat-is-a-test<%>) (super-new)))) + (contract-eval '(new object%))) + (test-flat-contract `(is-a?/c flat-is-a-test%) + (contract-eval `(new flat-is-a-test%)) + (contract-eval '(new object%))) + (test-flat-contract `(or/c #f (is-a?/c flat-is-a-test<%>)) + (contract-eval `(new (class* object% (flat-is-a-test<%>) (super-new)))) + (contract-eval '(new object%))) + (test-flat-contract `(or/c #f (is-a?/c flat-is-a-test%)) + (contract-eval `(new flat-is-a-test%)) + (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 '(vectorof boolean? #:flat? #t) (vector #t #f) (vector #f 3 #t)) + (test-flat-contract '(vectorof any/c #:flat? #t) (vector #t #f) 3) + (test-flat-contract '(vector-immutableof boolean?) + (vector-immutable #t #f) + (vector-immutable #f 3 #t)) + (test-flat-contract '(vector-immutableof any/c) (vector-immutable #t #f) 3) + + (test-flat-contract '(vector/c boolean? (flat-contract integer?) #:flat? #t) + (vector #t 1) + (vector 1 #f)) + (test-flat-contract '(vector/c boolean? (flat-contract integer?) #:flat? #t) (vector #t 1) #f) + (test-flat-contract '(vector-immutable/c boolean? (flat-contract integer?)) + (vector-immutable #t 1) (vector-immutable 1 #f)) + (test-flat-contract '(vector-immutable/c boolean? (flat-contract integer?)) + (vector-immutable #t 1) + #f) + + (test-flat-contract '(cons/c boolean? (flat-contract integer?)) (cons #t 1) (cons 1 #f)) + (test-flat-contract '(cons/c boolean? (flat-contract integer?)) (cons #t 1) #f) + (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) + + (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? #:flat? #t) (box #f) (box 1)) + (test-flat-contract '(box/c (flat-contract boolean?) #:flat? #t) (box #t) #f) + (test-flat-contract '(box-immutable/c boolean?) (box-immutable #f) (box-immutable 1)) + (test-flat-contract '(box-immutable/c (flat-contract boolean?)) (box-immutable #t) #f) + + (test-flat-contract '(flat-rec-contract sexp (cons/c sexp sexp) number?) '(1 2 . 3) '(1 . #f)) + (test-flat-contract '(flat-murec-contract ([even1 (or/c null? (cons/c number? even2))] + [even2 (cons/c number? even1)]) + even1) + '(1 2 3 4) + '(1 2 3)) + + (test-flat-contract '(hash/c symbol? boolean? #:flat? #t) (make-hash) 1) + (test-flat-contract '(hash/c symbol? boolean? #:flat? #t) + (let ([ht (make-hash)]) + (hash-set! ht 'x #t) + ht) + (let ([ht (make-hash)]) + (hash-set! ht 'x 1) + ht)) + (test-flat-contract '(hash/c symbol? boolean? #:flat? #t) + (let ([ht (make-hash)]) + (hash-set! ht 'x #t) + ht) + (let ([ht (make-hash)]) + (hash-set! ht 'x 1) + ht)) + + (test-flat-contract '(between/c 1 10) 3 11) + (test-flat-contract '(between/c 1 10) 4 1+1i) + (test-flat-contract '(<=/c 1) 0 1+1i) + (test-flat-contract '(/c 1) 4 1+1i) + (test-flat-contract '(>=/c 1) 4 1+1i) + + (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)) + + (test-flat-contract '(or/c (flat-contract integer?) char?) #\a #t) + (test-flat-contract '(or/c (flat-contract integer?) char?) 1 #t) + + + ;; test flat-contract-predicate + (test #t (flat-contract-predicate integer?) 1) + (test #t (flat-contract-predicate #t) #t)) \ No newline at end of file diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/hash.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/hash.rkt new file mode 100644 index 0000000000..ac1dc0100e --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/hash.rkt @@ -0,0 +1,218 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace (make-basic-contract-namespace)]) + (test/spec-passed + 'hash/c1 + '(contract (hash/c symbol? boolean?) + (make-hash) + 'pos + 'neg)) + + (test/spec-passed + 'hash/c1b + '(contract (hash/c symbol? boolean? #:flat? #t) + (make-hash) + 'pos + 'neg)) + + (test/spec-passed + 'hash/c1c + '(let ([h (contract (hash/c symbol? boolean?) + (make-hash) + 'pos + 'neg)]) + (hash-set! h 'x #t) + (hash-ref h 'x))) + + (test/neg-blame + 'hash/c1d + '(let ([h (contract (hash/c symbol? boolean?) + (make-hash) + 'pos + 'neg)]) + (hash-set! h 3 #t))) + + (test/neg-blame + 'hash/c1e + '(let ([h (contract (hash/c symbol? boolean?) + (make-hash) + 'pos + 'neg)]) + (hash-set! h 'x 3))) + + (test/neg-blame + 'hash/c1f + '(let ([h (contract (hash/c symbol? boolean?) + (make-hash) + 'pos + 'neg)]) + (hash-ref h 3))) + + (test/spec-passed + 'hash/c2 + '(contract (hash/c symbol? boolean?) + (let ([h (make-hash)]) + (hash-set! h 'x #t) + h) + 'pos + 'neg)) + + (test/pos-blame + 'hash/c3 + '(write (contract (hash/c symbol? boolean?) + (let ([h (make-hash)]) + (hash-set! h 'x 'x) + h) + 'pos + 'neg) + (open-output-string))) + + ;; no io, so failure undetected + (test/spec-passed + 'hash/c3b + '(contract (hash/c symbol? boolean?) + (let ([h (make-hash)]) + (hash-set! h 'x 'x) + h) + 'pos + 'neg)) + + (test/pos-blame + 'hash/c4 + '(write (contract (hash/c symbol? boolean?) + (let ([h (make-hash)]) + (hash-set! h #t #f) + h) + 'pos + 'neg) + (open-output-string))) + + ;; no io, so failure undetected + (test/spec-passed + 'hash/c4b + '(contract (hash/c symbol? boolean?) + (let ([h (make-hash)]) + (hash-set! h #t #f) + h) + 'pos + 'neg)) + + (test/pos-blame + 'hash/c5 + '(contract (hash/c symbol? boolean? #:immutable #t) + (let ([h (make-hash)]) + (hash-set! h 'x #f) + h) + 'pos + 'neg)) + + (test/spec-passed + 'hash/c6 + '(contract (hash/c symbol? boolean? #:immutable #t) + (make-immutable-hash '((x . #f))) + 'pos + 'neg)) + + (test/spec-passed + 'hash/c7 + '(contract (hash/c symbol? boolean? #:immutable #f) + (let ([h (make-hash)]) + (hash-set! h 'x #f) + h) + 'pos + 'neg)) + + (test/pos-blame + 'hash/c8 + '(contract (hash/c symbol? boolean? #:immutable #f) + (make-immutable-hash '((x . #f))) + 'pos + 'neg)) + + (test/spec-passed + 'hash/c9 + '(contract (hash/c symbol? boolean? #:immutable 'dont-care) + (make-immutable-hash '((x . #f))) + 'pos + 'neg)) + + (test/spec-passed + 'hash/c10 + '(contract (hash/c symbol? boolean? #:immutable 'dont-care) + (let ([h (make-hash)]) + (hash-set! h 'x #f) + h) + 'pos + 'neg)) + + (test/spec-passed/result + 'hash/c11 + '(hash-ref (contract (hash/c symbol? number? #:immutable #t) + (make-immutable-hash '((x . 1))) + 'pos + 'neg) + 'x) + 1) + + (test/spec-passed/result + 'hash/c12 + '(hash-ref (contract (hash/c symbol? number?) + (let ([ht (make-hash)]) + (hash-set! ht 'x 1) + ht) + 'pos + 'neg) + 'x) + 1) + + (test/pos-blame + 'hash/c13a + '(contract (hash/c (hash/c number? number?) number?) + (make-hasheq) + 'pos + 'neg)) + + (test/pos-blame + 'hash/c13b + '(contract (hash/c (hash/c number? number?) number?) + (make-hasheq) + 'pos + 'neg)) + + (test/neg-blame + 'hash/c13c + '(let ([h (contract (hash/c (hash/c number? number?) number?) + (make-hash) + 'pos + 'neg)]) + (hash-set! h (make-hash '((2 . 3))) 2) + (hash-set! h (make-hash '((3 . #t))) 3) + (for ([(k v) (in-hash h)]) + (hash-ref k v)))) + + + + (test/no-error + '(let ([v (chaperone-hash (make-immutable-hash (list (cons 1 2))) + (λ (hash k) (values k (λ (h k v) v))) + (λ (hash k v) (values k v)) + (λ (hash k) k) + (λ (hash k) k))]) + (contract (hash/c any/c any/c) v 'pos 'neg))) + + (test/no-error + '(let ([v (chaperone-hash (make-immutable-hasheq (list (cons 1 2))) + (λ (hash k) (values k (λ (h k v) v))) + (λ (hash k v) (values k v)) + (λ (hash k) k) + (λ (hash k) k))]) + (contract (hash/c any/c any/c) v 'pos 'neg))) + + (test/no-error + '(let ([v (chaperone-hash (make-immutable-hasheqv (list (cons 1 2))) + (λ (hash k) (values k (λ (h k v) v))) + (λ (hash k v) (values k v)) + (λ (hash k) k) + (λ (hash k) k))]) + (contract (hash/c any/c any/c) v 'pos 'neg)))) \ No newline at end of file diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/immutable.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/immutable.rkt new file mode 100644 index 0000000000..e643644e86 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/immutable.rkt @@ -0,0 +1,290 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace (make-basic-contract-namespace)]) + + (test/pos-blame + 'immutable1 + '(let ([ct (contract (listof (boolean? . -> . boolean?)) + #f + 'pos + 'neg)]) + ((car ct) 1))) + + (test/neg-blame + 'immutable2 + '(let ([ct (contract (listof (boolean? . -> . boolean?)) + (list (lambda (x) x)) + 'pos + 'neg)]) + ((car ct) 1))) + + (test/neg-blame + 'immutable3 + '(let ([ct (contract (listof (number? . -> . boolean?)) + (list (lambda (x) 1)) + 'pos + 'neg)]) + ((car ct) #f))) + + (test/pos-blame + 'immutable4 + '(let ([ct (contract (listof (number? . -> . boolean?)) + (list (lambda (x) 1)) + 'pos + 'neg)]) + ((car ct) 1))) + + (test/spec-passed + 'immutable5 + '(let ([ct (contract (listof (number? . -> . boolean?)) + (list (lambda (x) #t)) + 'pos + 'neg)]) + ((car ct) 1))) + + + (test/pos-blame + 'immutable6 + '(contract (cons/c (boolean? . -> . boolean?) (boolean? . -> . boolean?)) + #f + 'pos + 'neg)) + + (test/spec-passed + 'immutable7 + '(let ([ct (contract (non-empty-listof (boolean? . -> . boolean?)) + (list (λ (x) #t)) + 'pos + 'neg)]) + ((car ct) #f))) + + (test/neg-blame + 'immutable8 + '(let ([ct (contract (cons/c (number? . -> . boolean?) (number? . -> . boolean?)) + (cons (lambda (x) 1) (lambda (x) 1)) + 'pos + 'neg)]) + ((car ct) #f))) + + (test/neg-blame + 'immutable9 + '(let ([ct (contract (cons/c (number? . -> . boolean?) (number? . -> . boolean?)) + (cons (lambda (x) 1) (lambda (x) 1)) + 'pos + 'neg)]) + ((cdr ct) #f))) + + (test/pos-blame + 'immutable10 + '(let ([ct (contract (cons/c (number? . -> . boolean?) (number? . -> . boolean?)) + (cons (lambda (x) 1) (lambda (x) 1)) + 'pos + 'neg)]) + ((car ct) 1))) + + (test/pos-blame + 'immutable11 + '(let ([ct (contract (cons/c (number? . -> . boolean?) (number? . -> . boolean?)) + (cons (lambda (x) 1) (lambda (x) 1)) + 'pos + 'neg)]) + ((cdr ct) 1))) + + (test/spec-passed + 'immutable12 + '(let ([ct (contract (cons/c (number? . -> . boolean?) (number? . -> . boolean?)) + (cons (lambda (x) #t) (lambda (x) #t)) + 'pos + 'neg)]) + ((car ct) 1))) + + (test/spec-passed + 'immutable13 + '(let ([ct (contract (cons/c (number? . -> . boolean?) (number? . -> . boolean?)) + (cons (lambda (x) #t) (lambda (x) #t)) + 'pos + 'neg)]) + ((cdr ct) 1))) + + (test/spec-passed/result + 'immutable14 + '(contract (cons/c number? boolean?) + (cons 1 #t) + 'pos + 'neg) + (cons 1 #t)) + + (test/pos-blame + 'immutable15 + '(contract (list/c (number? . -> . boolean?) (number? . -> . boolean?)) + #f + 'pos + 'neg)) + + (test/pos-blame + 'immutable17 + '(contract (list/c (number? . -> . boolean?) (number? . -> . boolean?)) + (list (lambda (x) #t)) + 'pos + 'neg)) + + (test/pos-blame + 'immutable18 + '(contract (list/c (number? . -> . boolean?) (number? . -> . boolean?)) + (list (lambda (x) #t) (lambda (x) #t) (lambda (x) #t)) + 'pos + 'neg)) + + (test/spec-passed + 'immutable19 + '(let ([ctc (contract (list/c (number? . -> . boolean?) (number? . -> . boolean?)) + (list (lambda (x) #t) (lambda (x) #t)) + 'pos + 'neg)]) + (for-each (lambda (x) (x 1)) ctc))) + + (test/pos-blame + 'vector-immutable1 + '(contract (vector-immutableof (boolean? . -> . boolean?)) + #f + 'pos + 'neg)) + + (test/pos-blame + 'vector-immutable2 + '(contract (vector-immutableof (boolean? . -> . boolean?)) + (vector (lambda (x) x)) + 'pos + 'neg)) + + (test/neg-blame + 'vector-immutable3 + '(let ([ct (contract (vector-immutableof (number? . -> . boolean?)) + (vector->immutable-vector (vector (lambda (x) 1))) + 'pos + 'neg)]) + ((vector-ref ct 0) #f))) + + (test/pos-blame + 'vector-immutable4 + '(let ([ct (contract (vector-immutableof (number? . -> . boolean?)) + (vector->immutable-vector (vector (lambda (x) 1))) + 'pos + 'neg)]) + ((vector-ref ct 0) 1))) + + (test/spec-passed + 'vector-immutable5 + '(let ([ct (contract (vector-immutableof (number? . -> . boolean?)) + (vector->immutable-vector (vector (lambda (x) #t))) + 'pos + 'neg)]) + ((vector-ref ct 0) 1))) + + (test/pos-blame + 'vector-immutable6 + '(contract (vector-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) + #f + 'pos + 'neg)) + + (test/pos-blame + 'vector-immutable7 + '(contract (vector-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) + (vector (lambda (x) #t) (lambda (x) #t)) + 'pos + 'neg)) + + (test/pos-blame + 'vector-immutable8 + '(contract (vector-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) + (vector->immutable-vector (vector (lambda (x) #t))) + 'pos + 'neg)) + + (test/pos-blame + 'vector-immutable9 + '(contract (vector-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) + (vector->immutable-vector (vector (lambda (x) #t) (lambda (x) #t) (lambda (x) #t))) + 'pos + 'neg)) + + (test/spec-passed + 'vector-immutable10 + '(let ([ctc (contract (vector-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) + (vector->immutable-vector (vector (lambda (x) #t) (lambda (x) #t))) + 'pos + 'neg)]) + ((vector-ref ctc 0) 1) + ((vector-ref ctc 1) 1))) + + (test/spec-passed/result + 'vector-immutable11 + '(contract (vector-immutable/c number? boolean?) + (vector->immutable-vector (vector 1 #t)) + 'pos + 'neg) + (vector->immutable-vector (vector 1 #t))) + + (test/spec-passed/result + 'vector-immutable12 + '(immutable? (contract (vector-immutable/c number? boolean?) + (vector->immutable-vector (vector 1 #t)) + 'pos + 'neg)) + #t) + + (test/pos-blame + 'box-immutable1 + '(contract (box-immutable/c (number? . -> . boolean?)) + #f + 'pos + 'neg)) + + (test/pos-blame + 'box-immutable2 + '(contract (box-immutable/c (number? . -> . boolean?)) + (box (lambda (x) #t)) + 'pos + 'neg)) + + (test/neg-blame + 'box-immutable3 + '(let ([ctc (contract (box-immutable/c (number? . -> . boolean?)) + (box-immutable (lambda (x) #t)) + 'pos + 'neg)]) + ((unbox ctc) #f))) + + (test/pos-blame + 'box-immutable4 + '(let ([ctc (contract (box-immutable/c (number? . -> . boolean?)) + (box-immutable (lambda (x) 1)) + 'pos + 'neg)]) + ((unbox ctc) 1))) + + (test/spec-passed + 'box-immutable5 + '(let ([ctc (contract (box-immutable/c (number? . -> . boolean?)) + (box-immutable (lambda (x) #t)) + 'pos + 'neg)]) + ((unbox ctc) 1))) + + (test/spec-passed/result + 'box-immutable6 + '(contract (box-immutable/c boolean?) + (box-immutable #t) + 'pos + 'neg) + (box-immutable #t)) + + (test/spec-passed/result + 'box-immutable7 + '(immutable? (contract (box-immutable/c boolean?) + (box-immutable #t) + 'pos + 'neg)) + #t)) \ No newline at end of file diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/instanceof.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/instanceof.rkt new file mode 100644 index 0000000000..52c891a2f9 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/instanceof.rkt @@ -0,0 +1,103 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace + 'racket/class)]) + + (test/spec-passed + 'instanceof/c-first-order-1 + '(let* ([c% object%] + [c%/c (class/c)]) + (contract (instanceof/c c%/c) (new c%) 'pos 'neg))) + + (test/pos-blame + 'instanceof/c-first-order-2 + '(let* ([c% object%] + [c%/c (class/c (field [f number?]))]) + (contract (instanceof/c c%/c) (new c%) 'pos 'neg))) + + (test/pos-blame + 'instanceof/c-first-order-3 + '(let* ([c% object%] + [c%/c (class/c [m (->m number? number?)])]) + (contract (instanceof/c c%/c) (new c%) 'pos 'neg))) + + (test/spec-passed + 'instanceof/c-first-order-4 + '(let* ([c% (class object% (super-new) (field [f 3]))] + [c%/c (class/c (field [f number?]))]) + (contract (instanceof/c c%/c) (new c%) 'pos 'neg))) + + (test/spec-passed + 'instanceof/c-first-order-5 + '(let* ([c% (class object% (super-new) (define/public (m x) x))] + [c%/c (class/c [m (->m number? number?)])]) + (contract (instanceof/c c%/c) (new c%) 'pos 'neg))) + + (test/spec-passed + 'instanceof/c-first-order-6 + '(let* ([c% (class object% (super-new) (define/public (m x) x))] + [c%/c (class/c [m (->m number? number?)])] + [d%/c (class/c [n (->m number? number?)])]) + (contract (instanceof/c (or/c c%/c d%/c)) (new c%) 'pos 'neg))) + + (test/spec-passed + 'instanceof/c-first-order-7 + '(let* ([d% (class object% (super-new) (define/public (n x) x))] + [c%/c (class/c [m (->m number? number?)])] + [d%/c (class/c [n (->m number? number?)])]) + (contract (instanceof/c (or/c c%/c d%/c)) (new d%) 'pos 'neg))) + + (test/pos-blame + 'instanceof/c-first-order-8 + '(let* ([e% (class object% (super-new) (define/public (p x) x))] + [c%/c (class/c [m (->m number? number?)])] + [d%/c (class/c [n (->m number? number?)])]) + (contract (instanceof/c (or/c c%/c d%/c)) (new e%) 'pos 'neg))) + + (test/spec-passed/result + 'instanceof/c-higher-order-1 + '(let* ([c% (class object% (super-new) (field [f 3]))] + [c%/c (class/c (field [f number?]))] + [o (contract (instanceof/c c%/c) (new c%) 'pos 'neg)]) + (get-field f o)) + 3) + + (test/neg-blame + 'instanceof/c-higher-order-2 + '(let* ([c% (class object% (super-new) (field [f 3]))] + [c%/c (class/c (field [f number?]))] + [o (contract (instanceof/c c%/c) (new c%) 'pos 'neg)]) + (set-field! f o #t))) + + (test/pos-blame + 'instanceof/c-higher-order-3 + '(let* ([c% (class object% (super-new) (define/public (m x) (zero? x)))] + [c%/c (class/c [m (->m number? number?)])] + [o (contract (instanceof/c c%/c) (new c%) 'pos 'neg)]) + (send o m 3))) + + (test/spec-passed + 'instanceof/c-higher-order-4 + '(let* ([c% (class object% (super-new) (define/public (m x) x))] + [c%/c (class/c [m (->m number? number?)])] + [d%/c (class/c [n (->m number? number?)])] + [o (contract (instanceof/c (or/c c%/c d%/c)) (new c%) 'pos 'neg)]) + (send o m 3))) + + (test/pos-blame + 'instanceof/c-higher-order-4 + '(let* ([c% (class object% (super-new) (define/public (m x) #t))] + [c%/c (class/c [m (->m number? number?)])] + [d%/c (class/c [n (->m number? number?)])] + [o (contract (instanceof/c (or/c c%/c d%/c)) (new c%) 'pos 'neg)]) + (send o m 3))) + + (test/neg-blame + 'instanceof/c-higher-order-4 + '(let* ([c% (class object% (super-new) (define/public (m x) x))] + [c%/c (class/c [m (->m number? number?)])] + [d%/c (class/c [n (->m number? number?)])] + [o (contract (instanceof/c (or/c c%/c d%/c)) (new c%) 'pos 'neg)]) + (send o m #t)))) \ No newline at end of file diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/interface.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/interface.rkt new file mode 100644 index 0000000000..1b02e9f5ab --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/interface.rkt @@ -0,0 +1,235 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace + 'racket/class + 'racket/contract)]) + + (define exn:fail:contract:blame? (contract-eval 'exn:fail:contract:blame?)) + (test/spec-passed + 'interface-1 + '(interface () [x number?])) + + (test/spec-passed + 'interface-2 + '(interface () [x number?] [y number?])) + + (test/spec-passed + 'interface-3 + '(interface () [get-x (-> integer?)])) + + (contract-syntax-error-test + 'interface-4 + '(interface () [x number?] [x symbol?])) + + (contract-error-test + 'interface-5 + '(interface () [x (λ (x y) x)]) + exn:fail?) + + (contract-error-test + 'interface-6 + '(interface ((interface () x)) x) + exn:fail?) + + (test/spec-passed + 'interface-7 + '(interface ((interface () x)) [x integer?])) + + (test/spec-passed + 'interface-8 + '(interface ((interface () [x number?])) [x integer?])) + + (contract-error-test + 'interface-9 + '(interface ((interface () [x number?])) x) + exn:fail?) + + (test/spec-passed + 'interface-first-order-1 + '(let* ([i<%> (interface () [m (->m number? number?)])] + [c% (class* object% (i<%>) (super-new) (define/public (m x) x))]) + (new c%))) + + (test/spec-failed + 'interface-first-order-2 + '(let* ([i<%> (interface () [m (->m number? number?)])] + [c% (class* object% (i<%>) (super-new) (define/public (m) x))]) + (new c%)) + "(class c%)") + + (test/spec-passed + 'interface-higher-order-1 + '(let* ([i<%> (interface () [m (->m number? number?)])] + [c% (class* object% (i<%>) (super-new) (define/public (m x) x))]) + (send (new c%) m 3))) + + (test/spec-failed + 'interface-higher-order-2 + '(let* ([i<%> (interface () [m (->m number? number?)])] + [c% (class* object% (i<%>) (super-new) (define/public (m x) x))]) + (send (new c%) m "wrong")) + "top-level") + + (test/spec-failed + 'interface-higher-order-3 + '(let* ([i<%> (interface () [m (->m number? number?)])] + [c% (class* object% (i<%>) (super-new) (define/public (m x) "bad"))]) + (send (new c%) m 3)) + "(class c%)") + + (test/spec-failed + 'interface-higher-order-4 + '(let* ([i1<%> (interface () [m (->m number? number?)])] + [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] + [c% (class* object% (i2<%>) (super-new) (define/public (m x) x))]) + (send (new c%) m 3.14)) + "(interface i2<%>)") + + (test/spec-failed + 'interface-higher-order-5 + '(let* ([i1<%> (interface () [m (->m number? number?)])] + [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] + [c% (class* object% (i2<%>) (super-new) (define/public (m x) 3.14))]) + (send (new c%) m 3)) + "(class c%)") + + (test/spec-failed + 'interface-higher-order-6 + '(let* ([i1<%> (interface () [m (->m integer? integer?)])] + [i2<%> (interface (i1<%>) [m (->m number? number?)])] + [c% (class* object% (i2<%>) (super-new) (define/public (m x) 3.14))]) + (send (new c%) m 3)) + "(interface i2<%>)") + + (test/spec-passed + 'interface-higher-order-7 + '(let* ([i1<%> (interface () [m (->m integer? number?)])] + [i2<%> (interface (i1<%>) [m (->m number? integer?)])] + [c% (class* object% (i2<%>) (super-new) (define/public (m x) x))]) + (send (new c%) m 3))) + + (test/spec-failed + 'interface-higher-order-8 + '(let* ([i1<%> (interface () [m (->m integer? number?)])] + [i2<%> (interface (i1<%>) [m (->m number? integer?)])] + [c% (class* object% (i2<%>) (super-new) (define/public (m x) x))]) + (send (new c%) m 3.14)) + "top-level") + + (test/spec-failed + 'interface-higher-order-9 + '(let* ([i1<%> (interface () [m (->m integer? number?)])] + [i2<%> (interface (i1<%>) [m (->m number? integer?)])] + [c% (class* object% (i2<%>) (super-new) (define/public (m x) 3.14))]) + (send (new c%) m 3)) + "(class c%)") + + (test/spec-passed + 'interface-higher-order-10 + '(let* ([i1<%> (interface () [m (->m integer? integer?)])] + [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] + [c% (class* object% (i2<%>) (super-new) (define/public (m x) x))] + [c2% (class c% (super-new))]) + (send (new c2%) m 3))) + + (test/spec-passed + 'interface-higher-order-11 + '(let* ([i1<%> (interface () [m (->m integer? integer?)])] + [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] + [c% (contract (class/c) + (class* object% (i2<%>) (super-new) (define/public (m x) x)) + 'pos + 'neg)]) + (send (new c%) m 3))) + + (test/neg-blame + 'interface-higher-order-12 + '(let* ([i1<%> (interface () [m (->m integer? integer?)])] + [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] + [c% (contract (class/c [m (->m integer? integer?)]) + (class* object% (i2<%>) (super-new) (define/public (m x) x)) + 'pos + 'neg)]) + (send (new c%) m 5.14))) + + (test/spec-failed + 'interface-higher-order-13 + '(let* ([i1<%> (interface () [m (->m integer? integer?)])] + [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] + [c% (contract (class/c m) + (class* object% (i2<%>) (super-new) (define/public (m x) x)) + 'pos + 'neg)]) + (send (new c%) m 5.14)) + "pos") + + (test/spec-failed + 'interface-higher-order-14 + '(let* ([i1<%> (interface () [m (->m integer? integer?)])] + [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] + [c% (contract (class/c) + (class* object% (i2<%>) (super-new) (define/public (m x) x)) + 'pos + 'neg)]) + (send (new c%) m 5.14)) + "top-level") + + (test/spec-passed + 'interface-internal-name-1 + '(let* ([i1<%> (interface () [m (->m integer? integer?)])] + [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] + [c% (class* object% (i2<%>) + (super-new) + (public [n m]) + (define n (λ (x) x)))]) + (send (new c%) m 3))) + + (test/spec-passed + 'interface-internal-name-2 + '(let* ([i1<%> (interface () [m (->m integer? integer?)])] + [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] + [c% (contract + (class/c [m (->m integer? integer?)]) + (class* object% (i2<%>) + (super-new) + (public [n m]) + (define n (λ (x) x))) + 'pos + 'neg)]) + (send (new c%) m 3))) + + (test/spec-passed + 'interface-mixin-1 + '(let* ([i1<%> (interface () [m (->m integer? integer?)])] + [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] + [mixin (λ (cls) + (class* cls (i2<%>) + (super-new) + (define/public (m x) x)))]) + (send (new (mixin object%)) m 3))) + + (test/spec-passed + 'interface-bad-concretization-1 + '(let* ([i1<%> (interface () [m (->m integer? integer?)])] + [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] + [c% (class* object% (i2<%>) (super-new) (define/public (m x) x))] + [c2% (class c% (super-new))]) + (send (new c2%) m 3) + (with-contract region + #:result integer? + (send (new c2%) m 3)))) + + (contract-error-test + 'interface-method-name-1 + #'(begin + (eval '(module imn-bug scheme/base + (require scheme/class) + (define i<%> (interface () [m (->m integer? integer?)])) + (define c% (class* object% (i<%>) (super-new) (define/public (m x) x))) + (send (new c%) m "foo"))) + (eval '(require 'imn-bug))) + (λ (x) + (and (exn:fail:contract:blame? x) + (regexp-match #rx"m: contract violation" (exn-message x)))))) \ No newline at end of file diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/list.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/list.rkt new file mode 100644 index 0000000000..4dd2427077 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/list.rkt @@ -0,0 +1,14 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace (make-basic-contract-namespace)]) + (test/no-error '(listof any/c)) + (test/no-error '(listof (lambda (x) #t))) + (test/no-error '(((lambda (x) x) listof) #t)) + (test/no-error '(non-empty-listof any/c)) + (test/no-error '(non-empty-listof (lambda (x) #t))) + + (test/no-error '(list/c 'x "x" #t #f #\c #rx"a" #rx#"b")) + + (test/pos-blame 'list1 '(contract (list/c 1 2) (list 1 3) 'pos 'neg)) + (test/no-error '(contract (list/c 1 2) (list 1 2) 'pos 'neg))) \ No newline at end of file diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/make-contract.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/make-contract.rkt new file mode 100644 index 0000000000..6253a9ba39 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/make-contract.rkt @@ -0,0 +1,205 @@ +#lang racket/base + +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace 'racket/contract)]) +(contract-eval + '(define proj:add1->sub1 + (make-contract + #:name 'proj:add1->sub1 + #:projection + (lambda (blame) + (lambda (f) + (unless (and (procedure? f) (procedure-arity-includes? f 1)) + (raise-blame-error blame f "expected a unary function, got: ~e" f)) + (lambda (x) + (unless (and (integer? x) (exact? x)) + (raise-blame-error (blame-swap blame) x + "expected an integer, got: ~e" x)) + (let* ([y (f (add1 x))]) + (unless (and (integer? y) (exact? y)) + (raise-blame-error blame y "expected an integer, got: ~e" y)) + (sub1 y))))) + #:first-order + (lambda (f) + (and (procedure? f) (procedure-arity-includes? f 1)))))) + +(test/spec-passed/result + 'make-contract-1 + '((contract proj:add1->sub1 sqrt 'pos 'neg) 15) + 3) + +(test/pos-blame + 'make-contract-2 + '(contract proj:add1->sub1 'dummy 'pos 'neg)) + +(test/pos-blame + 'make-contract-3 + '((contract proj:add1->sub1 (lambda (x) 'dummy) 'pos 'neg) 2)) + +(test/neg-blame + 'make-contract-4 + '((contract proj:add1->sub1 sqrt 'pos 'neg) 'dummy)) + +(ctest #t contract? proj:add1->sub1) +(ctest #f flat-contract? proj:add1->sub1) +(ctest #f chaperone-contract? proj:add1->sub1) +(ctest #t impersonator-contract? proj:add1->sub1) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; make-chaperone-contract +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(contract-eval + '(define proj:prime-box-list/c + (let* ([prime? (λ (n) + (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) + (not (= (remainder n m) 0))))] + [wrap-box (λ (blame b) + (chaperone-box + b + (λ (b v) + (unless (prime? v) + (raise-blame-error blame v + "expected prime, got ~v" v)) + v) + (λ (b v) + (unless (prime? v) + (raise-blame-error (blame-swap blame) v + "expected prime, got ~v" v)) + v)))]) + (make-chaperone-contract + #:name 'prime-box-list/c + #:first-order (λ (v) (and (list? v) (andmap box? v))) + #:projection (λ (blame) + (λ (v) + (unless (and (list? v) (andmap box? v)) + (raise-blame-error blame v + "expected list of boxes, got ~v" v)) + (map (λ (b) (wrap-box blame b)) v))))))) + +(test/spec-passed/result + 'make-chaperone-contract-1 + '(contract proj:prime-box-list/c + (list (box 2) (box 3) (box 5) (box 7)) + 'pos 'neg) + (list (box 2) (box 3) (box 5) (box 7))) + +(test/pos-blame + 'make-chaperone-contract-2 + '(let ([boxes (contract proj:prime-box-list/c + (list (box 2) (box 3) (box 4) (box 5)) + 'pos 'neg)]) + (unbox (caddr boxes)))) + +(test/neg-blame + 'make-chaperone-contract-3 + '(let ([boxes (contract proj:prime-box-list/c + (list (box 2) (box 3) (box 4) (box 5)) + 'pos 'neg)]) + (set-box! (caddr boxes) 6))) + +(ctest #t contract? proj:prime-box-list/c) +(ctest #f flat-contract? proj:prime-box-list/c) +(ctest #t chaperone-contract? proj:prime-box-list/c) +(ctest #f impersonator-contract? proj:prime-box-list/c) + +(contract-eval + '(define proj:bad-prime-box-list/c + (let* ([prime? (λ (n) + (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) + (not (= (remainder n m) 0))))] + [wrap-box (λ (blame b) (box (unbox b)))]) + (make-chaperone-contract + #:name 'bad-prime-box-list/c + #:first-order (λ (v) (and (list? v) (andmap box? v))) + #:projection (λ (blame) + (λ (v) + (unless (and (list? v) (andmap box? v)) + (raise-blame-error blame v + "expected list of boxes, got ~v" v)) + (map (λ (b) (wrap-box blame b)) v))))))) + +(ctest #t contract? proj:bad-prime-box-list/c) +(ctest #f flat-contract? proj:bad-prime-box-list/c) +(ctest #t chaperone-contract? proj:bad-prime-box-list/c) +(ctest #f impersonator-contract? proj:bad-prime-box-list/c) + +(contract-error-test + 'contract-error-test5 + '(contract proj:bad-prime-box-list/c (list (box 2) (box 3)) 'pos 'neg) + exn:fail?) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; make-flat-contract +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(contract-eval + '(define proj:prime/c + (let ([prime? (λ (n) + (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) + (not (= (remainder n m) 0))))]) + (make-flat-contract + #:name 'prime/c + #:first-order prime?)))) + +(test/spec-passed/result + 'make-flat-contract-1 + '(contract proj:prime/c 2 'pos 'neg) + 2) + +(test/pos-blame + 'make-flat-contract-2 + '(contract proj:prime/c 4 'pos 'neg)) + +(ctest #t contract? proj:prime/c) +(ctest #t flat-contract? proj:prime/c) + +(test/spec-passed/result + 'make-flat-contract-5 + '(chaperone-contract? proj:prime/c) + #t) + +;; Check to make sure that flat contracts always return the original value, +;; even if the projection is written badly. +(contract-eval + '(define proj:prime-list/c + (let ([prime? (λ (n) + (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) + (not (= (remainder n m) 0))))]) + (make-flat-contract + #:name 'prime-list/c + #:first-order (λ (v) (and (list? v) (andmap prime? v))) + #:projection (λ (b) + (λ (v) + (unless (and (list? v) (andmap prime? v)) + (raise-blame-error b v "expected prime list, got ~v" v)) + (map values v))))))) + +(test/spec-passed/result + 'make-flat-contract-bad-1 + '(contract proj:prime-list/c (list 2 3 5 7) 'pos 'neg) + (list 2 3 5 7)) + +(test/pos-blame + 'make-flat-contract-bad-2 + '(contract proj:prime-list/c (list 2 3 4 5) 'pos 'neg)) + +(test/spec-passed/result + 'make-flat-contract-bad-3 + '(let ([l (list 2 3 5 7)]) + (eq? l (contract proj:prime-list/c l 'pos 'neg))) + #t) + +(ctest #t contract? proj:prime-list/c) +(ctest #t flat-contract? proj:prime-list/c) + +(test/spec-passed/result + 'make-flat-contract-bad-6 + '(chaperone-contract? proj:prime-list/c) + #t)) \ No newline at end of file diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/make-proj-contract.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/make-proj-contract.rkt new file mode 100644 index 0000000000..f67d10d6d7 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/make-proj-contract.rkt @@ -0,0 +1,47 @@ +#lang racket/base + +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace 'racket/contract)]) + + (contract-eval + '(define proj:add1->sub1 + (make-proj-contract + 'proj:add1->sub1 + (lambda (pos neg src name blame) + (lambda (f) + (unless (and (procedure? f) (procedure-arity-includes? f 1)) + (raise-contract-error f src pos name + "expected a unary function, got: ~e" + f)) + (lambda (x) + (unless (and (integer? x) (exact? x)) + (raise-contract-error x src neg name + "expected an integer, got: ~e" + x)) + (let* ([y (f (add1 x))]) + (unless (and (integer? y) (exact? y)) + (raise-contract-error y src pos name + "expected an integer, got: ~e" + y)) + (sub1 y))))) + (lambda (f) + (and (procedure? f) (procedure-arity-includes? f 1)))))) + + (test/spec-passed/result + 'make-proj-contract-1 + '((contract proj:add1->sub1 sqrt 'pos 'neg) 15) + 3) + + (test/pos-blame + 'make-proj-contract-2 + '(contract proj:add1->sub1 'dummy 'pos 'neg)) + + (test/pos-blame + 'make-proj-contract-3 + '((contract proj:add1->sub1 (lambda (x) 'dummy) 'pos 'neg) 2)) + + (test/neg-blame + 'make-proj-contract-4 + '((contract proj:add1->sub1 sqrt 'pos 'neg) 'dummy))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/multi-file.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/multi-file.rkt new file mode 100644 index 0000000000..d862a8ddd4 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/multi-file.rkt @@ -0,0 +1,154 @@ +#lang racket/base +(require "test-util.rkt" + racket/file) + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace 'racket/contract)]) + + + (define exn:fail:contract:blame-object (contract-eval 'exn:fail:contract:blame-object)) + (define exn:fail:contract:blame? (contract-eval 'exn:fail:contract:blame?)) + + ;; build-and-run : (listof (cons/c string[filename] + ;; (cons/c string[lang-line] + ;; (listof sexp[body-of-module]))) + ;; -> any + ;; sets up the files named by 'test-case', dynamically requires the first one, deletes the files + ;; and returns/raises-the-exception from the require'd file + (define (build-and-run test-case) + (define dir (make-temporary-file "contract-test~a" 'directory)) + (for ([f (in-list test-case)]) + (call-with-output-file (build-path dir (car f)) + (lambda (port) + (display (cadr f) port) + (newline port) + (for ([sexp (in-list (cddr f))]) + (fprintf port "~s\n" sexp))))) + (dynamic-wind + void + (lambda () (contract-eval `(dynamic-require ,(build-path dir (car (car test-case))) #f))) + (lambda () + (for ([f (in-list test-case)]) + (delete-file (build-path dir (car f)))) + (delete-directory dir)))) + + (define (get-last-part-of-path sexp) + (define str (format "orig-blame: ~s" sexp)) + (define m (regexp-match #rx"[/\\]([-a-z0-9.]*)[^/\\]*$" str)) + (if m (cadr m) str)) + + ;; basic negative blame case + (let ([blame + (exn:fail:contract:blame-object + (with-handlers ((exn:fail:contract:blame? values)) + (build-and-run + (list (list "a.rkt" + "#lang racket/base" + '(require "b.rkt") + '(f #f)) + (list "b.rkt" + "#lang racket/base" + '(require racket/contract) + '(provide/contract [f (-> integer? integer?)]) + '(define (f x) 1))))))]) + (ctest "a.rkt" + 'multi-file-blame1-positive + (,get-last-part-of-path (blame-positive ,blame))) + (ctest "b.rkt" + 'multi-file-blame1-negative + (,get-last-part-of-path (blame-negative ,blame)))) + + ;; basic positive blame case + (let ([blame + (exn:fail:contract:blame-object + (with-handlers ((exn:fail:contract:blame? values)) + (build-and-run + (list (list "a.rkt" + "#lang racket/base" + '(require "b.rkt") + '(f 1)) + (list "b.rkt" + "#lang racket/base" + '(require racket/contract) + '(provide/contract [f (-> integer? integer?)]) + '(define (f x) #f))))))]) + (ctest "b.rkt" + 'multi-file-blame2-positive + (,get-last-part-of-path (blame-positive ,blame))) + (ctest "a.rkt" + 'multi-file-blame2-negative + (,get-last-part-of-path (blame-negative ,blame)))) + + ;; positive blame via a re-provide + (let ([blame + (exn:fail:contract:blame-object + (with-handlers ((exn:fail:contract:blame? values)) + (build-and-run + (list (list "a.rkt" + "#lang racket/base" + '(require "b.rkt") + '(f 1)) + (list "b.rkt" + "#lang racket/base" + '(require "c.rkt") + '(provide f)) + (list "c.rkt" + "#lang racket/base" + '(require racket/contract) + '(provide/contract [f (-> integer? integer?)]) + '(define (f x) #f))))))]) + (ctest "c.rkt" + 'multi-file-blame3-positive + (,get-last-part-of-path (blame-positive ,blame))) + (ctest "a.rkt" + 'multi-file-blame3-negative + (,get-last-part-of-path (blame-negative ,blame)))) + + ;; negative blame via a re-provide + (let ([blame + (exn:fail:contract:blame-object + (with-handlers ((exn:fail:contract:blame? values)) + (build-and-run + (list (list "a.rkt" + "#lang racket/base" + '(require "b.rkt") + '(f #f)) + (list "b.rkt" + "#lang racket/base" + '(require "c.rkt") + '(provide f)) + (list "c.rkt" + "#lang racket/base" + '(require racket/contract) + '(provide/contract [f (-> integer? integer?)]) + '(define (f x) 1))))))]) + (ctest "a.rkt" + 'multi-file-blame4-positive + (,get-last-part-of-path (blame-positive ,blame))) + (ctest "c.rkt" + 'multi-file-blame4-negative + (,get-last-part-of-path (blame-negative ,blame)))) + + ;; have some sharing in the require graph + (let ([blame + (exn:fail:contract:blame-object + (with-handlers ((exn:fail:contract:blame? values)) + (build-and-run + (list (list "client.rkt" + "#lang racket/base" + '(require "server.rkt" "other.rkt") + '(turn-init #f)) + (list "server.rkt" + "#lang racket/base" + '(require racket/contract) + '(provide/contract [turn-init (-> number? any)]) + '(define turn-init void)) + (list "other.rkt" + "#lang racket/base" + '(require "server.rkt"))))))]) + (ctest "client.rkt" + 'multi-file-blame5-positive + (,get-last-part-of-path (blame-positive ,blame))) + (ctest "server.rkt" + 'multi-file-blame5-negative + (,get-last-part-of-path (blame-negative ,blame))))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/name.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/name.rkt new file mode 100644 index 0000000000..3ec4281253 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/name.rkt @@ -0,0 +1,379 @@ +#lang racket/base +(require "test-util.rkt" + (for-syntax racket/base)) + +(define-syntax (test-name stx) + (syntax-case stx () + [(_ name contract) + #'(do-name-test 'name 'contract)])) + +(define (do-name-test name contract-exp) + (contract-eval `(,test ,name contract-name ,contract-exp)) + (contract-eval `(,test ,name contract-name (opt/c ,contract-exp)))) + +(parameterize ([current-contract-namespace (make-basic-contract-namespace + 'racket/contract + 'racket/set + 'racket/class)]) + (test-name 'integer? (flat-contract integer?)) + (test-name 'boolean? (flat-contract boolean?)) + (test-name 'char? (flat-contract char?)) + (test-name 'any/c any/c) + + (test-name '(or/c) (or/c)) + (test-name '(or/c integer? gt0?) (or/c integer? (let ([gt0? (lambda (x) (> x 0))]) gt0?))) + (test-name '(or/c integer? boolean?) + (or/c (flat-contract integer?) + (flat-contract boolean?))) + (test-name '(or/c (-> (>=/c 5) (>=/c 5)) boolean?) + (or/c (-> (>=/c 5) (>=/c 5)) boolean?)) + (test-name '(or/c boolean? (-> (>=/c 5) (>=/c 5))) + (or/c boolean? (-> (>=/c 5) (>=/c 5)))) + + (test-name 'mumble (let ([frotz/c integer?] + [bazzle/c boolean?]) + (flat-named-contract 'mumble + (and/c frotz/c + (not/c bazzle/c))))) + + + (test-name '(-> integer? integer?) (-> integer? integer?)) + (test-name '(-> integer? any) (-> integer? any)) + (test-name '(-> integer? (values boolean? char?)) (-> integer? (values boolean? char?))) + (test-name '(-> integer? boolean? (values char? any/c)) + (->* (integer? boolean?) () (values char? any/c))) + (test-name '(-> integer? boolean? any) (->* (integer? boolean?) () any)) + (test-name '(-> integer? boolean? #:x string? any) (-> integer? #:x string? boolean? any)) + + (test-name '(->* (integer?) (string?) #:rest any/c (values char? any/c)) + (->* (integer?) (string?) #:rest any/c (values char? any/c))) + (test-name '(->* (integer? char?) (boolean?) any) (->* (integer? char?) (boolean?) any)) + (test-name '(->* (integer? char? #:z string?) (integer?) any) + (->* (#:z string? integer? char?) (integer?) any)) + (test-name '(->* (integer? char? #:z string?) (boolean? #:i number?) any) + (->* (#:z string? integer? char?) (boolean? #:i number?) any)) + (test-name '(->* (integer? char? #:z string?) (boolean? #:i number?) #:rest (listof integer?) any) + (->* (#:z string? integer? char?) (boolean? #:i number?) #:rest (listof integer?) any)) + (test-name '(->* (integer? char? #:z string?) (boolean? #:i number?) + (values number? boolean? symbol?)) + (->* (#:z string? integer? char?) (boolean? #:i number?) + (values number? boolean? symbol?))) + (test-name '(->* (integer? char? #:z string?) (boolean? #:i number?) #:rest (listof integer?) + (values number? boolean? symbol?)) + (->* (#:z string? integer? char?) (boolean? #:i number?) #:rest (listof integer?) + (values number? boolean? symbol?))) + + (test-name '(->* (integer?) #:pre ... integer?) + (->* (integer?) () #:pre (= 1 2) integer?)) + (test-name '(->* (integer?) integer? #:post ...) + (->* (integer?) () integer? #:post #f)) + (test-name '(->* (integer?) #:pre ... integer? #:post ...) + (->* (integer?) () #:pre (= 1 2) integer? #:post #f)) + + (test-name '(->d () () any) (->d () () any)) + (test-name '(->d ([x ...] #:y [y ...]) ([z ...] #:w [w ...]) any) + (->d ([x integer?] #:y [y integer?]) ([z integer?] #:w [w integer?]) any)) + (test-name '(->d () () (values [x ...] [y ...])) (->d () () (values [x number?] [y number?]))) + (test-name '(->d () () [x ...]) (->d () () [q number?])) + (test-name '(->d () () #:pre ... [x ...]) (->d () () #:pre #t [q number?])) + (test-name '(->d () () #:pre ... [x ...] #:post ...) (->d () () #:pre #t [q number?] #:post #t)) + (test-name '(->d () () [x ...] #:post ...) (->d () () [q number?] #:post #t)) + + (test-name '(->i () any) (->i () () any)) + (test-name '(->i () any) (->i () any)) + (test-name '(->i () [x () ...]) + (->i () () [x () number?])) + (test-name '(->i () [q number?]) + (->i () () [q number?])) + (test-name '(->i () (values [x number?] [y number?])) + (->i () (values [x number?] [y number?]))) + (test-name '(->i () (values [x (y) ...] [y number?])) + (->i () (values [x (y) number?] [y number?]))) + (test-name '(->i ([x integer?] #:y [y integer?]) ([z integer?] #:w [w integer?]) any) + (->i ([x integer?] #:y [y integer?]) ([z integer?] #:w [w integer?]) any)) + (test-name '(->i () #:pre () ... [q number?]) + (->i () #:pre () #t [q number?])) + (test-name '(->i () #:pre () ... [q () ...] #:post () ...) + (->i () #:pre () #t [q () number?] #:post () #t)) + (test-name '(->i ([x integer?]) #:pre (x) ... [q (x) ...] #:post (x) ...) + (->i ([x integer?]) #:pre (x) #t [q (x) number?] #:post (x) #t)) + (test-name '(->i ([x real?]) [_ (x) ...]) + (->i ([x real?]) [_ (x) (>/c x)])) + (test-name '(->i ([x any/c]) #:pre/name (x) "pair" ... #:pre/name (x) "car" ... any) + (->i ([x any/c]) #:pre/name (x) "pair" (pair? x) #:pre/name (x) "car" (car x) any)) + (test-name '(->i ([x any/c]) [y () ...] #:post/name (y) "pair" ... #:post/name (y) "car" ...) + (->i ([x any/c]) [y () any/c] #:post/name (y) "pair" (pair? y) + #:post/name (y) "car" (car y))) + + (test-name '(case->) (case->)) + (test-name '(case-> (-> integer? any) (-> boolean? boolean? any) (-> char? char? char? any)) + (case-> (-> integer? any) (-> boolean? boolean? any) (-> char? char? char? any))) + (test-name '(case-> (-> integer? integer?) (-> integer? integer? integer?)) + (case-> (-> integer? integer?) (-> integer? integer? integer?))) + (test-name '(case-> (-> integer? #:rest any/c any)) (case-> (-> integer? #:rest any/c any))) + (test-name '(case-> (-> integer? #:rest any/c (values boolean? char? number?))) + (case-> (-> integer? #:rest any/c (values boolean? char? number?)))) + (test-name '(case-> (-> integer? (values))) (case-> (-> integer? (values)))) + + (test-name '(unconstrained-domain-> number?) (unconstrained-domain-> number?)) + + (test-name '(or/c) (or/c)) + (test-name '(or/c '()) (or/c '())) + (test-name '(or/c integer? gt0?) (or/c integer? (let ([gt0? (lambda (x) (> x 0))]) gt0?))) + (test-name '(or/c integer? boolean?) + (or/c (flat-contract integer?) + (flat-contract boolean?))) + (test-name '(or/c integer? boolean?) + (or/c integer? boolean?)) + (test-name '(or/c (-> (>=/c 5) (>=/c 5)) boolean?) + (or/c (-> (>=/c 5) (>=/c 5)) boolean?)) + (test-name '(or/c boolean? (-> (>=/c 5) (>=/c 5))) + (or/c boolean? (-> (>=/c 5) (>=/c 5)))) + (test-name '(or/c (-> (>=/c 5) (>=/c 5)) + (-> (<=/c 5) (<=/c 5) (<=/c 5))) + (or/c (-> (>=/c 5) (>=/c 5)) + (-> (<=/c 5) (<=/c 5) (<=/c 5)))) + (test-name '(or/c boolean? + (-> (>=/c 5) (>=/c 5)) + (-> (<=/c 5) (<=/c 5) (<=/c 5))) + (or/c boolean? + (-> (>=/c 5) (>=/c 5)) + (-> (<=/c 5) (<=/c 5) (<=/c 5)))) + + (test-name 'any/c (and/c)) + (test-name '(and/c any/c) (and/c any/c)) + (test-name '(and/c any/c any/c) (and/c any/c any/c)) + (test-name '(and/c number? integer?) (and/c number? integer?)) + (test-name '(and/c number? integer?) (and/c (flat-contract number?) + (flat-contract integer?))) + (test-name '(and/c number? (-> integer? integer?)) (and/c number? (-> integer? integer?))) + (test-name '(and/c (-> boolean? boolean?) (-> integer? integer?)) + (and/c (-> boolean? boolean?) (-> integer? integer?))) + + (test-name '(not/c integer?) (not/c integer?)) + (test-name '(=/c 5) (=/c 5)) + (test-name '(>=/c 5) (>=/c 5)) + (test-name '(<=/c 5) (<=/c 5)) + (test-name '(/c 5) (>/c 5)) + (test-name '(between/c 5 6) (between/c 5 6)) + (test-name '(between/c -inf.0 +inf.0) (between/c -inf.0 +inf.0)) + (test-name '(integer-in 0 10) (integer-in 0 10)) + (test-name '(between/c 1 10) (real-in 1 10)) + (test-name '(string-len/c 3) (string-len/c 3)) + (test-name 'natural-number/c natural-number/c) + (test-name #f false/c) + (test-name #t #t) + (test-name #\a #\a) + (test-name "x" "x") + (test-name ''x 'x) + (test-name #rx"x" #rx"x") + (test-name #rx#"x" #rx#"x") + (test-name 'printable/c printable/c) + (test-name '(or/c 'a 'b 'c) (symbols 'a 'b 'c)) + (test-name '(or/c 1 2 3) (one-of/c 1 2 3)) + (test-name '(or/c '() 'x 1 #f #\a void? undefined?) + (one-of/c '() 'x 1 #f #\a (void) (letrec ([x x]) x))) + + (test-name '(or/c #f #t #\a "x") (or/c #f #t #\a "x")) + (test-name '(or/c #f #t #\a "x" #rx"x" #rx#"x") (or/c #f #t #\a "x" #rx"x" #rx#"x")) + + (test-name '(subclass?/c c%) + (let ([c% (class object% (super-new))]) (subclass?/c c%))) + + (test-name '(implementation?/c i<%>) + (let ([i<%> (interface ())]) + (implementation?/c i<%>))) + + (test-name '(is-a?/c i<%>) + (let ([i<%> (interface ())]) + (is-a?/c i<%>))) + (test-name '(is-a?/c 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)) + (test-name '(listof boolean?) (listof boolean?)) + (test-name '(listof any/c) (listof any/c)) + (test-name '(listof boolean?) (listof boolean?)) + (test-name '(listof (-> boolean? boolean?)) (listof (-> boolean? boolean?))) + + (test-name '(non-empty-listof boolean?) (non-empty-listof boolean?)) + (test-name '(non-empty-listof any/c) (non-empty-listof any/c)) + (test-name '(non-empty-listof boolean?) (non-empty-listof boolean?)) + (test-name '(non-empty-listof any/c) (non-empty-listof any/c)) + (test-name '(non-empty-listof boolean?) (non-empty-listof boolean?)) + (test-name '(non-empty-listof (-> boolean? boolean?)) (non-empty-listof (-> boolean? boolean?))) + + + (test-name '(vectorof boolean?) (vectorof boolean?)) + (test-name '(vectorof any/c) (vectorof any/c)) + + (test-name '(vector/c boolean? integer?) (vector/c boolean? integer?)) + (test-name '(vector/c boolean? integer?) (vector/c boolean? (flat-contract integer?))) + + (test-name '(cons/c boolean? integer?) (cons/c boolean? (flat-contract integer?))) + (test-name '(cons/c boolean? integer?) (cons/c boolean? (flat-contract integer?))) + (test-name '(list/c boolean? integer?) (list/c boolean? (flat-contract integer?))) + (test-name '(list/c boolean? integer?) (list/c boolean? (flat-contract integer?))) + + (test-name '(cons/c boolean? integer?) (cons/c boolean? (flat-contract integer?))) + (test-name '(cons/c boolean? integer?) (cons/c boolean? (flat-contract integer?))) + (test-name '(cons/c boolean? integer?) (cons/c boolean? (flat-contract integer?))) + (test-name '(cons/c (-> boolean? boolean?) integer?) (cons/c (-> boolean? boolean?) integer?)) + + (test-name '(list/c boolean? integer?) + (list/c boolean? (flat-contract integer?))) + (test-name '(list/c boolean? integer?) + (list/c boolean? (flat-contract integer?))) + (test-name '(list/c boolean? integer?) + (list/c boolean? (flat-contract integer?))) + (test-name '(list/c (-> boolean? boolean?) integer?) + (list/c (-> boolean? boolean?) integer?)) + + (test-name '(parameter/c integer?) (parameter/c integer?)) + (test-name '(parameter/c integer? string?) (parameter/c integer? string?)) + + (test-name '(hash/c symbol? boolean?) (hash/c symbol? boolean?)) + (test-name '(hash/c symbol? boolean? #:immutable #t) (hash/c symbol? boolean? #:immutable #t)) + (test-name '(hash/c symbol? boolean? #:immutable #f) (hash/c symbol? boolean? #:immutable #f)) + (test-name '(hash/c symbol? boolean?) (hash/c symbol? boolean? #:immutable 'dont-care)) + + (test-name '(box/c boolean?) (box/c boolean?)) + (test-name '(box/c boolean?) (box/c (flat-contract boolean?))) + (test-name 'the-name (flat-rec-contract the-name)) + + (test-name '(object-contract) (object-contract)) + (test-name '(object-contract (field x integer?)) (object-contract (field x integer?))) + (test-name '(object-contract (m (-> integer? integer?))) + (object-contract (m (-> integer? integer?)))) + (test-name '(object-contract (m (-> integer? any))) + (object-contract (m (-> integer? any)))) + (test-name '(object-contract (m (-> integer? (values integer? integer?)))) + (object-contract (m (-> integer? (values integer? integer?))))) + (test-name '(object-contract (m (case-> (-> integer? integer? integer?) + (-> integer? (values integer? integer?))))) + (object-contract (m (case-> + (-> integer? integer? integer?) + (-> integer? (values integer? integer?)))))) + (test-name + '(object-contract (m (->* (integer?) (boolean? number?) symbol?))) + (object-contract (m (->* (integer?) (boolean? number?) symbol?)))) + + (test-name '(object-contract (m (->d ((x ...)) () (y ...)))) + (object-contract (m (->d ((x number?)) () [result number?])))) + (test-name '(object-contract (m (->d ((x ...) (y ...) (z ...)) () [w ...]))) + (object-contract (m (->d ((x number?) (y boolean?) (z pair?)) () [result number?])))) + (test-name '(object-contract (m (->d ((x ...) (y ...) (z ...)) () #:rest w ... [x0 ...]))) + (object-contract (m (->d ((x number?) (y boolean?) (z pair?)) () + #:rest rest-x any/c [result number?])))) + + (test-name '(object-contract (m (->i ((x number?)) (result number?)))) + (object-contract (m (->i ((x number?)) () [result number?])))) + (test-name '(object-contract (m (->i ((x number?) (y boolean?) (z pair?)) [result number?]))) + (object-contract (m (->i ((x number?) (y boolean?) (z pair?)) () [result number?])))) + (test-name '(object-contract (m (->i ((x number?) (y boolean?) (z pair?)) + #:rest [rest-x any/c] [result number?]))) + (object-contract (m (->i ((x number?) (y boolean?) (z pair?)) () + #:rest [rest-x any/c] [result number?])))) + + (test-name '(promise/c any/c) (promise/c any/c)) + (test-name '(syntax/c any/c) (syntax/c any/c)) + (test-name '(struct/c st integer?) + (let () + (define-struct st (a)) + (struct/c st integer?))) + + (test-name '(recursive-contract (box/c boolean?)) (recursive-contract (box/c boolean?))) + (test-name '(recursive-contract boolean? #:flat) (let ([c (recursive-contract boolean? #:flat)]) + (contract c #f 'pos 'neg) + c)) + (test-name '(recursive-contract x) (let ([x (box/c boolean?)]) (recursive-contract x))) + (test-name '(recursive-contract integeeer?) + (let ([x (box/c boolean?)]) + (let ([c (recursive-contract (flat-named-contract 'integeeer? integer?))]) + (contract c 1 'pos 'neg) + c))) + (test-name '(recursive-contract (or/c (flat-named-contract 'integeeer? integer?) + (listof c))) + (letrec ([c (recursive-contract + (or/c (flat-named-contract 'integeeer? integer?) + (listof c)))]) + c)) + (test-name '(recursive-contract (or/c integeeer? (listof c))) + (letrec ([c (recursive-contract + (or/c (flat-named-contract 'integeeer? integer?) + (listof c)))]) + (contract c 1 'pos 'neg) + c)) + + (contract-eval '(define-contract-struct couple (hd tl))) + (test-name '(couple/c any/c any/c) + (couple/c any/c any/c)) + (test-name '(couple/c any/c any/c) + (couple/dc [hd any/c] [tl any/c])) + (test-name '(couple/dc [hd any/c] [tl ...]) + (couple/dc [hd any/c] [tl (hd) any/c])) + + (test-name '(set/c integer?) (set/c integer?)) + (test-name '(set/c boolean? #:cmp 'equal) (set/c boolean? #:cmp 'equal)) + (test-name '(set/c char? #:cmp 'eq) (set/c char? #:cmp 'eq)) + (test-name '(set/c (set/c char?) #:cmp 'eqv) (set/c (set/c char? #:cmp 'dont-care) #:cmp 'eqv)) + (test-name '(set/c (-> char? char?) #:cmp 'equal) (set/c (-> char? char?) #:cmp 'equal)) + + (test-name '(class/c [m (->m integer? integer?)]) (class/c [m (->m integer? integer?)])) + (test-name '(class/c [m (->*m (integer?) (integer?) integer?)]) + (class/c [m (->*m (integer?) (integer?) integer?)])) + (test-name '(class/c [m (case->m (-> integer? integer?) (-> integer? integer? integer?))]) + (class/c [m (case->m (-> integer? integer?) (-> integer? integer? integer?))])) + (test-name '(class/c [m (->dm ((x ...)) () (y ...))]) + (class/c [m (->dm ([d integer?]) () [r integer?])])) + (test-name 'c%/c (let ([c%/c (class/c [m (->m integer? integer?)])]) + c%/c)) + + (test-name '(struct/dc s + [a integer?] + [b symbol?] + [c (a b) ...] + [d (a b c) ...]) + (let () + (struct s (a b c d)) + (struct/dc s + [a integer?] + [b symbol?] + [c (a b) boolean?] + [d (a b c) integer?]))) + + (test-name '(struct/dc s + [a integer?] + [b #:lazy symbol?] + [c (a) ...] + [d (a c) ...]) + (let () + (struct s (a b c d)) + (struct/dc s + [a integer?] + [b #:lazy symbol?] + [c (a) boolean?] + [d (a c) integer?]))) + + ;; NOT YET RELEASED + #; + (test-name '(pr/dc [x integer?] + [y integer?] + where + [x-val ...] + [y-val ...] + and + ...) + (let () + (define-contract-struct pr (x y)) + (pr/dc [x integer?] + [y integer?] + where + [x-val x] + [y-val y] + and + (= x-val y-val))))) \ No newline at end of file diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/object-contract.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/object-contract.rkt new file mode 100644 index 0000000000..ac2237a6b3 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/object-contract.rkt @@ -0,0 +1,1483 @@ +#lang racket/base + +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace 'racket/class)]) + +(test/spec-passed + 'object-contract0 + '(contract (object-contract) + (new object%) + 'pos + 'neg)) + +(test/pos-blame + 'object-contract/field1 + '(contract (object-contract (field x integer?)) + (new object%) + 'pos + 'neg)) + +(test/pos-blame + 'object-contract/field2 + '(get-field + x + (contract (object-contract (field x integer?)) + (new (class object% (field [x #t]) (super-new))) + 'pos + 'neg))) + +(test/spec-passed/result + 'object-contract/field3 + '(get-field + x + (contract (object-contract (field x integer?)) + (new (class object% (field [x 12]) (super-new))) + 'pos + 'neg)) + 12) + +(test/pos-blame + 'object-contract/field4 + '(get-field + y + (contract (object-contract (field x boolean?) (field y boolean?)) + (new (class object% (field [x #t] [y 'x]) (super-new))) + 'pos + 'neg))) + +(test/pos-blame + 'object-contract/field5 + '(get-field + x + (contract (object-contract (field x symbol?) (field y symbol?)) + (new (class object% (field [x #t] [y 'x]) (super-new))) + 'pos + 'neg))) + +(test/spec-passed/result + 'object-contract/field6 + '(let ([o (contract (object-contract [m (integer? . -> . integer?)]) + (new (class object% (field [x 1]) (define/public (m y) x) (super-new))) + 'pos + 'neg)]) + (list (send o m 2) + (send/apply o m '(2)) + (let ([x '(2)]) (send o m . x)) + (with-method ([mm (o m)]) + (mm 2)) + (send* o (m 3) (m 4)))) + (list 1 1 1 1 1)) + +(test/spec-passed/result + 'object-contract/field7 + '(let ([o (contract (object-contract) + (new (class object% (field [x 1]) (define/public (m y) x) (super-new))) + 'pos + 'neg)]) + (list (send o m 2) + (send/apply o m '(2)) + (let ([x '(2)]) (send o m . x)) + (with-method ([mm (o m)]) + (mm 2)) + (send* o (m 3) (m 4)))) + (list 1 1 1 1 1)) + +(test/spec-passed/result + 'object-contract/field8 + '(let ([o (contract (object-contract [m (integer? . -> . integer?)]) + (new (class object% (define x 6) (define/public (m y) x) (super-new))) + 'pos + 'neg)]) + (list (send o m 2) + (send/apply o m '(2)) + (let ([x '(2)]) (send o m . x)) + (with-method ([mm (o m)]) + (mm 2)) + (send* o (m 3) (m 4)))) + (list 6 6 6 6 6)) + +(test/spec-passed/result + 'object-contract/field9 + '(let ([o (contract (object-contract) + (new (class object% (define x 6) (define/public (m y) x) (super-new))) + 'pos + 'neg)]) + (list (send o m 2) + (send/apply o m '(2)) + (let ([x '(2)]) (send o m . x)) + (with-method ([mm (o m)]) + (mm 2)) + (send* o (m 3) (m 4)))) + (list 6 6 6 6 6)) + +(test/spec-passed/result + 'object-contract/field10 + '(send (contract (object-contract) + (new (class object% (define x 1) (define/public (m y) x) (super-new))) + 'pos + 'neg) + m + 2) + 1) + +(test/spec-passed/result + 'object-contract->1 + '(send + (contract (object-contract (m (integer? . -> . integer?))) + (new (class object% (define/public (m x) x) (super-new))) + 'pos + 'neg) + m + 1) + 1) + +(test/pos-blame + 'object-contract->2 + '(contract (object-contract (m (integer? . -> . integer?))) + (make-object object%) + 'pos + 'neg)) + +(test/neg-blame + 'object-contract->3 + '(send + (contract (object-contract (m (integer? . -> . integer?))) + (make-object (class object% (define/public (m x) x) (super-new))) + 'pos + 'neg) + m + 'x)) + +(test/pos-blame + 'object-contract->4 + '(send + (contract (object-contract (m (integer? . -> . integer?))) + (make-object (class object% (define/public (m x) 'x) (super-new))) + 'pos + 'neg) + m + 1)) + +(test/pos-blame + 'object-contract->5 + '(contract (object-contract (m (integer? integer? . -> . integer?))) + (make-object (class object% (define/public (m x) 'x) (super-new))) + 'pos + 'neg)) + +(test/spec-passed/result + 'object-contract->6 + '(send + (contract (object-contract (m (integer? . -> . any))) + (new (class object% (define/public (m x) x) (super-new))) + 'pos + 'neg) + m + 1) + 1) + +(test/neg-blame + 'object-contract->7 + '(send + (contract (object-contract (m (integer? . -> . any))) + (make-object (class object% (define/public (m x) x) (super-new))) + 'pos + 'neg) + m + 'x)) + +(test/spec-passed + 'object-contract->8 + '(begin + (send + (contract (object-contract (m (integer? . -> . any))) + (make-object (class object% (define/public (m x) (values 1 2)) (super-new))) + 'pos + 'neg) + m + 1) + (void))) + +(test/spec-passed + 'object-contract->9 + '(begin + (send + (contract (object-contract (m (integer? . -> . any))) + (make-object (class object% (define/public (m x) (values)) (super-new))) + 'pos + 'neg) + m + 1) + (void))) + +(test/spec-passed + 'object-contract->10 + '(begin + (send (contract (object-contract (m (integer? . -> . (values integer? boolean?)))) + (make-object (class object% (define/public (m x) (values 1 #t)) (super-new))) + 'pos + 'neg) + m 1) + (void))) + +(test/neg-blame + 'object-contract->11 + '(send + (contract (object-contract (m (integer? . -> . (values integer? boolean?)))) + (make-object (class object% (define/public (m x) (values #t #t)) (super-new))) + 'pos + 'neg) + m + #f)) + +(test/pos-blame + 'object-contract->12 + '(send + (contract (object-contract (m (integer? . -> . (values integer? boolean?)))) + (make-object (class object% (define/public (m x) (values #t #t)) (super-new))) + 'pos + 'neg) + m + 1)) + +(test/pos-blame + 'object-contract->13 + '(send (contract (object-contract (m (integer? . -> . (values integer? boolean?)))) + (make-object (class object% (define/public (m x) (values #f #t)) (super-new))) + 'pos + 'neg) + m 1)) + +(test/pos-blame + 'object-contract->14 + '(send (contract (object-contract (m (integer? . -> . (values integer? boolean?)))) + (make-object (class object% (define/public (m x) (values 5 6)) (super-new))) + 'pos + 'neg) + m 1)) + +(test/pos-blame + 'object-contract-case->1 + '(contract (object-contract (m (case-> (boolean? . -> . boolean?) + (integer? integer? . -> . integer?)))) + (new object%) + 'pos + 'neg)) + +(test/pos-blame + 'object-contract-case->2 + '(contract (object-contract (m (case-> (boolean? . -> . boolean?) + (integer? integer? . -> . integer?)))) + (new (class object% (define/public (m x) x) (super-new))) + 'pos + 'neg)) + +(test/pos-blame + 'object-contract-case->3 + '(contract (object-contract (m (case-> (boolean? . -> . boolean?) + (integer? integer? . -> . integer?)))) + (new (class object% (define/public (m x y) x) (super-new))) + 'pos + 'neg)) + +(test/spec-passed + 'object-contract-case->4 + '(contract (object-contract (m (case-> (boolean? . -> . boolean?) + (integer? integer? . -> . integer?)))) + (new (class object% + (define/public m + (case-lambda + [(b) (not b)] + [(x y) (+ x y)])) + (super-new))) + 'pos + 'neg)) + +(test/spec-passed/result + 'object-contract-case->5 + '(send (contract (object-contract (m (case-> (boolean? . -> . boolean?) + (integer? integer? . -> . integer?)))) + (new (class object% + (define/public m + (case-lambda + [(b) (not b)] + [(x y) (+ x y)])) + (super-new))) + 'pos + 'neg) + m + #t) + #f) + +(test/spec-passed/result + 'object-contract-case->6 + '(send (contract (object-contract (m (case-> (boolean? . -> . boolean?) + (integer? integer? . -> . integer?)))) + (new (class object% + (define/public m + (case-lambda + [(b) (not b)] + [(x y) (+ x y)])) + (super-new))) + 'pos + 'neg) + m + 3 + 4) + 7) + +(test/pos-blame + 'object-contract->*1 + '(contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) + (new (class object% + (define/public m + (lambda (x [y 'a]) + x)) + (super-new))) + 'pos + 'neg)) + +(test/pos-blame + 'object-contract->*2 + '(contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) + (new (class object% + (define/public m + (lambda (x y [z #t]) + x)) + (super-new))) + 'pos + 'neg)) + +(test/spec-passed + 'object-contract->*3 + '(contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) + (new (class object% + (define/public m + (lambda (x [y 'a] [z #t]) + x)) + (super-new))) + 'pos + 'neg)) + +(test/spec-passed/result + 'object-contract->*4 + '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) + (new (class object% + (define/public m + (lambda (x [y 'a] [z #t]) + x)) + (super-new))) + 'pos + 'neg) + m + 1) + 1) + +(test/spec-passed/result + 'object-contract->*5 + '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) + (new (class object% + (define/public m + (lambda (x [y 'a] [z #t]) + x)) + (super-new))) + 'pos + 'neg) + m + 2 + 'z) + 2) + +(test/spec-passed/result + 'object-contract->*7 + '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) + (new (class object% + (define/public m + (lambda (x [y 'a] [z #t]) + x)) + (super-new))) + 'pos + 'neg) + m + 3 + 'z + #f) + 3) + +(test/neg-blame + 'object-contract->*8 + '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) + (new (class object% + (define/public m + (lambda (x [y 'a] [z #t]) + x)) + (super-new))) + 'pos + 'neg) + m + #f)) + +(test/neg-blame + 'object-contract->*9 + '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) + (new (class object% + (define/public m + (lambda (x [y 'a] [z #t]) + x)) + (super-new))) + 'pos + 'neg) + m + 2 + 4)) + +(test/neg-blame + 'object-contract->*10 + '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) + (new (class object% + (define/public m + (lambda (x [y 'a] [z #t]) + x)) + (super-new))) + 'pos + 'neg) + m + 3 + 'z + 'y)) + +(test/pos-blame + 'object-contract->*11 + '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) + (new (class object% + (define/public m + (lambda (x [y 'a] [z #t]) + 'x)) + (super-new))) + 'pos + 'neg) + m + 3 + 'z + #f)) + +(test/spec-passed/result + 'object-contract->*12 + '(let-values ([(x y) + (send (contract (object-contract + (m (->* (integer?) (symbol? boolean?) (values number? symbol?)))) + (new (class object% + (define/public m + (lambda (x [y 'a] [z #t]) + (values 1 'x))) + (super-new))) + 'pos + 'neg) + m + 3 + 'z + #f)]) + (cons x y)) + (cons 1 'x)) + +(test/pos-blame + 'object-contract->*13 + '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) (values number? symbol?)))) + (new (class object% + (define/public m + (lambda (x [y 'a] [z #t]) + (values 'x 'x))) + (super-new))) + 'pos + 'neg) + m + 3 + 'z + #f)) + +(test/pos-blame + 'object-contract->*14 + '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) + (values number? symbol?)))) + (new (class object% + (define/public m + (lambda (x [y 'a] [z #t]) + (values 1 1))) + (super-new))) + 'pos + 'neg) + m + 3 + 'z + #f)) + +(test/pos-blame + 'object-contract->*1 + '(contract (object-contract (m (-> integer? boolean?))) + (new (class object% (define/public (m x y) x) (super-new))) + 'pos + 'neg)) + +(test/neg-blame + 'object-contract->*2 + '(send (contract (object-contract (m (-> integer? boolean?))) + (new (class object% (define/public (m x) x) (super-new))) + 'pos + 'neg) + m #f)) + +(test/pos-blame + 'object-contract->*3 + '(send (contract (object-contract (m (-> integer? boolean?))) + (new (class object% (define/public (m x) x) (super-new))) + 'pos + 'neg) + m 1)) + +(test/spec-passed + 'object-contract->*4 + '(send (contract (object-contract (m (-> integer? boolean?))) + (new (class object% (define/public (m x) #f) (super-new))) + 'pos + 'neg) + m 1)) + +(test/pos-blame + 'object-contract->*5 + '(contract (object-contract (m (->* (integer?) () #:rest any/c boolean?))) + (new (class object% (define/public (m x y . z) x) (super-new))) + 'pos + 'neg)) + +(test/neg-blame + 'object-contract->*6 + '(send (contract (object-contract (m (->* (integer?) () #:rest any/c boolean?))) + (new (class object% (define/public (m x . z) x) (super-new))) + 'pos + 'neg) + m #t)) + +(test/pos-blame + 'object-contract->*7 + '(send (contract (object-contract (m (->* (integer?) () #:rest any/c boolean?))) + (new (class object% (define/public (m x . z) 1) (super-new))) + 'pos + 'neg) + m 1)) + +(test/spec-passed + 'object-contract->*8 + '(send (contract (object-contract (m (->* (integer?) () #:rest any/c boolean?))) + (new (class object% (define/public (m x . z) #f) (super-new))) + 'pos + 'neg) + m 1)) + +(test/spec-passed + 'object-contract->*9 + '(send (contract (object-contract (m (->* () () #:rest (listof number?) boolean?))) + (new (class object% (define/public (m . z) #f) (super-new))) + 'pos + 'neg) + m 1 2 3)) + +(test/neg-blame + 'object-contract->*10 + '(send (contract (object-contract (m (->* () () #:rest (listof number?) boolean?))) + (new (class object% (define/public (m . z) #f) (super-new))) + 'pos + 'neg) + m + #t)) + +(test/spec-passed + 'object-contract-->d1 + '(send (contract (object-contract (m (->d ([x number?]) () [range (<=/c x)]))) + (new (class object% (define/public m (lambda (x) (- x 1))) (super-new))) + 'pos + 'neg) + m + 1)) + +(test/spec-passed + 'object-contract-->d1b + '(send (contract (object-contract (m (->d ([x number?]) () [range (<=/c x)]))) + (new (class object% (define/public m (lambda (x) (- x 1))) (super-new))) + 'pos + 'neg) + m + 1)) + +(test/pos-blame + 'object-contract-->d2 + '(send (contract (object-contract (m (->d ([x number?]) () [range (<=/c x)]))) + (new (class object% (define/public m (lambda (x) (+ x 1))) (super-new))) + 'pos + 'neg) + m + 1)) + +(test/pos-blame + 'object-contract-->d2b + '(send (contract (object-contract (m (->d ([x number?]) () [range (<=/c x)]))) + (new (class object% (define/public m (lambda (x) (+ x 1))) (super-new))) + 'pos + 'neg) + m + 1)) + +(test/spec-passed + 'object-contract-->d3 + '(send (contract (object-contract (m (->d () () #:rest rst (listof number?) [range any/c]))) + (new (class object% (define/public m (lambda w 1)) (super-new))) + 'pos + 'neg) + m + 1)) + +(test/neg-blame + 'object-contract-->d4 + '(send (contract (object-contract (m (->d () () #:rest rst (listof number?) [range any/c]))) + (new (class object% (define/public m (lambda w 1)) (super-new))) + 'pos + 'neg) + m + #f)) + +(test/spec-passed + 'object-contract-->d5 + '(send (contract (object-contract (m (->d () () any))) + (new (class object% (define/public m (lambda () 1)) (super-new))) + 'pos + 'neg) + m)) + +(test/spec-passed + 'object-contract-->d6 + '(send (contract (object-contract (m (->d () () (values [x number?] [y (>=/c x)])))) + (new (class object% (define/public m (lambda () (values 1 2))) (super-new))) + 'pos + 'neg) + m)) + +(test/pos-blame + 'object-contract-->d7 + '(send (contract (object-contract (m (->d () () (values [x number?] [y (>=/c x)])))) + (new (class object% (define/public m (lambda () (values 2 1))) (super-new))) + 'pos + 'neg) + m)) + +(test/neg-blame + 'object-contract-->d/this-1 + '(send (contract (object-contract + (m (->d ([x (and/c integer? (lambda (x) (= x (get-field f this))))]) + () + any))) + (new (class object% (field [f 1]) (define/public m (lambda (x) 1)) (super-new))) + 'pos + 'neg) + m + 2)) + +(test/spec-passed + 'object-contract-->d/this-2 + '(send (contract (object-contract + (m (->d ([x (and/c integer? (lambda (x) (= x (get-field f this))))]) + () + any))) + (new (class object% (field [f 1]) (define/public m (lambda (x) 1)) (super-new))) + 'pos + 'neg) + m + 1)) + +(test/neg-blame + 'object-contract-->d/this-3 + '(send (contract (object-contract + (m (->d ([x (and/c integer? (lambda (x) (= x (get-field f this))))]) + () + #:rest rest-var any/c + any))) + (new (class object% (field [f 1]) + (define/public m (lambda (x . rest) 1)) + (super-new))) + 'pos + 'neg) + m + 2)) + +(test/spec-passed + 'object-contract-->d/this-4 + '(send (contract (object-contract + (m (->d ([x (and/c integer? (lambda (x) (= x (get-field f this))))]) + () + #:rest rest-var any/c + any))) + (new (class object% + (field [f 1]) + (define/public m (lambda (x . rest) 1)) + (super-new))) + 'pos + 'neg) + m + 1)) + +(test/spec-passed + 'object-contract-->pp1 + '(send (contract (object-contract + (m (->d ([x number?]) () #:pre-cond #t [unused (<=/c x)] #:post-cond #t))) + (new (class object% (define/public m (lambda (x) (- x 1))) (super-new))) + 'pos + 'neg) + m + 1)) + +(test/spec-passed + 'object-contract-->pp1b + '(send (contract (object-contract + (m (->d ([x number?]) () #:pre-cond #t [unused (<=/c x)] #:post-cond #t))) + (new (class object% + (define/public m (case-lambda [(x) (- x 1)] + [(x y) y])) + (super-new))) + 'pos + 'neg) + m + 1)) + +(test/pos-blame + 'object-contract-->pp2 + '(send (contract (object-contract + (m (->d ([x number?]) () #:pre-cond #t [unused (<=/c x)] #:post-cond #t))) + (new (class object% (define/public m (lambda (x) (+ x 1))) (super-new))) + 'pos + 'neg) + m + 1)) + +(test/pos-blame + 'object-contract-->pp2b + '(send (contract (object-contract + (m (->d ([x number?]) () #:pre-cond #t [unused (<=/c x)] #:post-cond #t))) + (new (class object% + (define/public m (case-lambda [(x) (+ x 1)])) + (super-new))) + 'pos + 'neg) + m + 1)) + +(test/spec-passed + 'object-contract-->pp3 + '(send (contract (object-contract + (m (->d () () #:rest rst (listof number?) + #:pre-cond #t [unused any/c] + #:post-cond #t))) + (new (class object% (define/public m (lambda w 1)) (super-new))) + 'pos + 'neg) + m + 1)) + +(test/neg-blame + 'object-contract-->pp4 + '(send (contract (object-contract + (m (->d () () #:rest rst (listof number?) + #:pre-cond #t [unused any/c] + #:post-cond #t))) + (new (class object% (define/public m (lambda w 1)) (super-new))) + 'pos + 'neg) + m + #f)) + +(test/spec-passed + 'object-contract-->pp5 + '(send (contract (object-contract (m (->d () () #:pre-cond #t any))) + (new (class object% (define/public m (lambda () 1)) (super-new))) + 'pos + 'neg) + m)) + +(test/spec-passed + 'object-contract-->pp6 + '(send (contract (object-contract (m (->d () () + #:pre-cond #t (values [x number?] [y (>=/c x)]) + #:post-cond #t))) + (new (class object% (define/public m (lambda () (values 1 2))) (super-new))) + 'pos + 'neg) + m)) + +(test/pos-blame + 'object-contract-->pp7 + '(send (contract (object-contract (m (->d () () #:pre-cond #t (values [x number?] [y (>=/c x)]) + #:post-cond #t))) + (new (class object% (define/public m (lambda () (values 2 1))) (super-new))) + 'pos + 'neg) + m)) + +(test/neg-blame + 'object-contract-->pp/this-1 + '(send (contract (object-contract (m (->d () + () + #:pre-cond (= 1 (get-field f this)) + [result-x any/c] + #:post-cond (= 2 (get-field f this))))) + (new (class object% + (field [f 2]) + (define/public m (lambda () (set! f 3))) + (super-new))) + 'pos + 'neg) + m)) + +(test/pos-blame + 'object-contract-->pp/this-2 + '(send (contract (object-contract (m (->d () () + #:pre-cond (= 1 (get-field f this)) + [result-x any/c] + #:post-cond (= 2 (get-field f this))))) + (new (class object% + (field [f 1]) + (define/public m (lambda () (set! f 3))) + (super-new))) + 'pos + 'neg) + m)) + +(test/spec-passed + 'object-contract-->pp/this-3 + '(send (contract (object-contract (m (->d () () + #:pre-cond (= 1 (get-field f this)) + [result-x any/c] + #:post-cond (= 2 (get-field f this))))) + (new (class object% + (field [f 1]) + (define/public m (lambda () (set! f 2))) + (super-new))) + 'pos + 'neg) + m)) + +(test/neg-blame + 'object-contract-->pp/this-4 + '(send (contract (object-contract (m (->d () () + #:rest rest-id any/c + #:pre-cond (= 1 (get-field f this)) + [result-x any/c] + #:post-cond (= 2 (get-field f this))))) + (new (class object% (field [f 2]) + (define/public m (lambda args (set! f 3))) + (super-new))) + 'pos + 'neg) + m)) + +(test/pos-blame + 'object-contract-->pp/this-5 + '(send (contract (object-contract (m (->d () () + #:rest rest-id any/c + #:pre-cond (= 1 (get-field f this)) + [result-x any/c] + #:post-cond (= 2 (get-field f this))))) + (new (class object% + (field [f 1]) + (define/public m (lambda args (set! f 3))) + (super-new))) + 'pos + 'neg) + m)) + +(test/spec-passed + 'object-contract-->pp/this-6 + '(send (contract (object-contract (m (->d () () + #:rest rest-id any/c + #:pre-cond (= 1 (get-field f this)) + [result-x any/c] + #:post-cond (= 2 (get-field f this))))) + (new (class object% + (field [f 1]) + (define/public m (lambda args (set! f 2))) + (super-new))) + 'pos + 'neg) + m)) +#| + (test/spec-passed + 'object-contract-->i1 + '(send (contract (object-contract (m (->i ([x number?]) () [range (x) (<=/c x)]))) + (new (class object% (define/public m (lambda (x) (- x 1))) (super-new))) + 'pos + 'neg) + m + 1)) + + (test/spec-passed + 'object-contract-->i1b + '(send (contract (object-contract (m (->i ([x number?]) () [range (x) (<=/c x)]))) + (new (class object% (define/public m (lambda (x) (- x 1))) (super-new))) + 'pos + 'neg) + m + 1)) + + (test/pos-blame + 'object-contract-->i2 + '(send (contract (object-contract (m (->i ([x number?]) () [range (x) (<=/c x)]))) + (new (class object% (define/public m (lambda (x) (+ x 1))) (super-new))) + 'pos + 'neg) + m + 1)) + + (test/pos-blame + 'object-contract-->i2b + '(send (contract (object-contract (m (->i ([x number?]) () [range (x) (<=/c x)]))) + (new (class object% (define/public m (lambda (x) (+ x 1))) (super-new))) + 'pos + 'neg) + m + 1)) + + (test/spec-passed + 'object-contract-->i3 + '(send (contract (object-contract (m (->i () () #:rest [rst (listof number?)] [range any/c]))) + (new (class object% (define/public m (lambda w 1)) (super-new))) + 'pos + 'neg) + m + 1)) + + (test/neg-blame + 'object-contract-->i4 + '(send (contract (object-contract (m (->i () () #:rest [rst (listof number?)] [range any/c]))) + (new (class object% (define/public m (lambda w 1)) (super-new))) + 'pos + 'neg) + m + #f)) + + (test/spec-passed + 'object-contract-->i5 + '(send (contract (object-contract (m (->i () () any))) + (new (class object% (define/public m (lambda () 1)) (super-new))) + 'pos + 'neg) + m)) + + (test/spec-passed + 'object-contract-->i6 + '(send (contract (object-contract (m (->i () () (values [x number?] [y (x) (>=/c x)])))) + (new (class object% (define/public m (lambda () (values 1 2))) (super-new))) + 'pos + 'neg) + m)) + + (test/pos-blame + 'object-contract-->i7 + '(send (contract (object-contract (m (->i () () (values [x number?] [y (x) (>=/c x)])))) + (new (class object% (define/public m (lambda () (values 2 1))) (super-new))) + 'pos + 'neg) + m)) + + (test/neg-blame + 'object-contract-->i/this-1 + '(send (contract (object-contract (m (->i ([x (and/c integer? (lambda (x) + (= x (get-field f this))))]) + () + any))) + (new (class object% (field [f 1]) (define/public m (lambda (x) 1)) (super-new))) + 'pos + 'neg) + m + 2)) + + (test/spec-passed + 'object-contract-->i/this-2 + '(send (contract (object-contract (m (->i ([x (and/c integer? (lambda (x) + (= x (get-field f this))))]) + () + any))) + (new (class object% (field [f 1]) (define/public m (lambda (x) 1)) (super-new))) + 'pos + 'neg) + m + 1)) + + (test/neg-blame + 'object-contract-->i/this-3 + '(send (contract (object-contract (m (->i ([x (and/c integer? (lambda (x) + (= x (get-field f this))))]) + () + #:rest [rest-var any/c] + any))) + (new (class object% (field [f 1]) (define/public m (lambda (x . rest) 1)) + (super-new))) + 'pos + 'neg) + m + 2)) + + (test/spec-passed + 'object-contract-->i/this-4 + '(send (contract (object-contract (m (->i ([x (and/c integer? (lambda (x) + (= x (get-field f this))))]) + () + #:rest [rest-var any/c] + any))) + (new (class object% (field [f 1]) (define/public m (lambda (x . rest) 1)) + (super-new))) + 'pos + 'neg) + m + 1)) + + (test/spec-passed + 'object-contract-->i-pp1 + '(send (contract (object-contract + (m (->i ([x number?]) () #:pre () #t [unused (x) (<=/c x)] #:post () #t))) + (new (class object% (define/public m (lambda (x) (- x 1))) (super-new))) + 'pos + 'neg) + m + 1)) + + (test/spec-passed + 'object-contract-->i-pp1b + '(send (contract (object-contract + (m (->i ([x number?]) () #:pre () #t [unused (x) (<=/c x)] #:post () #t))) + (new (class object% + (define/public m (case-lambda [(x) (- x 1)] + [(x y) y])) + (super-new))) + 'pos + 'neg) + m + 1)) + + (test/pos-blame + 'object-contract-->i-pp2 + '(send (contract (object-contract + (m (->i ([x number?]) () #:pre () #t [unused (x) (<=/c x)] #:post () #t))) + (new (class object% (define/public m (lambda (x) (+ x 1))) (super-new))) + 'pos + 'neg) + m + 1)) + + (test/pos-blame + 'object-contract-->i-pp2b + '(send (contract (object-contract + (m (->i ([x number?]) () #:pre () #t [unused (x) (<=/c x)] #:post () #t))) + (new (class object% + (define/public m (case-lambda [(x) (+ x 1)])) + (super-new))) + 'pos + 'neg) + m + 1)) + + (test/spec-passed + 'object-contract-->i-pp3 + '(send (contract (object-contract + (m (->i () () #:rest [rst (listof number?)] #:pre () #t [unused any/c] + #:post () #t))) + (new (class object% (define/public m (lambda w 1)) (super-new))) + 'pos + 'neg) + m + 1)) + + (test/neg-blame + 'object-contract-->i-pp4 + '(send (contract (object-contract (m (->i () () #:rest [rst (listof number?)] + #:pre () #t [unused any/c] #:post () #t))) + (new (class object% (define/public m (lambda w 1)) (super-new))) + 'pos + 'neg) + m + #f)) + + (test/spec-passed + 'object-contract-->i-pp5 + '(send (contract (object-contract (m (->i () () #:pre () #t any))) + (new (class object% (define/public m (lambda () 1)) (super-new))) + 'pos + 'neg) + m)) + + (test/spec-passed + 'object-contract-->i-pp6 + '(send (contract (object-contract (m (->i () () #:pre () #t (values [x number?] [y (x) (>=/c x)]) + #:post () #t))) + (new (class object% (define/public m (lambda () (values 1 2))) (super-new))) + 'pos + 'neg) + m)) + + (test/pos-blame + 'object-contract-->i-pp7 + '(send (contract (object-contract (m (->i () () #:pre () #t (values [x number?] [y (>=/c x)]) + #:post () #t))) + (new (class object% (define/public m (lambda () (values 2 1))) (super-new))) + 'pos + 'neg) + m)) + + (test/neg-blame + 'object-contract-->i-pp/this-1 + '(send (contract (object-contract (m (->i () + () + #:pre () (= 1 (get-field f this)) + [result-x any/c] + #:post () (= 2 (get-field f this))))) + (new (class object% (field [f 2]) (define/public m (lambda () (set! f 3))) + (super-new))) + 'pos + 'neg) + m)) + + (test/pos-blame + 'object-contract-->i-pp/this-2 + '(send (contract (object-contract (m (->i () () + #:pre () (= 1 (get-field f this)) + [result-x any/c] + #:post () (= 2 (get-field f this))))) + (new (class object% (field [f 1]) (define/public m (lambda () (set! f 3))) + (super-new))) + 'pos + 'neg) + m)) + + (test/spec-passed + 'object-contract-->i-pp/this-3 + '(send (contract (object-contract (m (->i () () + #:pre () (= 1 (get-field f this)) + [result-x any/c] + #:post () (= 2 (get-field f this))))) + (new (class object% (field [f 1]) (define/public m (lambda () (set! f 2))) + (super-new))) + 'pos + 'neg) + m)) + + (test/neg-blame + 'object-contract-->i-pp/this-4 + '(send (contract (object-contract (m (->i () () + #:rest [rest-id any/c] + #:pre () (= 1 (get-field f this)) + [result-x any/c] + #:post () (= 2 (get-field f this))))) + (new (class object% (field [f 2]) (define/public m (lambda args (set! f 3))) + (super-new))) + 'pos + 'neg) + m)) + + (test/pos-blame + 'object-contract-->i-pp/this-5 + '(send (contract (object-contract (m (->i () () + #:rest [rest-id any/c] + #:pre () (= 1 (get-field f this)) + [result-x any/c] + #:post () (= 2 (get-field f this))))) + (new (class object% (field [f 1]) (define/public m (lambda args (set! f 3))) + (super-new))) + 'pos + 'neg) + m)) + + (test/spec-passed + 'object-contract-->i-pp/this-6 + '(send (contract (object-contract (m (->i () () + #:rest [rest-id any/c] + #:pre () (= 1 (get-field f this)) + [result-x any/c] + #:post () (= 2 (get-field f this))))) + (new (class object% (field [f 1]) (define/public m (lambda args (set! f 2))) + (super-new))) + 'pos + 'neg) + m)) + |# + +(test/spec-passed/result + 'object-contract-drop-method1 + '(send (contract (object-contract (m (-> integer? integer?))) + (new (class object% (define/public (m x) x) (define/public (n x) x) (super-new))) + 'pos + 'neg) + n 1) + 1) + +(test/spec-passed/result + 'object-contract-drop-method2 + '(let ([o (contract (object-contract (m (-> integer? integer?))) + (new (class object% + (define/public (m x) x) + (define/public (n x) x) + (super-new))) + 'pos + 'neg)]) + (with-method ([m (o m)] + [n (o n)]) + (list (m 1) (n 2)))) + '(1 2)) + +(test/spec-passed/result + 'object-contract-drop-field1 + '(get-field g (contract (object-contract (field f integer?)) + (new (class object% (field [f 1] [g 2]) (super-new))) + 'pos + 'neg)) + 2) + +(test/spec-passed/result + 'object-contract-drop-field2 + '(field-bound? g (contract (object-contract (field f integer?)) + (new (class object% (field [f 1] [g 2]) (super-new))) + 'pos + 'neg)) + #t) + +(test/spec-passed/result + 'object-contract-drop-field3 + '(field-names + (contract (object-contract) + (new (class object% (field [g 2]) (super-new))) + 'pos + 'neg)) + '(g)) + + +(test/spec-passed/result + 'object-contract-ho-method1 + '(send (contract (object-contract (m (-> (-> integer? integer?) integer?))) + (new (class object% (define/public (m f) (f 1)) (super-new))) + 'pos + 'neg) + m + (λ (x) x)) + 1) + +(test/spec-passed/result + 'object-contract-ho-method2 + '(send (contract (object-contract (m (-> (->* (integer?) () integer?) integer?))) + (new (class object% (define/public (m f) (f 1)) (super-new))) + 'pos + 'neg) + m + (λ (x) x)) + 1) + +(test/spec-passed/result + 'object-contract-ho-method3 + '(send (contract (object-contract (m (-> (->i ([x integer?]) () [r integer?]) integer?))) + (new (class object% (define/public (m f) (f 1)) (super-new))) + 'pos + 'neg) + m + (λ (x) x)) + 1) + +(test/spec-passed/result + 'object-contract-layered1 + '(send (contract (object-contract (m (-> number? number?))) + (contract (object-contract) + (new (class object% (super-new) (define/public (m x) x))) + 'pos + 'neg) + 'pos + 'neg) + m + 5) + 5) + +;; Make sure we're not dropping projections on the floor. +(test/neg-blame + 'object-contract-layered2 + '(send (contract (object-contract (m (-> number? number?))) + (contract (object-contract (m (-> string? string?))) + (new (class object% (super-new) (define/public (m x) x))) + 'pos + 'neg) + 'pos + 'neg) + m + 5)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; test ->i works with object-contract +;; + +(test/spec-passed/result + 'object-contract/arrow-special-case1 + '(send (contract (object-contract + [m (-> any/c boolean?)]) + (new (class object% + (define/public (m x) #t) + (super-new))) + 'pos + 'neg) + m 1) + #t) + +(test/spec-passed/result + 'object-contract/arrow-special-case2 + '(send (contract (object-contract + [m (-> any/c any)]) + (new (class object% + (define/public (m x) #t) + (super-new))) + 'pos + 'neg) + m 1) + #t) + +(test/spec-passed/result + '->i22 + '(send (contract (object-contract + [m (->i ([x any/c] #:y [y any/c]) ([z any/c]) any)]) + (new (class object% + (define/public (m x #:y y [z 1]) x) + (super-new))) + 'pos + 'neg) + m 1 #:y 2) + 1) + + (test/spec-passed/result + '->i25 + '(send (contract (object-contract + [m (->i ([x any/c]) ([y any/c]) any)]) + (new (class object% + (define/public (m x [y 1]) x) + (super-new))) + 'pos + 'neg) + m 1) + 1) + + (test/spec-passed/result + '->i26 + '(send (contract (object-contract + [m (->i ([x any/c]) #:rest [rest any/c] any)]) + (new (class object% + (define/public (m x . y) x) + (super-new))) + 'pos + 'neg) + m 1) + 1) + + (test/spec-passed/result + '->i27 + '(send (contract (object-contract + [m (->i ([x any/c]) any)]) + (new (class object% + (define/public (m x) x) + (super-new))) + 'pos + 'neg) + m 1) + 1) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; test error message has right format +;; + +(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)) + (string-append + "m method: arity mismatch;\n" + " the expected number of arguments does not match the given number\n" + " expected: 1\n" + " given: 2\n" + " arguments...:\n" + " 1\n" + " 2")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; tests object utilities to be sure wrappers work right +;; + +(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)) + +(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<%> (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%)) + +;; Currently the new object contracts using impersonators don't even attempt to ensure that +;; these reflective operations still work, and I'm not even sure they should. For now, I +;; just get the class info from the original object, which means that all contracts are evaded. +;; +;; Just as a note, if we move the class-insp-mk +;; values forward in class/c-proj and make-wrapper-class, +;; we get a failure in object->vector for the second +;; testcase because the field-ref/field-set! in the +;; contracted version of the class (for a struct subtype +;; of the original class's struct type) doesn't +;; know how to get the fields out of the object struct. +;; We can always force it with unsafe-struct-ref, +;; but if we had impersonate-struct-type, with the same ability to replace the prop:object as +;; impersonate-struct has, then we might be able to handle this better. + +(let ([c% (parameterize ([current-inspector (make-inspector)]) + (contract-eval '(class object% (super-new))))]) + (test (list c% #f) + 'object-info + (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)]) + (contract-eval '(new (class object% (field [x 1] [y 2]) (super-new)))))] + [vec (contract-eval `(object->vector ,obj))]) + (test vec + (contract-eval 'object->vector) + (contract-eval + `(contract (object-contract (field x integer?) (field y integer?)) + ,obj + 'pos + 'neg))))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/object.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/object.rkt new file mode 100644 index 0000000000..47f4377b34 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/object.rkt @@ -0,0 +1,161 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace 'racket/class)]) +(test/pos-blame + 'object/c-first-order-object-1 + '(contract (object/c) + 3 + 'pos + 'neg)) + +(test/spec-passed + 'object/c-first-order-object-2 + '(contract (object/c) + (new object%) + 'pos + 'neg)) + +(test/pos-blame + 'object/c-first-order-method-1 + '(contract (object/c [m (-> any/c number? number?)]) + (new object%) + 'pos + 'neg)) + +(test/spec-passed + 'object/c-first-order-method-2 + '(contract (object/c [m (-> any/c number? number?)]) + (new (class object% (super-new) (define/public (m x) (add1 x)))) + 'pos + 'neg)) + +(test/pos-blame + 'object/c-first-order-local-method-1 + '(let () + (define-local-member-name m) + (contract (object/c [m (-> any/c number? number?)]) + (new object%) + 'pos + 'neg))) + +(test/spec-passed + 'object/c-first-order-local-method-2 + '(let () + (define-local-member-name m) + (contract (object/c [m (-> any/c number? number?)]) + (new (class object% (super-new) (define/public (m x) (add1 x)))) + 'pos + 'neg))) + +(test/pos-blame + 'object/c-first-order-field-1 + '(contract (object/c (field [n number?])) + (new object%) + 'pos + 'neg)) + +(test/spec-passed + 'object/c-first-order-field-2 + '(contract (object/c (field [n number?])) + (new (class object% (super-new) (field [n 3]))) + 'pos + 'neg)) + +(test/pos-blame + 'object/c-first-order-local-field-1 + '(let () + (define-local-member-name n) + (contract (object/c (field [n number?])) + (new object%) + 'pos + 'neg))) + +(test/spec-passed + 'object/c-first-order-local-field-2 + '(let () + (define-local-member-name n) + (contract (object/c (field [n number?])) + (new (class object% (super-new) (field [n 3]))) + 'pos + 'neg))) + +(test/spec-passed/result + 'object/c-higher-order-field-1 + '(get-field + n + (contract (object/c (field [n number?])) + (new (class object% (super-new) (field [n 3]))) + 'pos + 'neg)) + 3) + +(test/pos-blame + 'object/c-higher-order-field-2 + '(get-field + n + (contract (object/c (field [n number?])) + (new (class object% (super-new) (field [n #t]))) + 'pos + 'neg))) + +(test/spec-passed/result + 'object/c-higher-order-field-3 + '(let ([o (contract (object/c (field [n number?])) + (new (class object% (super-new) (field [n 3]))) + 'pos + 'neg)]) + (set-field! n o 5) + (get-field n o)) + 5) + +(test/neg-blame + 'object/c-higher-order-field-4 + '(let ([o (contract (object/c (field [n number?])) + (new (class object% (super-new) (field [n 3]))) + 'pos + 'neg)]) + (set-field! n o #t))) + +(test/spec-passed/result + 'object/c-higher-order-field-5 + '(let* ([pre-o (new (class object% (super-new) (field [n 3])))] + [o (contract (object/c (field [n number?])) + pre-o + 'pos + 'neg)]) + (set-field! n pre-o 5) + (get-field n o)) + 5) + +(test/spec-passed/result + 'object/c-higher-order-field-6 + '(let* ([pre-o (new (class object% (super-new) (field [n 3])))] + [o (contract (object/c (field [n number?])) + pre-o + 'pos + 'neg)]) + (set-field! n o 5) + (get-field n pre-o)) + 5) + +(test/neg-blame + 'object/c-higher-order-field-7 + '(let* ([pre-o (new (class object% (super-new) (field [n 3])))] + [o (contract (object/c (field [n number?])) + pre-o + 'pos + 'neg)]) + (set-field! n o #t) + (get-field n pre-o))) + +(test/pos-blame + 'object/c-higher-order-field-8 + '(let* ([pre-o (new (class object% (super-new) (field [n 3])))] + [o (contract (object/c (field [n number?])) + pre-o + 'pos + 'neg)]) + (set-field! n pre-o #t) + (get-field n o)))) \ No newline at end of file diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/obligations.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/obligations.rkt new file mode 100644 index 0000000000..112d7e342e --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/obligations.rkt @@ -0,0 +1,93 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace)]) +(define (test-obligations quoted-expr expected-props) + + (define (cleanup key obj stx) + (case key + [(racket/contract:contract) + (define (cleanup-ent x) + (sort (map syntax->datum (vector-ref obj x)) string<=? #:key (λ (x) (format "~s" x)))) + (list key (cleanup-ent 1) (cleanup-ent 2))] + [(racket/contract:positive-position racket/contract:negative-position) + (list key (syntax->datum stx))] + [(racket/contract:contract-on-boundary) + `(racket/contract:contract-on-boundary ,(syntax->datum stx))] + [(racket/contract:internal-contract) + `(racket/contract:internal-contract ,(syntax->datum stx))] + [else + (error 'test-obligations "unknown property ~s" key)])) + + (let ([props '()]) + (let ([stx (contract-expand-once quoted-expr)]) + (let loop ([stx stx]) + (cond + [(syntax? stx) + (for ([key (in-list (syntax-property-symbol-keys stx))]) + (when (regexp-match #rx"^racket/contract:" (symbol->string key)) + (set! props (cons (cleanup key (syntax-property stx key) stx) + props)))) + (loop (syntax-e stx))] + [(pair? stx) + (loop (car stx)) + (loop (cdr stx))]))) + (test expected-props + `(obligations-for ,quoted-expr) + (sort props string<=? #:key (λ (x) (format "~s" x)))))) + + (test-obligations '(-> a b) + '((racket/contract:contract (->) ()) + (racket/contract:negative-position a) + (racket/contract:positive-position b))) + (test-obligations '(->i ([x a]) any) + '((racket/contract:contract (->i) ()) + (racket/contract:contract-on-boundary a) + (racket/contract:negative-position a))) + (test-obligations '(->i ([x a]) [res b]) + '((racket/contract:contract (->i) ()) + (racket/contract:contract-on-boundary a) + (racket/contract:contract-on-boundary b) + (racket/contract:negative-position a) + (racket/contract:positive-position b))) + (test-obligations '(->i ([x a]) #:pre () #t [res b] #:post () #t) + '((racket/contract:contract (#:post ->i) (#:pre)) + (racket/contract:contract-on-boundary a) + (racket/contract:contract-on-boundary b) + (racket/contract:negative-position a) + (racket/contract:positive-position b))) + (test-obligations '(listof a) + '((racket/contract:contract (listof) ()) + (racket/contract:positive-position a))) + (test-obligations '(hash/c a b) + '((racket/contract:contract (hash/c) ()) + (racket/contract:negative-position a) + (racket/contract:positive-position b))) + (test-obligations '(box/c a) + '((racket/contract:contract (box/c) ()) + (racket/contract:negative-position a) + (racket/contract:positive-position a))) + (test-obligations '(box-immutable/c a) + '((racket/contract:contract (box-immutable/c) ()) + (racket/contract:positive-position a))) + (test-obligations '(vectorof a) + '((racket/contract:contract (vectorof) ()) + (racket/contract:negative-position a) + (racket/contract:positive-position a))) + (test-obligations '(vector-immutableof a) + '((racket/contract:contract (vector-immutableof) ()) + (racket/contract:positive-position a))) + (test-obligations '(vector/c a b c) + '((racket/contract:contract (vector/c) ()) + (racket/contract:negative-position a) + (racket/contract:negative-position b) + (racket/contract:negative-position c) + (racket/contract:positive-position a) + (racket/contract:positive-position b) + (racket/contract:positive-position c))) + (test-obligations '(vector-immutable/c a b c) + '((racket/contract:contract (vector-immutable/c) ()) + (racket/contract:positive-position a) + (racket/contract:positive-position b) + (racket/contract:positive-position c)))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/opt-c.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/opt-c.rkt new file mode 100644 index 0000000000..1f628812aa --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/opt-c.rkt @@ -0,0 +1,176 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace 'racket/contract)]) + + (contract-eval '(define-contract-struct couple (hd tl))) + + (contract-eval + '(begin + (define proj:blame/c + (make-contract + #:name 'proj:blame/c + #:projection + (lambda (blame) + (lambda (x) + (if (blame-swapped? blame) 'negative 'positive))))) + + (define call*0 'dummy) + (define (call*1 x0) x0) + (define (call*2 f1 x0) (f1 x0)) + (define (call*3 f2 x1 x0) (f2 x1 x0)))) + + (test/spec-passed/result + 'opt/c-blame-0 + '((contract + (-> (-> (-> proj:blame/c any/c) any/c any/c) (-> any/c any/c) any/c any/c) + call*3 + 'pos + 'neg) + call*2 + call*1 + call*0) + 'negative) + + (test/spec-passed/result + 'opt/c-blame-1 + '((contract + (opt/c (-> (-> (-> proj:blame/c any/c) any/c any/c) (-> any/c any/c) any/c any/c)) + call*3 + 'pos + 'neg) + call*2 + call*1 + call*0) + 'negative) + + (test/spec-passed/result + 'opt/c-blame-2 + '((contract + (-> (opt/c (-> (-> proj:blame/c any/c) any/c any/c)) (-> any/c any/c) any/c any/c) + call*3 + 'pos + 'neg) + call*2 + call*1 + call*0) + 'negative) + + (test/spec-passed/result + 'opt/c-blame-3 + '((contract + (-> (-> (opt/c (-> proj:blame/c any/c)) any/c any/c) (-> any/c any/c) any/c any/c) + call*3 + 'pos + 'neg) + call*2 + call*1 + call*0) + 'negative) + + (test/spec-passed/result + 'opt/c-blame-4 + '((contract + (-> (-> (-> (opt/c proj:blame/c) any/c) any/c any/c) (-> any/c any/c) any/c any/c) + call*3 + 'pos + 'neg) + call*2 + call*1 + call*0) + 'negative) + + ;; NOT YET RELEASED + #; + (test/pos-blame + 'd-c-s/attr-1 + '(let () + (define-contract-struct pr (x y)) + (pr-x + (contract (pr/dc [x integer?] + [y integer?] + where + [x-val x] + [y-val y] + and + (= x-val y-val)) + (make-pr 4 5) + 'pos + 'neg)))) + + ;; NOT YET RELEASED + #; + (test/spec-passed + 'd-c-s/attr-2 + '(let () + (define-contract-struct pr (x y)) + (contract (pr/dc [x integer?] + [y integer?] + where + [x-val x] + [y-val y] + and + (= x-val y-val)) + (make-pr 4 5) + 'pos + 'neg))) + + ;; NOT YET RELEASED + #; + (let () + (define-contract-struct node (n l r) (make-inspector)) + + (define (get-val n attr) + (if (null? n) + 1 + (let ([h (synthesized-value n attr)]) + (if (unknown? h) + h + (+ h 1))))) + + (define (full-bbt lo hi) + (or/c null? + (node/dc [n (between/c lo hi)] + [l (n) (full-bbt lo n)] + [r (n) (full-bbt n hi)] + + where + [lheight (get-val l lheight)] + [rheight (get-val r rheight)] + + and + (<= 0 (- lheight rheight) 1)))) + + (define t (contract (full-bbt -inf.0 +inf.0) + (make-node 0 + (make-node -1 null null) + (make-node 2 + (make-node 1 null null) + (make-node 3 null null))) + 'pos + 'neg)) + (test/spec-passed + 'd-c-s/attr-3 + `(,node-l (,node-l ,t))) + + (test/pos-blame + 'd-c-s/attr-4 + `(,node-r (,node-r (,node-r ,t))))) + + ;; NOT YET RELEASED + #| + +need a test that will revisit a node a second time (when it already has a wrapper) +with a new parent. make sure the new parent is recorded in the parents field +so that propagation occurs. + +|# + + + ;; test the predicate + (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)) \ No newline at end of file diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/or-and.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/or-and.rkt new file mode 100644 index 0000000000..0fffe8fc61 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/or-and.rkt @@ -0,0 +1,222 @@ +#lang racket/base +(require "test-util.rkt") +(parameterize ([current-contract-namespace + (make-basic-contract-namespace)]) + + (test/pos-blame + 'or/c1 + '(contract (or/c false/c) #t 'pos 'neg)) + + (test/spec-passed + 'or/c2 + '(contract (or/c false/c) #f 'pos 'neg)) + + (test/spec-passed + 'or/c3 + '((contract (or/c (-> integer? integer?)) (lambda (x) x) 'pos 'neg) 1)) + + (test/neg-blame + 'or/c4 + '((contract (or/c (-> integer? integer?)) (lambda (x) x) 'pos 'neg) #f)) + + (test/pos-blame + 'or/c5 + '((contract (or/c (-> integer? integer?)) (lambda (x) #f) 'pos 'neg) 1)) + + (test/spec-passed + 'or/c6 + '(contract (or/c false/c (-> integer? integer?)) #f 'pos 'neg)) + + (test/spec-passed + 'or/c7 + '((contract (or/c false/c (-> integer? integer?)) (lambda (x) x) 'pos 'neg) 1)) + + (test/spec-passed/result + 'or/c8 + '((contract ((or/c false/c (-> string?)) . -> . any) + (λ (y) y) + 'pos + 'neg) + #f) + #f) + + (test/spec-passed/result + 'or/c9 + '((contract (or/c (-> string?) (-> integer? integer?)) + (λ () "x") + 'pos + 'neg)) + "x") + + (test/spec-passed/result + 'or/c10 + '((contract (or/c (-> string?) (-> integer? integer?)) + (λ (x) x) + 'pos + 'neg) + 1) + 1) + + (test/pos-blame + 'or/c11 + '(contract (or/c (-> string?) (-> integer? integer?)) + 1 + 'pos + 'neg)) + + (test/pos-blame + 'or/c12 + '((contract (or/c (-> string?) (-> integer? integer?)) + 1 + 'pos + 'neg) + 'x)) + + (test/pos-blame + 'or/c13 + '(contract (or/c not) #t 'pos 'neg)) + + (test/spec-passed + 'or/c14 + '(contract (or/c not) #f 'pos 'neg)) + + (test/spec-passed/result + 'or/c-not-error-early + '(begin (or/c (-> integer? integer?) (-> boolean? boolean?)) + 1) + 1) + + (contract-error-test + 'contract-error-test4 + #'(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) + '(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 + 'or/c-hmm + '(let ([funny/c (or/c (and/c procedure? (-> any)) (listof (-> number?)))]) + (contract (-> funny/c any) void 'pos 'neg))) + + + (test/spec-passed + 'or/c-opt-unknown-flat + '(let () + (define arr (-> number? number?)) + ((contract (opt/c (or/c not arr)) (λ (x) x) 'pos 'neg) 1))) + + + + + + + ; + ; + ; + ; ;;;; ;; + ; ;;;; ;; + ; ;;;;;;; ;;;; ;;; ;;;;;;; ;; ;;;;; + ; ;;;;;;;; ;;;;;;;;; ;;;;;;;; ;; ;;;;;; + ; ;;;; ;;;; ;;;; ;;;;;;;;; ;;;;;;;;; + ; ;;;;;;; ;;;; ;;;; ;;;; ;;;; ;; ;;;; + ; ;; ;;;; ;;;; ;;;; ;;;;;;;;; ;; ;;;;;;; + ; ;;;;;;;; ;;;; ;;;; ;;;;;;;; ;; ;;;;;; + ; ;; ;;;; ;;;; ;;;; ;;;;;;; ;; ;;;;; + ; ;; + ; + ; + + (test/spec-passed + 'and/c1 + '((contract (and/c (-> (<=/c 100) (<=/c 100)) + (-> (>=/c -100) (>=/c -100))) + (λ (x) x) + 'pos + 'neg) + 1)) + + (test/neg-blame + 'and/c2 + '((contract (and/c (-> (<=/c 100) (<=/c 100)) + (-> (>=/c -100) (>=/c -100))) + (λ (x) x) + 'pos + 'neg) + 200)) + + (test/pos-blame + 'and/c3 + '((contract (and/c (-> (<=/c 100) (<=/c 100)) + (-> (>=/c -100) (>=/c -100))) + (λ (x) 200) + 'pos + 'neg) + 1)) + + + + + (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) + (reverse x)) + '(3 1 2 4)) + + (test/spec-passed/result + 'and/c-isnt + '(and (regexp-match #rx"isn't: even?" + (with-handlers ((exn:fail? exn-message)) + (contract (and/c integer? even? positive?) + -3 + 'pos + 'neg) + "not the error!")) + #t) + #t) + + (test/spec-passed + 'contract-flat1 + '(contract not #f 'pos 'neg)) + + (test/pos-blame + 'contract-flat2 + '(contract not #t 'pos 'neg))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/parameter.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/parameter.rkt new file mode 100644 index 0000000000..3a2d616d41 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/parameter.rkt @@ -0,0 +1,50 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace)]) + + (test/neg-blame + 'parameter/c1 + '((contract (parameter/c integer?) + (make-parameter 1) + 'pos 'neg) + #f)) + + (test/pos-blame + 'parameter/c2 + '((contract (parameter/c integer?) + (make-parameter 'not-an-int) + 'pos 'neg))) + + (test/pos-blame + 'parameter/c3 + '((contract (parameter/c integer? string?) + (make-parameter 'not-an-int number->string) + 'pos 'neg))) + + (test/neg-blame + 'parameter/c4 + '((contract (parameter/c integer? string?) + (make-parameter 5 number->string) + 'pos 'neg) + 'not-an-int)) + + (test/spec-passed + 'parameter/c5 + '((contract (parameter/c integer? string?) + (make-parameter "foo" number->string) + 'pos 'neg))) + + (test/spec-passed + 'parameter/c6 + '((contract (parameter/c integer? string?) + (make-parameter "foo" number->string) + 'pos 'neg) + 5)) + + (test/pos-blame + 'parameter/c7 + '((contract (parameter/c integer? string?) + (make-parameter 5 values) + 'pos 'neg)))) \ No newline at end of file diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/parametric.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/parametric.rkt new file mode 100644 index 0000000000..9ef35817ba --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/parametric.rkt @@ -0,0 +1,55 @@ +#lang racket/base + +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace 'racket/contract)]) + + (test/spec-passed/result + 'parametric->/c1 + '((contract (parametric->/c (A) (-> A A)) + (λ (x) x) + 'pos 'neg) + 1) + 1) + + (test/pos-blame + 'parametric->/c2 + '((contract (parametric->/c (A) (-> A A)) + (λ (x) 1) + 'pos 'neg) + 1)) + + (test/pos-blame + 'parametric->/c3 + '((contract (parametric->/c (A B) (-> A B)) + (λ (x) x) + 'pos 'neg) + 1)) + + ;; this should (probably) not require the + ;; application to 1, but parametric->/c + ;; currently checks only that its argument + ;; is a procedure and otherwise delays any + ;; checking until the first application of + ;; the wrapper + (test/pos-blame + 'parametric->/c4 + '((contract (parametric->/c (A) (-> A A)) + (λ (x y) x) + 'pos 'neg) + 1)) + + (test/pos-blame + 'parametric->/c5 + '(contract (parametric->/c (A) (-> A A)) + 5 + 'pos 'neg)) + + (test/spec-passed/result + 'parametric->/c6 + '((contract (parametric->/c (A B) (-> A B (or/c A B))) + (λ (x y) x) + 'pos 'neg) + 1 "foo") + 1)) \ No newline at end of file diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/predicates.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/predicates.rkt new file mode 100644 index 0000000000..19faa26b5d --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/predicates.rkt @@ -0,0 +1,229 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace 'racket/contract + 'racket/set)]) + + (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?)) + + (ctest #t flat-contract? (-> any/c any/c any)) + + (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?))) + (ctest #t flat-contract? (let () + (define-struct s (a b)) + (struct/c s any/c any/c))) + (ctest #f flat-contract? (let () + (define-struct s (a b) #:mutable) + (struct/c s any/c any/c))) + (ctest #f flat-contract? (let () + (define-struct s (a b) #:mutable) + (struct/c s any/c integer?))) + (ctest #t chaperone-contract? (let () + (define-struct s (a b) #:mutable) + (struct/c s any/c any/c))) + (ctest #f impersonator-contract? (let () + (define-struct s (a b) #:mutable) + (struct/c s any/c any/c))) + (ctest #f flat-contract? (let () + (define-struct s ([a #:mutable] b)) + (struct/c s any/c any/c))) + (ctest #t chaperone-contract? (let () + (define-struct s ([a #:mutable] b)) + (struct/c s any/c any/c))) + (ctest #f impersonator-contract? (let () + (define-struct s ([a #:mutable] b)) + (struct/c s any/c any/c))) + (ctest #f flat-contract? (let () + (define-struct s (a [b #:mutable])) + (struct/c s any/c any/c))) + (ctest #t chaperone-contract? (let () + (define-struct s (a [b #:mutable])) + (struct/c s any/c any/c))) + (ctest #f impersonator-contract? (let () + (define-struct s (a [b #:mutable])) + (struct/c s any/c any/c))) + (ctest #f flat-contract? (let () + (define-struct s (f)) + (struct/c s (-> number? any)))) + (ctest #t chaperone-contract? (let () + (define-struct s (f)) + (struct/c s (-> number? any)))) + (ctest #f impersonator-contract? (let () + (define-struct s (f)) + (struct/c s (-> number? any)))) + + (ctest #f flat-contract? (let () + (define-struct s (a) #:mutable) + (define alpha (new-∃/c 'alpha)) + (struct/c s alpha))) + (ctest #f chaperone-contract? (let () + (define-struct s (a) #:mutable) + (define alpha (new-∃/c 'alpha)) + (struct/c s alpha))) + (ctest #t impersonator-contract? (let () + (define-struct s (a) #:mutable) + (define alpha (new-∃/c 'alpha)) + (struct/c s alpha))) + (ctest #t contract? (let () + (define-struct s (a) #:mutable) + (define alpha (new-∃/c 'alpha)) + (struct/c s alpha))) + + (ctest #t chaperone-contract? + (let () + (struct s (a b)) + (let ([x (struct/dc s [a integer?] [b integer?])]) + (opt/c x)))) + + (ctest #t flat-contract? (set/c integer?)) + (ctest #f flat-contract? (set/c (-> integer? integer?))) + (ctest #t chaperone-contract? (set/c (-> integer? integer?))) + + (ctest #t flat-contract? (list/c integer?)) + (ctest #t chaperone-contract? (list/c (-> integer? integer?))) + + (ctest #t chaperone-contract? (promise/c integer?)) + (ctest #f chaperone-contract? (promise/c (new-∃/c 'alpha))) + + ;; Make sure that impersonators cannot be used as the element contract in set/c. + (contract-error-test + 'contract-error-test-set + '(let ([proxy-ctc + (make-contract + #:name 'proxy-ctc + #:first-order values + #:projection (λ (b) values))]) + (set/c proxy-ctc)) + exn:fail?) + + ;; Hash contracts with flat domain/range contracts + (ctest #t contract? (hash/c any/c any/c #:immutable #f)) + (ctest #t chaperone-contract? (hash/c any/c any/c #:immutable #f)) + (ctest #f impersonator-contract? (hash/c any/c any/c #:immutable #f)) + (ctest #t flat-contract? (hash/c any/c any/c #:immutable #f #:flat? #t)) + + (ctest #t flat-contract? (hash/c any/c any/c #:immutable #t)) + (ctest #t flat-contract? (hash/c any/c any/c #:immutable #t #:flat? #t)) + + (ctest #t contract? (hash/c any/c any/c)) + (ctest #t chaperone-contract? (hash/c any/c any/c)) + (ctest #f impersonator-contract? (hash/c any/c any/c)) + (ctest #t flat-contract? (hash/c any/c any/c #:flat? #t)) + + ;; Hash contracts with chaperone range contracts + (ctest #t contract? (hash/c number? (hash/c number? number?))) + (ctest #t chaperone-contract? (hash/c number? (hash/c number? number?))) + (ctest #f impersonator-contract? (hash/c number? (hash/c number? number?))) + (ctest #f flat-contract? (hash/c number? (hash/c number? number?))) + + ;; Hash contracts with proxy range contracts + (contract-eval + '(define trivial-proxy-ctc + (make-contract + #:name 'trivial-proxy-ctc + #:first-order values + #:projection (λ (b) values)))) + + (ctest #t contract? (hash/c number? trivial-proxy-ctc #:immutable #f)) + (ctest #f chaperone-contract? (hash/c number? trivial-proxy-ctc #:immutable #f)) + (ctest #t impersonator-contract? (hash/c number? trivial-proxy-ctc #:immutable #f)) + (ctest #f flat-contract? (hash/c number? trivial-proxy-ctc #:immutable #f)) + + (ctest #t contract? (hash/c number? trivial-proxy-ctc #:immutable #t)) + (ctest #f chaperone-contract? (hash/c number? trivial-proxy-ctc #:immutable #t)) + (ctest #t impersonator-contract? (hash/c number? trivial-proxy-ctc #:immutable #t)) + (ctest #f flat-contract? (hash/c number? trivial-proxy-ctc #:immutable #t)) + + (ctest #t contract? (hash/c number? trivial-proxy-ctc)) + (ctest #f chaperone-contract? (hash/c number? trivial-proxy-ctc)) + (ctest #t impersonator-contract? (hash/c number? trivial-proxy-ctc)) + (ctest #f flat-contract? (hash/c number? trivial-proxy-ctc)) + + ;; Make sure that proxies cannot be used as the domain contract in hash/c. + (contract-error-test + 'contract-error-test6 + '(let ([proxy-ctc + (make-contract + #:name 'proxy-ctc + #:first-order values + #:projection (λ (b) values))]) + (hash/c proxy-ctc proxy-ctc)) + exn:fail?) + + (ctest #t contract? (box/c number? #:flat? #t)) + (ctest #t chaperone-contract? (box/c number? #:flat? #t)) + (ctest #f impersonator-contract? (box/c number? #:flat? #t)) + (ctest #t flat-contract? (box/c number? #:flat? #t)) + + (ctest #t contract? (box/c number? #:immutable #t)) + (ctest #t chaperone-contract? (box/c number? #:immutable #t)) + (ctest #f impersonator-contract? (box/c number? #:immutable #t)) + (ctest #t flat-contract? (box/c number? #:immutable #t)) + + (ctest #t contract? (box/c number?)) + (ctest #t chaperone-contract? (box/c number?)) + (ctest #f impersonator-contract? (box/c number?)) + (ctest #f flat-contract? (box/c number?)) + + (ctest #t contract? (box/c (box/c number?) #:immutable #t)) + (ctest #t chaperone-contract? (box/c (box/c number?) #:immutable #t)) + (ctest #f impersonator-contract? (box/c (box/c number?) #:immutable #t)) + (ctest #f flat-contract? (box/c (box/c number?) #:immutable #t)) + + (ctest #t contract? (box/c trivial-proxy-ctc)) + (ctest #f chaperone-contract? (box/c trivial-proxy-ctc)) + (ctest #t impersonator-contract? (box/c trivial-proxy-ctc)) + (ctest #f flat-contract? (box/c trivial-proxy-ctc)) + + (ctest #t contract? (box/c trivial-proxy-ctc #:immutable #t)) + (ctest #f chaperone-contract? (box/c trivial-proxy-ctc #:immutable #t)) + (ctest #t impersonator-contract? (box/c trivial-proxy-ctc #:immutable #t)) + (ctest #f flat-contract? (box/c trivial-proxy-ctc #:immutable #t)) + + ;; Test the ability to create different types of contracts with recursive-contract + (ctest #t flat-contract? (letrec ([ctc (or/c number? + (cons/c (recursive-contract ctc #:flat) + (recursive-contract ctc #:flat)))]) + ctc)) + + (ctest #f flat-contract? (letrec ([ctc (or/c number? + (box/c (recursive-contract ctc #:chaperone)))]) + ctc)) + (ctest #t chaperone-contract? (letrec ([ctc (or/c number? + (box/c (recursive-contract ctc #:chaperone)))]) + ctc)) + (ctest #f impersonator-contract? (letrec ([ctc (or/c number? + (box/c (recursive-contract ctc #:chaperone)))]) + ctc)) + + (ctest #t contract? 1) + (ctest #t contract? (-> 1 1)) + + (ctest #t chaperone-contract? (let () + (struct s (a b)) + (struct/dc s [a integer?] [b integer?]))) + (ctest #t flat-contract? (let () + (struct s (a b)) + (struct/dc s [a integer?] [b integer?]))) + (ctest #t flat-contract? (let () + (struct s (a b)) + (struct/dc s [a integer?] [b (a) #:flat (>=/c a)]))) + (contract-error-test + 'struct/dc-not-really-flat-dep-field + #'(let () + (struct s (a b)) + (contract (struct/dc s [a integer?] [b (a) #:flat (-> integer? integer?)]) + (s 1 (λ (x) x)) + 'pos + 'neg)) + exn:fail?) + (ctest #t chaperone-contract? (let () + (struct s (a b)) + (struct/dc s [a integer?] [b (a) (>=/c a)])))) \ No newline at end of file diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/proc-accepts-and-more.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/proc-accepts-and-more.rkt new file mode 100644 index 0000000000..9d8d5daaed --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/proc-accepts-and-more.rkt @@ -0,0 +1,24 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace (make-basic-contract-namespace + 'racket/contract/private/arrow)]) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; procedure accepts-and-more + ;; + + (ctest #t procedure-accepts-and-more? (lambda (x . y) 1) 3) + (ctest #t procedure-accepts-and-more? (lambda (x . y) 1) 2) + (ctest #t procedure-accepts-and-more? (lambda (x . y) 1) 1) + (ctest #f procedure-accepts-and-more? (lambda (x . y) 1) 0) + + (ctest #t procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 3) + (ctest #t procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 2) + (ctest #t procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 1) + (ctest #f procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 0) + + (ctest #t procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 2) + (ctest #t procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 1) + (ctest #f procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 0)) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/promise.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/promise.rkt new file mode 100644 index 0000000000..86be1c200a --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/promise.rkt @@ -0,0 +1,72 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace 'racket/promise + 'racket/contract)]) + + (test/pos-blame + 'promise/c1 + '(force (contract (promise/c boolean?) + (delay 1) + 'pos + 'neg))) + + (test/spec-passed + 'promise/c2 + '(force (contract (promise/c boolean?) + (delay #t) + 'pos + 'neg))) + + (test/spec-passed/result + 'promise/c3 + '(let ([x 0]) + (contract (promise/c any/c) + (delay (set! x (+ x 1))) + 'pos + 'neg) + x) + 0) + + (test/spec-passed/result + 'promise/c4 + '(let ([x 0]) + (force (contract (promise/c any/c) + (delay (set! x (+ x 1))) + 'pos + 'neg)) + x) + 1) + + (test/spec-passed/result + 'promise/c5 + '(let ([x 0]) + (let ([p (contract (promise/c any/c) + (delay (set! x (+ x 1))) + 'pos + 'neg)]) + (force p) + (force p)) + x) + 1) + + (test/spec-passed/result + 'promise/c5 + '(let ([a (delay 7)]) + (equal? a + (contract (promise/c integer?) + a + 'pos + 'neg))) + #t) + + (test/spec-passed/result + 'promise/c6 + '(let ([a (delay 7)]) + (equal? a + (contract (promise/c (new-∃/c 'α)) + a + 'pos + 'neg))) + #t)) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/prompt-tag.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/prompt-tag.rkt new file mode 100644 index 0000000000..6917f492e5 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/prompt-tag.rkt @@ -0,0 +1,181 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace)]) + (test/spec-passed + 'prompt-tag/c-fo-1 + '(contract (prompt-tag/c string?) + (make-continuation-prompt-tag) + 'pos 'neg)) + + (test/pos-blame + 'prompt-tag/c-fo-2 + '(contract (prompt-tag/c string?) 5 'pos 'neg)) + + (test/spec-passed + 'prompt-tag/c-ho-1 + '(let ([pt (contract (prompt-tag/c number?) + (make-continuation-prompt-tag) + 'pos + 'neg)]) + (call-with-continuation-prompt + (λ () (abort-current-continuation pt 3)) + pt + (λ (x) (+ x 1))))) + + (test/neg-blame + 'prompt-tag/c-ho-2 + '(let ([pt (contract (prompt-tag/c string?) + (make-continuation-prompt-tag) + 'pos + 'neg)]) + (call-with-continuation-prompt + (λ () (abort-current-continuation pt 3)) + pt + (λ (x) (+ x 1))))) + + (test/neg-blame + 'prompt-tag/c-ho-3 + '(let ([pt (contract (prompt-tag/c (-> string? number?)) + (make-continuation-prompt-tag) + 'pos + 'neg)]) + (call-with-continuation-prompt + (λ () (abort-current-continuation pt (λ (x) 5))) + pt + (λ (x) (x 8))))) + + (test/neg-blame + 'prompt-tag/c-ho-4 + '(let ([pt (contract (prompt-tag/c (-> string? number?)) + (make-continuation-prompt-tag) + 'pos + 'neg)]) + (call-with-continuation-prompt + (λ () (abort-current-continuation pt (λ (x) "bad"))) + pt + (λ (x) (x "potato"))))) + + (test/pos-blame + 'prompt-tag/c-ho-5 + '(let* ([pt (make-continuation-prompt-tag)] + [do-prompt (contract + (-> (-> (prompt-tag/c (-> number? number?)) + any) + number?) + (λ (f) (call-with-continuation-prompt + (λ () (f pt)) + pt + (λ (f) (f "bad")))) + 'pos + 'neg)]) + (do-prompt (λ (pt) + (abort-current-continuation pt (λ (v) (+ v 1))))))) + + (test/spec-failed + 'prompt-tag/c-ho-5 + '(let* ([pt (make-continuation-prompt-tag)] + [do-prompt (contract + (-> (-> (prompt-tag/c (-> number? number?)) + any) + number?) + (λ (f) (call-with-continuation-prompt + (λ () (f pt)) + pt + (λ (f) (f 0)))) + 'A + 'B)] + [do-prompt2 (contract + (-> (-> (prompt-tag/c (-> string? number?)) + any) + number?) + do-prompt + 'B + 'C)]) + (do-prompt2 + (λ (pt) (abort-current-continuation pt (λ (v) (+ v 1)))))) + "B") + + (test/neg-blame + 'prompt-tag/c-ho-6 + '(let ([pt (contract (prompt-tag/c string? number?) + (make-continuation-prompt-tag) + 'pos + 'neg)]) + (call-with-continuation-prompt + (λ () (abort-current-continuation pt 3 "bad")) + pt + (λ (x y) (values x y))))) + + (test/spec-passed + 'prompt-tag/c-ho-7 + '(let ([pt (contract (prompt-tag/c string? number?) + (make-continuation-prompt-tag) + 'pos + 'neg)]) + (call-with-continuation-prompt + (λ () (abort-current-continuation pt "good" 5)) + pt + (λ (x y) (values x y))))) + + (test/spec-passed + 'prompt-tag/c-call/cc-1 + '(let* ([pt (contract (prompt-tag/c string? + #:call/cc string?) + (make-continuation-prompt-tag) + 'pos + 'neg)] + [abort-k (call-with-continuation-prompt + (λ () (call/cc (λ (k) k) pt)) + pt)]) + (call-with-continuation-prompt + (λ () (abort-k "ok")) + pt + (λ (s) (string-append s "post"))))) + + (test/spec-passed + 'prompt-tag/c-call/cc-2 + '(let* ([pt (contract (prompt-tag/c string? + #:call/cc (values string? integer?)) + (make-continuation-prompt-tag) + 'pos + 'neg)] + [abort-k (call-with-continuation-prompt + (λ () (call/cc (λ (k) k) pt)) + pt)]) + (call-with-continuation-prompt + (λ () (abort-k "ok" 5)) + pt + (λ (s n) (string-append s "post"))))) + + (test/neg-blame + 'prompt-tag/c-call/cc-2 + '(letrec ([pt (make-continuation-prompt-tag)] + [do-test (λ () + (+ 1 + (call-with-continuation-prompt + (lambda () + (+ 1 (abort-k 1))) + pt)))] + [cpt (contract (prompt-tag/c #:call/cc number?) + pt + 'pos + 'neg)] + [abort-k (call-with-continuation-prompt + (λ () + (let ([v (call/cc (lambda (k) k) cpt)]) + (if (procedure? v) + v + (format "~a" v)))) + pt)]) + (do-test))) + + (test/spec-passed/result + 'prompt-tag/c-has-contract + '(let ([pt (contract (prompt-tag/c string? number?) + (make-continuation-prompt-tag) + 'pos + 'neg)]) + (has-contract? pt)) + #t)) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/recursive-contract.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/recursive-contract.rkt new file mode 100644 index 0000000000..523c688ee2 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/recursive-contract.rkt @@ -0,0 +1,75 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace)]) + + (test/spec-passed + 'recursive-contract1 + '(letrec ([ctc (-> integer? (recursive-contract ctc))]) + (letrec ([f (λ (x) f)]) + ((((contract ctc f 'pos 'neg) 1) 2) 3)))) + + (test/neg-blame + 'recursive-contract2 + '(letrec ([ctc (-> integer? (recursive-contract ctc))]) + (letrec ([f (λ (x) f)]) + ((contract ctc f 'pos 'neg) #f)))) + + (test/neg-blame + 'recursive-contract3 + '(letrec ([ctc (-> integer? (recursive-contract ctc))]) + (letrec ([f (λ (x) f)]) + ((((contract ctc f 'pos 'neg) 1) 2) #f)))) + + (test/pos-blame + 'recursive-contract4 + '(letrec ([ctc (-> integer? (recursive-contract ctc))]) + (letrec ([c 0] + [f (λ (x) + (set! c (+ c 1)) + (if (= c 2) + 'nope + f))]) + ((((contract ctc f 'pos 'neg) 1) 2) 3)))) + + (test/spec-passed + 'recursive-contract5 + '(contract (recursive-contract #f) + #f + 'pos + 'neg)) + + (test/spec-passed + 'recursive-contract6 + '(letrec ([ctc (or/c number? (cons/c number? (recursive-contract ctc #:flat)))]) + (contract ctc (cons 1 (cons 2 3)) 'pos 'neg))) + + (test/pos-blame + 'recursive-contract7 + '(letrec ([ctc (or/c number? (cons/c number? (recursive-contract ctc #:flat)))]) + (contract ctc (cons 1 (cons 2 #t)) 'pos 'neg))) + + (test/pos-blame + 'recursive-contract8 + '(letrec ([ctc (or/c number? (cons/c number? (recursive-contract ctc #:flat)))]) + (contract ctc (cons 1 (cons #t 3)) 'pos 'neg))) + + (test/spec-passed + 'recursive-contract9 + '(letrec ([ctc (or/c number? (hash/c (recursive-contract ctc #:chaperone) number?))]) + (make-hash (list (cons (make-hash (list (cons 3 4))) 5))))) + + (test/pos-blame + 'recursive-contract10 + '(let () + (struct doll (contents)) + (letrec ([doll-ctc (recursive-contract (or/c 'center (struct/c doll doll-ctc)) #:flat)]) + (contract doll-ctc (doll 3) 'pos 'neg)))) + + (test/pos-blame + 'recursive-contract11 + '(let () + (struct doll (contents)) + (letrec ([doll-ctc2 (or/c 'center (struct/c doll (recursive-contract doll-ctc2 #:flat)))]) + (contract doll-ctc2 (doll 4) 'pos 'neg))))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/set.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/set.rkt new file mode 100644 index 0000000000..c641e8634d --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/set.rkt @@ -0,0 +1,60 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace 'racket/set)]) + + (test/spec-passed/result + 'set/c1 + '(contract (set/c integer?) + (set 0) + 'pos 'neg) + (contract-eval '(set 0))) + + (test/pos-blame + 'set/c2 + '(contract (set/c integer?) + (set #t) + 'pos 'neg)) + + (test/pos-blame + 'set/c3 + '(contract (set/c integer? #:cmp 'eq) + (set 0) + 'pos 'neg)) + + (test/pos-blame + 'set/c4 + '(contract (set/c integer? #:cmp 'eqv) + (set 0) + 'pos 'neg)) + + (test/pos-blame + 'set/c5 + '(contract (set/c integer? #:cmp 'equal) + (seteq 0) + 'pos 'neg)) + + (test/spec-passed/result + 'set/c6 + '(set-map (contract (set/c integer?) + (set 0) + 'pos 'neg) + values) + (list 0)) + + (test/neg-blame + 'set/c7 + '(let ([s (set-map (contract (set/c (-> integer? integer?)) + (set (λ (x) #f)) + 'pos 'neg) + values)]) + ((car s) #f))) + + (test/pos-blame + 'set/c8 + '(let ([s (set-map (contract (set/c (-> integer? integer?)) + (set (λ (x) #f)) + 'pos 'neg) + values)]) + ((car s) 1)))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt new file mode 100644 index 0000000000..acacf47d6d --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt @@ -0,0 +1,208 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace 'racket/contract)]) + + (contract-eval '(define-contract-struct couple (hd tl))) + (contract-eval '(define-contract-struct triple (a b c))) + + (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 #f contract-stronger? + (-> integer? #:x integer? integer?) + (-> integer? #:y integer? integer?)) + (ctest #f contract-stronger? + (-> integer? #:y integer? integer?) + (-> integer? #:x integer? integer?)) + (ctest #t contract-stronger? + (-> integer? #:x integer? integer?) + (-> integer? #:x integer? integer?)) + (ctest #t contract-stronger? (-> #:x (>=/c 3) (>=/c 3)) (-> #:x (>=/c 3) (>=/c 2))) + + (let ([c (contract-eval '(->* () () any))]) + (test #t (contract-eval 'contract-stronger?) c c)) + (let ([c (contract-eval '(->d () () any))]) + (test #t (contract-eval 'contract-stronger?) c c)) + (let ([c (contract-eval '(->i () () any))]) + (test #t (contract-eval 'contract-stronger?) c c)) + + (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?))) + + (ctest #t contract-stronger? number? number?) + (ctest #f contract-stronger? boolean? number?) + + (ctest #t contract-stronger? (parameter/c (between/c 0 5)) (parameter/c (between/c 0 5))) + (ctest #f contract-stronger? (parameter/c (between/c 0 5)) (parameter/c (between/c 1 4))) + (ctest #f contract-stronger? (parameter/c (between/c 1 4)) (parameter/c (between/c 0 5))) + + (ctest #f contract-stronger? (parameter/c (between/c 1 4) (between/c 0 5)) + (parameter/c (between/c 0 5))) + (ctest #t contract-stronger? (parameter/c (between/c 0 5) (between/c 1 4)) + (parameter/c (between/c 1 4))) + (ctest #t contract-stronger? (parameter/c (between/c 0 5)) + (parameter/c (between/c 1 4) (between/c 0 5))) + (ctest #f contract-stronger? (parameter/c (between/c 1 4)) + (parameter/c (between/c 0 5) (between/c 0 5))) + (ctest #t contract-stronger? (parameter/c (between/c 0 5) (between/c 1 4)) + (parameter/c (between/c 1 4) (between/c 0 5))) + (ctest #f contract-stronger? (parameter/c (between/c 1 4) (between/c 0 5)) + (parameter/c (between/c 0 5) (between/c 1 4))) + + (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)) + + (ctest #t contract-stronger? + (or/c (-> (>=/c 3) (>=/c 3)) (-> string?)) + (or/c (-> (>=/c 4) (>=/c 3)) (-> string?))) + (ctest #f contract-stronger? + (or/c (-> string?) (-> integer? integer?)) + (or/c (-> string?) (-> any/c integer?))) + (ctest #f contract-stronger? + (or/c (-> string?) (-> any/c integer?)) + (or/c (-> string?) (-> integer? integer?))) + (ctest #t contract-stronger? + (or/c (-> string?) (-> integer? integer?) integer? boolean?) + (or/c (-> string?) (-> integer? integer?) integer? boolean?)) + (ctest #f contract-stronger? + (or/c (-> string?) (-> integer? integer?) integer? char?) + (or/c (-> string?) (-> integer? integer?) integer? boolean?)) + (ctest #f contract-stronger? + (or/c (-> string?) (-> integer? integer?) integer?) + (or/c (-> string?) (-> integer? integer?) integer? boolean?)) + (ctest #f contract-stronger? + (or/c (-> string?) (-> integer? integer?) integer?) + (or/c (-> integer? integer?) integer?)) + + (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)) + + (letrec ([mk-c + (λ (x) + (triple/dc [a (<=/c x)] + [b any/c] + [c (a b) (or/c #f (mk-c a))]))]) + (,test #t contract-stronger? (mk-c 1) (mk-c 2))))) + + + (contract-eval + `(let () + + (struct s (a b)) + (struct t (a b)) + + (,test #f contract-stronger? + (struct/dc s + [a (>=/c 1)] + [b (>=/c 2)]) + (struct/dc s + [a (>=/c 2)] + [b (>=/c 3)])) + (,test #t contract-stronger? + (struct/dc s + [a (>=/c 2)] + [b (>=/c 3)]) + (struct/dc s + [a (>=/c 1)] + [b (>=/c 2)])) + + (,test #f contract-stronger? + (struct/dc s + [a number?] + [b number?]) + (struct/dc t + [a number?] + [b number?])) + + (,test #f contract-stronger? + (struct/dc t + [a number?] + [b number?]) + (struct/dc s + [a number?] + [b number?])) + + (define (mk c) + (struct/dc s + [a (>=/c c)] + [b (a) (>=/c a)])) + (define one (mk 1)) + (define two (mk 2)) + (,test #f contract-stronger? one two) + (,test #t contract-stronger? two one)))) \ No newline at end of file diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/struct-dc.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/struct-dc.rkt new file mode 100644 index 0000000000..db945ac64a --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/struct-dc.rkt @@ -0,0 +1,1043 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace 'racket/contract)]) + + (define exn:fail:contract:blame? (contract-eval 'exn:fail:contract:blame?)) + + (test/spec-passed + 'struct/c1 + '(let () + (define-struct s (a)) + (contract (struct/c s integer?) + (make-s 1) + 'pos + 'neg))) + + (test/pos-blame + 'struct/c2 + '(let () + (define-struct s (a)) + (contract (struct/c s integer?) + (make-s #f) + 'pos + 'neg))) + + (test/pos-blame + 'struct/c3 + '(let () + (define-struct s (a)) + (contract (struct/c s integer?) + 1 + 'pos + 'neg))) + + (test/spec-passed + 'struct/c4 + '(let () + (define-struct s (a b)) + (contract (struct/c s integer? (struct/c s integer? boolean?)) + (make-s 1 (make-s 2 #t)) + 'pos + 'neg))) + + (test/pos-blame + 'struct/c5 + '(let () + (define-struct s (a b)) + (contract (struct/c s integer? (struct/c s integer? boolean?)) + (make-s 1 (make-s 2 3)) + 'pos + 'neg))) + + (test/spec-passed + 'struct/c6 + '(let () + (define-struct s (f)) + (let ([v (contract (struct/c s (-> number? number?)) + (make-s values) + 'pos + 'neg)]) + ((s-f v) 3)))) + + (test/neg-blame + 'struct/c7 + '(let () + (define-struct s (f)) + (let ([v (contract (struct/c s (-> number? number?)) + (make-s values) + 'pos + 'neg)]) + ((s-f v) #f)))) + + (test/pos-blame + 'struct/c8 + '(let () + (define-struct s (f)) + (let ([v (contract (struct/c s (-> number? number?)) + (make-s (λ (v) #f)) + 'pos + 'neg)]) + ((s-f v) 3)))) + + (test/spec-passed + 'struct/c9 + '(let () + (define-struct s (a b) #:mutable) + (let ([v (contract (struct/c s integer? boolean?) + (make-s 3 #t) + 'pos + 'neg)]) + (set-s-a! v 4) + (set-s-b! v #t)))) + + (test/neg-blame + 'struct/c10 + '(let () + (define-struct s (a b) #:mutable) + (let ([v (contract (struct/c s integer? boolean?) + (make-s 3 #t) + 'pos + 'neg)]) + (set-s-a! v #f)))) + + (test/neg-blame + 'struct/c11 + '(let () + (define-struct s (a [b #:mutable])) + (let ([v (contract (struct/c s integer? boolean?) + (make-s 3 #t) + 'pos + 'neg)]) + (set-s-b! v 5)))) + + (test/spec-passed/result + 'struct/c12 + '(let () + (define-struct s (a) #:mutable) + (define alpha (new-∃/c 'alpha)) + (define v (make-s 3)) + (let ([v* (contract (struct/c s alpha) v 'pos 'neg)]) + (set-s-a! v* (s-a v*))) + (s-a v)) + 3) + + (test/neg-blame + 'struct/c13 + '(let () + (define-struct s (a) #:mutable) + (define alpha (new-∃/c 'alpha)) + (define v (make-s 3)) + (let ([v* (contract (struct/c s alpha) v 'pos 'neg)]) + (set-s-a! v* 4)))) + + (test/spec-passed/result + 'struct/c14 + '(let () + (struct heap (v)) + (struct heap-node heap ()) + + (heap-v (contract (struct/c heap-node number?) + (heap-node 11) + 'pos + 'neg))) + 11) + + (test/spec-passed/result + 'struct/c15 + '(let () + (struct a (x)) + (struct b a (y)) + (struct c b (z)) + (struct d c (w)) + + (b-y (contract (struct/c d number? number? number? number?) + (d 11 22 33 44) + 'pos + 'neg))) + 22) + + (test/spec-passed/result + 'struct/c16 + '(let () + (struct doll (contents)) + (list ((flat-contract-predicate (struct/c doll 'center)) (doll 'center)) + ((flat-contract-predicate (struct/c doll 'center)) (doll 'not-center-center)))) + '(#t #f)) + + (contract-error-test + 'struct/c17 + '(let () + (struct foo (v)) + (contract (struct/c foo number?) + #f + 'pos + 'neg)) + (λ (x) + (and (exn:fail:contract:blame? x) + (regexp-match #rx"promised: foo?" (exn-message x))))) + + + ; + ; + ; + ; + ; ; ; ; ;;; + ; ;;; ;;; ; ;;; + ; ;;;; ;;;; ;;; ;;;; ;;; ;;; ;;;; ; ;; ;;; ;;; + ; ;;; ;; ;;;; ;;;;;;;; ;;; ;;;;; ;;;; ; ;;;;;;; ;;;;; + ; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ; ;;; ;;; ;;; ;; + ; ;;;; ;;; ;;; ;;; ;;; ;;; ;;; ; ;;; ;;; ;;; + ; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ; ;;; ;;; ;;; ;; + ; ;; ;;; ;;;; ;;; ;;;;;;; ;;;;; ;;;; ; ;;;;;;; ;;;;; + ; ;;;; ;;; ;;; ;; ;;; ;;; ;;; ; ;; ;;; ;;; + ; + ; + ; + ; + + + (test/spec-passed + 'struct/dc-1 + '(let () + (struct s (a b)) + (contract (struct/dc s + [a () number?] + [b (a) boolean?]) + (s 1 #f) + 'pos + 'neg))) + + (test/spec-passed + 'struct/dc-1a + '(let () + (struct s (a b)) + (contract (struct/dc s + [a () number?] + [b (a) #:chaperone boolean?]) + (s 1 #f) + 'pos + 'neg))) + + (test/spec-passed + 'struct/dc-2 + '(let () + (struct s (a b)) + (contract (struct/dc s + [a () number?] + [b (a) (>=/c a)]) + (s 1 2) + 'pos + 'neg))) + + (test/pos-blame + 'struct/dc-3 + '(let () + (struct s (a b)) + (contract (struct/dc s + [a () number?] + [b (a) (>=/c a)]) + (s 2 1) + 'pos + 'neg))) + + (test/spec-passed + 'struct/dc-3b + '(let () + (struct s (a b)) + (contract (struct/dc s + [a () number?] + [b (a) (<=/c a)]) + (s 2 1) + 'pos + 'neg))) + + (test/spec-passed + 'struct/dc-4 + '(let () + (struct s (a b)) + (contract (struct/dc s + [a number?] + [b (a) (>=/c a)]) + (s 1 2) + 'pos + 'neg))) + + + (test/pos-blame + 'struct/dc-5 + '(let () + (struct s (a b)) + (s-b (contract (struct/dc s + [a () number?] + [b (a) (>=/c a)]) + (s 2 1) + 'pos + 'neg)))) + + (test/spec-passed/result + 'struct/dc-6 + '(let () + (struct s (a b)) + (define-opt/c (f z) + (struct/dc s + [a (>=/c z)] + [b (a) #:lazy (f a)])) + + (s-a (contract (f 11) + (s 12 (s 13 #f)) + 'pos + 'neg))) + 12) + + (test/spec-passed/result + 'struct/dc-7 + '(let () + (struct s (a b)) + (define-opt/c (f z) + (struct/dc s + [a (>=/c z)] + [b (a) #:lazy (f a)])) + + (s-a (s-b (contract (f 11) + (s 12 (s 13 #f)) + 'pos + 'neg)))) + 13) + + + (test/pos-blame + 'struct/dc-8 + '(let () + (struct s (a b)) + (define-opt/c (f z) + (struct/dc s + [a (>=/c z)] + [b (a) #:lazy (f a)])) + (s-b (s-b (contract (f 11) + (s 12 (s 13 #f)) + 'pos + 'neg))))) + + + (test/spec-passed/result + 'struct/dc-9 + '(let () + (struct s (a b)) + + (define-opt/c (g z) + (struct/dc s + [a (>=/c z)] + [b (a) #:lazy (>=/c (+ a 1))])) + + (s-a (contract (g 10) + (s 12 (s 14 #f)) + 'pos + 'neg))) + 12) + + (test/spec-passed/result + 'struct/dc-10 + '(let () + (struct s (a b)) + + (define-opt/c (g z) + (struct/dc s + [a (>=/c z)] + [b (a) #:lazy (>=/c (+ a 1))])) + + (s-b (contract (g 10) + (s 12 14) + 'pos + 'neg))) + 14) + + (test/pos-blame + 'struct/dc-11 + '(let () + + (struct s (a b)) + + (define-opt/c (g z) + (struct/dc s + [a (>=/c z)] + [b (a) #:lazy (>=/c (+ a 1))])) + + (s-b (contract (g 11) + (s 12 10) + 'pos + 'neg)))) + + (test/spec-passed/result + 'struct/dc-12 + '(let () + (struct kons (hd tl) #:transparent) + (define (unknown-function a) (=/c a)) + (define-opt/c (f a b) + (or/c not + (struct/dc kons + [hd (unknown-function a)] + [tl () #:lazy (or/c #f (f b a))]))) + (kons-hd (kons-tl (contract (f 1 2) + (kons 1 (kons 2 #f)) + 'pos + 'neg)))) + 2) + + (test/spec-passed + 'struct/dc-13 + '(let () + (struct s (a)) + (contract (struct/dc s + [a #:lazy integer?]) + (s #f) + 'pos + 'neg))) + + (test/spec-passed + 'struct/dc-14 + '(let () + (struct s (a)) + (contract (struct/dc s + [a #:lazy (-> integer? integer?)]) + (s #f) + 'pos + 'neg))) + + (test/pos-blame + 'struct/dc-15 + '(let () + (struct s (a)) + (contract (struct/dc s + [a integer?]) + (s #f) + 'pos + 'neg))) + + (test/pos-blame + 'struct/dc-16 + '(let () + (struct s (a)) + (contract (struct/dc s + [a (-> integer? integer?)]) + (s #f) + 'pos + 'neg))) + + (test/spec-passed + 'struct/dc-17 + '(let () + (struct s (q a)) + (contract (struct/dc s + [q integer?] + [a (q) #:lazy (<=/c q)]) + (s 1 #f) + 'pos + 'neg))) + + (test/pos-blame + 'struct/dc-18 + '(let () + (struct s (q a)) + (contract (struct/dc s + [q integer?] + [a (q) (<=/c q)]) + (s 1 #f) + 'pos + 'neg))) + + (contract-error-test + 'struct/dc-19 + '(let () + (struct s (a b)) + (struct/dc s [a (new-∃/c 'α)] [b integer?])) + exn:fail?) + + (contract-error-test + 'struct/dc-20 + '(let () + (struct s (a b)) + (contract (struct/dc s [a (b) (new-∃/c 'α)] [b integer?]) + (s 1 2) + 'pos 'neg)) + exn:fail?) + + (test/pos-blame + 'struct/dc-new1 + '(let () + (struct s (a)) + (contract (struct/dc s [a integer?]) (s #f) 'pos 'neg))) + + (test/spec-passed + 'struct/dc-new2 + '(let () + (struct s (a)) + (contract (struct/dc s [a #:lazy integer?]) (s #f) 'pos 'neg))) + + (test/pos-blame + 'struct/dc-new3 + '(let () + (struct s (a)) + (s-a (contract (struct/dc s [a #:lazy integer?]) (s #f) 'pos 'neg)))) + + (test/spec-passed + 'struct/dc-new4 + '(let () + (struct s ([a #:mutable])) + (contract (struct/dc s [a integer?]) (s #f) 'pos 'neg))) + + (test/pos-blame + 'struct/dc-new5 + '(let () + (struct s ([a #:mutable])) + (s-a (contract (struct/dc s [a integer?]) (s #f) 'pos 'neg)))) + + (test/neg-blame + 'struct/dc-new6 + '(let () + (struct s ([a #:mutable])) + (set-s-a! (contract (struct/dc s [a integer?]) (s 1) 'pos 'neg) + #f))) + + (test/spec-passed + 'struct/dc-new7 + '(let () + (struct s (a b c)) + (s-c (contract (struct/dc s [a any/c] [b (a) (non-empty-listof real?)] [c (b) (<=/c (car b))]) + (s 3 '(2) 1) + 'pos + 'neg)))) + + + (test/spec-passed + 'struct/dc-new8 + '(let () + (struct s (a b c)) + (s-c (contract (struct/dc s + [a any/c] + [b (a) (non-empty-listof real?)] + [c (a b) (and/c (<=/c a) (<=/c (car b)))]) + (s 3 '(2) 1) + 'pos + 'neg)))) + + (test/spec-passed + 'struct/dc-new9 + '(let () + (struct s (a b c)) + (s-c (contract (struct/dc s + [a any/c] + [b (a) (non-empty-listof real?)] + [c (b a) (and/c (<=/c a) (<=/c (car b)))]) + (s 3 '(2) 1) + 'pos + 'neg)))) + + + (test/spec-passed + 'struct/dc-new10 + '(let () + (struct s (a b c)) + (s-c (contract (struct/dc s + [a (b) (<=/c (car b))] + [b (c) (non-empty-listof real?)] + [c real?]) + (s 1 '(2) 3) + 'pos + 'neg)))) + + (test/spec-passed + 'struct/dc-new11 + '(let () + (struct s (a b c)) + (s-c (contract (struct/dc s + [a (b c) (and/c (<=/c (car b)) (<=/c c))] + [b (c) (non-empty-listof real?)] + [c real?]) + (s 1 '(2) 3) + 'pos + 'neg)))) + + (test/spec-passed + 'struct/dc-new12 + '(let () + (struct s (a b c)) + (s-c (contract (struct/dc s + [a (c b) (and/c (<=/c (car b)) (<=/c c))] + [b (c) (non-empty-listof real?)] + [c real?]) + (s 1 '(2) 3) + 'pos + 'neg)))) + + + (test/pos-blame + 'struct/dc-new13 + '(let () + (struct s (f b)) + (contract (struct/dc s [f (-> integer? integer?)] [b (f) (<=/c (f 1))]) + (s (λ (x) #f) 123) + 'pos + 'neg))) + + (test/spec-failed + 'struct/dc-new14 + '(let () + (struct s (f b)) + (contract (struct/dc s [f (-> integer? integer?)] [b (f) (<=/c (f #f))]) + (s (λ (x) 1) 123) + 'pos + 'neg)) + "top-level") + + (test/pos-blame + 'struct/dc-new15 + '(let () + (struct s (f b)) + (contract (struct/dc s [f (-> integer? integer?)] [b (f) #:lazy (<=/c (f 1))]) + (s (λ (x) #f) 123) + 'pos + 'neg))) + + (test/spec-failed + 'struct/dc-new16 + '(let () + (struct s (f b)) + (contract (struct/dc s [f (-> integer? integer?)] [b (f) #:lazy (<=/c (f #f))]) + (s (λ (x) 1) 123) + 'pos + 'neg)) + "top-level") + + (test/pos-blame + 'struct/dc-new17 + '(let () + (struct s (f b)) + (contract (struct/dc s [f #:lazy (-> integer? integer?)] [b (f) #:lazy (<=/c (f 1))]) + (s (λ (x) #f) 123) + 'pos + 'neg))) + + (test/spec-failed + 'struct/dc-new18 + '(let () + (struct s (f b)) + (contract (struct/dc s [f #:lazy (-> integer? integer?)] [b (f) #:lazy (<=/c (f #f))]) + (s (λ (x) 1) 123) + 'pos + 'neg)) + "top-level") + + (test/spec-passed + 'struct/dc-new19 + '(let () + (struct s (a b c d)) + (contract (struct/dc s + [a integer?] + [b #:lazy symbol?] + [c (a) boolean?] + [d (a c) integer?]) + (s 1 'x #t 5) + 'pos 'neg))) + + (test/spec-passed + 'struct/dc-new20 + '(let () + (struct s (a [b #:mutable] c [d #:mutable])) + (contract (struct/dc s + [a integer?] + [b symbol?] + [c (a) boolean?] + [d (a c) integer?]) + (s 1 'x #t 5) + 'pos 'neg))) + + (test/spec-passed + 'struct/dc-new21 + '(let () + (struct s ([a #:mutable] b)) + (define an-s (contract (struct/dc s [a integer?] [b boolean?]) + (s 1 #f) + 'pos 'neg)) + (set-s-a! an-s 2))) + + (test/neg-blame + 'struct/dc-new22 + '(let () + (struct s ([a #:mutable] b)) + (define an-s (contract (struct/dc s [a integer?] [b boolean?]) + (s 1 #f) + 'pos 'neg)) + (set-s-a! an-s #f))) + + (test/spec-passed + 'struct/dc-new22 + '(let () + (struct s ([a #:mutable] b)) + (contract (struct/dc s [a integer?] [b boolean?]) + (s 'one #f) + 'pos 'neg))) + + (test/pos-blame + 'struct/dc-new23 + '(let () + (struct s ([a #:mutable] b)) + (s-a (contract (struct/dc s [a integer?] [b boolean?]) + (s 'one #f) + 'pos 'neg)))) + + (test/pos-blame + 'struct/dc-new24 + '(let () + (struct s ([a #:mutable] b)) + (define an-s (contract (struct/dc s [a (-> integer? integer?)] [b boolean?]) + (s (λ (x) #f) #f) + 'pos 'neg)) + ((s-a an-s) 1))) + + (test/neg-blame + 'struct/dc-new25 + '(let () + (struct s ([a #:mutable] b)) + (define an-s (contract (struct/dc s [a (-> integer? integer?)] [b boolean?]) + (s (λ (x) #f) #f) + 'pos 'neg)) + (set-s-a! an-s (λ (x) #f)) + ((s-a an-s) 1))) + + (test/pos-blame + 'struct/dc-new26 + '(let () + (struct s ([a #:mutable] b)) + (contract (struct/dc s [a (-> integer? integer?)] [b (a) (<=/c (a 1))]) + (s (λ (x) #f) #f) + 'pos 'neg))) + + (test/pos-blame + 'struct/dc-new27 + '(let () + (struct s ([a #:mutable] b)) + (define an-s (contract (struct/dc s [a (-> integer? integer?)] [b (a) (<=/c (a 1))]) + (s (λ (x) 1) 1) + 'pos 'neg)) + (set-s-a! an-s (λ (x) -2)) + (s-b an-s))) + + (test/neg-blame + 'struct/dc-new28 + '(let () + (struct s ([a #:mutable] b)) + (define an-s (contract (struct/dc s [a (-> integer? integer?)] [b (a) (<=/c (a 1))]) + (s (λ (x) 1) 1) + 'pos 'neg)) + (set-s-a! an-s (λ (x) #f)) + (s-b an-s))) + + (test/pos-blame + 'struct/dc-new29 + '(let () + (struct s ([a #:mutable] b c)) + (define an-s (contract (struct/dc s + [a (-> integer? integer?)] + [b (a) (<=/c (a 1))] + [c (b) (<=/c b)]) + (s (λ (x) 1) -11 1) + 'pos 'neg)) + (set-s-a! an-s (λ (x) -2)) + (s-c an-s))) + + (test/pos-blame + 'struct/dc-new30 + '(let () + (struct s ([a #:mutable] b c)) + (define an-s (contract (struct/dc s + [a (-> integer? integer?)] + [b (a) (<=/c (a 1))] + [c (b) (<=/c b)]) + (s (λ (x) 1) 1 -2) + 'pos 'neg)) + (set-s-a! an-s (λ (x) -2)) + (s-c an-s))) + + (test/neg-blame + 'struct/dc-new31 + '(let () + (struct s ([a #:mutable] [b #:mutable])) + (define an-s (contract (struct/dc s + [a (-> integer? integer?)] + [b (a) (<=/c (a 1))]) + (s (λ (x) 1) 1) + 'pos 'neg)) + (set-s-b! an-s 3))) + + (test/pos-blame + 'struct/dc-new32 + '(let () + (struct s ([a #:mutable] [b #:mutable])) + (define an-s (contract (struct/dc s + [a (-> integer? integer?)] + [b (a) (<=/c (a 1))]) + (s (λ (x) 1) 1) + 'pos 'neg)) + (set-s-a! an-s (λ (x) -1)) + (s-b an-s))) + + (test/spec-failed + 'struct/dc-new33 + '(let () + (struct s (a [b #:mutable] [c #:mutable])) + (define an-s (contract (struct/dc s + [a (-> integer? integer?)] + [b any/c] + [c (a b) (<=/c (a b))]) + (s (λ (x) 1) 1 1) + 'pos 'neg)) + (set-s-b! an-s #f) + (s-c an-s)) + "top-level") + + (contract-error-test + 'struct/dc-new-34 + '(let () + (struct s ([a #:mutable] [b #:mutable])) + (contract (struct/dc s + [a boolean?] + [b (a) + #:flat + (if a + (<=/c 1) + (-> integer? integer?))]) + (s #f 1) + 'pos + 'neg)) + (λ (x) (regexp-match #rx"struct/dc: .*flat" (exn-message x)))) + + (contract-error-test + 'struct/dc-new-35 + '(let () + (struct s ([a #:mutable] [b #:mutable])) + (define an-s (contract (struct/dc s + [a boolean?] + [b (a) + #:flat + (if a + (<=/c 1) + (-> integer? integer?))]) + (s #t 1) + 'pos + 'neg)) + (set-s-a! an-s #f) + (s-b an-s)) + (λ (x) (regexp-match #rx"struct/dc: .*flat" (exn-message x)))) + + (contract-error-test + 'struct/dc-new-36 + '(let () + (struct s ([a #:mutable] b)) + (contract (struct/dc s + [a boolean?] + [b (a) + (if a + (<=/c 1) + (new-∃/c 'α))]) + (s #f 1) + 'pos + 'neg)) + (λ (x) (regexp-match #rx"struct/dc: .*chaperone" (exn-message x)))) + + (contract-error-test + 'struct/dc-new-37 + '(let () + (struct s ([a #:mutable] b)) + (define an-s (contract (struct/dc s + [a boolean?] + [b (a) + (if a + (<=/c 1) + (new-∃/c 'α))]) + (s #t 1) + 'pos + 'neg)) + (set-s-a! an-s #f) + (s-b an-s)) + (λ (x) (regexp-match #rx"struct/dc: .*chaperone" (exn-message x)))) + + (contract-error-test + 'struct/dc-new-38 + '(let () + (struct s ([a #:mutable] b [c #:mutable])) + (define an-s (contract (struct/dc s + [a boolean?] + [b (a) + (if a + (<=/c 1) + (new-∃/c 'α))] + [c (b) integer?]) + (s #t 1 1) + 'pos + 'neg)) + (set-s-a! an-s #f) + (s-c an-s)) + (λ (x) (regexp-match #rx"struct/dc: .*chaperone" (exn-message x)))) + + (test/spec-passed + 'struct/dc-new-39 + '(let () + (struct s (a b)) + (contract (struct/dc s [a integer?] [b integer?]) (s 1 2) 'pos 'neg))) + + (test/spec-passed + 'struct/dc-new40 + '(let () + (struct s (a b)) + (contract (struct/dc s [a (-> integer? integer?)] [b (-> integer? integer?)]) + (s (λ (x) x) (λ (y) y)) + 'pos + 'neg))) + + (test/spec-passed/result + 'struct/dc-new41 + '(let () + (struct s (a [b #:mutable])) + (define α (new-∀/c 'α)) + (s-b ((contract (-> α (struct/dc s [b α])) + (λ (x) (s 11 x)) + 'pos + 'neg) 1))) + 1) + + (test/spec-passed/result + 'struct/dc-new42 + '(let () + (struct s (a [b #:mutable])) + (define α (new-∀/c 'α)) + (s-b ((contract (-> α (struct/dc s [a integer?] [b (a) #:impersonator α])) + (λ (x) (s 11 x)) + 'pos + 'neg) 1))) + 1) + + (test/spec-passed + 'struct/dc-new42 + '(let () + (struct s (a [b #:mutable])) + (contract (struct/dc s [a (-> integer? integer?)] [b (new-∀/c 'α)]) + (s (λ (x) x) 1) + 'pos + 'neg))) + + (test/spec-passed/result + 'struct/dc-new43 + '(let () + (struct a (x)) + (struct b a (y)) + (struct c b (z)) + (struct d c (w)) + + (b-y (contract (struct/dc d + [(x #:parent a) boolean?] + [(y #:parent b) char?] + [(z #:parent c) number?] + [w string?]) + (d #t #\a 3 "x") + 'pos + 'neg))) + #\a) + + (test/spec-passed/result + 'struct/dc-new44 + '(let () + (struct a (x)) + (struct b a (y)) + (struct c b (z)) + (struct d c (w)) + + (b-y (contract (struct/dc d + [(x #:parent a) (w) boolean?] + [(y #:parent b) ((x #:parent a)) char?] + [(z #:parent c) number?] + [w string?]) + (d #t #\a 3 "x") + 'pos + 'neg))) + #\a) + + (test/spec-passed/result + 'struct/dc-pred1 + '(let () + (struct s (a b)) + (define p? (flat-contract-predicate (struct/dc s [a number?] [b (a) #:flat (<=/c a)]))) + (list (p? (s 2 1)) + (p? (s 1 2)))) + '(#t #f)) + + (test/spec-passed/result + 'struct/dc-pred2 + '(let () + (struct s (a b c)) + (define p? (flat-contract-predicate (struct/dc s + [a number?] + [b boolean?] + [c (a b) + #:flat + (if (and (= a 1) b) + any/c + none/c)]))) + + (list (p? (s 1 #t 'whatever)) + (p? (s 11 #f 'whatver)))) + '(#t #f)) + + + + (contract-error-test + 'struct/dc-imp-nondep-runtime-error + '(let () + (struct s (ernie bert)) + (struct/dc s [ernie integer?] [bert (new-∀/c 'α)])) + (λ (x) + (and (exn:fail? x) + (regexp-match #rx"chaperone-contract[?]" (exn-message x))))) + + (contract-error-test + 'struct/dc-not-a-field + #'(eval '(let () + (struct s (a b)) + (struct/dc s [a integer?] [y integer?]))) + exn:fail:syntax?) + + (contract-error-test + 'struct/dc-circular-dependecies1 + #'(eval '(let () + (struct s (a b)) + (struct/dc s [a (a) integer?] [b (a) integer?]))) + exn:fail:syntax?) + + (contract-error-test + 'struct/dc-circular-dependecies2 + #'(eval '(let () + (struct s (a b c)) + (struct/dc s [a (b) integer?] [b (a) integer?] [c integer?]))) + exn:fail:syntax?) + + (contract-error-test + 'struct/dc-dep-on-lazy + #'(eval '(let () + (struct s (a b)) + (struct/dc s [a #:lazy integer?] [b (a) integer?]))) + exn:fail:syntax?) + + (contract-error-test + 'struct/dc-lazy-mutable + #'(eval '(let () + (struct s (a [b #:mutable])) + (struct/dc s [a integer?] [b #:lazy integer?]))) + exn:fail:syntax?) + + (contract-error-test + 'struct/dc-immutable-impersonator + #'(eval '(let () + (struct s (a b)) + (struct/dc s [a integer?] [b (a) #:impersonator (<=/c a)]))) + (λ (x) (and (exn:fail:syntax? x) (regexp-match #rx"immutable" (exn-message x)))))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/syntax.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/syntax.rkt new file mode 100644 index 0000000000..d2a625e926 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/syntax.rkt @@ -0,0 +1,23 @@ +#lang racket/base + +(require "test-util.rkt") +(parameterize ([current-contract-namespace + (make-basic-contract-namespace)]) + + (test/pos-blame + 'syntax/c1 + '(contract (syntax/c boolean?) + #'x + 'pos + 'neg)) + + (test/spec-passed + 'syntax/c2 + '(contract (syntax/c symbol?) + #'x + 'pos + 'neg)) + + (test/no-error '(syntax/c (list/c #f))) + (contract-error-test 'syntax/c-non-flat '(syntax/c (vector/c #f)) + (λ (x) (regexp-match? #rx"flat-contract[?]" (exn-message x))))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/tail.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/tail.rkt new file mode 100644 index 0000000000..0036af961f --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/tail.rkt @@ -0,0 +1,134 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace)]) + + (contract-eval + `(define (counter) + (let ([c 0]) + (case-lambda + [() c] + [(x) (set! c (+ c 1)) #t])))) + + (ctest/rewrite 1 + 'tail-arrow + (let ([c (counter)]) + (letrec ([f + (contract (-> any/c c) + (λ (x) (if (zero? x) x (f (- x 1)))) + 'pos + 'neg)]) + (f 3)) + (c))) + + (ctest/rewrite 1 + 'tail-unconstrained-domain-arrow + (let ([c (counter)]) + (letrec ([f + (contract (unconstrained-domain-> c) + (λ (x) (if (zero? x) x (f (- x 1)))) + 'pos + 'neg)]) + (f 3)) + (c))) + + (ctest/rewrite 2 + 'tail-multiple-value-arrow + (let ([c (counter)]) + (letrec ([f + (contract (-> any/c (values c c)) + (λ (x) (if (zero? x) (values x x) (f (- x 1)))) + 'pos + 'neg)]) + (f 3)) + (c))) + + (ctest/rewrite 2 + 'tail-arrow-star + (let ([c (counter)]) + (letrec ([f + (contract (->* (any/c) () (values c c)) + (λ (x) (if (zero? x) (values x x) (f (- x 1)))) + 'pos + 'neg)]) + (f 3)) + (c))) + + + (ctest/rewrite 1 + 'case->-regular + (let ([c (counter)]) + (letrec ([f + (contract (case-> (-> any/c c) + (-> any/c any/c c)) + (case-lambda + [(x) (if (zero? x) x (f (- x 1)))] + [(x y) (f x)]) + 'pos + 'neg)]) + (f 4 1)) + (c))) + + (ctest/rewrite 1 + 'case->-rest-args + (let ([c (counter)]) + (letrec ([f + (contract (case-> (-> any/c #:rest any/c c) + (-> any/c any/c #:rest any/c c)) + (case-lambda + [(x) (f x 1)] + [(x y . z) (if (zero? x) x (apply f (- x 1) y (list y y)))]) + 'pos + 'neg)]) + (f 4)) + (c))) + + (ctest/rewrite '(1) + 'mut-rec-with-any/c + (let () + (define f + (contract (-> number? any/c) + (lambda (x) + (if (zero? x) + (continuation-mark-set->list (current-continuation-marks) + 'tail-test) + (with-continuation-mark 'tail-test x + (g (- x 1))))) + 'something-that-is-not-pos + 'neg)) + + (define g + (contract (-> number? any/c) + (lambda (x) + (f x)) + 'also-this-is-not-pos + 'neg)) + + (f 3))) + + + (test/pos-blame + 'different-blame=>cannot-drop-check + '((contract (-> integer? integer?) + (λ (x) + ((contract (-> integer? integer?) + (λ (x) #f) + 'pos + 'neg) + x)) + 'abc + 'def) + 5)) + + (test/pos-blame 'free-vars-change-so-cannot-drop-the-check + '(let () + (define f + (contract (->i ([x number?]) () [_ (x) ( void +;; tests a passing specification +(define (test/spec-passed name expression) + (parameterize ([compile-enforce-module-constants #f]) + (contract-eval + `(,test + (void) + (let ([for-each-eval (lambda (l) (for-each eval l))]) for-each-eval) + (list ',expression '(void)))) + (let ([new-expression (rewrite-out expression)]) + (when new-expression + (contract-eval + `(,test + (void) + (let ([for-each-eval (lambda (l) (for-each eval l))]) for-each-eval) + (list ',new-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-to-add-opt/c expression k) '(void)))))) + +(define (test/spec-passed/result name expression result) + (parameterize ([compile-enforce-module-constants #f]) + (contract-eval `(,test ',result eval ',expression)) + (let/ec k + (contract-eval + `(,test + ',result + eval + ',(rewrite-to-add-opt/c expression k)))) + (let ([new-expression (rewrite-out expression)]) + (when new-expression + (contract-eval + `(,test + ',result + eval + ',new-expression)))))) + +;; rewrites `provide/contract' to use `contract-out' +(define (rewrite-out orig-exp) + (define rewrote? #f) + (define maybe-rewritten? + (let loop ([exp orig-exp]) + (match exp + [`(module ,modname ,lang ,bodies ...) + (define at-beginning '()) + (define at-end '()) + + ;; remove (and save) the provide/contract & contract-out + ;; declarations, switching their senses + (define removed-bodies + (apply + append + (for/list ([body (in-list bodies)]) + (match body + [`(provide/contract . ,args) + (set! rewrote? #t) + (set! at-beginning (cons `(provide (contract-out . ,args)) + at-beginning)) + (list)] + [`(provide (contract-out . ,args)) + (set! rewrote? #t) + (set! at-end (cons `(provide/contract . ,args) + at-end)) + (list)] + [else + (list body)])))) + + ;; insert the provide/contract (rewrite to contract-out) after the + ;; first require that has 'contract' in it + (define inserted-bodies + (if (equal? lang 'racket) + (append (reverse at-beginning) + removed-bodies) + (apply + append + (for/list ([body (in-list removed-bodies)]) + (match body + [`(require . ,(? (λ (l) + (for/or ([x (in-list l)]) + (and (symbol? x) + (regexp-match #rx"contract" (symbol->string x))))))) + (cons body (reverse at-beginning))] + [else + (list body)]))))) + + `(module ,modname ,lang + (void) ;; always insert this to work around bug in 'provide' + ,@inserted-bodies ,@(reverse at-end))] + [(? list?) + (map loop exp)] + [else exp]))) + + (and rewrote? maybe-rewritten?)) + +;; rewrites `contract' to use opt/c. If there is a module definition in there, we skip that test. +(define (rewrite-to-add-opt/c 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]))) + +;; blame : (or/c 'pos 'neg string?) +;; if blame is a string, expect to find the string (format "blaming: ~a" blame) in the exn message +(define (test/spec-failed name expression blame) + (let () + (define (has-proper-blame? msg) + (define reg + (cond + [(eq? blame 'pos) #rx"blaming: pos"] + [(eq? blame 'neg) #rx"blaming: neg"] + [(string? blame) (string-append "blaming: " (regexp-quote blame))] + [else #f])) + + (when reg + (unless (regexp-match? reg msg) + (eprintf "ACK!! ~s ~s\n" blame msg) + (custodian-shutdown-all (current-custodian)))) + (and reg (regexp-match? reg msg))) + (contract-eval + `(,test-an-error + ',name + (lambda () ,expression) + ',expression + (lambda (exn) + (and (exn:fail:contract:blame? exn) + (,has-proper-blame? (exn-message exn)))))) + (let/ec k + (let ([rewritten (rewrite-to-add-opt/c expression k)]) + (contract-eval + `(,test-an-error + ',name + (lambda () ,rewritten) + ',rewritten + (lambda (exn) + (and (exn:fail:contract:blame? exn) + (,has-proper-blame? (exn-message exn)))))))))) + +(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-syntax (ctest/rewrite stx) + (syntax-case stx () + [(_ expected name expression) + #'(begin + (contract-eval `(,test expected name expression)) + (let/ec k + (contract-eval `(,test expected + ',(string->symbol (format "~a+opt/c" name)) + ,(rewrite-to-add-opt/c 'expression k)))))])) + +(define (test/well-formed stx) + (contract-eval + `(,test (void) + (let ([expand/ret-void (lambda (x) (expand x) (void))]) expand/ret-void) + ,stx))) + +(define (test/no-error sexp) + (contract-eval + `(,test (void) + eval + '(begin ,sexp (void)))) + (let/ec k + (contract-eval + `(,test (void) + eval + '(begin ,(rewrite-to-add-opt/c sexp k) (void)))))) + + diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/unconstrained-domain.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/unconstrained-domain.rkt new file mode 100644 index 0000000000..75139c2209 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/unconstrained-domain.rkt @@ -0,0 +1,48 @@ +#lang racket/base + +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace)]) + (test/no-error '(unconstrained-domain-> number?)) + (test/no-error '(unconstrained-domain-> (flat-contract number?))) + + + (test/spec-passed + 'unconstrained-domain->1 + '(contract (unconstrained-domain-> number?) (λ (x) x) 'pos 'neg)) + (test/pos-blame + 'unconstrained-domain->2 + '(contract (unconstrained-domain-> number?) 1 'pos 'neg)) + (test/spec-passed + 'unconstrained-domain->3 + '((contract (unconstrained-domain-> number?) (λ (x) x) 'pos 'neg) 1)) + (test/pos-blame + 'unconstrained-domain->4 + '((contract (unconstrained-domain-> number?) (λ (x) x) 'pos 'neg) #f)) + + (test/spec-passed/result + 'unconstrained-domain->5 + '((contract (->d ([size natural-number/c] + [proc (and/c (unconstrained-domain-> number?) + (λ (p) (procedure-arity-includes? p size)))]) + () + [range number?]) + (λ (i f) (apply f (build-list i add1))) + 'pos + 'neg) + 10 +) + 55) + + (test/spec-passed/result + 'unconstrained-domain->6 + '((contract (unconstrained-domain-> any/c) + (λ (#:key k) k) + 'pos + 'neg) + #:key 1) + 1) + + (test/pos-blame + 'unconstrained-domain->7 + '((contract (unconstrained-domain-> number?) (λ (#:x x) x) 'pos 'neg) #:x #f))) \ No newline at end of file diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/value-contract.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/value-contract.rkt new file mode 100644 index 0000000000..1521a5d828 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/value-contract.rkt @@ -0,0 +1,45 @@ +#lang racket/base +(require "test-util.rkt") +(parameterize ([current-contract-namespace + (make-basic-contract-namespace 'racket/unit 'racket/class 'racket/contract)]) + + (ctest #f value-contract #f) + (ctest #f value-contract (λ (x) x)) + (ctest #f value-contract (unit (import) (export))) + (ctest #f value-contract object%) + + (contract-eval + `(let ([ctc (-> number? number?)]) + (,test ctc value-contract (contract ctc (λ (x) x) 'pos 'neg)))) + (contract-eval + `(let ([ctc (->* (number?) (number?) number?)]) + (,test ctc value-contract (contract ctc (λ (x [y 3]) x) 'pos 'neg)))) + (contract-eval + `(let ([ctc (->d ([x number?]) ([y number?]) [_ number?])]) + (,test ctc value-contract (contract ctc (λ (x [y 3]) x) 'pos 'neg)))) + (contract-eval + `(let ([ctc (->i ([x number?]) ([y number?]) [_ number?])]) + (,test ctc value-contract (contract ctc (λ (x [y 3]) x) 'pos 'neg)))) + (contract-eval + `(let ([ctc (unconstrained-domain-> number?)]) + (,test ctc value-contract (contract ctc (λ (x) 3) 'pos 'neg)))) + (contract-eval + `(let ([ctc (case-> (-> number? number? number?) (-> number? number?))]) + (,test ctc value-contract (contract ctc (case-lambda [(x) 3] [(x y) (+ x y)]) 'pos 'neg)))) + + (contract-eval + `(let ([ctc (box/c number?)]) + (,test ctc value-contract (contract ctc (box 3) 'pos 'neg)))) + (contract-eval + `(let ([ctc (hash/c number? number?)]) + (,test ctc value-contract (contract ctc (make-hash) 'pos 'neg)))) + (contract-eval + `(let ([ctc (vectorof number?)]) + (,test ctc value-contract (contract ctc (vector 1 2 3) 'pos 'neg)))) + (contract-eval + `(let ([ctc (vector/c number? number?)]) + (,test ctc value-contract (contract ctc (vector 4 5) 'pos 'neg)))) + + (contract-eval + `(let ([ctc (object-contract)]) + (,test ctc value-contract (contract ctc (new object%) 'pos 'neg))))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/vector.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/vector.rkt new file mode 100644 index 0000000000..cd21077f5e --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/vector.rkt @@ -0,0 +1,16 @@ +#lang racket/base +(require "test-util.rkt") +(parameterize ([current-contract-namespace + (make-basic-contract-namespace)]) + + (test/no-error + '(let ([v (chaperone-vector (vector-immutable 1) + (λ (vec i v) v) + (λ (vec i v) v))]) + (contract (vectorof any/c) v 'pos 'neg))) + + (test/no-error + '(let ([v (chaperone-vector (vector-immutable 1) + (λ (vec i v) v) + (λ (vec i v) v))]) + (contract (vector/c any/c) v 'pos 'neg)))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/with-contract.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/with-contract.rkt new file mode 100644 index 0000000000..ff7b506e36 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/with-contract.rkt @@ -0,0 +1,260 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace 'racket/contract)]) + + (test/spec-passed + 'with-contract-def-1 + '(let () + (with-contract odd-even + ([oddp (-> number? boolean?)] + [evenp (-> number? boolean?)]) + (define (oddp n) + (if (zero? n) #f (evenp (sub1 n)))) + (define (evenp n) + (if (zero? n) #t (oddp (sub1 n))))) + (oddp 5))) + + (test/spec-failed + 'with-contract-def-2 + '(let () + (with-contract odd-even + ([oddp (-> number? boolean?)] + [evenp (-> number? boolean?)]) + (define (oddp n) + (if (zero? n) #f (evenp (sub1 n)))) + (define (evenp n) + (if (zero? n) #t (oddp (sub1 n))))) + (oddp #t)) + "top-level") + + (test/spec-failed + 'with-contract-def-3 + '(let () + (with-contract odd-even + ([oddp (-> number? boolean?)] + [evenp (-> number? boolean?)]) + (define (oddp n) + (if (zero? n) n (evenp (sub1 n)))) + (define (evenp n) + (if (zero? n) #t (oddp (sub1 n))))) + (oddp 4)) + "(region odd-even)") + + ;; Functions within the same with-contract region can call + ;; each other however they want, so here we have even? + ;; call odd? with a boolean, even though its contract in + ;; the odd-even contract says it only takes numbers. + (test/spec-passed + 'with-contract-def-4 + '(let () + (with-contract odd-even + ([oddp (-> number? boolean?)] + [evenp (-> number? boolean?)]) + (define (oddp n) + (cond + [(not (number? n)) #f] + [(zero? n) #f] + [else (evenp (sub1 n))])) + (define (evenp n) + (if (zero? n) #t (oddp (zero? n))))) + (oddp 5))) + + (test/spec-passed + 'with-contract-def-5 + '(let () + (with-contract region1 + ([x (-> number? number?)]) + (with-contract region2 + ([y (-> number? boolean?)]) + (define (y n) #t)) + (define (x n) (if (y n) 0 3))) + (x 4))) + + (test/spec-failed + 'with-contract-def-6 + '(let () + (with-contract region1 + ([x (-> number? number?)]) + (with-contract region2 + ([y (-> number? boolean?)]) + (define (y n) #t)) + (define (x n) (y n))) + (x 4)) + "(region region1)") + + (test/spec-failed + 'with-contract-def-7 + '(let () + (with-contract region1 + ([x (-> number? number?)]) + (with-contract region2 + ([y (-> number? boolean?)]) + (define (y n) #t)) + (define (x n) (if (y #t) 4 0))) + (x 4)) + "(region region1)") + + (test/spec-failed + 'with-contract-def-8 + '(let () + (with-contract region1 + ([x (-> number? number?)]) + (with-contract region2 + ([y (-> number? boolean?)]) + (define (y n) 3)) + (define (x n) (if (y n) 4 0))) + (x 4)) + "(region region2)") + + ;; make sure uncontracted exports make it out + (test/spec-passed + 'with-contract-def-9 + '(let () + (with-contract region1 () + (define f 3)) + f)) + + (test/spec-failed + 'with-contract-def-10 + '(let () + (with-contract r + ([x number?]) + (define x 3) + (define-values () + (begin (set! x #f) (values)))) + x) + "(region r)") + + (test/spec-failed + 'with-contract-def-11 + '(let () + (with-contract r + ([x number?]) + (define x 3)) + (set! x #f) + x) + "top-level") + + (test/spec-passed + 'with-contract-exp-1 + '(with-contract r + #:result number? + 3)) + + (test/spec-failed + 'with-contract-exp-2 + '(with-contract r + #:result number? + "foo") + "(region r)") + + (test/spec-passed + 'with-contract-exp-3 + '((with-contract r + #:result (-> number? number?) + (λ (x) 5)) + 3)) + + (test/spec-failed + 'with-contract-exp-4 + '((with-contract r + #:result (-> number? number?) + (λ (x) (zero? x))) + 3) + "(region r)") + + (test/spec-failed + 'with-contract-exp-5 + '((with-contract r + #:result (-> number? number?) + (λ (x) 5)) + #t) + "top-level") + + (test/spec-passed + 'with-contract-exp-values-1 + '(let-values ([() (with-contract r #:results () (values))]) + 1)) + + (test/spec-passed + 'with-contract-exp-values-1 + '(let-values ([(x y) (with-contract r + #:results (number? string?) + (values 3 "foo"))]) + 1)) + + (test/spec-failed + 'with-contract-exp-values-2 + '(let-values ([(x y) (with-contract r + #:results (number? string?) + (values "bar" "foo"))]) + 1) + "(region r)") + + (test/spec-passed + 'with-contract-exp-values-3 + '(let-values ([(x y) (with-contract r + #:results (number? string?) + (define (f) (values 3 "foo")) + (f))]) + 1)) + + (test/spec-passed/result + 'with-contract-#%app + '(begin + (eval '(module with-contract-#%app-app racket + (define-syntax (-app x) #''apped) + (provide (rename-out (-app #%app))))) + (eval '(module with-contract-#%app-client racket + (require 'with-contract-#%app-app) + (provide with-contract-#%app-h with-contract-#%app-i) + (with-contract x ([f any/c]) (define (f x) 'f)) + (define (g x) 'g) + (define with-contract-#%app-h (f 2)) + (define with-contract-#%app-i (g 2)))) + (eval '(require 'with-contract-#%app-client)) + (eval '(list with-contract-#%app-h with-contract-#%app-i))) + (list 'apped 'apped)) + + (test/spec-passed/result + 'with-contract-one-contract-app-per-mutation-1 + '(let* ([counter 0] + [ctc (λ (x) (set! counter (add1 counter)) (number? x))]) + (with-contract foo ([x ctc]) + (define x 3)) + (+ x 4) + (+ x 6) + counter) + 1) + + (test/spec-passed/result + 'with-contract-one-contract-app-per-mutation-2 + '(let* ([counter 0] + [ctc (λ (x) (set! counter (add1 counter)) (number? x))]) + (with-contract foo ([x ctc]) + (define x 3)) + (+ x 4) + (+ x 6) + (set! x 6) + (+ x 6) + (+ x 2) + counter) + ;; 3 because of a double wrapping that occurs for outside mutations + ;; (that is, internal gets wrapped, then external gets wrapped again + ;; to fix blame. Could be optimized away if we had blame collapsing, + ;; e.g., (contract ctc (contract ctc x n1 p1) n2 p2) => + ;; (contract ctc x n2 p1), so if this breaks after adding such adjust it. + 3) + + ;; Check to make sure that any non-delayed set!s within the region don't + ;; get overridden when accessing the external version. + (test/spec-passed/result + 'with-contract-on-contract-app-per-mutation-3 + '(let () + (with-contract foo ([x number?]) + (define x 3) + (set! x 4)) + x) + 4))