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

Make open-Result not incorrectly close over rest and keyword arguments.

Browse Source 
original commit: 448c66a7a82a30ddd3f1ad536638b3a0ad5f9c67
This commit is contained in:
Eric Dobson 2014-04-01 21:11:59 -07:00
parent 9f76a941ed
commit 751a9aa46a
3 changed files with 25 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base
(require "../utils/utils.rkt"
racket/match unstable/list unstable/sequence racket/set
racket/match unstable/list unstable/sequence racket/set racket/list
syntax/stx
(only-in srfi/1 unzip4) (only-in racket/list make-list)
(contract-req)
@ -39,29 +39,29 @@
[a (in-syntax args-stx)]
[arg-t (in-list t-a)])
(parameterize ([current-orig-stx a]) (check-below arg-t dom-t))))
(let* ([dom-count (length dom)]
[arg-count (+ dom-count (if rest 1 0) (length kws))])
(let* ([dom-count (length dom)])
;; Currently do nothing with rest args and keyword args as there are no support for them in
;; objects yet.
(let-values
([(o-a t-a) (for/lists (os ts)
([nm (in-range arg-count)]
([nm (in-range dom-count)]
[oa (in-sequence-forever (in-list o-a) -empty-obj)]
[ta (in-sequence-forever (in-list t-a) -Bottom)])
(values (if (>= nm dom-count) -empty-obj oa)
ta))])
[ta (in-sequence-forever (in-list t-a) #f)])
(values oa ta))])
(match rng
((AnyValues:) tc-any-results)
((Values: results)
[(AnyValues:) tc-any-results]
[(Values: results)
(define-values (t-r f-r o-r)
(for/lists (t-r f-r o-r)
([r (in-list results)])
(open-Result r o-a t-a)))
(ret t-r f-r o-r))
((ValuesDots: results dty dbound)
(ret t-r f-r o-r)]
[(ValuesDots: results dty dbound)
(define-values (t-r f-r o-r)
(for/lists (t-r f-r o-r)
([r (in-list results)])
(open-Result r o-a t-a)))
(ret t-r f-r o-r dty dbound)))))]
(ret t-r f-r o-r dty dbound)])))]
;; this case should only match if the function type has mandatory keywords
;; but no keywords were provided in the application
[((arr: _ _ _ _

4
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-subst.rkt
View File

@ -18,7 +18,7 @@
;; of a Result for function application. This matches up to the substitutions
;; in the T-App rule from the ICFP paper.
(define/cond-contract (open-Result r objs [ts #f])
(->* (Result? (listof Object?)) ((listof Type/c)) (values Type/c FilterSet? Object?))
(->* (Result? (listof Object?)) ((listof (or/c #f Type/c))) (values Type/c FilterSet? Object?))
(match-define (Result: t fs old-obj) r)
(for/fold ([t t] [fs fs] [old-obj old-obj])
([(o arg) (in-indexed (in-list objs))]
@ -32,7 +32,7 @@
;; This is essentially ψ+|ψ- [o/x] from the paper
(define/cond-contract (subst-filter-set fs k o polarity [t #f])
(->* ((or/c FilterSet? NoFilter?) name-ref/c Object? boolean?) ((or/c #f Type/c)) FilterSet?)
(define extra-filter (if t (make-TypeFilter t null k) -top))
(define extra-filter (if t (-filter t k) -top))
(define (add-extra-filter f)
(define f* (-and extra-filter f))
(match f*

12
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt
View File

@ -879,7 +879,7 @@
#:ret (ret -Number)]
[tc-err (call-with-values 5
(lambda: ([x : Number] [y : Number]) (+ x y)))
#:ret (ret -Number)]
#:ret (ret -Number -bot-filter)]
[tc-err (call-with-values (lambda () (values 2))
5)]
[tc-err (call-with-values (lambda () (values 2 1))
@ -2737,6 +2737,16 @@
(if (number? x) (add1 x) 0))
-Bottom]
[tc-err
(let ([f (lambda (x y) y)])
(f 1))
#:ret (ret Univ -top-filter)]
[tc-err
(let ([f (lambda (x y) y)])
(f 1 2 3))
#:ret (ret Univ -true-filter)]
)
(test-suite
"tc-literal tests"