change the way +1 arity functions work so the code is generated
by `contract-out` instead of `->` This seems to save about a second of startup time in (non-cs) DrRacket and about .1 seconds in drracketcs. The code is also theoretically more easily inlined. Still not easy enough, however.
This commit is contained in:
Robby Findler
parent
2045c4abd8
commit
93f4c9226b
|
|
@ -6,17 +6,48 @@
|
|||
'racket/contract/private/guts
|
||||
'racket/contract/private/blame
|
||||
'racket/contract/private/arrow-val-first
|
||||
'racket/contract/private/provide
|
||||
'racket/contract/private/arity-checking)])
|
||||
|
||||
(contract-eval '(require (for-syntax racket/base)))
|
||||
(contract-eval
|
||||
'(define (neg-party-fn c val)
|
||||
(define blame (make-blame (srcloc #f #f #f #f #f)
|
||||
'a-name
|
||||
(λ () (contract-name c))
|
||||
'pos
|
||||
#f #t))
|
||||
(wrapped-extra-arg-arrow-extra-neg-party-argument
|
||||
(((contract-struct-val-first-projection c) blame) val))))
|
||||
'(define-syntax (define-the-neg-party-accepting-function stx)
|
||||
(syntax-case stx ()
|
||||
[(_ neg-party-fn-id ctc fn-id)
|
||||
(let ()
|
||||
(define-values (arrow? definition-of-plus-one-acceptor the-valid-app-shapes)
|
||||
(build-definition-of-plus-one-acceptor #'ctc
|
||||
#'fn-id
|
||||
#'neg-party-fn-id
|
||||
#'the-contract
|
||||
#'blame-id))
|
||||
(if arrow?
|
||||
#`(begin
|
||||
(define the-contract ctc)
|
||||
(define blame-id
|
||||
(make-blame (srcloc '#,(syntax-source stx)
|
||||
'#,(syntax-line stx)
|
||||
'#,(syntax-column stx)
|
||||
'#,(syntax-position stx)
|
||||
'#,(syntax-span stx))
|
||||
fn-id
|
||||
(λ () (contract-name the-contract))
|
||||
'pos #f #t))
|
||||
#,definition-of-plus-one-acceptor)
|
||||
#`(error 'allow-neg-party.rkt
|
||||
"no neg-party-acceptor defined for ~s"
|
||||
'#,(syntax->datum #'ctc))))])))
|
||||
|
||||
(contract-eval
|
||||
'(define-syntax (neg-party-fn stx)
|
||||
(syntax-case stx ()
|
||||
[(_ c val)
|
||||
#'(let ()
|
||||
(define the-value val)
|
||||
(define-the-neg-party-accepting-function the-neg-party-accepting-function
|
||||
c the-value)
|
||||
the-neg-party-accepting-function)])))
|
||||
|
||||
(test/spec-passed/result
|
||||
'arity-as-string1
|
||||
'(arity-as-string (let ([f (λ (x) x)]) f))
|
||||
|
|
@ -62,7 +93,7 @@
|
|||
(-> integer? integer?)
|
||||
(λ (x) x))
|
||||
'neg 1))
|
||||
|
||||
|
||||
(test/neg-blame
|
||||
'->neg-party2
|
||||
'((neg-party-fn
|
||||
|
|
@ -97,14 +128,13 @@
|
|||
(-> integer? integer?)
|
||||
(λ (x) (values x x)))
|
||||
'neg 1))
|
||||
|
||||
|
||||
(test/spec-passed
|
||||
'->*neg-party1
|
||||
'((neg-party-fn
|
||||
(->* (integer?) integer?)
|
||||
(λ (x) x))
|
||||
'neg 1))
|
||||
|
||||
(test/neg-blame
|
||||
'->*neg-party2
|
||||
'((neg-party-fn
|
||||
|
|
@ -125,14 +155,14 @@
|
|||
(->* (integer?) (#:x integer?) any)
|
||||
(λ (x #:x [y #f]) y))
|
||||
'neg 1 #:x #f))
|
||||
|
||||
|
||||
(test/neg-blame
|
||||
'->*neg-party5
|
||||
'((neg-party-fn
|
||||
(->* (integer?) #:pre #f any)
|
||||
(λ (x) y))
|
||||
'neg 1))
|
||||
|
||||
|
||||
(test/pos-blame
|
||||
'->*neg-party6
|
||||
'((neg-party-fn
|
||||
|
|
@ -301,4 +331,20 @@
|
|||
(-> any/c boolean?)
|
||||
(λ (x) #t))
|
||||
'neg 1)
|
||||
#t))
|
||||
#t)
|
||||
|
||||
(test/neg-blame
|
||||
'->neg-party25
|
||||
'((neg-party-fn
|
||||
(->* () () #:pre/desc "get-apples not allowed" any)
|
||||
(λ () #t))
|
||||
'neg))
|
||||
|
||||
(test/pos-blame
|
||||
'->neg-party26
|
||||
'((neg-party-fn
|
||||
(->* () () any/c #:post/desc "put-apples not allowed")
|
||||
(λ () #t))
|
||||
'neg))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -16,8 +16,6 @@
|
|||
(test/no-error '(->* ((flat-contract integer?)) () #:pre #t (flat-contract integer?) #:post #t))
|
||||
(test/no-error '(->* (any/c) () #:pre/desc #t (flat-contract integer?) #:post/desc #t))
|
||||
|
||||
|
||||
|
||||
(test/spec-passed
|
||||
'contract-arrow-star0a
|
||||
'(contract (->* (integer?) () integer?)
|
||||
|
|
|
|||
|
|
@ -72,38 +72,34 @@
|
|||
1 1 '() '(#:y #:z))
|
||||
#f)
|
||||
|
||||
|
||||
(check-equal? (->-valid-app-shapes #'(-> integer? integer?))
|
||||
(define (->-shapes arg)
|
||||
(define-values (a b) (->-valid-app-shapes arg))
|
||||
a)
|
||||
(check-equal? (->-shapes #'(-> integer? integer?))
|
||||
(valid-app-shapes '(1) '() '()))
|
||||
(check-equal? (->-valid-app-shapes #'(-> integer? boolean? integer?))
|
||||
(check-equal? (->-shapes #'(-> integer? boolean? integer?))
|
||||
(valid-app-shapes '(2) '() '()))
|
||||
(check-equal? (->-valid-app-shapes #'(-> integer? #:x any/c integer?))
|
||||
(check-equal? (->-shapes #'(-> integer? #:x any/c integer?))
|
||||
(valid-app-shapes '(1) '(#:x) '()))
|
||||
(check-equal? (->-valid-app-shapes #'(-> integer? (... ...) any))
|
||||
(check-equal? (->-shapes #'(-> integer? (... ...) any))
|
||||
(valid-app-shapes 0 '() '()))
|
||||
(check-equal? (->-valid-app-shapes #'(-> integer? integer? (... ...) any))
|
||||
(check-equal? (->-shapes #'(-> integer? integer? (... ...) any))
|
||||
(valid-app-shapes 1 '() '()))
|
||||
(check-equal? (->-valid-app-shapes #'(-> integer? integer? (... ...) integer? any))
|
||||
(check-equal? (->-shapes #'(-> integer? integer? (... ...) integer? any))
|
||||
(valid-app-shapes 2 '() '()))
|
||||
(check-equal? (->-valid-app-shapes #'(-> integer? integer? (... ...) integer? boolean? char? any))
|
||||
(check-equal? (->-shapes #'(-> integer? integer? (... ...) integer? boolean? char? any))
|
||||
(valid-app-shapes 4 '() '()))
|
||||
(check-equal? (->-valid-app-shapes #'(-> integer? boolean? char? (... ...) integer? char? any))
|
||||
(check-equal? (->-shapes #'(-> integer? boolean? char? (... ...) integer? char? any))
|
||||
(valid-app-shapes 4 '() '()))
|
||||
|
||||
(check-equal? (->*-valid-app-shapes #'(->* (integer? #:x any/c #:y any/c) integer?))
|
||||
(define (->*-shapes arg)
|
||||
(define-values (a b) (->*-valid-app-shapes arg))
|
||||
a)
|
||||
(check-equal? (->*-shapes #'(->* (integer? #:x any/c #:y any/c) integer?))
|
||||
(valid-app-shapes '(1) '(#:x #:y) '()))
|
||||
(check-equal? (->*-valid-app-shapes #'(->* () (integer? #:x any/c #:y any/c) integer?))
|
||||
(check-equal? (->*-shapes #'(->* () (integer? #:x any/c #:y any/c) integer?))
|
||||
(valid-app-shapes '(0 1) '() '(#:x #:y)))
|
||||
(check-equal? (->*-valid-app-shapes #'(->* (any/c) (any/c) #:rest any/c integer?))
|
||||
(valid-app-shapes '(1 2 . 3) '() '()))
|
||||
|
||||
(check-equal? (->i-valid-app-shapes #'(->i () () [r any/c]))
|
||||
(valid-app-shapes '(0) '() '()))
|
||||
(check-equal? (->*-valid-app-shapes #'(->i ([p integer?] #:x [x any/c] #:y [y any/c]) [r any/c]))
|
||||
(valid-app-shapes '(1) '(#:x #:y) '()))
|
||||
(check-equal? (->*-valid-app-shapes #'(->i () ([p integer?] #:x [x any/c] #:y [y any/c]) [r any/c]))
|
||||
(valid-app-shapes '(0 1) '() '(#:x #:y)))
|
||||
(check-equal? (->*-valid-app-shapes #'(->i ([m any/c]) ([o any/c]) #:rest [r any/c] [r any/c]))
|
||||
(check-equal? (->*-shapes #'(->* (any/c) (any/c) #:rest any/c integer?))
|
||||
(valid-app-shapes '(1 2 . 3) '() '()))
|
||||
|
||||
(check-true (valid-argument-list? #'(f x) (valid-app-shapes '(1 2 . 3) '() '())))
|
||||
|
|
|
|||
|
|
@ -34,8 +34,7 @@
|
|||
matches-arity-exactly?
|
||||
keywords-match
|
||||
bad-number-of-results
|
||||
(for-syntax check-tail-contract
|
||||
parse-leftover->*)
|
||||
(for-syntax check-tail-contract)
|
||||
tail-marks-match?
|
||||
values/drop
|
||||
arity-checking-wrapper
|
||||
|
|
|
|||
|
|
@ -75,7 +75,6 @@
|
|||
contract-continuation-mark-key
|
||||
with-contract-continuation-mark
|
||||
|
||||
(struct-out wrapped-extra-arg-arrow)
|
||||
contract-custom-write-property-proc
|
||||
(rename-out [contract-custom-write-property-proc custom-write-property-proc])
|
||||
|
||||
|
|
|
|||
|
|
@ -632,33 +632,8 @@ code does the parsing and validation of the syntax.
|
|||
[_
|
||||
(raise-syntax-error #f "bad syntax" stx)])))
|
||||
|
||||
(define (->i-valid-app-shapes stx)
|
||||
(define an-istx (parse-->i stx))
|
||||
(define mans 0)
|
||||
(define opts 0)
|
||||
(define man-kwds '())
|
||||
(define opt-kwds '())
|
||||
(for ([arg (in-list (istx-args an-istx))])
|
||||
(define kwd (arg-kwd arg))
|
||||
(define opt? (arg-optional? arg))
|
||||
(cond
|
||||
[(and kwd opt?)
|
||||
(set! opt-kwds (cons kwd opt-kwds))]
|
||||
[(and kwd (not opt?))
|
||||
(set! man-kwds (cons kwd man-kwds))]
|
||||
[(and (not kwd) opt?)
|
||||
(set! opts (+ opts 1))]
|
||||
[(and (not kwd) (not opt?))
|
||||
(set! mans (+ mans 1))]))
|
||||
(valid-app-shapes-from-man/opts mans
|
||||
opts
|
||||
(istx-rst an-istx)
|
||||
man-kwds
|
||||
opt-kwds))
|
||||
|
||||
(provide
|
||||
parse-->i
|
||||
->i-valid-app-shapes
|
||||
(struct-out istx)
|
||||
(struct-out arg/res)
|
||||
(struct-out arg)
|
||||
|
|
|
|||
|
|
@ -33,14 +33,14 @@
|
|||
;; kwd-infos : (listof kwd-info)
|
||||
;; rest : (or/c #f contract?)
|
||||
;; pre? : (or/c #f 'pre 'pre/desc)
|
||||
;; pre-thunk : (or/c #f thunk)
|
||||
;; rngs : (listof contract?)
|
||||
;; post? : (or/c #f 'post 'post/desc)
|
||||
;; plus-one-arity-function : procedure? -- special, +1 argument wrapper that accepts neg-party
|
||||
;; post-thunk : (or/c #f thunk)
|
||||
;; chaperone-constructor ; procedure? -- function that builds a projection tailored to this arrow
|
||||
;; method? : boolean?
|
||||
(define-struct base-> (min-arity doms kwd-infos rest pre? rngs post?
|
||||
plus-one-arity-function chaperone-constructor
|
||||
method?)
|
||||
(define-struct base-> (min-arity doms kwd-infos rest pre? pre-thunk rngs post? post-thunk
|
||||
chaperone-constructor method?)
|
||||
#:property prop:custom-write custom-write-property-proc)
|
||||
|
||||
(define-struct unsupplied-arg ())
|
||||
|
|
|
|||
|
|
@ -21,7 +21,10 @@
|
|||
->-proj
|
||||
check-pre-cond
|
||||
check-post-cond
|
||||
arity-checking-wrapper)
|
||||
check-pre-cond/desc
|
||||
check-post-cond/desc
|
||||
arity-checking-wrapper
|
||||
build-subcontract-late-negs)
|
||||
|
||||
(define-for-syntax (build-chaperone-constructor/real ;; (listof (or/c #f stx))
|
||||
;; #f => syntactically known to be any/c
|
||||
|
|
@ -41,14 +44,20 @@
|
|||
[(mandatory-dom-kwd-proj ...) (nvars (length mandatory-dom-kwds) 'mandatory-dom-proj)]
|
||||
[(optional-dom-kwd-proj ...) (nvars (length optional-dom-kwds) 'optional-dom-proj)]
|
||||
[(rng-proj ...) (if rngs (generate-temporaries rngs) '())]
|
||||
[(rest-proj ...) (if rest (generate-temporaries '(rest-proj)) '())])
|
||||
[(rest-proj ...) (if rest (generate-temporaries '(rest-proj)) '())]
|
||||
[(pre-thunk pre/desc-thunk post-thunk post/desc-thunk)
|
||||
(generate-temporaries '(pre-thunk pre/desc-thunk post-thunk post/desc-thunk))])
|
||||
#`(λ (blame f neg-party blame-party-info is-impersonator? rng-ctcs
|
||||
mandatory-dom-proj ...
|
||||
optional-dom-proj ...
|
||||
mandatory-dom-proj ...
|
||||
optional-dom-proj ...
|
||||
rest-proj ...
|
||||
mandatory-dom-kwd-proj ...
|
||||
optional-dom-kwd-proj ...
|
||||
rng-proj ...)
|
||||
mandatory-dom-kwd-proj ...
|
||||
optional-dom-kwd-proj ...
|
||||
#,@(if pre (list #'pre-thunk) (list))
|
||||
#,@(if pre/desc (list #'pre/desc-thunk) (list))
|
||||
rng-proj ...
|
||||
#,@(if post (list #'post-thunk) (list))
|
||||
#,@(if post/desc (list #'post/desc-thunk) (list)))
|
||||
(define blame+neg-party (cons blame neg-party))
|
||||
#,(create-chaperone
|
||||
#'blame #'neg-party #'blame+neg-party #'blame-party-info #'is-impersonator? #'f #'rng-ctcs
|
||||
|
|
@ -62,41 +71,47 @@
|
|||
(map list
|
||||
optional-dom-kwds
|
||||
(syntax->list #'(optional-dom-kwd-proj ...)))
|
||||
pre pre/desc
|
||||
(if pre #'pre-thunk #f)
|
||||
(if pre/desc #'pre/desc-thunk #f)
|
||||
(if rest (car (syntax->list #'(rest-proj ...))) #f)
|
||||
(if rngs (syntax->list #'(rng-proj ...)) #f)
|
||||
post post/desc
|
||||
(if post #'post-thunk #f)
|
||||
(if post/desc #'post/desc-thunk #f)
|
||||
method?))))
|
||||
|
||||
|
||||
(define (check-pre-cond pre blame neg-party blame+neg-party val)
|
||||
(define (check-pre-cond pre blame+neg-party val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(unless (pre)
|
||||
(raise-blame-error (blame-swap blame)
|
||||
#:missing-party neg-party
|
||||
(raise-blame-error (blame-swap (car blame+neg-party))
|
||||
#:missing-party (cdr blame+neg-party)
|
||||
val "#:pre condition"))))
|
||||
|
||||
(define (check-post-cond post blame neg-party blame+neg-party val)
|
||||
(define (check-post-cond post blame+neg-party val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(unless (post)
|
||||
(raise-blame-error blame
|
||||
#:missing-party neg-party
|
||||
(raise-blame-error (car blame+neg-party)
|
||||
#:missing-party (cdr blame+neg-party)
|
||||
val "#:post condition"))))
|
||||
|
||||
(define (check-pre-cond/desc post blame neg-party val)
|
||||
(handle-pre-post/desc-string #t post blame neg-party val))
|
||||
(define (check-post-cond/desc post blame neg-party val)
|
||||
(handle-pre-post/desc-string #f post blame neg-party val))
|
||||
(define (handle-pre-post/desc-string pre? thunk blame neg-party val)
|
||||
(define condition-result (thunk))
|
||||
(define (check-pre-cond/desc post blame+neg-party val)
|
||||
(handle-pre-post/desc-string #t post blame+neg-party val))
|
||||
(define (check-post-cond/desc post blame+neg-party val)
|
||||
(handle-pre-post/desc-string #f post blame+neg-party val))
|
||||
(define (handle-pre-post/desc-string pre? thunk blame+neg-party val)
|
||||
(define condition-result
|
||||
(with-contract-continuation-mark blame+neg-party
|
||||
(thunk)))
|
||||
(cond
|
||||
[(equal? condition-result #t)
|
||||
(void)]
|
||||
[else
|
||||
(define msg
|
||||
(arrow:pre-post/desc-result->string condition-result pre? '->*))
|
||||
(define blame (car blame+neg-party))
|
||||
(define neg-party (cdr blame+neg-party))
|
||||
(raise-blame-error (if pre? (blame-swap blame) blame)
|
||||
#:missing-party neg-party
|
||||
val "~a" msg)]))
|
||||
|
|
@ -117,16 +132,16 @@
|
|||
(with-syntax ([(pre ...)
|
||||
(cond
|
||||
[pre
|
||||
(list #`(check-pre-cond #,pre blame neg-party blame+neg-party val))]
|
||||
(list #`(check-pre-cond #,pre blame+neg-party val))]
|
||||
[pre/desc
|
||||
(list #`(check-pre-cond/desc #,pre/desc blame neg-party val))]
|
||||
(list #`(check-pre-cond/desc #,pre/desc blame+neg-party val))]
|
||||
[else null])]
|
||||
[(post ...)
|
||||
(cond
|
||||
[post
|
||||
(list #`(check-post-cond #,post blame neg-party blame+neg-party val))]
|
||||
(list #`(check-post-cond #,post blame+neg-party val))]
|
||||
[post/desc
|
||||
(list #`(check-post-cond/desc #,post/desc blame neg-party val))]
|
||||
(list #`(check-post-cond/desc #,post/desc blame+neg-party val))]
|
||||
[else null])])
|
||||
(with-syntax ([(dom-x ...) (generate-temporaries doms)]
|
||||
[(opt-dom-ctc ...) opt-doms]
|
||||
|
|
@ -541,8 +556,8 @@
|
|||
|
||||
(define (->-proj is-impersonator? ctc
|
||||
;; fields of the 'ctc' struct
|
||||
min-arity doms kwd-infos rest pre? rngs post?
|
||||
plus-one-arity-function chaperone-constructor method?
|
||||
min-arity doms kwd-infos rest pre? pre-thunk rngs post? post-thunk
|
||||
chaperone-constructor method?
|
||||
late-neg?)
|
||||
(define has-c-c-support?
|
||||
(->-contract-has-collapsible-support? ctc))
|
||||
|
|
@ -558,65 +573,24 @@
|
|||
(andmap any/c? doms)
|
||||
(= optionals-length 0)))
|
||||
(λ (orig-blame)
|
||||
(define rng-blame (arrow:blame-add-range-context orig-blame))
|
||||
(define swapped-domain (blame-add-context orig-blame "the domain of" #:swap? #t))
|
||||
(define-values (partial-doms
|
||||
partial-rests
|
||||
man-then-opt-partial-kwds
|
||||
partial-ranges
|
||||
c-c-doms
|
||||
maybe-c-c-ranges)
|
||||
(build-subcontract-late-negs orig-blame doms rest rngs kwd-infos method?))
|
||||
(define the-args (append partial-doms
|
||||
partial-rests
|
||||
man-then-opt-partial-kwds
|
||||
(if pre-thunk (list pre-thunk) '())
|
||||
partial-ranges
|
||||
(if post-thunk (list post-thunk) '())))
|
||||
|
||||
;; if the ctc supports c-c mode, there are only positional args
|
||||
(define-values (partial-doms c-c-doms)
|
||||
(for/lists (projs ses)
|
||||
([dom (in-list doms)]
|
||||
[n (in-naturals 1)])
|
||||
(define dom-blame
|
||||
(blame-add-context orig-blame
|
||||
(nth-argument-of (if method? (sub1 n) n))
|
||||
#:swap? #t))
|
||||
(define prepared (get/build-collapsible-late-neg-projection dom))
|
||||
(prepared dom-blame)))
|
||||
|
||||
(define rest-blame
|
||||
(if (ellipsis-rest-arg-ctc? rest)
|
||||
(blame-swap orig-blame)
|
||||
(blame-add-context orig-blame "the rest argument of"
|
||||
#:swap? #t)))
|
||||
(define partial-rest (and rest
|
||||
((get/build-late-neg-projection rest)
|
||||
rest-blame)))
|
||||
(define-values (partial-ranges maybe-c-c-ranges)
|
||||
(cond
|
||||
[rngs
|
||||
(for/lists (proj c-c)
|
||||
([rng (in-list rngs)])
|
||||
(define prepared (get/build-collapsible-late-neg-projection rng))
|
||||
(prepared rng-blame))]
|
||||
[else (values '() #f)]))
|
||||
(define partial-kwds
|
||||
(for/list ([kwd-info (in-list kwd-infos)]
|
||||
[kwd (in-list kwd-infos)])
|
||||
((get/build-late-neg-projection (kwd-info-ctc kwd-info))
|
||||
(blame-add-context orig-blame
|
||||
(format "the ~a argument of" (kwd-info-kwd kwd))
|
||||
#:swap? #t))))
|
||||
(define man-then-opt-partial-kwds
|
||||
(append (for/list ([partial-kwd (in-list partial-kwds)]
|
||||
[kwd-info (in-list kwd-infos)]
|
||||
#:when (kwd-info-mandatory? kwd-info))
|
||||
partial-kwd)
|
||||
(for/list ([partial-kwd (in-list partial-kwds)]
|
||||
[kwd-info (in-list kwd-infos)]
|
||||
#:unless (kwd-info-mandatory? kwd-info))
|
||||
partial-kwd)))
|
||||
(define c-c-mergable
|
||||
(and has-c-c-support?
|
||||
(build-collapsible-arrow (car maybe-c-c-ranges) c-c-doms ctc orig-blame chaperone?)))
|
||||
(define the-args (append partial-doms
|
||||
(if partial-rest (list partial-rest) '())
|
||||
man-then-opt-partial-kwds
|
||||
partial-ranges))
|
||||
(define plus-one-constructor-args
|
||||
(append partial-doms
|
||||
man-then-opt-partial-kwds
|
||||
partial-ranges
|
||||
(if partial-rest (list partial-rest) '())))
|
||||
|
||||
(define blame-party-info (arrow:get-blame-party-info orig-blame))
|
||||
(define (successfully-got-the-right-kind-of-function val neg-party)
|
||||
(define old-c-c-prop (get-impersonator-prop:collapsible val #f))
|
||||
|
|
@ -718,31 +692,74 @@
|
|||
(or c-c-mergable (build-collapsible-leaf arrow-higher-order:lnp ctc orig-blame)))])]
|
||||
[else
|
||||
(define (arrow-higher-order:vfp val)
|
||||
(define-values (normal-proc proc-with-no-result-checking expected-number-of-results)
|
||||
(apply plus-one-arity-function orig-blame val plus-one-constructor-args))
|
||||
(cond
|
||||
[(do-arity-checking orig-blame val doms rest min-arity kwd-infos method?)
|
||||
=>
|
||||
(λ (neg-party-acceptor)
|
||||
;; probably don't need to include the wrapped-extra-arrow wrapper
|
||||
;; here, but it is easier to reason about the contract-out invariant
|
||||
;; with it here
|
||||
(wrapped-extra-arg-arrow neg-party-acceptor normal-proc))]
|
||||
neg-party-acceptor)]
|
||||
[else
|
||||
(wrapped-extra-arg-arrow
|
||||
(λ (neg-party)
|
||||
(successfully-got-the-right-kind-of-function val neg-party))
|
||||
(if (equal? (procedure-result-arity val) expected-number-of-results)
|
||||
proc-with-no-result-checking
|
||||
normal-proc))]))
|
||||
(λ (neg-party)
|
||||
(successfully-got-the-right-kind-of-function val neg-party))]))
|
||||
(if okay-to-do-only-arity-check?
|
||||
(λ (val)
|
||||
(cond
|
||||
[(arrow:procedure-arity-exactly/no-kwds val min-arity)
|
||||
(define-values (normal-proc proc-with-no-result-checking expected-number-of-results)
|
||||
(apply plus-one-arity-function orig-blame val plus-one-constructor-args))
|
||||
(wrapped-extra-arg-arrow
|
||||
(λ (neg-party) val)
|
||||
normal-proc)]
|
||||
(λ (neg-party) val)]
|
||||
[else (arrow-higher-order:vfp val)]))
|
||||
arrow-higher-order:vfp)])))
|
||||
|
||||
(define (build-subcontract-late-negs orig-blame doms rest rngs kwd-infos method?)
|
||||
(define rng-blame (arrow:blame-add-range-context orig-blame))
|
||||
(define swapped-domain (blame-add-context orig-blame "the domain of" #:swap? #t))
|
||||
|
||||
;; if the ctc supports c-c mode, there are only positional args
|
||||
(define-values (partial-doms c-c-doms)
|
||||
(for/lists (projs ses)
|
||||
([dom (in-list doms)]
|
||||
[n (in-naturals 1)])
|
||||
(define dom-blame
|
||||
(blame-add-context orig-blame
|
||||
(nth-argument-of (if method? (sub1 n) n))
|
||||
#:swap? #t))
|
||||
(define prepared (get/build-collapsible-late-neg-projection dom))
|
||||
(prepared dom-blame)))
|
||||
|
||||
(define rest-blame
|
||||
(if (ellipsis-rest-arg-ctc? rest)
|
||||
(blame-swap orig-blame)
|
||||
(blame-add-context orig-blame "the rest argument of"
|
||||
#:swap? #t)))
|
||||
(define partial-rest (and rest
|
||||
((get/build-late-neg-projection rest)
|
||||
rest-blame)))
|
||||
(define-values (partial-ranges maybe-c-c-ranges)
|
||||
(cond
|
||||
[rngs
|
||||
(for/lists (proj c-c)
|
||||
([rng (in-list rngs)])
|
||||
(define prepared (get/build-collapsible-late-neg-projection rng))
|
||||
(prepared rng-blame))]
|
||||
[else (values '() #f)]))
|
||||
(define partial-kwds
|
||||
(for/list ([kwd-info (in-list kwd-infos)]
|
||||
[kwd (in-list kwd-infos)])
|
||||
((get/build-late-neg-projection (kwd-info-ctc kwd-info))
|
||||
(blame-add-context orig-blame
|
||||
(format "the ~a argument of" (kwd-info-kwd kwd))
|
||||
#:swap? #t))))
|
||||
(define man-then-opt-partial-kwds
|
||||
(append (for/list ([partial-kwd (in-list partial-kwds)]
|
||||
[kwd-info (in-list kwd-infos)]
|
||||
#:when (kwd-info-mandatory? kwd-info))
|
||||
partial-kwd)
|
||||
(for/list ([partial-kwd (in-list partial-kwds)]
|
||||
[kwd-info (in-list kwd-infos)]
|
||||
#:unless (kwd-info-mandatory? kwd-info))
|
||||
partial-kwd)))
|
||||
|
||||
(values partial-doms
|
||||
(if partial-rest (list partial-rest) '())
|
||||
man-then-opt-partial-kwds
|
||||
partial-ranges
|
||||
c-c-doms
|
||||
maybe-c-c-ranges))
|
||||
|
|
@ -1,4 +1,15 @@
|
|||
#lang racket/base
|
||||
|
||||
#|
|
||||
|
||||
TODO: find the places where the functions are constructed and called for plus1 and chaperone.
|
||||
(to be able to add the pre/post conditions as arguments instead of inlining them into the wrappers)
|
||||
|
||||
plus1 call: build->*-plus-one-acceptor
|
||||
plus1 arg list construction: build-plus-one-arity-function/real
|
||||
|
||||
|#
|
||||
|
||||
(require (for-syntax racket/base
|
||||
"application-arity-checking.rkt"
|
||||
"arr-util.rkt")
|
||||
|
|
@ -20,12 +31,26 @@
|
|||
base->? base->-name base->-rngs base->-doms
|
||||
dynamic->*
|
||||
arity-checking-wrapper
|
||||
(for-syntax parse-leftover->*)
|
||||
(for-syntax ->-arity-check-only->?
|
||||
->*-arity-check-only->?
|
||||
->-valid-app-shapes
|
||||
->*-valid-app-shapes)
|
||||
(rename-out [-predicate/c predicate/c]))
|
||||
(rename-out [-predicate/c predicate/c])
|
||||
build->*-plus-one-acceptor)
|
||||
|
||||
(begin-for-syntax
|
||||
(struct parsed->* (man-dom ;; syntax?[(id ...)]
|
||||
man-dom-kwds ;; syntax?[((kwd id) ..)]
|
||||
opt-dom ;; syntax?[(id ...)]
|
||||
opt-dom-kwds ;; syntax?[((kwd id) ..)]
|
||||
rest-ctc ;; (or/c #f syntax?[id])
|
||||
pre ;; (or/c #f syntax?[id])
|
||||
pre/desc ;; (or/c #f syntax?[id])
|
||||
rng-ctcs ;; (or/c #f syntax?[(id ...)])
|
||||
post ;; (or/c #f syntax?[id])
|
||||
post/desc ;; (or/c #f syntax?[id])
|
||||
lets) ;; syntax?[([id expr] ...)]
|
||||
#:prefab))
|
||||
|
||||
(define-for-syntax (->-arity-check-only->? stx)
|
||||
(syntax-case stx (any any/c)
|
||||
|
|
@ -67,11 +92,11 @@
|
|||
[else success ...])))])))
|
||||
|
||||
(define-for-syntax popular-keys
|
||||
;; of the 6075 contracts that get compiled during
|
||||
;; 'raco setup' of main-distribution and main-distribution-test,
|
||||
;; these are all the ones that appear at least 60 times, as of
|
||||
;; January 2016. Plus the ones that appear at least 10 times in
|
||||
;; contracts that TR generates for plot-gui-lib, as of October 2017
|
||||
;; the most popular contract shapes as of January 2016 from
|
||||
;; the main distribution package; plus some that TR generates
|
||||
;; for plot-gui-lib as of October 2017; as of July 2019, using
|
||||
;; these popular keys appears to save about 10% of the disk
|
||||
;; space taken by .zo files during the main-distribution build
|
||||
`((() 0 () () #f 1)
|
||||
(() 0 () () #f #f)
|
||||
((#f) 0 () () #f 1)
|
||||
|
|
@ -126,7 +151,7 @@
|
|||
'popular-chaperone-key-id)))))]))
|
||||
(generate-popular-key-ids popular-key-ids)
|
||||
|
||||
(define-for-syntax (build-plus-one-arity-function+chaperone-constructor
|
||||
(define-for-syntax (argument-details->popular-keys-table-entry/info
|
||||
pre-regular-args
|
||||
optional-args
|
||||
mandatory-kwds
|
||||
|
|
@ -145,44 +170,114 @@
|
|||
(syntax-case stx (any/c)
|
||||
[any/c #f]
|
||||
[else stx])))
|
||||
(define key (and (not pre) (not pre/desc)
|
||||
(not post) (not post/desc)
|
||||
(list (map not regular-args/no-any/c)
|
||||
(length optional-args)
|
||||
(map syntax-e mandatory-kwds)
|
||||
(map syntax-e optional-kwds)
|
||||
(and rest #t)
|
||||
(and rngs (if (syntax? rngs)
|
||||
(length (syntax->list rngs))
|
||||
(length rngs))))))
|
||||
(define key
|
||||
(and (not pre) (not pre/desc)
|
||||
(not post) (not post/desc)
|
||||
(list (map not regular-args/no-any/c)
|
||||
(length optional-args)
|
||||
(map syntax-e mandatory-kwds)
|
||||
(map syntax-e optional-kwds)
|
||||
(and rest #t)
|
||||
(and rngs (if (syntax? rngs)
|
||||
(length (syntax->list rngs))
|
||||
(length rngs))))))
|
||||
(define entry-in-table (and key (member key popular-keys)))
|
||||
(define index (and entry-in-table
|
||||
(- (length popular-keys) (length entry-in-table))))
|
||||
(values (and index (list-ref popular-key-ids index))
|
||||
regular-args/no-any/c
|
||||
regular-args))
|
||||
|
||||
(define-for-syntax (build-code-for-chaperone-constructor
|
||||
a-parsed->*
|
||||
method?)
|
||||
|
||||
(define pre-regular-args (parsed->*-man-dom a-parsed->*))
|
||||
(define optional-args (parsed->*-opt-dom a-parsed->*))
|
||||
(define mandatory-kwds
|
||||
(with-syntax ([((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...)
|
||||
(parsed->*-man-dom-kwds a-parsed->*)])
|
||||
(syntax->list #'(mandatory-dom-kwd ...))))
|
||||
(define optional-kwds
|
||||
(with-syntax ([((optional-dom-kwd optional-dom-kwd-ctc) ...)
|
||||
(parsed->*-opt-dom-kwds a-parsed->*)])
|
||||
(syntax->list #'(optional-dom-kwd ...))))
|
||||
(define rest (parsed->*-rest-ctc a-parsed->*))
|
||||
(define rngs (parsed->*-rng-ctcs a-parsed->*))
|
||||
(define pre (parsed->*-pre a-parsed->*))
|
||||
(define pre/desc (parsed->*-pre/desc a-parsed->*))
|
||||
(define post (parsed->*-post a-parsed->*))
|
||||
(define post/desc (parsed->*-post/desc a-parsed->*))
|
||||
|
||||
(define-values (ids regular-args/no-any/c regular-args)
|
||||
(argument-details->popular-keys-table-entry/info pre-regular-args
|
||||
optional-args
|
||||
mandatory-kwds
|
||||
optional-kwds
|
||||
pre pre/desc
|
||||
rest
|
||||
rngs
|
||||
post post/desc
|
||||
method?))
|
||||
(cond
|
||||
[(and key (member key popular-keys))
|
||||
=>
|
||||
(λ (l)
|
||||
(define index (- (length popular-keys) (length l)))
|
||||
(define ids (list-ref popular-key-ids index))
|
||||
(values (list-ref ids 0) (list-ref ids 1)))]
|
||||
[ids (list-ref ids 1)]
|
||||
[else
|
||||
(values (build-plus-one-arity-function/real
|
||||
regular-args
|
||||
optional-args
|
||||
mandatory-kwds
|
||||
optional-kwds
|
||||
pre pre/desc
|
||||
rest
|
||||
rngs
|
||||
post post/desc
|
||||
method?)
|
||||
(build-chaperone-constructor/real
|
||||
regular-args/no-any/c
|
||||
optional-args
|
||||
mandatory-kwds
|
||||
optional-kwds
|
||||
pre pre/desc
|
||||
rest
|
||||
rngs
|
||||
post post/desc
|
||||
method?))]))
|
||||
(build-chaperone-constructor/real
|
||||
regular-args/no-any/c
|
||||
optional-args
|
||||
mandatory-kwds
|
||||
optional-kwds
|
||||
pre pre/desc
|
||||
rest
|
||||
rngs
|
||||
post post/desc
|
||||
method?)]))
|
||||
|
||||
(define-for-syntax (build-code-for-plus-one-arity-function
|
||||
a-parsed->*
|
||||
method?)
|
||||
|
||||
(define pre-regular-args (parsed->*-man-dom a-parsed->*))
|
||||
(define optional-args (parsed->*-opt-dom a-parsed->*))
|
||||
(define mandatory-kwds
|
||||
(with-syntax ([((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...)
|
||||
(parsed->*-man-dom-kwds a-parsed->*)])
|
||||
(syntax->list #'(mandatory-dom-kwd ...))))
|
||||
(define optional-kwds
|
||||
(with-syntax ([((optional-dom-kwd optional-dom-kwd-ctc) ...)
|
||||
(parsed->*-opt-dom-kwds a-parsed->*)])
|
||||
(syntax->list #'(optional-dom-kwd ...))))
|
||||
(define rest (parsed->*-rest-ctc a-parsed->*))
|
||||
(define rngs (parsed->*-rng-ctcs a-parsed->*))
|
||||
|
||||
(define pre (parsed->*-pre a-parsed->*))
|
||||
(define pre/desc (parsed->*-pre/desc a-parsed->*))
|
||||
(define post (parsed->*-post a-parsed->*))
|
||||
(define post/desc (parsed->*-post/desc a-parsed->*))
|
||||
|
||||
(define-values (ids regular-args/no-any/c regular-args)
|
||||
(argument-details->popular-keys-table-entry/info pre-regular-args
|
||||
optional-args
|
||||
mandatory-kwds
|
||||
optional-kwds
|
||||
pre pre/desc
|
||||
rest
|
||||
rngs
|
||||
post post/desc
|
||||
method?))
|
||||
(cond
|
||||
[ids (list-ref ids 0)]
|
||||
[else
|
||||
(build-plus-one-arity-function/real
|
||||
regular-args
|
||||
optional-args
|
||||
mandatory-kwds
|
||||
optional-kwds
|
||||
pre pre/desc
|
||||
rest
|
||||
rngs
|
||||
post post/desc
|
||||
method?)]))
|
||||
|
||||
(define-syntax (build-populars stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -221,19 +316,14 @@
|
|||
rng-vars
|
||||
#f #f #f))
|
||||
(define #,(syntax-local-introduce chaperone-id)
|
||||
#,(let ([ans (build-chaperone-constructor/real
|
||||
mans/no-any/c opts
|
||||
mandatory-kwds
|
||||
optional-kwds
|
||||
#f #f
|
||||
rest
|
||||
rng-vars
|
||||
#f #f #f)])
|
||||
#;
|
||||
(when (equal? key (list '(#t) 0 '() '() #f 1))
|
||||
((dynamic-require 'racket/pretty 'pretty-write) (syntax->datum ans))
|
||||
(exit))
|
||||
ans))))
|
||||
#,(build-chaperone-constructor/real
|
||||
mans/no-any/c opts
|
||||
mandatory-kwds
|
||||
optional-kwds
|
||||
#f #f
|
||||
rest
|
||||
rng-vars
|
||||
#f #f #f))))
|
||||
(define popular-chaperone-key-table
|
||||
(make-hash
|
||||
(list #,@(for/list ([id (in-list popular-key-ids)]
|
||||
|
|
@ -283,13 +373,19 @@
|
|||
(with-syntax ([(wrapper-args ...) #'(neg-party arg-x ... formal-kwd-args ...)]
|
||||
[(the-call ...) #`(f #,@(reverse normal-arg-vars) kwd-arg-exps ...)]
|
||||
[(pre-check ...)
|
||||
(if pre
|
||||
(list #`(check-pre-cond #,pre blame neg-party (cons blame neg-party) f))
|
||||
(list))]
|
||||
(cond
|
||||
[pre
|
||||
(list #`(check-pre-cond #,pre blame+neg-party f))]
|
||||
[pre/desc
|
||||
(list #`(check-pre-cond/desc #,pre/desc blame+neg-party f))]
|
||||
[else (list)])]
|
||||
[(post-check ...)
|
||||
(if post
|
||||
(list #`(check-post-cond #,post blame neg-party (cons blame neg-party) f))
|
||||
(list))]
|
||||
(cond
|
||||
[post
|
||||
(list #`(check-post-cond #,post blame+neg-party f))]
|
||||
[post/desc
|
||||
(list #`(check-post-cond/desc #,post/desc blame+neg-party f))]
|
||||
[else (list)])]
|
||||
[(restb) (generate-temporaries '(rest-args))])
|
||||
(define (make-body-proc range-checking?)
|
||||
(cond
|
||||
|
|
@ -373,8 +469,8 @@
|
|||
(rb res-x neg-party)
|
||||
...))))]))]
|
||||
#`[#,the-args
|
||||
pre-check ...
|
||||
(let ([blame+neg-party (cons blame neg-party)])
|
||||
pre-check ...
|
||||
(let-values (#,let-values-clause)
|
||||
#,full-call))]))
|
||||
(cons the-clause
|
||||
|
|
@ -394,37 +490,66 @@
|
|||
[else
|
||||
#`(make-checking-proc f blame
|
||||
#,(if pre pre #'#f)
|
||||
#,(if pre/desc pre/desc #'#f)
|
||||
'(#,@mandatory-kwds) (list kb ...)
|
||||
'(#,@optional-kwds) (list okb ...)
|
||||
'(#,@optional-kwds) (list okb ...)
|
||||
#,(length regular-args) (list regb ... optb ...)
|
||||
#,(if rest #'restb #'#f)
|
||||
#,(if post post #'#f)
|
||||
#,(if post/desc post/desc #'#f)
|
||||
#,(if rngs #'(list rb ...) #'#f)
|
||||
#,method?)]))
|
||||
(define body-proc (make-body-proc #t))
|
||||
(define body-proc/no-range-checking (make-body-proc #f))
|
||||
(define number-of-rngs (and rngs (with-syntax ([rngs rngs]) (length (syntax->list #'rngs)))))
|
||||
#`(λ (blame f regb ... optb ... kb ... okb ... rb ... #,@(if rest (list #'restb) '()))
|
||||
(values
|
||||
(procedure-specialize
|
||||
#,body-proc)
|
||||
#,(if rngs
|
||||
#`(procedure-specialize
|
||||
#,body-proc/no-range-checking)
|
||||
#'shouldnt-be-called)
|
||||
'#,(if rngs number-of-rngs 'there-is-no-range-contract)))))))
|
||||
#`(λ (f)
|
||||
(λ (blame regb ... optb ... kb ... okb ...
|
||||
#,@(if pre (list pre) '())
|
||||
#,@(if pre/desc (list pre/desc) '())
|
||||
#,@(if rest (list #'restb) '())
|
||||
rb ...
|
||||
#,@(if post (list post) '())
|
||||
#,@(if post/desc (list post/desc) '()))
|
||||
(procedure-specialize
|
||||
#,(if rngs
|
||||
#`(if (equal? #,number-of-rngs (procedure-result-arity f))
|
||||
#,(make-body-proc #f)
|
||||
#,(make-body-proc #t))
|
||||
(make-body-proc #t)))))))))
|
||||
|
||||
(define (shouldnt-be-called . args)
|
||||
(error 'arrow-val-first.rkt
|
||||
(string-append
|
||||
"this function should not ever be called because"
|
||||
" procedure-result-arity shouldn't return 'there-is-no-range-contract")))
|
||||
(define (build->*-plus-one-acceptor plus-one-arity-wrapper-maker
|
||||
blame
|
||||
->stct)
|
||||
(define-values (partial-doms
|
||||
partial-rests
|
||||
man-then-opt-partial-kwds
|
||||
partial-ranges
|
||||
c-c-doms
|
||||
maybe-c-c-ranges)
|
||||
(build-subcontract-late-negs blame
|
||||
(base->-doms ->stct)
|
||||
(base->-rest ->stct)
|
||||
(base->-rngs ->stct)
|
||||
(base->-kwd-infos ->stct)
|
||||
#f))
|
||||
(define plus-one-constructor-args
|
||||
(append partial-doms
|
||||
man-then-opt-partial-kwds
|
||||
partial-rests
|
||||
(if (base->-pre-thunk ->stct)
|
||||
(list (base->-pre-thunk ->stct))
|
||||
'())
|
||||
partial-ranges
|
||||
(if (base->-post-thunk ->stct)
|
||||
(list (base->-post-thunk ->stct))
|
||||
'())))
|
||||
(apply plus-one-arity-wrapper-maker
|
||||
blame
|
||||
plus-one-constructor-args))
|
||||
|
||||
(define (make-checking-proc f blame pre
|
||||
(define (make-checking-proc f blame pre pre/desc
|
||||
original-mandatory-kwds kbs
|
||||
original-optional-kwds okbs
|
||||
minimum-arg-count rbs rest-ctc
|
||||
post rngs
|
||||
post post/desc rngs
|
||||
method?)
|
||||
(make-keyword-procedure
|
||||
(λ (actual-kwds actual-kwd-args neg-party . regular-args)
|
||||
|
|
@ -480,15 +605,18 @@
|
|||
[else
|
||||
(cons ((car rbs) (car regular-args) neg-party)
|
||||
(loop (cdr regular-args) (cdr rbs)))]))))
|
||||
(define complete-blame (blame-add-missing-party blame neg-party))
|
||||
(when pre (check-pre-cond pre blame neg-party complete-blame f))
|
||||
(define blame+neg-party (cons blame neg-party))
|
||||
(when pre (check-pre-cond pre blame+neg-party f))
|
||||
(when pre/desc (check-pre-cond/desc pre blame+neg-party f))
|
||||
(cond
|
||||
[rngs
|
||||
(define results (call-with-values mk-call list))
|
||||
(define rng-len (length rngs))
|
||||
(unless (= (length results) rng-len)
|
||||
(bad-number-of-results complete-blame f rng-len results))
|
||||
(when post (check-post-cond post blame neg-party complete-blame f))
|
||||
(bad-number-of-results (blame-add-missing-party blame neg-party)
|
||||
f rng-len results))
|
||||
(when post (check-post-cond post blame+neg-party f))
|
||||
(when post/desc (check-post-cond post/desc blame+neg-party f))
|
||||
(apply
|
||||
values
|
||||
(for/list ([result (in-list results)]
|
||||
|
|
@ -577,6 +705,22 @@
|
|||
[(keyword<? opt-kwd kwd)
|
||||
(loop mandatory-kwds (cdr optional-kwds) kwds)])])])))
|
||||
|
||||
(define-for-syntax (parse-> stx this->)
|
||||
(syntax-case stx ()
|
||||
[(_ args ... rng)
|
||||
(let ()
|
||||
(define-values (regular-args kwds kwd-args let-bindings ellipsis-info)
|
||||
(parse-arrow-args stx (syntax->list #'(args ...)) this->))
|
||||
(define (add-pos-obligations stxes)
|
||||
(for/list ([stx (in-list stxes)])
|
||||
(syntax-property stx 'racket/contract:positive-position this->)))
|
||||
(define rngs
|
||||
(syntax-case #'rng (any values)
|
||||
[any #f]
|
||||
[(values rng ...) (add-pos-obligations (syntax->list #'(rng ...)))]
|
||||
[rng (add-pos-obligations (list #'rng))]))
|
||||
(values regular-args kwds kwd-args let-bindings ellipsis-info rngs))]))
|
||||
|
||||
(define-for-syntax (parse-arrow-args stx args this->)
|
||||
(let loop ([args args]
|
||||
[regular-args '()]
|
||||
|
|
@ -674,17 +818,26 @@
|
|||
|
||||
(define-for-syntax (->-valid-app-shapes stx)
|
||||
(syntax-case stx ()
|
||||
[(_ args ...)
|
||||
[(_ args ... rng)
|
||||
(let ()
|
||||
(define this-> (gensym 'this->))
|
||||
(define-values (regular-args kwds kwd-args let-bindings ellipsis-info)
|
||||
(parse-arrow-args stx (syntax->list #'(args ...)) this->))
|
||||
(define arg-count (- (length regular-args) 1))
|
||||
(valid-app-shapes (if ellipsis-info
|
||||
(+ arg-count (- (length ellipsis-info) 1))
|
||||
(list arg-count))
|
||||
(map syntax->datum kwds)
|
||||
'()))]))
|
||||
(define-values (regular-args kwds kwd-args let-bindings ellipsis-info rngs)
|
||||
(parse-> stx (gensym 'this->)))
|
||||
(define arg-count (length regular-args))
|
||||
(define app-shapes
|
||||
(valid-app-shapes (if ellipsis-info
|
||||
(+ arg-count (length ellipsis-info) -1)
|
||||
(list arg-count))
|
||||
(map syntax->datum kwds)
|
||||
'()))
|
||||
(values app-shapes
|
||||
(build-code-for-plus-one-arity-function
|
||||
(with-syntax ([(kwds ...) kwds]
|
||||
[(kwd-args ...) kwd-args])
|
||||
(parsed->* regular-args #'((kwds kwd-args) ...)
|
||||
'() '()
|
||||
(and ellipsis-info #t)
|
||||
#f #f rngs #f #f '()))
|
||||
#f)))]))
|
||||
|
||||
(define-syntax (->/c stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -696,19 +849,16 @@
|
|||
[(_ args ... rng)
|
||||
(let ()
|
||||
(define this-> (gensym 'this->))
|
||||
(define-values (regular-args kwds kwd-args let-bindings ellipsis-info)
|
||||
(parse-arrow-args stx (syntax->list #'(args ...)) this->))
|
||||
(define (add-pos-obligations stxes)
|
||||
(for/list ([stx (in-list stxes)])
|
||||
(syntax-property stx 'racket/contract:positive-position this->)))
|
||||
(define rngs
|
||||
(syntax-case #'rng (any values)
|
||||
[any #f]
|
||||
[(values rng ...) (add-pos-obligations (syntax->list #'(rng ...)))]
|
||||
[rng (add-pos-obligations (list #'rng))]))
|
||||
(define-values (plus-one-arity-function chaperone-constructor)
|
||||
(build-plus-one-arity-function+chaperone-constructor
|
||||
regular-args '() kwds '() #f #f (and ellipsis-info #t) rngs #f #f
|
||||
(define-values (regular-args kwds kwd-args let-bindings ellipsis-info rngs)
|
||||
(parse-> stx this->))
|
||||
(define chaperone-constructor
|
||||
(build-code-for-chaperone-constructor
|
||||
(with-syntax ([(kwds ...) kwds]
|
||||
[(kwd-args ...) kwd-args])
|
||||
(parsed->* regular-args #'((kwds kwd-args) ...)
|
||||
'() '()
|
||||
(and ellipsis-info #t) #f #f rngs #f #f
|
||||
'()))
|
||||
method?))
|
||||
(syntax-property
|
||||
#`(let #,let-bindings
|
||||
|
|
@ -723,14 +873,12 @@
|
|||
(quasisyntax/loc stx
|
||||
(build-nullary-very-simple-->
|
||||
#,(car rngs)
|
||||
#,plus-one-arity-function
|
||||
#,chaperone-constructor))]
|
||||
[(and (equal? rng-count 1) (= doms-count 1))
|
||||
(quasisyntax/loc stx
|
||||
(build-unary-very-simple-->
|
||||
#,(car regular-args)
|
||||
#,(car rngs)
|
||||
#,plus-one-arity-function
|
||||
#,chaperone-constructor))]
|
||||
[else
|
||||
(quasisyntax/loc stx
|
||||
|
|
@ -739,7 +887,6 @@
|
|||
#,(if rngs
|
||||
#`(list #,@rngs)
|
||||
#'#f)
|
||||
#,plus-one-arity-function
|
||||
#,chaperone-constructor))])]
|
||||
[else
|
||||
(quasisyntax/loc stx
|
||||
|
|
@ -750,7 +897,6 @@
|
|||
#,(if rngs
|
||||
#`(list #,@rngs)
|
||||
#'#f)
|
||||
#,plus-one-arity-function
|
||||
#,chaperone-constructor
|
||||
#,(if ellipsis-info
|
||||
#`(ellipsis-rest-arg #,(length regular-args) #,@ellipsis-info)
|
||||
|
|
@ -810,31 +956,32 @@
|
|||
(syntax-case stx ()
|
||||
[(_ (raw-mandatory-dom ...) . other)
|
||||
(let ()
|
||||
(define-values (raw-optional-doms rest-ctc pre pre/desc rng-ctcs post post/desc)
|
||||
(define-values (raw-optional-doms rest-ctc pre pre/desc rng-ctcs post post/desc
|
||||
additional-lets)
|
||||
(parse-leftover->* stx #'other))
|
||||
(with-syntax ([(man-dom
|
||||
man-dom-kwds
|
||||
man-lets)
|
||||
(man-lets ...))
|
||||
(:split-doms stx '->* #'(raw-mandatory-dom ...) this->*)]
|
||||
[(opt-dom
|
||||
opt-dom-kwds
|
||||
opt-lets)
|
||||
(:split-doms stx '->* raw-optional-doms this->*)])
|
||||
(opt-lets ...))
|
||||
(:split-doms stx '->* raw-optional-doms this->*)]
|
||||
[(additional-lets ...) additional-lets])
|
||||
;; call sort-keywords for the duplicate variable check
|
||||
(sort-keywords stx (append (syntax->list #'man-dom-kwds) (syntax->list #'opt-dom-kwds)))
|
||||
(values
|
||||
#'man-dom
|
||||
#'man-dom-kwds
|
||||
#'man-lets
|
||||
#'opt-dom
|
||||
#'opt-dom-kwds
|
||||
#'opt-lets
|
||||
rest-ctc pre pre/desc rng-ctcs post post/desc)))]))
|
||||
(parsed->* (syntax->list #'man-dom)
|
||||
#'man-dom-kwds
|
||||
(syntax->list #'opt-dom)
|
||||
#'opt-dom-kwds
|
||||
rest-ctc pre pre/desc rng-ctcs post post/desc
|
||||
#'(man-lets ... opt-lets ... additional-lets ...))))]))
|
||||
|
||||
;; -> (values raw-optional-doms rest-ctc pre rng-ctc post)
|
||||
;; rest-ctc (or/c #f syntax) -- #f means no rest contract, syntax is the contract
|
||||
;; rng-ctc (or/c #f syntax) -- #f means `any', syntax is a sequence of result values
|
||||
(define-for-syntax (parse-leftover->* stx leftover)
|
||||
(define additional-lets '())
|
||||
(let*-values ([(raw-optional-doms leftover)
|
||||
(syntax-case leftover ()
|
||||
[(kwd . rst)
|
||||
|
|
@ -857,17 +1004,25 @@
|
|||
(not (keyword? #'another-thing)))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected the #:rest keyword to be followed only by the range (possibly with pre- and post-conditions)"
|
||||
(string-append
|
||||
"expected the #:rest keyword to be followed only by the range"
|
||||
" (possibly with pre- and post-conditions)")
|
||||
stx #'another-thing)]
|
||||
[(#:rest rest-expr . leftover)
|
||||
(values #'rest-expr #'leftover)]
|
||||
(with-syntax ([(rest-x) (generate-temporaries #'(rest-expr))])
|
||||
(set! additional-lets (cons #'[rest-x rest-expr] additional-lets))
|
||||
(values #'rest-x #'leftover))]
|
||||
[_ (values #f leftover)])]
|
||||
[(pre pre/desc leftover)
|
||||
(syntax-case leftover ()
|
||||
[(#:pre pre-expr . leftover)
|
||||
(values #'pre-expr #f #'leftover)]
|
||||
(with-syntax ([(pre-x) (generate-temporaries #'(pre-expr))])
|
||||
(set! additional-lets (cons #`[pre-x (λ () pre-expr)] additional-lets))
|
||||
(values #'pre-x #f #'leftover))]
|
||||
[(#:pre/desc pre-expr . leftover)
|
||||
(values #f #'pre-expr #'leftover)]
|
||||
(with-syntax ([(pre-x) (generate-temporaries #'(pre-expr))])
|
||||
(set! additional-lets (cons #`[pre-x (λ () pre-expr)] additional-lets))
|
||||
(values #f #'pre-x #'leftover))]
|
||||
[_ (values #f #f leftover)])]
|
||||
[(rng leftover)
|
||||
(syntax-case leftover (any values)
|
||||
|
|
@ -885,31 +1040,36 @@
|
|||
[(post post/desc leftover)
|
||||
(syntax-case leftover ()
|
||||
[(#:post post-expr . leftover)
|
||||
(values #'post-expr #f #'leftover)]
|
||||
(with-syntax ([(post-x) (generate-temporaries #'(post-expr))])
|
||||
(set! additional-lets (cons #`[post-x (λ () post-expr)] additional-lets))
|
||||
(values #'post-x #f #'leftover))]
|
||||
[(#:post/desc post-expr . leftover)
|
||||
(values #f #'post-expr #'leftover)]
|
||||
(with-syntax ([(post-x) (generate-temporaries #'(post-expr))])
|
||||
(set! additional-lets (cons #`[post-x (λ () post-expr)] additional-lets))
|
||||
(values #f #'post-x #'leftover))]
|
||||
[else
|
||||
(values #f #f leftover)])])
|
||||
(syntax-case leftover ()
|
||||
[() (values raw-optional-doms rst pre pre/desc rng post post/desc)]
|
||||
[(x . y) (raise-syntax-error #f "expected the contract to end, but found an extra sub-piece" stx #'x)])))
|
||||
[() (values raw-optional-doms rst pre pre/desc rng post post/desc
|
||||
(reverse additional-lets))]
|
||||
[(x . y) (raise-syntax-error #f "expected the contract to end, but found an extra sub-piece"
|
||||
stx #'x)])))
|
||||
|
||||
(define-for-syntax (->*-valid-app-shapes stx)
|
||||
(define this->* (gensym 'this->*))
|
||||
(define-values (man-dom man-dom-kwds man-lets
|
||||
opt-dom opt-dom-kwds opt-lets
|
||||
rest-ctc pre pre/desc rng-ctcs post post/desc)
|
||||
(parse->* stx this->*))
|
||||
(with-syntax ([((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...) man-dom-kwds]
|
||||
[((optional-dom-kwd optional-dom-kwd-ctc) ...) opt-dom-kwds])
|
||||
(cond
|
||||
[(or pre pre/desc post post/desc) #f]
|
||||
[else
|
||||
(valid-app-shapes-from-man/opts (length (syntax->list man-dom))
|
||||
(length (syntax->list opt-dom))
|
||||
rest-ctc
|
||||
(syntax->datum #'(mandatory-dom-kwd ...))
|
||||
(syntax->datum #'(optional-dom-kwd ...)))])))
|
||||
(define a-parsed->* (parse->* stx this->*))
|
||||
(with-syntax ([((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...)
|
||||
(parsed->*-man-dom-kwds a-parsed->*)]
|
||||
[((optional-dom-kwd optional-dom-kwd-ctc) ...)
|
||||
(parsed->*-opt-dom-kwds a-parsed->*)])
|
||||
(values (valid-app-shapes-from-man/opts (length (parsed->*-man-dom a-parsed->*))
|
||||
(length (parsed->*-opt-dom a-parsed->*))
|
||||
(parsed->*-rest-ctc a-parsed->*)
|
||||
(syntax->datum #'(mandatory-dom-kwd ...))
|
||||
(syntax->datum #'(optional-dom-kwd ...)))
|
||||
(build-code-for-plus-one-arity-function
|
||||
a-parsed->*
|
||||
#f))))
|
||||
|
||||
(define-syntax (->* stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -918,68 +1078,45 @@
|
|||
|
||||
(define-for-syntax (->*-internal stx method?)
|
||||
(define this->* (gensym 'this->*))
|
||||
(define-values (man-dom man-dom-kwds man-lets
|
||||
opt-dom opt-dom-kwds opt-lets
|
||||
rest-ctc pre pre/desc rng-ctcs post post/desc)
|
||||
(parse->* stx this->*))
|
||||
(with-syntax ([(mandatory-dom ...) man-dom]
|
||||
[((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...) man-dom-kwds]
|
||||
[(mandatory-let-bindings ...) man-lets]
|
||||
[(optional-dom ...) opt-dom]
|
||||
[((optional-dom-kwd optional-dom-kwd-ctc) ...) opt-dom-kwds]
|
||||
[(optional-let-bindings ...) opt-lets]
|
||||
[(pre-x post-x) (generate-temporaries '(pre-cond post-cond))])
|
||||
(with-syntax ([((kwd dom opt?) ...) #'((mandatory-dom-kwd mandatory-dom-kwd-ctc #f) ...
|
||||
(optional-dom-kwd optional-dom-kwd-ctc #t) ...)]
|
||||
[(pre-let-binding ...) (if (or pre pre/desc)
|
||||
(list #`[pre-x (λ () #,(or pre pre/desc))])
|
||||
(list))]
|
||||
[(post-let-binding ...) (if (or post post/desc)
|
||||
(list #`[post-x (λ () #,(or post post/desc))])
|
||||
(list))])
|
||||
(define-values (plus-one-arity-function chaperone-constructor)
|
||||
(build-plus-one-arity-function+chaperone-constructor
|
||||
(syntax->list #'(mandatory-dom ...))
|
||||
(syntax->list #'(optional-dom ...))
|
||||
(syntax->list #'(mandatory-dom-kwd ...))
|
||||
(syntax->list #'(optional-dom-kwd ...))
|
||||
(and pre #'pre-x)
|
||||
(and pre/desc #'pre-x)
|
||||
rest-ctc
|
||||
rng-ctcs
|
||||
(and post #'post-x)
|
||||
(and post/desc #'post-x)
|
||||
method?))
|
||||
(syntax-property
|
||||
#`(let (mandatory-let-bindings ...
|
||||
optional-let-bindings ...
|
||||
pre-let-binding ...
|
||||
post-let-binding ...)
|
||||
(build--> '->*
|
||||
(list mandatory-dom ...)
|
||||
(list optional-dom ...)
|
||||
'(mandatory-dom-kwd ...)
|
||||
(list mandatory-dom-kwd-ctc ...)
|
||||
'(optional-dom-kwd ...)
|
||||
(list optional-dom-kwd-ctc ...)
|
||||
#,rest-ctc
|
||||
#,(cond [pre #''pre] [pre/desc #''pre/desc] [else #'#f])
|
||||
#,(if rng-ctcs
|
||||
#`(list #,@(for/list ([rng-ctc (in-list (syntax->list rng-ctcs))])
|
||||
(syntax-property rng-ctc
|
||||
'racket/contract:positive-position
|
||||
this->*)))
|
||||
#'#f)
|
||||
#,(cond [post #''post] [post/desc #''post/desc] [else #'#f])
|
||||
#,plus-one-arity-function
|
||||
#,chaperone-constructor
|
||||
#,method?))
|
||||
(define a-parsed->* (parse->* stx this->*))
|
||||
(with-syntax ([((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...) (parsed->*-man-dom-kwds a-parsed->*)]
|
||||
[((optional-dom-kwd optional-dom-kwd-ctc) ...) (parsed->*-opt-dom-kwds a-parsed->*)]
|
||||
[(let-bindings ...) (parsed->*-lets a-parsed->*)])
|
||||
(define pre (parsed->*-pre a-parsed->*))
|
||||
(define pre/desc (parsed->*-pre/desc a-parsed->*))
|
||||
(define post (parsed->*-post a-parsed->*))
|
||||
(define post/desc (parsed->*-post/desc a-parsed->*))
|
||||
(define rest-ctc (parsed->*-rest-ctc a-parsed->*))
|
||||
(define rng-ctcs (parsed->*-rng-ctcs a-parsed->*))
|
||||
(define chaperone-constructor (build-code-for-chaperone-constructor a-parsed->* method?))
|
||||
(syntax-property
|
||||
#`(let (let-bindings ...)
|
||||
(build--> '->*
|
||||
(list #,@(parsed->*-man-dom a-parsed->*))
|
||||
(list #,@(parsed->*-opt-dom a-parsed->*))
|
||||
'(mandatory-dom-kwd ...)
|
||||
(list mandatory-dom-kwd-ctc ...)
|
||||
'(optional-dom-kwd ...)
|
||||
(list optional-dom-kwd-ctc ...)
|
||||
#,rest-ctc
|
||||
#,(cond [pre #''pre] [pre/desc #''pre/desc] [else #'#f])
|
||||
#,(or pre pre/desc #'#f)
|
||||
#,(if rng-ctcs
|
||||
#`(list #,@(for/list ([rng-ctc (in-list (syntax->list rng-ctcs))])
|
||||
(syntax-property rng-ctc
|
||||
'racket/contract:positive-position
|
||||
this->*)))
|
||||
#'#f)
|
||||
#,(cond [post #''post] [post/desc #''post/desc] [else #'#f])
|
||||
#,(or post post/desc #'#f)
|
||||
#,chaperone-constructor
|
||||
#,method?))
|
||||
|
||||
'racket/contract:contract
|
||||
(vector this->*
|
||||
;; the -> in the original input to this guy
|
||||
(list (car (syntax-e stx)))
|
||||
'())))))
|
||||
'racket/contract:contract
|
||||
(vector this->*
|
||||
;; the -> in the original input to this guy
|
||||
(list (car (syntax-e stx)))
|
||||
'()))))
|
||||
|
||||
(define (wrong-number-of-results-blame blame neg-party val reses expected-values)
|
||||
(define length-reses (length reses))
|
||||
|
|
@ -992,7 +1129,6 @@
|
|||
(if (= 1 expected-values) "" "s")))
|
||||
|
||||
(define (build-nullary-very-simple--> _rng
|
||||
plus-one-arity-function
|
||||
chaperone-constructor)
|
||||
(define rng (coerce-contract '-> _rng))
|
||||
(cond
|
||||
|
|
@ -1001,20 +1137,17 @@
|
|||
->void-contract]
|
||||
[(chaperone-contract? rng)
|
||||
(make--> 0
|
||||
'() '() #f #f
|
||||
(list rng) #f
|
||||
plus-one-arity-function
|
||||
'() '() #f #f #f
|
||||
(list rng) #f #f
|
||||
chaperone-constructor
|
||||
#f)]
|
||||
[else
|
||||
(make-impersonator-> 0 '() '() #f #f
|
||||
(list rng) #f
|
||||
plus-one-arity-function
|
||||
(make-impersonator-> 0 '() '() #f #f #f
|
||||
(list rng) #f #f
|
||||
chaperone-constructor
|
||||
#f)]))
|
||||
|
||||
(define (build-unary-very-simple--> _dom _rng
|
||||
plus-one-arity-function
|
||||
chaperone-constructor)
|
||||
(define dom (coerce-contract '-> _dom))
|
||||
(define rng (coerce-contract '-> _rng))
|
||||
|
|
@ -1026,23 +1159,20 @@
|
|||
[(and (chaperone-contract? dom)
|
||||
(chaperone-contract? rng))
|
||||
(make--> 1
|
||||
(list dom) '() #f #f
|
||||
(list rng) #f
|
||||
plus-one-arity-function
|
||||
(list dom) '() #f #f #f
|
||||
(list rng) #f #f
|
||||
chaperone-constructor
|
||||
#f)]
|
||||
[else
|
||||
(make-impersonator-> 1
|
||||
(list dom) '() #f #f
|
||||
(list rng) #f
|
||||
plus-one-arity-function
|
||||
(list dom) '() #f #f #f
|
||||
(list rng) #f #f
|
||||
chaperone-constructor
|
||||
#f)]))
|
||||
|
||||
;; INVARIANT: this is not called when `build-unary-very-simple-->`
|
||||
;; or `build-nullary-very-simple-->` could have been
|
||||
(define (build-very-simple--> raw-regular-doms raw-rngs
|
||||
plus-one-arity-function
|
||||
chaperone-constructor)
|
||||
(define regular-doms
|
||||
(for/list ([dom (in-list raw-regular-doms)])
|
||||
|
|
@ -1055,23 +1185,20 @@
|
|||
[(and (andmap chaperone-contract? regular-doms)
|
||||
(andmap chaperone-contract? (or rngs '())))
|
||||
(make--> (length raw-regular-doms)
|
||||
regular-doms '() #f #f
|
||||
rngs #f
|
||||
plus-one-arity-function
|
||||
regular-doms '() #f #f #f
|
||||
rngs #f #f
|
||||
chaperone-constructor
|
||||
#f)]
|
||||
[else
|
||||
(make-impersonator-> (length raw-regular-doms)
|
||||
regular-doms '() #f #f
|
||||
rngs #f
|
||||
plus-one-arity-function
|
||||
regular-doms '() #f #f #f
|
||||
rngs #f #f
|
||||
chaperone-constructor
|
||||
#f)]))
|
||||
|
||||
(define (build-simple--> raw-regular-doms
|
||||
mandatory-kwds mandatory-raw-kwd-doms
|
||||
raw-rngs
|
||||
plus-one-arity-function
|
||||
chaperone-constructor
|
||||
raw-rest-ctc
|
||||
method?)
|
||||
|
|
@ -1080,8 +1207,7 @@
|
|||
mandatory-kwds mandatory-raw-kwd-doms
|
||||
'() '()
|
||||
raw-rest-ctc
|
||||
#f raw-rngs #f
|
||||
plus-one-arity-function
|
||||
#f #f raw-rngs #f #f
|
||||
chaperone-constructor
|
||||
method?))
|
||||
|
||||
|
|
@ -1090,8 +1216,9 @@
|
|||
mandatory-kwds mandatory-raw-kwd-doms
|
||||
optional-kwds optional-raw-kwd-doms
|
||||
raw-rest-ctc
|
||||
pre-cond raw-rngs post-cond
|
||||
plus-one-arity-function
|
||||
pre-cond pre-cond-thunk
|
||||
raw-rngs
|
||||
post-cond post-cond-thunk
|
||||
chaperone-constructor
|
||||
method?)
|
||||
(define raw-regular-doms
|
||||
|
|
@ -1144,16 +1271,16 @@
|
|||
(andmap (λ (x) (chaperone-contract? (kwd-info-ctc x))) kwd-infos)
|
||||
(andmap chaperone-contract? (or rngs '())))
|
||||
(make--> (length raw-regular-doms)
|
||||
regular-doms kwd-infos rest-ctc pre-cond
|
||||
rngs post-cond
|
||||
plus-one-arity-function
|
||||
regular-doms kwd-infos rest-ctc
|
||||
pre-cond pre-cond-thunk
|
||||
rngs post-cond post-cond-thunk
|
||||
chaperone-constructor
|
||||
method?)]
|
||||
[else
|
||||
(make-impersonator-> (length raw-regular-doms)
|
||||
regular-doms kwd-infos rest-ctc pre-cond
|
||||
rngs post-cond
|
||||
plus-one-arity-function
|
||||
regular-doms kwd-infos rest-ctc
|
||||
pre-cond pre-cond-thunk
|
||||
rngs post-cond post-cond-thunk
|
||||
chaperone-constructor
|
||||
method?)]))
|
||||
|
||||
|
|
@ -1169,6 +1296,8 @@
|
|||
;; leave these out for now
|
||||
(define pre-cond #f)
|
||||
(define post-cond #f)
|
||||
(define pre-cond-thunk #f)
|
||||
(define post-cond-thunk #f)
|
||||
|
||||
(define-syntax-rule (check-list e) (check-list/proc e 'e))
|
||||
(define (check-list/proc e name)
|
||||
|
|
@ -1226,13 +1355,6 @@
|
|||
[(null? _args) (error 'plug-one-arity-function-dynamic->* "internal error")]
|
||||
[else (cons (car _args) (loop (- n 1) (cdr _args)))]))))
|
||||
|
||||
(define (plus-one-arity-function blame f . args)
|
||||
(define f
|
||||
(make-keyword-procedure
|
||||
(λ (kwds kwd-args . regular-args)
|
||||
(error 'plus-one-arity-function "not implemented for dynamic->*"))))
|
||||
(values f f 'not-a-number-so-it-doesnt-match-any-result-from-procedure-result-arity))
|
||||
|
||||
(define min-arity (length mandatory-domain-contracts))
|
||||
(define optionals (length optional-domain-contracts))
|
||||
(define rng-len (and range-contracts (length range-contracts)))
|
||||
|
|
@ -1317,8 +1439,7 @@
|
|||
mandatory-keywords mandatory-keyword-contracts
|
||||
optional-keywords optional-keyword-contracts
|
||||
rest-contract
|
||||
pre-cond range-contracts post-cond
|
||||
plus-one-arity-function
|
||||
pre-cond pre-cond-thunk range-contracts post-cond post-cond-thunk
|
||||
build-chaperone-constructor
|
||||
#f)) ; not a method contract
|
||||
|
||||
|
|
@ -1539,9 +1660,10 @@
|
|||
(base->-kwd-infos ->stct)
|
||||
(base->-rest ->stct)
|
||||
(base->-pre? ->stct)
|
||||
(base->-pre-thunk ->stct)
|
||||
(base->-rngs ->stct)
|
||||
(base->-post? ->stct)
|
||||
(base->-plus-one-arity-function ->stct)
|
||||
(base->-post-thunk ->stct)
|
||||
(base->-chaperone-constructor ->stct)
|
||||
(base->-method? ->stct)
|
||||
#f)))
|
||||
|
|
@ -1553,9 +1675,10 @@
|
|||
(base->-kwd-infos ->stct)
|
||||
(base->-rest ->stct)
|
||||
(base->-pre? ->stct)
|
||||
(base->-pre-thunk ->stct)
|
||||
(base->-rngs ->stct)
|
||||
(base->-post? ->stct)
|
||||
(base->-plus-one-arity-function ->stct)
|
||||
(base->-post-thunk ->stct)
|
||||
(base->-chaperone-constructor ->stct)
|
||||
(base->-method? ->stct)
|
||||
#t)))
|
||||
|
|
@ -1622,7 +1745,7 @@
|
|||
(not (base->-pre? that))
|
||||
(not (base->-post? this))
|
||||
(not (base->-post? that))))
|
||||
|
||||
|
||||
(define-struct (-> base->) ()
|
||||
#:property prop:chaperone-contract (make-property #f))
|
||||
|
||||
|
|
@ -1641,31 +1764,9 @@
|
|||
(error '->void-contract "expected the 0th key to be ~s" desired-key))
|
||||
(define ids (list-ref popular-key-ids expected-index))
|
||||
(list-ref ids 1))])
|
||||
(make--> 0 '() '() #f #f
|
||||
(make--> 0 '() '() #f #f #f
|
||||
(list (coerce-contract 'whatever void?))
|
||||
#f
|
||||
(λ (blame f _ignored)
|
||||
(values
|
||||
(λ (neg-party)
|
||||
(call-with-values/check-range
|
||||
(λ () (f))
|
||||
(case-lambda
|
||||
[(rng)
|
||||
(if (void? rng)
|
||||
rng
|
||||
(raise-blame-error blame #:missing-party neg-party rng
|
||||
'(expected: "void?" given: "~e")
|
||||
rng))]
|
||||
[args
|
||||
(wrong-number-of-results-blame blame neg-party f args 1)])))
|
||||
(λ (neg-party)
|
||||
(let ([rng (f)])
|
||||
(if (void? rng)
|
||||
rng
|
||||
(raise-blame-error blame #:missing-party neg-party rng
|
||||
'(expected: "void?" given: "~e")
|
||||
rng))))
|
||||
1))
|
||||
#f #f
|
||||
(get-chaperone-constructor)
|
||||
#f))) ; not a method contract
|
||||
|
||||
|
|
@ -1682,22 +1783,9 @@
|
|||
(check-result blame neg-party rng)]
|
||||
[args
|
||||
(wrong-number-of-results-blame blame neg-party f args 1)]))
|
||||
(constructor 1 (list any/c) '() #f #f
|
||||
(constructor 1 (list any/c) '() #f #f #f
|
||||
(list (coerce-contract 'whatever boolean?))
|
||||
#f
|
||||
(λ (blame f _ignored-dom-contract _ignored-rng-contract)
|
||||
(values
|
||||
(λ (neg-party argument)
|
||||
(call-with-values/check-range
|
||||
(λ () (f argument))
|
||||
(case-lambda
|
||||
[(rng)
|
||||
(check-result blame neg-party rng)]
|
||||
[args
|
||||
(wrong-number-of-results-blame blame neg-party f args 1)])))
|
||||
(λ (neg-party argument)
|
||||
(check-result blame neg-party (f argument)))
|
||||
1))
|
||||
#f #f
|
||||
(λ (blame f neg-party
|
||||
_ignored-blame-party-info
|
||||
_ignored-is-impersonator?
|
||||
|
|
|
|||
|
|
@ -64,7 +64,6 @@
|
|||
collapsible-contract-continuation-mark-key
|
||||
with-collapsible-contract-continuation-mark
|
||||
|
||||
(struct-out wrapped-extra-arg-arrow)
|
||||
contract-custom-write-property-proc
|
||||
(rename-out [contract-custom-write-property-proc custom-write-property-proc])
|
||||
|
||||
|
|
@ -448,9 +447,6 @@
|
|||
(let-syntax ([m (λ (x) #`(list #,@(known-good-contracts)))])
|
||||
(m)))
|
||||
|
||||
(struct wrapped-extra-arg-arrow (real-func extra-neg-party-argument)
|
||||
#:property prop:procedure 0)
|
||||
|
||||
(define-syntax (define/final-prop stx)
|
||||
(syntax-case stx ()
|
||||
[(_ header bodies ...)
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
(provide provide/contract
|
||||
provide/contract-for-contract-out
|
||||
define-module-boundary-contract
|
||||
(protect-out (for-syntax true-provide/contract
|
||||
(protect-out (for-syntax build-definition-of-plus-one-acceptor ;; used in test suite
|
||||
true-provide/contract
|
||||
;make-provide/contract-transformer
|
||||
provide/contract-info?
|
||||
provide/contract-info-contract-id
|
||||
|
|
@ -318,25 +319,16 @@
|
|||
contract-error-name
|
||||
pos-module-source
|
||||
context-limit)
|
||||
(define-values (arrow? the-valid-app-shapes)
|
||||
(syntax-case ctrct (-> ->* ->i)
|
||||
[(-> . _)
|
||||
(not (->-arity-check-only->? ctrct))
|
||||
(values #t (->-valid-app-shapes ctrct))]
|
||||
[(->* . _)
|
||||
(cond
|
||||
[(->*-arity-check-only->? ctrct) (values #f #f)]
|
||||
[else
|
||||
(define shapes (->*-valid-app-shapes ctrct))
|
||||
(if shapes
|
||||
(values #t shapes)
|
||||
(values #f #f))])]
|
||||
[(->i . _) (values #t (->i-valid-app-shapes ctrct))]
|
||||
[_ (values #f #f)]))
|
||||
(with-syntax ([id id]
|
||||
[(partially-applied-id extra-neg-party-argument-fn contract-id blame-id)
|
||||
(generate-temporaries (list 'idX 'idY 'idZ 'idB))]
|
||||
[ctrct ctrct])
|
||||
(define-values (arrow? definition-of-plus-one-acceptor the-valid-app-shapes)
|
||||
(build-definition-of-plus-one-acceptor #'ctrct
|
||||
#'id
|
||||
#'extra-neg-party-argument-fn
|
||||
#'contract-id
|
||||
#'blame-id))
|
||||
(syntax-local-lift-module-end-declaration
|
||||
#`(begin
|
||||
(define-values (partially-applied-id blame-id)
|
||||
|
|
@ -347,9 +339,7 @@
|
|||
#,srcloc-expr
|
||||
#,context-limit))
|
||||
#,@(if arrow?
|
||||
(list #`(define extra-neg-party-argument-fn
|
||||
(wrapped-extra-arg-arrow-extra-neg-party-argument
|
||||
partially-applied-id)))
|
||||
(list definition-of-plus-one-acceptor)
|
||||
(list))))
|
||||
|
||||
#`(begin
|
||||
|
|
@ -376,6 +366,42 @@
|
|||
(quote-syntax partially-applied-id)
|
||||
(quote-syntax blame-id)))))))
|
||||
|
||||
(define-for-syntax (build-definition-of-plus-one-acceptor ctrct
|
||||
id
|
||||
extra-neg-party-argument-fn
|
||||
contract-id
|
||||
blame-id)
|
||||
(define-values (arrow? the-valid-app-shapes
|
||||
build-plus-one-acceptor
|
||||
plus-one-arity-function-code)
|
||||
(syntax-case ctrct (-> ->* ->i)
|
||||
[(-> . _)
|
||||
(not (->-arity-check-only->? ctrct))
|
||||
(let ()
|
||||
(define-values (valid-app-shapes plus-one-arity-function-code)
|
||||
(->-valid-app-shapes ctrct))
|
||||
(values #t
|
||||
valid-app-shapes
|
||||
#'build->*-plus-one-acceptor
|
||||
plus-one-arity-function-code))]
|
||||
[(->* . _)
|
||||
(cond
|
||||
[(->*-arity-check-only->? ctrct) (values #f #f #f #f)]
|
||||
[else
|
||||
(define-values (shapes plus-one-arity-function-code)
|
||||
(->*-valid-app-shapes ctrct))
|
||||
(if shapes
|
||||
(values #t shapes #'build->*-plus-one-acceptor plus-one-arity-function-code)
|
||||
(values #f #f #f #f))
|
||||
])]
|
||||
[_ (values #f #f #f #f)]))
|
||||
(values arrow?
|
||||
#`(define #,extra-neg-party-argument-fn
|
||||
(#,build-plus-one-acceptor (#,plus-one-arity-function-code #,id)
|
||||
#,blame-id
|
||||
#,contract-id))
|
||||
the-valid-app-shapes))
|
||||
|
||||
(define-syntax (define-module-boundary-contract stx)
|
||||
(cond
|
||||
[(equal? (syntax-local-context) 'module-begin)
|
||||
|
|
|
|||
|
|
@ -4,8 +4,6 @@
|
|||
"class-wrapped.rkt"
|
||||
"../contract/base.rkt"
|
||||
"../contract/combinator.rkt"
|
||||
(only-in "../contract/private/guts.rkt"
|
||||
wrapped-extra-arg-arrow?)
|
||||
(for-syntax racket/base
|
||||
syntax/name
|
||||
syntax/stx))
|
||||
|
|
@ -206,17 +204,14 @@
|
|||
(define projd-mth (w/blame m-mth))
|
||||
(hash-set! neg-acceptors-ht mth-name projd-mth)
|
||||
(define neg-extra-arg
|
||||
(cond
|
||||
[(wrapped-extra-arg-arrow? projd-mth)
|
||||
(wrapped-extra-arg-arrow-extra-neg-party-argument projd-mth)]
|
||||
[else
|
||||
;; if some contract doesn't subscribe to the wrapped-extra-arg-arrow
|
||||
;; protocol, then make an inefficient wrapper for it.
|
||||
(make-keyword-procedure
|
||||
(λ (kwds kwd-args neg-party . args)
|
||||
(keyword-apply (projd-mth neg-party) kwds kwd-args args))
|
||||
(λ (neg-party . args)
|
||||
(apply (projd-mth neg-party) args)))]))
|
||||
;; the way extra args worked changed so we cannot use it here anymore
|
||||
;; keep an inefficient wrapper (but maybe this whole approach should
|
||||
;; go away)
|
||||
(make-keyword-procedure
|
||||
(λ (kwds kwd-args neg-party . args)
|
||||
(keyword-apply (projd-mth neg-party) kwds kwd-args args))
|
||||
(λ (neg-party . args)
|
||||
(apply (projd-mth neg-party) args))))
|
||||
(vector-set! neg-extra-arg-vec mth-idx neg-extra-arg)))
|
||||
|
||||
(define absent-methods (ext-class/c-contract-absent-methods this))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user