adjust -> opter so that it avoids stacking up range checks
(using continuation marks, just like the un opt/c version of ->)
This commit is contained in:
Robby Findler
parent
6edfc0cc9d
commit
8706ac286e
|
|
@ -1768,64 +1768,6 @@ v4 todo:
|
|||
(append acc x)))
|
||||
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
; ; ;;; ;;;
|
||||
; ;;; ;;;
|
||||
; ;;;; ;;;;; ;;; ;;;
|
||||
; ;;;; ;;;;;;; ;;; ;;;
|
||||
; ;;; ;; ;;; ;;; ;;;
|
||||
; ;;; ;;;;; ;;; ;;;
|
||||
; ;;; ;;; ;;; ;;; ;;;
|
||||
; ;;;; ;;; ;;; ;;; ;;;
|
||||
; ;;; ;;;;;; ;;; ;;;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
|
||||
(define-syntax (apply-projections stx)
|
||||
(syntax-case stx ()
|
||||
[(_ ((x f) ...) e)
|
||||
(with-syntax ([count (length (syntax->list #'(x ...)))])
|
||||
#'(let ([fs (list f ...)]
|
||||
[thunk (λ () e)])
|
||||
(call-with-immediate-continuation-mark
|
||||
multiple-contract-key
|
||||
(λ (first-mark)
|
||||
(if (and first-mark
|
||||
(= (length first-mark) count)
|
||||
(andmap procedure-closure-contents-eq? fs first-mark))
|
||||
(thunk)
|
||||
(let-values ([(x ...) (with-continuation-mark multiple-contract-key fs
|
||||
(thunk))])
|
||||
(values/drop (f x) ...)))))))]))
|
||||
|
||||
|
||||
(define multiple-contract-key (gensym 'multiple-contract-key))
|
||||
|
||||
(define-syntax (apply-projection stx)
|
||||
(syntax-case stx ()
|
||||
[(_ ctc arg)
|
||||
#'(apply-projection/proc ctc (λ () arg))]))
|
||||
|
||||
(define single-contract-key (gensym 'single-contract-key))
|
||||
|
||||
(define (apply-projection/proc ctc thnk)
|
||||
(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 (and first-mark (procedure-closure-contents-eq? first-mark ctc))
|
||||
(thnk)
|
||||
(ctc
|
||||
(with-continuation-mark single-contract-key ctc
|
||||
(thnk)))))))
|
||||
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
;
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@
|
|||
(provide get-opter reg-opter! opter
|
||||
interleave-lifts
|
||||
|
||||
make-opt/info
|
||||
build-opt/info
|
||||
opt/info-contract
|
||||
opt/info-val
|
||||
opt/info-blame
|
||||
|
|
@ -22,6 +22,7 @@
|
|||
opt/info-swap-blame
|
||||
opt/info-add-blame-context
|
||||
opt/info-change-val
|
||||
opt/info-positive-blame
|
||||
|
||||
opt/unknown
|
||||
opt-error-name
|
||||
|
|
@ -148,13 +149,22 @@
|
|||
|
||||
;; struct for color-keeping across opters
|
||||
(define-struct opt/info
|
||||
(contract val blame-stx swap-blame? free-vars recf base-pred this that))
|
||||
(contract val blame-original-id blame-stx swap-blame? free-vars recf base-pred this that))
|
||||
(define (build-opt/info contract val blame-id free-vars this that)
|
||||
(make-opt/info contract val blame-id blame-id #f free-vars #f #f this that))
|
||||
|
||||
(define (opt/info-blame oi)
|
||||
(if (opt/info-swap-blame? oi)
|
||||
#`(blame-swap #,(opt/info-blame-stx oi))
|
||||
(opt/info-blame-stx oi)))
|
||||
|
||||
;; returns syntax that, when evaluated, computes
|
||||
;; the name of the positive blame party
|
||||
(define (opt/info-positive-blame oi)
|
||||
(if (opt/info-swap-blame? oi)
|
||||
#`(blame-positive #,(opt/info-blame-original-id oi))
|
||||
#`(blame-negative #,(opt/info-blame-original-id oi))))
|
||||
|
||||
;; opt/info-swap-blame : opt/info -> opt/info
|
||||
;; swaps pos and neg
|
||||
(define (opt/info-swap-blame info)
|
||||
|
|
|
|||
|
|
@ -229,7 +229,7 @@
|
|||
(values #'e (syntax-e #'x)))]))
|
||||
|
||||
(parameterize ([opt-error-name error-name-sym])
|
||||
(define info (make-opt/info #'ctc #'val #'blame #f '() #f #f #'this #'that))
|
||||
(define info (build-opt/info #'ctc #'val #'blame '() #'this #'that))
|
||||
(define an-optres (opt/i info exp #:call-opt/unknown? #f))
|
||||
(if an-optres
|
||||
(bind-superlifts
|
||||
|
|
@ -258,7 +258,7 @@
|
|||
(cond
|
||||
[(top-level-unknown? #'e) #'(otherwise-id e val-e blame-e)]
|
||||
[else
|
||||
(define info (make-opt/info #'ctc #'val #'blame #f '() #f #f #'this #'that))
|
||||
(define info (build-opt/info #'ctc #'val #'blame '() #'this #'that))
|
||||
(define an-optres (opt/i info #'e))
|
||||
#`(let ([val val-e]
|
||||
[blame blame-e])
|
||||
|
|
@ -302,9 +302,9 @@
|
|||
(syntax-case stx ()
|
||||
[(_ f1 f2 no-neg-blame? (id args ...) e)
|
||||
(let ()
|
||||
(define info (make-opt/info #'ctc #'val #'blame #f
|
||||
(define info (build-opt/info #'ctc #'val #'blame
|
||||
(syntax->list #'(args ...))
|
||||
#f #f #'this #'that))
|
||||
#'this #'that))
|
||||
;; it seems like this syntax-local-value can fail when expand-once
|
||||
;; is called, but otherwise I think it shouldn't fail
|
||||
(define bx (syntax-local-value #'no-neg-blame? (λ () #f)))
|
||||
|
|
|
|||
|
|
@ -557,27 +557,39 @@
|
|||
((next-dom ...) next-doms)
|
||||
(dom-len (length dom-vars))
|
||||
(rng-len (length rng-vars))
|
||||
((next-rng ...) next-rngs))
|
||||
((next-rng ...) next-rngs)
|
||||
[(dom-vars ...) (generate-temporaries dom-vars)]
|
||||
[(cont-mark-value) (generate-temporaries '(cont-mark-value))])
|
||||
(define (values/maybe-one stx)
|
||||
(syntax-case stx ()
|
||||
[(x) #'x]
|
||||
[(x ...) #'(values x ...)]))
|
||||
#`(let ([exact-proc (case-lambda
|
||||
[(dom-arg ...)
|
||||
(values
|
||||
(case-lambda
|
||||
[(rng-arg ...)
|
||||
#,(values/maybe-one #'(next-rng ...))]
|
||||
[args
|
||||
(bad-number-of-results blame val rng-len args)])
|
||||
next-dom ...)]
|
||||
[args
|
||||
(bad-number-of-arguments blame val args dom-len)])])
|
||||
#`(let* ([cont-mark-value (cons #,(opt/info-positive-blame opt/info) '#,rngs)]
|
||||
[exact-proc (case-lambda
|
||||
[(dom-arg ...)
|
||||
(let-values ([(rng-checker dom-vars ...)
|
||||
(values (case-lambda
|
||||
[(rng-arg ...)
|
||||
#,(values/maybe-one #'(next-rng ...))]
|
||||
[args
|
||||
(bad-number-of-results blame val rng-len args)])
|
||||
next-dom ...)])
|
||||
(call-with-immediate-continuation-mark
|
||||
opt->/c-cm-key
|
||||
(λ (mark-value)
|
||||
(if (equal? mark-value cont-mark-value)
|
||||
(values dom-vars ...)
|
||||
(values rng-checker
|
||||
dom-vars ...)))))]
|
||||
[args
|
||||
(bad-number-of-arguments blame val args dom-len)])])
|
||||
(if (and (procedure? val)
|
||||
(equal? dom-len (procedure-arity val))
|
||||
(let-values ([(a b) (procedure-keywords val)])
|
||||
(null? b)))
|
||||
(chaperone-procedure val exact-proc)
|
||||
(chaperone-procedure val exact-proc
|
||||
impersonator-prop:application-mark
|
||||
(cons opt->/c-cm-key cont-mark-value))
|
||||
(handle-non-exact-procedure val dom-len blame exact-proc))))
|
||||
(append lifts-doms lifts-rngs)
|
||||
(append superlifts-doms superlifts-rngs)
|
||||
|
|
@ -709,6 +721,8 @@
|
|||
#:name name)
|
||||
(opt/unknown opt/i opt/info stx))))]))
|
||||
|
||||
(define opt->/c-cm-key (gensym 'opt->/c-cm-key))
|
||||
|
||||
(define (blame-add-nth-arg-context blame n)
|
||||
(blame-add-context blame
|
||||
(format "the ~a argument of" (n->th n))))
|
||||
|
|
|
|||
|
|
@ -186,17 +186,32 @@
|
|||
(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)))
|
||||
(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)))))
|
||||
`(,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))
|
||||
|
|
@ -13040,100 +13055,114 @@ so that propagation occurs.
|
|||
[() c]
|
||||
[(x) (set! c (+ c 1)) #t]))))
|
||||
|
||||
(ctest 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 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 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 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 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 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 '(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)))))
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(define g
|
||||
(contract (-> number? any/c)
|
||||
(lambda (x)
|
||||
(f x))
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(f 3)))
|
||||
(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 ()
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user