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

fix bug in ->i (neg party was getting dropped)

Browse Source
This commit is contained in:
Robby Findler 2020-09-24 14:30:10 -05:00
parent 5665fd8a85
commit 816e20b803
2 changed files with 12 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
pkgs/racket-test/tests/racket/contract/arrow-i.rkt
View File

@ -1790,6 +1790,14 @@
'pos 'pos
'neg) 'neg)
1)) 1))
(test/neg-blame
'->i-neg-party-is-being-passed-properly
'((contract (-> (->i () any) any)
(λ (x) 1)
'pos
'neg)
0))
;; 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))

8
racket/collects/racket/contract/private/arr-i.rkt
View File

@ -83,17 +83,17 @@
(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* c-or-i-procedure (list* c-or-i-procedure
(λ (val mtd?) (λ (val mtd? neg-party)
(if has-rest (if has-rest
(check-procedure/more val mtd? (check-procedure/more val mtd?
(->i-mandatory-args ctc) (->i-mandatory-args ctc)
(->i-mandatory-kwds ctc) (->i-mandatory-kwds ctc)
(->i-opt-kwds ctc) (->i-opt-kwds ctc)
blame #f) blame neg-party)
(check-procedure val mtd? (check-procedure val mtd?
(->i-mandatory-args ctc) (->i-opt-args ctc) (->i-mandatory-args ctc) (->i-opt-args ctc)
(->i-mandatory-kwds ctc) (->i-opt-kwds ctc) (->i-mandatory-kwds ctc) (->i-opt-kwds ctc)
blame #f))) blame neg-party)))
ctc ctc
blame swapped-blame ;; used by the #:pre and #:post checking blame swapped-blame ;; used by the #:pre and #:post checking
(append blames (append blames
@ -969,7 +969,7 @@ evaluted left-to-right.)
#`(λ #,wrapper-proc-arglist #`(λ #,wrapper-proc-arglist
(λ (val neg-party) (λ (val neg-party)
(define blame+neg-party (cons blame neg-party)) (define blame+neg-party (cons blame neg-party))
(chk val #,method?) (chk val #,method? neg-party)
(c-or-i-procedure (c-or-i-procedure
val val
(let ([arg-checker (let ([arg-checker