suzanne.soy/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
This commit is contained in:
Eric Dobson 2014-04-01 21:11:59 -07:00
parent d29df205f7
commit 448c66a7a8
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 #lang racket/base
(require "../utils/utils.rkt" (require "../utils/utils.rkt"
racket/match unstable/list unstable/sequence racket/set racket/match unstable/list unstable/sequence racket/set racket/list
syntax/stx syntax/stx
(only-in srfi/1 unzip4) (only-in racket/list make-list) (only-in srfi/1 unzip4) (only-in racket/list make-list)
(contract-req) (contract-req)
@ -39,29 +39,29 @@
[a (in-syntax args-stx)] [a (in-syntax args-stx)]
[arg-t (in-list t-a)]) [arg-t (in-list t-a)])
(parameterize ([current-orig-stx a]) (check-below arg-t dom-t)))) (parameterize ([current-orig-stx a]) (check-below arg-t dom-t))))
(let* ([dom-count (length dom)] (let* ([dom-count (length dom)])
[arg-count (+ dom-count (if rest 1 0) (length kws))]) ;; Currently do nothing with rest args and keyword args as there are no support for them in
;; objects yet.
(let-values (let-values
([(o-a t-a) (for/lists (os ts) ([(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)] [oa (in-sequence-forever (in-list o-a) -empty-obj)]
[ta (in-sequence-forever (in-list t-a) -Bottom)]) [ta (in-sequence-forever (in-list t-a) #f)])
(values (if (>= nm dom-count) -empty-obj oa) (values oa ta))])
ta))])
(match rng (match rng
((AnyValues:) tc-any-results) [(AnyValues:) tc-any-results]
((Values: results) [(Values: results)
(define-values (t-r f-r o-r) (define-values (t-r f-r o-r)
(for/lists (t-r f-r o-r) (for/lists (t-r f-r o-r)
([r (in-list results)]) ([r (in-list results)])
(open-Result r o-a t-a))) (open-Result r o-a t-a)))
(ret t-r f-r o-r)) (ret t-r f-r o-r)]
((ValuesDots: results dty dbound) [(ValuesDots: results dty dbound)
(define-values (t-r f-r o-r) (define-values (t-r f-r o-r)
(for/lists (t-r f-r o-r) (for/lists (t-r f-r o-r)
([r (in-list results)]) ([r (in-list results)])
(open-Result r o-a t-a))) (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 ;; this case should only match if the function type has mandatory keywords
;; but no keywords were provided in the application ;; but no keywords were provided in the application
[((arr: _ _ _ _ [((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 ;; of a Result for function application. This matches up to the substitutions
;; in the T-App rule from the ICFP paper. ;; in the T-App rule from the ICFP paper.
(define/cond-contract (open-Result r objs [ts #f]) (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) (match-define (Result: t fs old-obj) r)
(for/fold ([t t] [fs fs] [old-obj old-obj]) (for/fold ([t t] [fs fs] [old-obj old-obj])
([(o arg) (in-indexed (in-list objs))] ([(o arg) (in-indexed (in-list objs))]
@ -32,7 +32,7 @@
;; This is essentially ψ+|ψ- [o/x] from the paper ;; This is essentially ψ+|ψ- [o/x] from the paper
(define/cond-contract (subst-filter-set fs k o polarity [t #f]) (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?) (->* ((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 (add-extra-filter f)
(define f* (-and extra-filter f)) (define f* (-and extra-filter f))
(match 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)] #:ret (ret -Number)]
[tc-err (call-with-values 5 [tc-err (call-with-values 5
(lambda: ([x : Number] [y : Number]) (+ x y))) (lambda: ([x : Number] [y : Number]) (+ x y)))
#:ret (ret -Number)] #:ret (ret -Number -bot-filter)]
[tc-err (call-with-values (lambda () (values 2)) [tc-err (call-with-values (lambda () (values 2))
5)] 5)]
[tc-err (call-with-values (lambda () (values 2 1)) [tc-err (call-with-values (lambda () (values 2 1))
@ -2737,6 +2737,16 @@
(if (number? x) (add1 x) 0)) (if (number? x) (add1 x) 0))
-Bottom] -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 (test-suite
"tc-literal tests" "tc-literal tests"