some progress on the contract test suite
svn: r7850
This commit is contained in:
Robby Findler
parent
ba448d3f4b
commit
47a4b69e5d
|
|
@ -95,12 +95,12 @@ it around flattened out.
|
|||
(values))))
|
||||
(list))
|
||||
|
||||
(define-syntax name (list-immutable #'struct:-name
|
||||
#'struct-maker
|
||||
#'predicate
|
||||
(reverse (list-immutable #'selectors ...))
|
||||
(list-immutable #,@(map (λ (x) #f) (syntax->list #'(selectors ...))))
|
||||
#t))
|
||||
(define-syntax name (list #'struct:-name
|
||||
#'struct-maker
|
||||
#'predicate
|
||||
(reverse (list #'selectors ...))
|
||||
(list #,@(map (λ (x) #f) (syntax->list #'(selectors ...))))
|
||||
#t))
|
||||
|
||||
(define (evaluate-attrs stct contract/info)
|
||||
(when (wrap-parent-get stct 0) ;; test to make sure this even has attributes
|
||||
|
|
|
|||
|
|
@ -821,10 +821,8 @@ improve method arity mismatch contract violation error messages?
|
|||
false/c
|
||||
printable/c
|
||||
symbols one-of/c
|
||||
listof list-immutableof
|
||||
listof cons/c list/c
|
||||
vectorof vector-immutableof vector/c vector-immutable/c
|
||||
cons-immutable/c cons/c list-immutable/c list/c
|
||||
listof-unsafe cons-unsafe/c list-unsafe/c
|
||||
box-immutable/c box/c
|
||||
promise/c
|
||||
struct/c
|
||||
|
|
@ -1532,68 +1530,45 @@ improve method arity mismatch contract violation error messages?
|
|||
(build-compound-type-name 'not/c (proc/ctc->ctc f))
|
||||
(λ (x) (not (test-proc/flat-contract f x)))))
|
||||
|
||||
(define (listof p)
|
||||
(unless (flat-contract/predicate? p)
|
||||
(error 'listof "expected a flat contract or procedure of arity 1 as argument, got: ~e" p))
|
||||
(build-flat-contract
|
||||
(build-compound-type-name 'listof (proc/ctc->ctc p))
|
||||
(λ (v)
|
||||
(and (list? v)
|
||||
(andmap (λ (ele) (test-proc/flat-contract p ele))
|
||||
v)))))
|
||||
|
||||
(define-syntax (*-immutableof stx)
|
||||
(syntax-case stx ()
|
||||
[(_ predicate? fill type-name name)
|
||||
[(_ predicate? fill testmap type-name name)
|
||||
(identifier? (syntax predicate?))
|
||||
(syntax
|
||||
(let ([fill-name fill])
|
||||
(λ (input)
|
||||
(let* ([ctc (coerce-contract 'name input)]
|
||||
[proj (contract-proc ctc)])
|
||||
(make-proj-contract
|
||||
(build-compound-type-name 'name ctc)
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([p-app (proj pos-blame neg-blame src-info orig-str)])
|
||||
(λ (val)
|
||||
(unless (predicate? val)
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
pos-blame
|
||||
orig-str
|
||||
"expected <~a>, given: ~e"
|
||||
'type-name
|
||||
val))
|
||||
(fill-name p-app val))))
|
||||
predicate?)))))]))
|
||||
(let ([ctc (coerce-contract 'name input)])
|
||||
(if (flat-contract? ctc)
|
||||
(let ([content-pred? (flat-contract-predicate ctc)])
|
||||
(flat-contract
|
||||
(lambda (x) (and (predicate? x) (testmap content-pred? x)))))
|
||||
(let ([proj (contract-proc ctc)])
|
||||
(make-proj-contract
|
||||
(build-compound-type-name 'name ctc)
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([p-app (proj pos-blame neg-blame src-info orig-str)])
|
||||
(λ (val)
|
||||
(unless (predicate? val)
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
pos-blame
|
||||
orig-str
|
||||
"expected <~a>, given: ~e"
|
||||
'type-name
|
||||
val))
|
||||
(fill-name p-app val))))
|
||||
predicate?)))))))]))
|
||||
|
||||
(define (map-immutable f lst)
|
||||
(let loop ([lst lst])
|
||||
(cond
|
||||
[(pair? lst)
|
||||
(cons (f (car lst))
|
||||
(loop (cdr lst)))]
|
||||
[(null? lst) null])))
|
||||
|
||||
(define (immutable-list? val)
|
||||
(let loop ([v val])
|
||||
(or (and (pair? v)
|
||||
(immutable? v)
|
||||
(loop (cdr v)))
|
||||
(null? v))))
|
||||
|
||||
(define list-immutableof
|
||||
(*-immutableof immutable-list? map-immutable immutable-list list-immutableof))
|
||||
|
||||
(define listof-unsafe
|
||||
(*-immutableof list? map list listof-unsafe))
|
||||
(define listof
|
||||
(*-immutableof list? map andmap list listf))
|
||||
|
||||
(define (immutable-vector? val) (and (immutable? val) (vector? val)))
|
||||
|
||||
(define vector-immutableof
|
||||
(*-immutableof immutable-vector?
|
||||
(λ (f v) (apply vector-immutable (map f (vector->list v))))
|
||||
(λ (f v) (andmap f (vector->list v)))
|
||||
immutable-vector
|
||||
vector-immutableof))
|
||||
|
||||
|
|
@ -1635,17 +1610,6 @@ improve method arity mismatch contract violation error messages?
|
|||
(λ (x)
|
||||
(and (box? x)
|
||||
(test-proc/flat-contract pred (unbox x))))))
|
||||
|
||||
(define (cons/c hdp tlp)
|
||||
(unless (and (flat-contract/predicate? hdp)
|
||||
(flat-contract/predicate? tlp))
|
||||
(error 'cons/c "expected two flat contracts or procedures of arity 1, got: ~e and ~e" hdp tlp))
|
||||
(build-flat-contract
|
||||
(build-compound-type-name 'cons/c (proc/ctc->ctc hdp) (proc/ctc->ctc tlp))
|
||||
(λ (x)
|
||||
(and (pair? x)
|
||||
(test-proc/flat-contract hdp (car x))
|
||||
(test-proc/flat-contract tlp (cdr x))))))
|
||||
|
||||
;;
|
||||
;; cons/c opter
|
||||
|
|
@ -1730,28 +1694,35 @@ improve method arity mismatch contract violation error messages?
|
|||
[selector-names selectors] ...)
|
||||
(λ (params ...)
|
||||
(let ([ctc-x (coerce-contract 'name params)] ...)
|
||||
(let ([procs (contract-proc ctc-x)] ...)
|
||||
(make-proj-contract
|
||||
(build-compound-type-name 'name (proc/ctc->ctc params) ...)
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([p-apps (procs pos-blame neg-blame src-info orig-str)] ...)
|
||||
(λ (v)
|
||||
(if #,(if test-immutable?
|
||||
#'(and (predicate?-name v)
|
||||
(immutable? v))
|
||||
#'(predicate?-name v))
|
||||
(constructor-name (p-apps (selector-names v)) ...)
|
||||
(raise-contract-error
|
||||
v
|
||||
src-info
|
||||
pos-blame
|
||||
orig-str
|
||||
#,(if test-immutable?
|
||||
"expected immutable <~a>, given: ~e"
|
||||
"expected <~a>, given: ~e")
|
||||
'type-name
|
||||
v)))))
|
||||
#f)))))))]
|
||||
(if (and (flat-contract? ctc-x) ...)
|
||||
(let ([p-apps (flat-contract-predicate ctc-x)] ...)
|
||||
(flat-contract
|
||||
(lambda (x)
|
||||
(and (predicate?-name x)
|
||||
(p-apps (selector-names x))
|
||||
...))))
|
||||
(let ([procs (contract-proc ctc-x)] ...)
|
||||
(make-proj-contract
|
||||
(build-compound-type-name 'name (proc/ctc->ctc params) ...)
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([p-apps (procs pos-blame neg-blame src-info orig-str)] ...)
|
||||
(λ (v)
|
||||
(if #,(if test-immutable?
|
||||
#'(and (predicate?-name v)
|
||||
(immutable? v))
|
||||
#'(predicate?-name v))
|
||||
(constructor-name (p-apps (selector-names v)) ...)
|
||||
(raise-contract-error
|
||||
v
|
||||
src-info
|
||||
pos-blame
|
||||
orig-str
|
||||
#,(if test-immutable?
|
||||
"expected immutable <~a>, given: ~e"
|
||||
"expected <~a>, given: ~e")
|
||||
'type-name
|
||||
v)))))
|
||||
#f))))))))]
|
||||
[(_ predicate? constructor (arb? selector) correct-size type-name name)
|
||||
(eq? #t (syntax-object->datum (syntax arb?)))
|
||||
(syntax
|
||||
|
|
@ -1788,8 +1759,7 @@ improve method arity mismatch contract violation error messages?
|
|||
v)))))
|
||||
#f))))))]))
|
||||
|
||||
(define cons-immutable/c (*-immutable/c pair? cons (#f car cdr) immutable-cons cons-immutable/c))
|
||||
(define cons-unsafe/c (*-immutable/c pair? cons (#f car cdr) cons cons-unsafe/c #f))
|
||||
(define cons/c (*-immutable/c pair? cons (#f car cdr) cons cons/c #f))
|
||||
(define box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c))
|
||||
(define vector-immutable/c (*-immutable/c vector?
|
||||
vector-immutable
|
||||
|
|
@ -1799,16 +1769,16 @@ improve method arity mismatch contract violation error messages?
|
|||
vector-immutable/c))
|
||||
|
||||
;;
|
||||
;; cons-immutable/c opter
|
||||
;; cons/c opter
|
||||
;;
|
||||
(define/opter (cons-immutable/c opt/i opt/info stx)
|
||||
(define (opt/cons-immutable-ctc hdp tlp)
|
||||
(define/opter (cons/c opt/i opt/info stx)
|
||||
(define (opt/cons-ctc hdp tlp)
|
||||
(let-values ([(next-hdp lifts-hdp superlifts-hdp partials-hdp flat-hdp unknown-hdp stronger-ribs-hd)
|
||||
(opt/i opt/info hdp)]
|
||||
[(next-tlp lifts-tlp superlifts-tlp partials-tlp flat-tlp unknown-tlp stronger-ribs-tl)
|
||||
(opt/i opt/info tlp)])
|
||||
(with-syntax ((check (with-syntax ((val (opt/info-val opt/info)))
|
||||
(syntax (and (immutable? val) (pair? val))))))
|
||||
(syntax (pair? val)))))
|
||||
(values
|
||||
(with-syntax ((val (opt/info-val opt/info))
|
||||
(ctc (opt/info-contract opt/info))
|
||||
|
|
@ -1842,43 +1812,10 @@ improve method arity mismatch contract violation error messages?
|
|||
#f
|
||||
(append stronger-ribs-hd stronger-ribs-tl)))))
|
||||
|
||||
(syntax-case stx (cons-immutable/c)
|
||||
[(cons-immutable/c hdp tlp) (opt/cons-immutable-ctc #'hdp #'tlp)]))
|
||||
|
||||
(syntax-case stx (cons/c)
|
||||
[(_ hdp tlp) (opt/cons-ctc #'hdp #'tlp)]))
|
||||
|
||||
(define (list/c . args)
|
||||
(unless (andmap flat-contract/predicate? args)
|
||||
(error 'list/c "expected flat contracts, got: ~a"
|
||||
(let loop ([args args])
|
||||
(cond
|
||||
[(null? args) ""]
|
||||
[(null? (cdr args)) (format "~e" (car args))]
|
||||
[else (string-append
|
||||
(format "~e " (car args))
|
||||
(loop (cdr args)))]))))
|
||||
(let loop ([args args])
|
||||
(cond
|
||||
[(null? args) (flat-contract null?)]
|
||||
[else (cons/c (car args) (loop (cdr args)))])))
|
||||
|
||||
(define (list-immutable/c . args)
|
||||
(unless (andmap (λ (x) (or (contract? x)
|
||||
(and (procedure? x)
|
||||
(procedure-arity-includes? x 1))))
|
||||
args)
|
||||
(error 'list/c "expected contracts or procedures of arity 1, got: ~a"
|
||||
(let loop ([args args])
|
||||
(cond
|
||||
[(null? args) ""]
|
||||
[(null? (cdr args)) (format "~e" (car args))]
|
||||
[else (string-append
|
||||
(format "~e " (car args))
|
||||
(loop (cdr args)))]))))
|
||||
(let loop ([args args])
|
||||
(cond
|
||||
[(null? args) (flat-contract null?)]
|
||||
[else (cons-immutable/c (car args) (loop (cdr args)))])))
|
||||
|
||||
(define (list-unsafe/c . args)
|
||||
(unless (andmap (λ (x) (or (contract? x)
|
||||
(and (procedure? x)
|
||||
(procedure-arity-includes? x 1))))
|
||||
|
|
@ -1893,8 +1830,8 @@ improve method arity mismatch contract violation error messages?
|
|||
(loop (cdr args)))]))))
|
||||
(let loop ([args args])
|
||||
(cond
|
||||
[(null? args) (flat-contract null?)]
|
||||
[else (cons-unsafe/c (car args) (loop (cdr args)))])))
|
||||
[(null? args) (flat-contract null?)]
|
||||
[else (cons/c (car args) (loop (cdr args)))])))
|
||||
|
||||
(define (syntax/c ctc-in)
|
||||
(let ([ctc (coerce-contract 'syntax/c ctc-in)])
|
||||
|
|
|
|||
|
|
@ -2791,7 +2791,7 @@
|
|||
|
||||
(test/pos-blame
|
||||
'immutable1
|
||||
'(let ([ct (contract (list-immutableof (boolean? . -> . boolean?))
|
||||
'(let ([ct (contract (listof (boolean? . -> . boolean?))
|
||||
#f
|
||||
'pos
|
||||
'neg)])
|
||||
|
|
@ -2799,7 +2799,7 @@
|
|||
|
||||
(test/pos-blame
|
||||
'immutable2
|
||||
'(let ([ct (contract (list-immutableof (boolean? . -> . boolean?))
|
||||
'(let ([ct (contract (listof (boolean? . -> . boolean?))
|
||||
(list (lambda (x) x))
|
||||
'pos
|
||||
'neg)])
|
||||
|
|
@ -2807,24 +2807,24 @@
|
|||
|
||||
(test/neg-blame
|
||||
'immutable3
|
||||
'(let ([ct (contract (list-immutableof (number? . -> . boolean?))
|
||||
(list-immutable (lambda (x) 1))
|
||||
'(let ([ct (contract (listof (number? . -> . boolean?))
|
||||
(list (lambda (x) 1))
|
||||
'pos
|
||||
'neg)])
|
||||
((car ct) #f)))
|
||||
|
||||
(test/pos-blame
|
||||
'immutable4
|
||||
'(let ([ct (contract (list-immutableof (number? . -> . boolean?))
|
||||
(list-immutable (lambda (x) 1))
|
||||
'(let ([ct (contract (listof (number? . -> . boolean?))
|
||||
(list (lambda (x) 1))
|
||||
'pos
|
||||
'neg)])
|
||||
((car ct) 1)))
|
||||
|
||||
(test/spec-passed
|
||||
'immutable5
|
||||
'(let ([ct (contract (list-immutableof (number? . -> . boolean?))
|
||||
(list-immutable (lambda (x) #t))
|
||||
'(let ([ct (contract (listof (number? . -> . boolean?))
|
||||
(list (lambda (x) #t))
|
||||
'pos
|
||||
'neg)])
|
||||
((car ct) 1)))
|
||||
|
|
@ -2832,119 +2832,96 @@
|
|||
|
||||
(test/pos-blame
|
||||
'immutable6
|
||||
'(contract (cons-immutable/c (boolean? . -> . boolean?) (boolean? . -> . boolean?))
|
||||
'(contract (cons/c (boolean? . -> . boolean?) (boolean? . -> . boolean?))
|
||||
#f
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(test/pos-blame
|
||||
'immutable7
|
||||
'(contract (cons-immutable/c (boolean? . -> . boolean?) (boolean? . -> . boolean?))
|
||||
(cons (lambda (x) x) (lambda (x) x))
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(test/neg-blame
|
||||
'immutable8
|
||||
'(let ([ct (contract (cons-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
|
||||
(cons-immutable (lambda (x) 1) (lambda (x) 1))
|
||||
'(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-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
|
||||
(cons-immutable (lambda (x) 1) (lambda (x) 1))
|
||||
'(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-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
|
||||
(cons-immutable (lambda (x) 1) (lambda (x) 1))
|
||||
'(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-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
|
||||
(cons-immutable (lambda (x) 1) (lambda (x) 1))
|
||||
'(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-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
|
||||
(cons-immutable (lambda (x) #t) (lambda (x) #t))
|
||||
'(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-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
|
||||
(cons-immutable (lambda (x) #t) (lambda (x) #t))
|
||||
'(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-immutable/c number? boolean?)
|
||||
(cons-immutable 1 #t)
|
||||
'(contract (cons/c number? boolean?)
|
||||
(cons 1 #t)
|
||||
'pos
|
||||
'neg)
|
||||
(cons-immutable 1 #t))
|
||||
(cons 1 #t))
|
||||
|
||||
(test/pos-blame
|
||||
'immutable15
|
||||
'(contract (list-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
|
||||
'(contract (list/c (number? . -> . boolean?) (number? . -> . boolean?))
|
||||
#f
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(test/pos-blame
|
||||
'immutable16
|
||||
'(contract (list-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
|
||||
(list (lambda (x) #t) (lambda (x) #t))
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(test/pos-blame
|
||||
'immutable17
|
||||
'(contract (list-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
|
||||
(list-immutable (lambda (x) #t))
|
||||
'(contract (list/c (number? . -> . boolean?) (number? . -> . boolean?))
|
||||
(list (lambda (x) #t))
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(test/pos-blame
|
||||
'immutable18
|
||||
'(contract (list-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
|
||||
(list-immutable (lambda (x) #t) (lambda (x) #t) (lambda (x) #t))
|
||||
'(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-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
|
||||
(list-immutable (lambda (x) #t) (lambda (x) #t))
|
||||
'(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/spec-passed/result
|
||||
'immutable20
|
||||
'(let ([ctc (contract (list-immutable/c number?)
|
||||
(list-immutable 1)
|
||||
'pos
|
||||
'neg)])
|
||||
(immutable? ctc))
|
||||
#t)
|
||||
|
||||
(test/pos-blame
|
||||
'vector-immutable1
|
||||
'(contract (vector-immutableof (boolean? . -> . boolean?))
|
||||
|
|
@ -3089,191 +3066,6 @@
|
|||
'pos
|
||||
'neg))
|
||||
#t)
|
||||
|
||||
(test/pos-blame
|
||||
'unsafe1
|
||||
'(let ([ct (contract (listof-unsafe (boolean? . -> . boolean?))
|
||||
#f
|
||||
'pos
|
||||
'neg)])
|
||||
((car ct) 1)))
|
||||
|
||||
(test/neg-blame
|
||||
'unsafe2
|
||||
'(let ([ct (contract (listof-unsafe (boolean? . -> . boolean?))
|
||||
(list (lambda (x) x))
|
||||
'pos
|
||||
'neg)])
|
||||
((car ct) 1)))
|
||||
|
||||
(test/spec-passed
|
||||
'unsafe2b
|
||||
'(let ([ct (contract (listof-unsafe (boolean? . -> . boolean?))
|
||||
(list (lambda (x) x))
|
||||
'pos
|
||||
'neg)])
|
||||
((car ct) #t)))
|
||||
|
||||
(test/neg-blame
|
||||
'unsafe3
|
||||
'(let ([ct (contract (listof-unsafe (number? . -> . boolean?))
|
||||
(list (lambda (x) 1))
|
||||
'pos
|
||||
'neg)])
|
||||
((car ct) #f)))
|
||||
|
||||
(test/pos-blame
|
||||
'unsafe4
|
||||
'(let ([ct (contract (list-unsafe/c (number? . -> . boolean?))
|
||||
(list (lambda (x) 1))
|
||||
'pos
|
||||
'neg)])
|
||||
((car ct) 1)))
|
||||
|
||||
(test/spec-passed
|
||||
'unsafe5
|
||||
'(let ([ct (contract (listof-unsafe (number? . -> . boolean?))
|
||||
(list (lambda (x) #t))
|
||||
'pos
|
||||
'neg)])
|
||||
((car ct) 1)))
|
||||
|
||||
|
||||
(test/pos-blame
|
||||
'unsafe6
|
||||
'(contract (cons-unsafe/c (boolean? . -> . boolean?) (boolean? . -> . boolean?))
|
||||
#f
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(test/spec-passed
|
||||
'unsafe7
|
||||
'(contract (cons-unsafe/c (boolean? . -> . boolean?) (boolean? . -> . boolean?))
|
||||
(cons (lambda (x) x) (lambda (x) x))
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(test/neg-blame
|
||||
'unsafe8
|
||||
'(let ([ct (contract (cons-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?))
|
||||
(cons (lambda (x) 1) (lambda (x) 1))
|
||||
'pos
|
||||
'neg)])
|
||||
((car ct) #f)))
|
||||
|
||||
(test/neg-blame
|
||||
'unsafe9
|
||||
'(let ([ct (contract (cons-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?))
|
||||
(cons (lambda (x) 1) (lambda (x) 1))
|
||||
'pos
|
||||
'neg)])
|
||||
((cdr ct) #f)))
|
||||
|
||||
(test/pos-blame
|
||||
'unsafe10
|
||||
'(let ([ct (contract (cons-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?))
|
||||
(cons (lambda (x) 1) (lambda (x) 1))
|
||||
'pos
|
||||
'neg)])
|
||||
((car ct) 1)))
|
||||
|
||||
(test/pos-blame
|
||||
'unsafe11
|
||||
'(let ([ct (contract (cons-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?))
|
||||
(cons (lambda (x) 1) (lambda (x) 1))
|
||||
'pos
|
||||
'neg)])
|
||||
((cdr ct) 1)))
|
||||
|
||||
(test/spec-passed
|
||||
'unsafe12
|
||||
'(let ([ct (contract (cons-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?))
|
||||
(cons (lambda (x) #t) (lambda (x) #t))
|
||||
'pos
|
||||
'neg)])
|
||||
((car ct) 1)))
|
||||
|
||||
(test/spec-passed
|
||||
'unsafe13
|
||||
'(let ([ct (contract (cons-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?))
|
||||
(cons (lambda (x) #t) (lambda (x) #t))
|
||||
'pos
|
||||
'neg)])
|
||||
((cdr ct) 1)))
|
||||
|
||||
(test/spec-passed/result
|
||||
'unsafe14
|
||||
'(contract (cons-unsafe/c number? boolean?)
|
||||
(cons 1 #t)
|
||||
'pos
|
||||
'neg)
|
||||
(cons-immutable 1 #t))
|
||||
|
||||
(test/pos-blame
|
||||
'unsafe15
|
||||
'(contract (list-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?))
|
||||
#f
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(test/spec-passed
|
||||
'unsafe16
|
||||
'(contract (list-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?))
|
||||
(list (lambda (x) #t) (lambda (x) #t))
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(test/pos-blame
|
||||
'unsafe17
|
||||
'(contract (list-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?))
|
||||
(list (lambda (x) #t))
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(test/pos-blame
|
||||
'unsafe18
|
||||
'(contract (list-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?))
|
||||
(list (lambda (x) #t) (lambda (x) #t) (lambda (x) #t))
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(test/spec-passed
|
||||
'unsafe19
|
||||
'(let ([ctc (contract (list-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?))
|
||||
(list (lambda (x) #t) (lambda (x) #t))
|
||||
'pos
|
||||
'neg)])
|
||||
(for-each (lambda (x) (x 1)) ctc)))
|
||||
|
||||
(test/spec-passed/result
|
||||
'unsafe20
|
||||
'(let ([ctc (contract (list-unsafe/c number?)
|
||||
(list 1)
|
||||
'pos
|
||||
'neg)])
|
||||
(immutable? ctc))
|
||||
#f)
|
||||
|
||||
(test/spec-passed/result
|
||||
'unsafe21
|
||||
'(let* ([orig-list (list 1 2 3)]
|
||||
[ctc (contract (listof-unsafe number?)
|
||||
orig-list
|
||||
'pos
|
||||
'neg)])
|
||||
(eq? orig-list ctc))
|
||||
#f)
|
||||
|
||||
(test/spec-passed/result
|
||||
'listof-no-copy
|
||||
'(let* ([orig-list (list 1 2 3)]
|
||||
[ctc (contract (listof number?)
|
||||
orig-list
|
||||
'pos
|
||||
'neg)])
|
||||
(eq? orig-list ctc))
|
||||
#t)
|
||||
|
||||
|
||||
(test/pos-blame
|
||||
'promise/c1
|
||||
|
|
@ -4385,10 +4177,10 @@ so that propagation occurs.
|
|||
|
||||
(test-name '(listof boolean?) (listof boolean?))
|
||||
(test-name '(listof any/c) (listof any/c))
|
||||
(test-name '(list-immutableof boolean?) (list-immutableof boolean?))
|
||||
(test-name '(list-immutableof any/c) (list-immutableof any/c))
|
||||
(test-name '(list-immutableof boolean?) (list-immutableof boolean?))
|
||||
(test-name '(list-immutableof (-> boolean? boolean?)) (list-immutableof (-> boolean? boolean?)))
|
||||
(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 '(vectorof boolean?) (vectorof boolean?))
|
||||
(test-name '(vectorof any/c) (vectorof any/c))
|
||||
|
|
@ -4401,19 +4193,19 @@ so that propagation occurs.
|
|||
(test-name '(cons/c boolean? (cons/c integer? null?)) (list/c boolean? (flat-contract integer?)))
|
||||
(test-name '(cons/c boolean? (cons/c integer? null?)) (list/c boolean? (flat-contract integer?)))
|
||||
|
||||
(test-name '(cons-immutable/c boolean? integer?) (cons-immutable/c boolean? (flat-contract integer?)))
|
||||
(test-name '(cons-immutable/c boolean? integer?) (cons-immutable/c boolean? (flat-contract integer?)))
|
||||
(test-name '(cons-immutable/c boolean? integer?) (cons-immutable/c boolean? (flat-contract integer?)))
|
||||
(test-name '(cons-immutable/c (-> boolean? boolean?) integer?) (cons-immutable/c (-> boolean? boolean?) 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 '(cons-immutable/c boolean? (cons-immutable/c integer? null?))
|
||||
(list-immutable/c boolean? (flat-contract integer?)))
|
||||
(test-name '(cons-immutable/c boolean? (cons-immutable/c integer? null?))
|
||||
(list-immutable/c boolean? (flat-contract integer?)))
|
||||
(test-name '(cons-immutable/c boolean? (cons-immutable/c integer? null?))
|
||||
(list-immutable/c boolean? (flat-contract integer?)))
|
||||
(test-name '(cons-immutable/c (-> boolean? boolean?) (cons-immutable/c integer? null?))
|
||||
(list-immutable/c (-> boolean? boolean?) integer?))
|
||||
(test-name '(cons/c boolean? (cons/c integer? null?))
|
||||
(list/c boolean? (flat-contract integer?)))
|
||||
(test-name '(cons/c boolean? (cons/c integer? null?))
|
||||
(list/c boolean? (flat-contract integer?)))
|
||||
(test-name '(cons/c boolean? (cons/c integer? null?))
|
||||
(list/c boolean? (flat-contract integer?)))
|
||||
(test-name '(cons/c (-> boolean? boolean?) (cons/c integer? null?))
|
||||
(list/c (-> boolean? boolean?) integer?))
|
||||
|
||||
(test-name '(parameter/c integer?) (parameter/c integer?))
|
||||
|
||||
|
|
@ -4639,9 +4431,9 @@ so that propagation occurs.
|
|||
(ctest #f contract-first-order-passes? (->d integer? boolean? (lambda (x y) char?)) (λ (x) x))
|
||||
(ctest #f contract-first-order-passes? (->d integer? boolean? (lambda (x y) char?)) (λ (x y z) x))
|
||||
|
||||
(ctest #t contract-first-order-passes? (list-immutableof integer?) (list-immutable 1))
|
||||
(ctest #f contract-first-order-passes? (list-immutableof integer?) (list 1))
|
||||
(ctest #f contract-first-order-passes? (list-immutableof integer?) #f)
|
||||
(ctest #t contract-first-order-passes? (listof integer?) (list 1))
|
||||
(ctest #f contract-first-order-passes? (listof integer?) (list 1))
|
||||
(ctest #f contract-first-order-passes? (listof integer?) #f)
|
||||
|
||||
(ctest #t contract-first-order-passes? (vector-immutableof integer?) (vector->immutable-vector (vector 1)))
|
||||
(ctest #f contract-first-order-passes? (vector-immutableof integer?) 'x)
|
||||
|
|
@ -4717,11 +4509,11 @@ so that propagation occurs.
|
|||
(ctest #f contract-first-order-passes? (and/c (-> integer?) (-> integer? integer?)) (λ (x) x))
|
||||
|
||||
(ctest #t contract-first-order-passes?
|
||||
(cons-immutable/c boolean? (-> integer? integer?))
|
||||
(list*-immutable #t (λ (x) x)))
|
||||
(cons/c boolean? (-> integer? integer?))
|
||||
(list* #t (λ (x) x)))
|
||||
(ctest #t contract-first-order-passes?
|
||||
(cons-immutable/c boolean? (-> integer? integer?))
|
||||
(list*-immutable 1 2))
|
||||
(cons/c boolean? (-> integer? integer?))
|
||||
(list* 1 2))
|
||||
|
||||
(ctest #f contract-first-order-passes? (flat-rec-contract the-name) 1)
|
||||
|
||||
|
|
@ -4912,7 +4704,7 @@ so that propagation occurs.
|
|||
(require (lib "contract.ss"))
|
||||
(define-struct s_ (a))
|
||||
(provide/contract (struct s_ ((a any/c))))))
|
||||
(eval '(require contract-test-suite6b))
|
||||
(eval '(require 'contract-test-suite6b))
|
||||
(eval '(module contract-test-suite6b2 mzscheme
|
||||
(require 'contract-test-suite6b)
|
||||
(require (lib "contract.ss"))
|
||||
|
|
@ -4973,7 +4765,7 @@ so that propagation occurs.
|
|||
(provide/contract (struct s ((a number?) (b number?))))))
|
||||
(eval '(module pc10-n mzscheme
|
||||
(require (lib "struct.ss")
|
||||
pc10-m)
|
||||
'pc10-m)
|
||||
(print-struct #t)
|
||||
(copy-struct s
|
||||
(make-s 1 2)
|
||||
|
|
@ -5166,7 +4958,7 @@ so that propagation occurs.
|
|||
(provide/contract [f integer?])
|
||||
(define f 1)))
|
||||
(eval '(module provide/contract21b mzscheme
|
||||
(require-for-syntax provide/contract21a)
|
||||
(require-for-syntax 'provide/contract21a)
|
||||
(define-syntax (unit-body stx)
|
||||
f f
|
||||
#'1)))))
|
||||
|
|
@ -5179,7 +4971,7 @@ so that propagation occurs.
|
|||
(provide/contract [make-bound-identifier-mapping integer?])
|
||||
(define make-bound-identifier-mapping 1)))
|
||||
(eval '(module provide/contract22b mzscheme
|
||||
(require-for-syntax provide/contract22a)
|
||||
(require-for-syntax 'provide/contract22a)
|
||||
|
||||
(define-syntax (unit-body stx)
|
||||
make-bound-identifier-mapping)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user