suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Enforce that flat contracts return the original value.

Browse Source 
Also fix up tail call contract handling, which was affected by this change.
This commit is contained in:
Stevie Strickland 2010-09-07 16:47:21 -04:00
parent df18d1914d
commit 56a5a2627e
3 changed files with 101 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/racket/contract/private/arrow.rkt
View File

@ -1457,7 +1457,7 @@ v4 todo:
(λ (first-mark)
(if (and first-mark
(= (length first-mark) count)
(andmap eq? fs first-mark))
(andmap procedure-closure-contents-eq? fs first-mark))
(thunk)
(let-values ([(x ...) (with-continuation-mark multiple-contract-key fs
(thunk))])
@ -1477,7 +1477,7 @@ v4 todo:
(call-with-immediate-continuation-mark
single-contract-key
(λ (first-mark) ;; note this is #f if there is no mark (so if #f can be a contract, something must change)
(if (eq? first-mark ctc)
(if (and first-mark (procedure-closure-contents-eq? first-mark ctc))
(thnk)
(ctc
(with-continuation-mark single-contract-key ctc

49
collects/racket/contract/private/prop.rkt
View File

@ -108,7 +108,7 @@
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define ((build-property mk default-name)
(define ((build-property mk default-name projection-wrapper)
#:name [get-name #f]
#:first-order [get-first-order #f]
#:projection [get-projection #f]
@ -117,19 +117,31 @@
(let* ([get-name (or get-name (lambda (c) default-name))]
[get-first-order (or get-first-order get-any?)]
[get-projection (or get-projection
(get-first-order-projection
get-name get-first-order))]
[get-projection
(cond
[get-projection (projection-wrapper get-projection)]
[else (get-first-order-projection
get-name get-first-order)])]
[stronger (or stronger weakest)])
(mk get-name get-first-order get-projection stronger generator)))
(define build-contract-property
(build-property make-contract-property 'anonymous-contract))
(build-property make-contract-property 'anonymous-contract values))
;; Here we'll force the projection to always return the original value,
;; instead of assuming that the provided projection does so appropriately.
(define (flat-projection-wrapper f)
(λ (c)
(let ([proj (f c)])
(λ (b)
(let ([p (proj b)])
(λ (v) (p v) v))))))
(define build-flat-contract-property
(build-property (compose make-flat-contract-property make-contract-property)
'anonymous-flat-contract))
'anonymous-flat-contract
flat-projection-wrapper))
(define (get-any? c) any?)
(define (any? x) #t)
@ -153,23 +165,22 @@
(define-struct make-contract [ name first-order projection stronger ]
#:omit-define-syntaxes
#:property prop:contract
(make-contract-property
(lambda (c) (make-contract-name c))
(lambda (c) (make-contract-first-order c))
(lambda (c) (make-contract-projection c))
(lambda (a b) ((make-contract-stronger a) a b))
#f))
(build-contract-property
#:name (lambda (c) (make-contract-name c))
#:first-order (lambda (c) (make-contract-first-order c))
#:projection (lambda (c) (make-contract-projection c))
#:stronger (lambda (a b) ((make-contract-stronger a) a b))
#:generator #f))
(define-struct make-flat-contract [ name first-order projection stronger ]
#:omit-define-syntaxes
#:property prop:flat-contract
(make-flat-contract-property
(make-contract-property
(lambda (c) (make-flat-contract-name c))
(lambda (c) (make-flat-contract-first-order c))
(lambda (c) (make-flat-contract-projection c))
(lambda (a b) ((make-flat-contract-stronger a) a b))
#f)))
(build-flat-contract-property
#:name (lambda (c) (make-flat-contract-name c))
#:first-order (lambda (c) (make-flat-contract-first-order c))
#:projection (lambda (c) (make-flat-contract-projection c))
#:stronger (lambda (a b) ((make-flat-contract-stronger a) a b))
#:generator #f))
(define ((build-contract mk default-name)
#:name [name #f]

70
collects/tests/racket/contract-test.rktl
View File

@ -3670,6 +3670,71 @@
'make-contract-4
'((contract proj:add1->sub1 sqrt 'pos 'neg) 'dummy))
(ctest #t contract? proj:add1->sub1)
(ctest #f flat-contract? proj:add1->sub1)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; 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)
;; 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)
;
;
;
@ -9539,7 +9604,10 @@ so that propagation occurs.
(f 3))
(c)))
(ctest 2
;; Robby had this as 2, but now we only end up checking it once, which
;; looks right to me. Not sure whether "2" was _wanted_, or if it just
;; happened to be what it returned when run.
(ctest 1
'case->-regular
(let ([c (counter)])
(letrec ([f