add the ability to make chaperone contracts to ->i
This commit is contained in:
Robby Findler
parent
962a72dfda
commit
506c9be0cd
|
|
@ -2,7 +2,7 @@
|
||||||
(require "test-util.rkt")
|
(require "test-util.rkt")
|
||||||
|
|
||||||
(parameterize ([current-contract-namespace
|
(parameterize ([current-contract-namespace
|
||||||
(make-basic-contract-namespace)])
|
(make-basic-contract-namespace 'racket/contract/parametric)])
|
||||||
(define exn:fail:contract:blame? (contract-eval 'exn:fail:contract:blame?))
|
(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?]) any))
|
||||||
|
|
@ -1397,4 +1397,31 @@
|
||||||
1))
|
1))
|
||||||
|
|
||||||
;; this used to cause a runtime error in the code that parses ->i
|
;; 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)))
|
(test/no-error '(->i ([x () any/c] [y (x) any/c]) any))
|
||||||
|
|
||||||
|
(test/spec-passed/result
|
||||||
|
'really-chaperones.1
|
||||||
|
'(let ([f (λ () 1)])
|
||||||
|
(chaperone-of?
|
||||||
|
(contract (->i #:chaperone () any) f 'pos 'neg)
|
||||||
|
f))
|
||||||
|
#t)
|
||||||
|
|
||||||
|
(test/spec-passed/result
|
||||||
|
'really-chaperones.2
|
||||||
|
'(let ([f (λ () 1)])
|
||||||
|
(chaperone-of?
|
||||||
|
(contract (->i () [_ (new-∀/c)]) f 'pos 'neg)
|
||||||
|
f))
|
||||||
|
#f)
|
||||||
|
|
||||||
|
(test/spec-passed/result
|
||||||
|
'really-chaperones.3
|
||||||
|
'(with-handlers ([exn:fail?
|
||||||
|
(λ (x)
|
||||||
|
(regexp-match? #rx"^->i:.*chaperone" (exn-message x)))])
|
||||||
|
((contract (->i #:chaperone ([x integer?] [y (x) (new-∀/c)]) any)
|
||||||
|
(λ (x y) x)
|
||||||
|
'pos 'neg) 1 2)
|
||||||
|
"didn't raise an error")
|
||||||
|
#t))
|
||||||
|
|
|
||||||
|
|
@ -20,12 +20,13 @@ code does the parsing and validation of the syntax.
|
||||||
|
|
||||||
|#
|
|#
|
||||||
|
|
||||||
|
;; istx-is-chaperone-contract? : boolean?
|
||||||
;; args : (listof arg?)
|
;; args : (listof arg?)
|
||||||
;; rst : (or/c #f arg/res?)
|
;; rst : (or/c #f arg/res?)
|
||||||
;; pre : (listof pre/post?)
|
;; pre : (listof pre/post?)
|
||||||
;; ress : (or/c #f (listof eres?) (listof lres?))
|
;; ress : (or/c #f (listof eres?) (listof lres?))
|
||||||
;; post : (listof pre/post?)
|
;; post : (listof pre/post?)
|
||||||
(struct istx (args rst pre ress post) #:transparent)
|
(struct istx (is-chaperone-contract? args rst pre ress post) #:transparent)
|
||||||
;; NOTE: the ress field may contain a mixture of eres and lres structs
|
;; NOTE: the ress field may contain a mixture of eres and lres structs
|
||||||
;; but only temporarily; in that case, a syntax error
|
;; but only temporarily; in that case, a syntax error
|
||||||
;; is signaled and the istx struct is not used afterwards
|
;; is signaled and the istx struct is not used afterwards
|
||||||
|
|
@ -59,11 +60,13 @@ code does the parsing and validation of the syntax.
|
||||||
(define (parse-->i stx)
|
(define (parse-->i stx)
|
||||||
(if (identifier? stx)
|
(if (identifier? stx)
|
||||||
(raise-syntax-error #f "expected ->i to follow an open parenthesis" stx)
|
(raise-syntax-error #f "expected ->i to follow an open parenthesis" stx)
|
||||||
(let-values ([(raw-mandatory-doms raw-optional-doms
|
(let-values ([(is-chaperone-contract?
|
||||||
id/rest-id pre-cond range post-cond)
|
raw-mandatory-doms raw-optional-doms
|
||||||
|
id/rest-id pre-cond range post-cond)
|
||||||
(pull-out-pieces stx)])
|
(pull-out-pieces stx)])
|
||||||
(let ([candidate
|
(let ([candidate
|
||||||
(istx (append (parse-doms stx #f raw-mandatory-doms)
|
(istx is-chaperone-contract?
|
||||||
|
(append (parse-doms stx #f raw-mandatory-doms)
|
||||||
(parse-doms stx #t raw-optional-doms))
|
(parse-doms stx #t raw-optional-doms))
|
||||||
id/rest-id
|
id/rest-id
|
||||||
pre-cond
|
pre-cond
|
||||||
|
|
@ -393,12 +396,26 @@ code does the parsing and validation of the syntax.
|
||||||
;; pull-out-pieces :
|
;; pull-out-pieces :
|
||||||
;; stx -> (values raw-mandatory-doms raw-optional-doms id/rest-id pre-cond range post-cond)
|
;; stx -> (values raw-mandatory-doms raw-optional-doms id/rest-id pre-cond range post-cond)
|
||||||
(define (pull-out-pieces stx)
|
(define (pull-out-pieces stx)
|
||||||
(let*-values ([(raw-mandatory-doms leftover)
|
(let*-values ([(is-chaperone-contract? leftover)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ (raw-mandatory-doms ...) . leftover)
|
[(_ #:chaperone . leftover)
|
||||||
|
(values #t #'leftover)]
|
||||||
|
[(_ . leftover)
|
||||||
|
(let ([lst (syntax->list stx)])
|
||||||
|
(when (null? (cdr lst))
|
||||||
|
(raise-syntax-error #f "expected a sequence of mandatory domain elements"
|
||||||
|
stx))
|
||||||
|
(when (keyword? (syntax-e (cadr lst)))
|
||||||
|
(raise-syntax-error #f "unknown keyword"
|
||||||
|
stx
|
||||||
|
(cadr lst)))
|
||||||
|
(values #f #'leftover))])]
|
||||||
|
[(raw-mandatory-doms leftover)
|
||||||
|
(syntax-case leftover ()
|
||||||
|
[((raw-mandatory-doms ...) . leftover)
|
||||||
(values (syntax->list #'(raw-mandatory-doms ...))
|
(values (syntax->list #'(raw-mandatory-doms ...))
|
||||||
#'leftover)]
|
#'leftover)]
|
||||||
[(_ a . leftover)
|
[(a . leftover)
|
||||||
(raise-syntax-error #f
|
(raise-syntax-error #f
|
||||||
"expected a sequence of mandatory domain elements"
|
"expected a sequence of mandatory domain elements"
|
||||||
stx #'a)]
|
stx #'a)]
|
||||||
|
|
@ -604,7 +621,9 @@ code does the parsing and validation of the syntax.
|
||||||
(values (reverse post-conds) leftover)]))])
|
(values (reverse post-conds) leftover)]))])
|
||||||
(syntax-case leftover ()
|
(syntax-case leftover ()
|
||||||
[()
|
[()
|
||||||
(values raw-mandatory-doms raw-optional-doms id/rest-id pre-conds range post-conds)]
|
(values is-chaperone-contract?
|
||||||
|
raw-mandatory-doms raw-optional-doms id/rest-id pre-conds
|
||||||
|
range post-conds)]
|
||||||
[(a . b)
|
[(a . b)
|
||||||
(raise-syntax-error #f "bad syntax" stx #'a)]
|
(raise-syntax-error #f "bad syntax" stx #'a)]
|
||||||
[_
|
[_
|
||||||
|
|
|
||||||
|
|
@ -27,7 +27,7 @@
|
||||||
|
|
||||||
(provide (rename-out [->i/m ->i]))
|
(provide (rename-out [->i/m ->i]))
|
||||||
|
|
||||||
(define (build-??-args ctc blame)
|
(define (build-??-args c-or-i-procedure ctc blame)
|
||||||
(define arg-ctc-projs (map (λ (x) (contract-projection (->i-arg-contract x))) (->i-arg-ctcs ctc)))
|
(define arg-ctc-projs (map (λ (x) (contract-projection (->i-arg-contract x))) (->i-arg-ctcs ctc)))
|
||||||
(define indy-arg-ctc-projs (map (λ (x) (contract-projection (cdr x)))
|
(define indy-arg-ctc-projs (map (λ (x) (contract-projection (cdr x)))
|
||||||
(->i-indy-arg-ctcs ctc)))
|
(->i-indy-arg-ctcs ctc)))
|
||||||
|
|
@ -81,7 +81,8 @@
|
||||||
[rng-pr (in-list (->i-indy-rng-ctcs ctc))])
|
[rng-pr (in-list (->i-indy-rng-ctcs ctc))])
|
||||||
(rng-proj (blame-add-context indy-rng-blame (format "the ~a result of"
|
(rng-proj (blame-add-context indy-rng-blame (format "the ~a result of"
|
||||||
(car rng-pr))))))
|
(car rng-pr))))))
|
||||||
(list* (λ (val mtd?)
|
(list* c-or-i-procedure
|
||||||
|
(λ (val mtd?)
|
||||||
(if has-rest
|
(if has-rest
|
||||||
(check-procedure/more val mtd?
|
(check-procedure/more val mtd?
|
||||||
(->i-mandatory-args ctc)
|
(->i-mandatory-args ctc)
|
||||||
|
|
@ -104,10 +105,10 @@
|
||||||
partial-indy-rngs)))
|
partial-indy-rngs)))
|
||||||
|
|
||||||
(define arr->i-proj
|
(define arr->i-proj
|
||||||
(λ (ctc)
|
(λ (ctc c-or-i-procedure)
|
||||||
(define func (->i-mk-wrapper ctc))
|
(define func (->i-mk-wrapper ctc))
|
||||||
(λ (blame)
|
(λ (blame)
|
||||||
(define ???-args (build-??-args ctc blame))
|
(define ???-args (build-??-args c-or-i-procedure ctc blame))
|
||||||
(apply func ???-args))))
|
(apply func ???-args))))
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -183,140 +184,160 @@
|
||||||
pre/post-procs
|
pre/post-procs
|
||||||
mandatory-args opt-args mandatory-kwds opt-kwds rest
|
mandatory-args opt-args mandatory-kwds opt-kwds rest
|
||||||
mtd? here mk-wrapper mk-val-first-wrapper name-info)
|
mtd? here mk-wrapper mk-val-first-wrapper name-info)
|
||||||
#:property prop:custom-write custom-write-property-proc
|
#:property prop:custom-write custom-write-property-proc)
|
||||||
#:property prop:contract
|
|
||||||
(build-contract-property
|
(define (mk-prop chaperone?)
|
||||||
#:val-first-projection
|
(define c-or-i-procedure (if chaperone? chaperone-procedure impersonate-procedure))
|
||||||
(λ (ctc)
|
((if chaperone? build-chaperone-contract-property build-contract-property)
|
||||||
(define blame-accepting-proj (arr->i-proj ctc))
|
#:val-first-projection
|
||||||
(λ (blame)
|
(λ (ctc)
|
||||||
(λ (val)
|
(define blame-accepting-proj (arr->i-proj ctc c-or-i-procedure))
|
||||||
(wrapped-extra-arg-arrow
|
(λ (blame)
|
||||||
(λ (neg-party)
|
(λ (val)
|
||||||
((blame-accepting-proj (blame-add-missing-party blame neg-party)) val))
|
(wrapped-extra-arg-arrow
|
||||||
(->i-mk-val-first-wrapper ctc)))))
|
(λ (neg-party)
|
||||||
#:late-neg-projection
|
((blame-accepting-proj (blame-add-missing-party blame neg-party)) val))
|
||||||
(λ (ctc)
|
(->i-mk-val-first-wrapper ctc)))))
|
||||||
(define blame-accepting-proj (arr->i-proj ctc))
|
#:late-neg-projection
|
||||||
(λ (blame)
|
(λ (ctc)
|
||||||
(λ (val neg-party)
|
(define blame-accepting-proj (arr->i-proj ctc c-or-i-procedure))
|
||||||
((blame-accepting-proj (blame-add-missing-party blame neg-party)) val))))
|
(λ (blame)
|
||||||
#:projection arr->i-proj
|
(λ (val neg-party)
|
||||||
#:name (λ (ctc)
|
((blame-accepting-proj (blame-add-missing-party blame neg-party)) val))))
|
||||||
(define (arg/ress->spec infos ctcs dep-ctcs skip?)
|
#:projection (λ (ctc) (arr->i-proj ctc c-or-i-procedure))
|
||||||
(let loop ([infos infos]
|
#:name (λ (ctc)
|
||||||
[ctcs ctcs]
|
(define (arg/ress->spec infos ctcs dep-ctcs skip?)
|
||||||
[dep-ctcs dep-ctcs])
|
(let loop ([infos infos]
|
||||||
(cond
|
[ctcs ctcs]
|
||||||
[(null? infos) '()]
|
[dep-ctcs dep-ctcs])
|
||||||
[else
|
(cond
|
||||||
(let* ([info (car infos)]
|
[(null? infos) '()]
|
||||||
[dep/nodep (list-ref info 0)]
|
[else
|
||||||
[var (list-ref info 1)]
|
(let* ([info (car infos)]
|
||||||
[vars (list-ref info 2)]
|
[dep/nodep (list-ref info 0)]
|
||||||
[kwd (list-ref info 3)])
|
[var (list-ref info 1)]
|
||||||
(case dep/nodep
|
[vars (list-ref info 2)]
|
||||||
[(nodep)
|
[kwd (list-ref info 3)])
|
||||||
(if (skip? info)
|
(case dep/nodep
|
||||||
(loop (cdr infos) (cdr ctcs) dep-ctcs)
|
[(nodep)
|
||||||
`(,@(if kwd
|
(if (skip? info)
|
||||||
(list kwd)
|
(loop (cdr infos) (cdr ctcs) dep-ctcs)
|
||||||
(list))
|
`(,@(if kwd
|
||||||
[,var ,(contract-name (car ctcs))]
|
(list kwd)
|
||||||
.
|
(list))
|
||||||
,(loop (cdr infos) (cdr ctcs) dep-ctcs)))]
|
[,var ,(contract-name (car ctcs))]
|
||||||
[(dep)
|
.
|
||||||
(define body-src (list-ref info 5))
|
,(loop (cdr infos) (cdr ctcs) dep-ctcs)))]
|
||||||
(if (skip? info)
|
[(dep)
|
||||||
(loop (cdr infos) ctcs (cdr dep-ctcs))
|
(define body-src (list-ref info 5))
|
||||||
`(,@(if kwd
|
(if (skip? info)
|
||||||
(list kwd)
|
(loop (cdr infos) ctcs (cdr dep-ctcs))
|
||||||
(list))
|
`(,@(if kwd
|
||||||
[,var ,vars ,body-src]
|
(list kwd)
|
||||||
.
|
(list))
|
||||||
,(loop (cdr infos) ctcs (cdr dep-ctcs))))]))])))
|
[,var ,vars ,body-src]
|
||||||
(let* ([name-info (->i-name-info ctc)]
|
.
|
||||||
[args-info (vector-ref name-info 0)]
|
,(loop (cdr infos) ctcs (cdr dep-ctcs))))]))])))
|
||||||
[rest-info (vector-ref name-info 1)]
|
(let* ([name-info (->i-name-info ctc)]
|
||||||
[pre-infos (vector-ref name-info 2)]
|
[args-info (vector-ref name-info 0)]
|
||||||
[rng-info (vector-ref name-info 3)]
|
[rest-info (vector-ref name-info 1)]
|
||||||
[post-infos (vector-ref name-info 4)])
|
[pre-infos (vector-ref name-info 2)]
|
||||||
`(->i ,(arg/ress->spec args-info
|
[rng-info (vector-ref name-info 3)]
|
||||||
(map ->i-arg-contract (->i-arg-ctcs ctc))
|
[post-infos (vector-ref name-info 4)])
|
||||||
(->i-arg-dep-ctcs ctc)
|
`(->i ,(arg/ress->spec args-info
|
||||||
(λ (x) (list-ref x 4)))
|
(map ->i-arg-contract (->i-arg-ctcs ctc))
|
||||||
,@(let ([rests (arg/ress->spec args-info
|
(->i-arg-dep-ctcs ctc)
|
||||||
(map ->i-arg-contract (->i-arg-ctcs ctc))
|
(λ (x) (list-ref x 4)))
|
||||||
(->i-arg-dep-ctcs ctc)
|
,@(let ([rests (arg/ress->spec args-info
|
||||||
(λ (x) (not (list-ref x 4))))])
|
(map ->i-arg-contract (->i-arg-ctcs ctc))
|
||||||
(if (null? rests)
|
(->i-arg-dep-ctcs ctc)
|
||||||
'()
|
(λ (x) (not (list-ref x 4))))])
|
||||||
(list rests)))
|
(if (null? rests)
|
||||||
,@(if rest-info
|
'()
|
||||||
(case (car rest-info)
|
(list rests)))
|
||||||
[(nodep) `(#:rest
|
,@(if rest-info
|
||||||
[,(list-ref rest-info 1)
|
(case (car rest-info)
|
||||||
,(contract-name
|
[(nodep) `(#:rest
|
||||||
(car
|
[,(list-ref rest-info 1)
|
||||||
(reverse
|
,(contract-name
|
||||||
(map ->i-arg-contract (->i-arg-ctcs ctc)))))])]
|
(car
|
||||||
[(dep) `(#:rest [,(list-ref rest-info 1)
|
(reverse
|
||||||
,(list-ref rest-info 2)
|
(map ->i-arg-contract (->i-arg-ctcs ctc)))))])]
|
||||||
,(list-ref rest-info 3)])])
|
[(dep) `(#:rest [,(list-ref rest-info 1)
|
||||||
'())
|
,(list-ref rest-info 2)
|
||||||
,@(apply
|
,(list-ref rest-info 3)])])
|
||||||
append
|
'())
|
||||||
(for/list ([pre-info pre-infos])
|
,@(apply
|
||||||
(define ids (list-ref pre-info 0))
|
append
|
||||||
(define name (list-ref pre-info 1))
|
(for/list ([pre-info pre-infos])
|
||||||
(define code (list-ref pre-info 2))
|
(define ids (list-ref pre-info 0))
|
||||||
(cond
|
(define name (list-ref pre-info 1))
|
||||||
[(string? name)
|
(define code (list-ref pre-info 2))
|
||||||
`(#:pre/name ,ids ,name ,code)]
|
(cond
|
||||||
[(equal? name 'bool)
|
[(string? name)
|
||||||
`(#:pre ,ids ,code)]
|
`(#:pre/name ,ids ,name ,code)]
|
||||||
[(equal? name 'desc)
|
[(equal? name 'bool)
|
||||||
`(#:pre/desc ,ids ,code)])))
|
`(#:pre ,ids ,code)]
|
||||||
,(cond
|
[(equal? name 'desc)
|
||||||
[(not rng-info)
|
`(#:pre/desc ,ids ,code)])))
|
||||||
'any]
|
,(cond
|
||||||
[else
|
[(not rng-info)
|
||||||
(let ([infos (arg/ress->spec rng-info
|
'any]
|
||||||
(map cdr (->i-rng-ctcs ctc))
|
[else
|
||||||
(->i-rng-dep-ctcs ctc)
|
(let ([infos (arg/ress->spec rng-info
|
||||||
(λ (x) #f))])
|
(map cdr (->i-rng-ctcs ctc))
|
||||||
(cond
|
(->i-rng-dep-ctcs ctc)
|
||||||
[(or (null? infos) (not (null? (cdr infos))))
|
(λ (x) #f))])
|
||||||
`(values ,@infos)]
|
(cond
|
||||||
[else
|
[(or (null? infos) (not (null? (cdr infos))))
|
||||||
(car infos)]))])
|
`(values ,@infos)]
|
||||||
,@(apply
|
[else
|
||||||
append
|
(car infos)]))])
|
||||||
(for/list ([post-info post-infos])
|
,@(apply
|
||||||
(define ids (list-ref post-info 0))
|
append
|
||||||
(define name (list-ref post-info 1))
|
(for/list ([post-info post-infos])
|
||||||
(define code (list-ref post-info 2))
|
(define ids (list-ref post-info 0))
|
||||||
(cond
|
(define name (list-ref post-info 1))
|
||||||
[(string? name)
|
(define code (list-ref post-info 2))
|
||||||
`(#:post/name ,ids ,name ,code)]
|
(cond
|
||||||
[(equal? name 'bool)
|
[(string? name)
|
||||||
`(#:post ,ids ,code)]
|
`(#:post/name ,ids ,name ,code)]
|
||||||
[(equal? name 'desc)
|
[(equal? name 'bool)
|
||||||
`(#:post/desc ,ids ,code)]))))))
|
`(#:post ,ids ,code)]
|
||||||
#:first-order
|
[(equal? name 'desc)
|
||||||
(λ (ctc)
|
`(#:post/desc ,ids ,code)]))))))
|
||||||
(let ([has-rest (->i-rest ctc)]
|
#:first-order
|
||||||
[mtd? (->i-mtd? ctc)]
|
(λ (ctc)
|
||||||
[mand-args (->i-mandatory-args ctc)]
|
(let ([has-rest (->i-rest ctc)]
|
||||||
[opt-args (->i-opt-args ctc)]
|
[mtd? (->i-mtd? ctc)]
|
||||||
[mand-kwds (->i-mandatory-kwds ctc)]
|
[mand-args (->i-mandatory-args ctc)]
|
||||||
[opt-kwds (->i-opt-kwds ctc)])
|
[opt-args (->i-opt-args ctc)]
|
||||||
(λ (val)
|
[mand-kwds (->i-mandatory-kwds ctc)]
|
||||||
(if has-rest
|
[opt-kwds (->i-opt-kwds ctc)])
|
||||||
(check-procedure/more val mtd? mand-args mand-kwds opt-kwds #f #f)
|
(λ (val)
|
||||||
(check-procedure val mtd? mand-args opt-args mand-kwds opt-kwds #f #f)))))
|
(if has-rest
|
||||||
#:exercise exercise->i
|
(check-procedure/more val mtd? mand-args mand-kwds opt-kwds #f #f)
|
||||||
#:stronger (λ (this that) (eq? this that)))) ;; WRONG
|
(check-procedure val mtd? mand-args opt-args mand-kwds opt-kwds #f #f)))))
|
||||||
|
#:exercise exercise->i
|
||||||
|
#:stronger (λ (this that) (eq? this that)))) ;; WRONG
|
||||||
|
|
||||||
|
(struct chaperone->i ->i () #:property prop:chaperone-contract (mk-prop #t))
|
||||||
|
(struct impersonator->i ->i () #:property prop:contract (mk-prop #f))
|
||||||
|
(define (make-->i is-chaperone-contract? blame-info
|
||||||
|
arg-ctcs arg-dep-ctcs indy-arg-ctcs
|
||||||
|
rng-ctcs rng-dep-ctcs indy-rng-ctcs
|
||||||
|
pre/post-procs
|
||||||
|
mandatory-args opt-args mandatory-kwds opt-kwds rest
|
||||||
|
mtd? here mk-wrapper mk-val-first-wrapper name-info)
|
||||||
|
(define maker (if is-chaperone-contract? chaperone->i impersonator->i))
|
||||||
|
(maker blame-info
|
||||||
|
arg-ctcs arg-dep-ctcs indy-arg-ctcs
|
||||||
|
rng-ctcs rng-dep-ctcs indy-rng-ctcs
|
||||||
|
pre/post-procs
|
||||||
|
mandatory-args opt-args mandatory-kwds opt-kwds rest
|
||||||
|
mtd? here mk-wrapper mk-val-first-wrapper name-info))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;; find-ordering : (listof arg) -> (values (listof arg) (listof number))
|
;; find-ordering : (listof arg) -> (values (listof arg) (listof number))
|
||||||
;; sorts the arguments according to the dependency order.
|
;; sorts the arguments according to the dependency order.
|
||||||
|
|
@ -655,7 +676,7 @@ evaluted left-to-right.)
|
||||||
;; adds nested lets that bind the wrapper-args and the indy-arg/res-vars to projected values,
|
;; adds nested lets that bind the wrapper-args and the indy-arg/res-vars to projected values,
|
||||||
;; with 'body' in the body of the let also handles adding code to check to see if unsupplied
|
;; with 'body' in the body of the let also handles adding code to check to see if unsupplied
|
||||||
;; args are present (skipping the contract check, if so)
|
;; args are present (skipping the contract check, if so)
|
||||||
(define-for-syntax (add-wrapper-let body swapped-blame? neg-calls?
|
(define-for-syntax (add-wrapper-let body is-chaperone-contract? swapped-blame? neg-calls?
|
||||||
ordered-arg/reses indicies
|
ordered-arg/reses indicies
|
||||||
arg/res-proj-vars indy-arg/res-proj-vars
|
arg/res-proj-vars indy-arg/res-proj-vars
|
||||||
wrapper-arg/ress indy-arg/res-vars
|
wrapper-arg/ress indy-arg/res-vars
|
||||||
|
|
@ -706,11 +727,12 @@ evaluted left-to-right.)
|
||||||
wrapper-arg
|
wrapper-arg
|
||||||
(cond
|
(cond
|
||||||
[(and (eres? an-arg/res) (arg/res-vars an-arg/res))
|
[(and (eres? an-arg/res) (arg/res-vars an-arg/res))
|
||||||
#`(un-dep #,(eres-eid an-arg/res)
|
#`(#,(if is-chaperone-contract? #'un-dep/chaperone #'un-dep)
|
||||||
#,wrapper-arg
|
#,(eres-eid an-arg/res)
|
||||||
#,(build-blame-identifier #f
|
#,wrapper-arg
|
||||||
swapped-blame?
|
#,(build-blame-identifier #f
|
||||||
(arg/res-var an-arg/res)))]
|
swapped-blame?
|
||||||
|
(arg/res-var an-arg/res)))]
|
||||||
[(arg/res-vars an-arg/res)
|
[(arg/res-vars an-arg/res)
|
||||||
#`(#,arg/res-proj-var
|
#`(#,arg/res-proj-var
|
||||||
#,@(map (λ (var) (arg/res-to-indy-var indy-arg-vars
|
#,@(map (λ (var) (arg/res-to-indy-var indy-arg-vars
|
||||||
|
|
@ -789,6 +811,7 @@ evaluted left-to-right.)
|
||||||
#,(add-wrapper-let
|
#,(add-wrapper-let
|
||||||
(add-post-cond an-istx indy-arg-vars ordered-args indy-res-vars ordered-ress
|
(add-post-cond an-istx indy-arg-vars ordered-args indy-res-vars ordered-ress
|
||||||
#`(values #,@(vector->list wrapper-ress)))
|
#`(values #,@(vector->list wrapper-ress)))
|
||||||
|
(istx-is-chaperone-contract? an-istx)
|
||||||
#f #f
|
#f #f
|
||||||
ordered-ress res-indices
|
ordered-ress res-indices
|
||||||
res-proj-vars indy-res-proj-vars
|
res-proj-vars indy-res-proj-vars
|
||||||
|
|
@ -868,6 +891,7 @@ evaluted left-to-right.)
|
||||||
(istx-rst an-istx)
|
(istx-rst an-istx)
|
||||||
wrapper-args
|
wrapper-args
|
||||||
this-param)))
|
this-param)))
|
||||||
|
(istx-is-chaperone-contract? an-istx)
|
||||||
#t #f
|
#t #f
|
||||||
ordered-args arg-indices
|
ordered-args arg-indices
|
||||||
arg-proj-vars indy-arg-proj-vars
|
arg-proj-vars indy-arg-proj-vars
|
||||||
|
|
@ -879,7 +903,7 @@ evaluted left-to-right.)
|
||||||
#`(λ #,wrapper-proc-arglist
|
#`(λ #,wrapper-proc-arglist
|
||||||
(λ (val)
|
(λ (val)
|
||||||
(chk val #,(and (syntax-parameter-value #'making-a-method) #t))
|
(chk val #,(and (syntax-parameter-value #'making-a-method) #t))
|
||||||
(impersonate-procedure
|
(c-or-i-procedure
|
||||||
val
|
val
|
||||||
(let ([arg-checker
|
(let ([arg-checker
|
||||||
(λ #,(args/vars->arglist an-istx wrapper-args this-param)
|
(λ #,(args/vars->arglist an-istx wrapper-args this-param)
|
||||||
|
|
@ -954,7 +978,7 @@ evaluted left-to-right.)
|
||||||
'()))))
|
'()))))
|
||||||
|
|
||||||
(define wrapper-proc-arglist
|
(define wrapper-proc-arglist
|
||||||
#`(chk ctc blame swapped-blame #,@(map car blame-ids)
|
#`(c-or-i-procedure chk ctc blame swapped-blame #,@(map car blame-ids)
|
||||||
|
|
||||||
;; the pre- and post-condition procs
|
;; the pre- and post-condition procs
|
||||||
#,@(for/list ([pres (istx-pre an-istx)]
|
#,@(for/list ([pres (istx-pre an-istx)]
|
||||||
|
|
@ -1037,6 +1061,7 @@ evaluted left-to-right.)
|
||||||
(istx-rst an-istx)
|
(istx-rst an-istx)
|
||||||
wrapper-args
|
wrapper-args
|
||||||
this-param)
|
this-param)
|
||||||
|
(istx-is-chaperone-contract? an-istx)
|
||||||
#t #t
|
#t #t
|
||||||
ordered-args arg-indices
|
ordered-args arg-indices
|
||||||
arg-proj-vars indy-arg-proj-vars
|
arg-proj-vars indy-arg-proj-vars
|
||||||
|
|
@ -1059,8 +1084,17 @@ evaluted left-to-right.)
|
||||||
#`(f #,@argument-list)))
|
#`(f #,@argument-list)))
|
||||||
|
|
||||||
(begin-encourage-inline
|
(begin-encourage-inline
|
||||||
(define (un-dep ctc obj blame)
|
(define (un-dep/chaperone orig-ctc obj blame)
|
||||||
(let ([ctc (coerce-contract '->i ctc)])
|
(let ([ctc (coerce-contract '->i orig-ctc)])
|
||||||
|
(unless (chaperone-contract? ctc)
|
||||||
|
(raise-argument-error '->i
|
||||||
|
"chaperone-contract?"
|
||||||
|
orig-ctc))
|
||||||
|
(((contract-projection ctc) blame) obj))))
|
||||||
|
|
||||||
|
(begin-encourage-inline
|
||||||
|
(define (un-dep orig-ctc obj blame)
|
||||||
|
(let ([ctc (coerce-contract '->i orig-ctc)])
|
||||||
(((contract-projection ctc) blame) obj))))
|
(((contract-projection ctc) blame) obj))))
|
||||||
|
|
||||||
(define-for-syntax (mk-used-indy-vars an-istx)
|
(define-for-syntax (mk-used-indy-vars an-istx)
|
||||||
|
|
@ -1161,10 +1195,13 @@ evaluted left-to-right.)
|
||||||
an-id arg/ress-to-look-in))
|
an-id arg/ress-to-look-in))
|
||||||
ans))
|
ans))
|
||||||
|
|
||||||
|
(define is-chaperone-contract? (istx-is-chaperone-contract? an-istx))
|
||||||
|
|
||||||
#`(let ([arg-exp-xs (coerce-contract '->i arg-exps)] ...
|
#`(let ([arg-exp-xs (coerce-contract '->i arg-exps)] ...
|
||||||
[res-exp-xs (coerce-contract '->i res-exps)] ...)
|
[res-exp-xs (coerce-contract '->i res-exps)] ...)
|
||||||
#,(syntax-property
|
#,(syntax-property
|
||||||
#`(->i
|
#`(make-->i
|
||||||
|
#,is-chaperone-contract?
|
||||||
;; the information needed to make the blame records and their new contexts
|
;; the information needed to make the blame records and their new contexts
|
||||||
'#,blame-ids
|
'#,blame-ids
|
||||||
;; all of the non-dependent argument contracts
|
;; all of the non-dependent argument contracts
|
||||||
|
|
@ -1185,7 +1222,8 @@ evaluted left-to-right.)
|
||||||
#,@(arg/res-vars arg)
|
#,@(arg/res-vars arg)
|
||||||
;; this used to use opt/direct, but
|
;; this used to use opt/direct, but
|
||||||
;; opt/direct duplicates code (bad!)
|
;; opt/direct duplicates code (bad!)
|
||||||
(un-dep #,ctc-stx val blame))))
|
(#,(if is-chaperone-contract? #'un-dep/chaperone #'un-dep)
|
||||||
|
#,ctc-stx val blame))))
|
||||||
;; then the non-dependent argument contracts that are themselves dependend on
|
;; then the non-dependent argument contracts that are themselves dependend on
|
||||||
(list #,@(filter values
|
(list #,@(filter values
|
||||||
(map (λ (arg/res indy-id)
|
(map (λ (arg/res indy-id)
|
||||||
|
|
@ -1225,7 +1263,8 @@ evaluted left-to-right.)
|
||||||
;; this used to use opt/direct, but
|
;; this used to use opt/direct, but
|
||||||
;; opt/direct duplicates code (bad!)
|
;; opt/direct duplicates code (bad!)
|
||||||
#,@(arg/res-vars arg)
|
#,@(arg/res-vars arg)
|
||||||
(un-dep #,arg-stx val blame)))))
|
(#,(if is-chaperone-contract? #'un-dep/chaperone #'un-dep)
|
||||||
|
#,arg-stx val blame)))))
|
||||||
#''())
|
#''())
|
||||||
#,(if (istx-ress an-istx)
|
#,(if (istx-ress an-istx)
|
||||||
#`(list #,@(filter values
|
#`(list #,@(filter values
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user