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

Moved the rest of special cases to reified syntax classes.

Browse Source
This commit is contained in:
Eric Dobson 2012-08-22 22:24:56 -07:00 committed by Sam Tobin-Hochstadt
parent dda1d60211
commit ba7647d7e2
7 changed files with 267 additions and 219 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/typed-racket/typecheck/tc-app.rkt
View File

@ -24,18 +24,17 @@
[(#%plain-app . [(#%plain-app .
(~or (~reflect v (tc/app-list expected) #:attributes (check)) (~or (~reflect v (tc/app-list expected) #:attributes (check))
(~reflect v (tc/app-apply expected) #:attributes (check)) (~reflect v (tc/app-apply expected) #:attributes (check))
(~reflect v (tc/app-eq expected) #:attributes (check)))) (~reflect v (tc/app-eq expected) #:attributes (check))
(~reflect v (tc/app-hetero expected) #:attributes (check))
(~reflect v (tc/app-values expected) #:attributes (check))
(~reflect v (tc/app-keywords expected) #:attributes (check))
(~reflect v (tc/app-objects expected) #:attributes (check))
(~reflect v (tc/app-lambda expected) #:attributes (check))
(~reflect v (tc/app-special expected) #:attributes (check))))
((attribute v.check))] ((attribute v.check))]
[_ #f]) [_ #f])
(tc/app-hetero form expected)
(tc/app-values form expected)
(tc/app-keywords form expected)
(tc/app-objects form expected)
(tc/app-lambda form expected)
(tc/app-special form expected)
(tc/app-regular form expected))) (tc/app-regular form expected)))
(define-syntax-class annotated-op (define-syntax-class annotated-op
(pattern i:identifier (pattern i:identifier
#:when (or (syntax-property #'i 'type-inst) #:when (or (syntax-property #'i 'type-inst)

132
collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt
View File

@ -3,6 +3,7 @@
(require "../../utils/utils.rkt" (require "../../utils/utils.rkt"
(prefix-in c: (contract-req)) (prefix-in c: (contract-req))
syntax/parse racket/match syntax/parse racket/match
syntax/parse/experimental/reflect
"signatures.rkt" "signatures.rkt"
;; fixme - don't need to be bound in this phase - only to make tests work ;; fixme - don't need to be bound in this phase - only to make tests work
racket/unsafe/ops racket/unsafe/ops
@ -75,64 +76,73 @@
(single-value val-e) (single-value val-e)
(index-error i-val i-bound i-e vec-t expected name)])) (index-error i-val i-bound i-e vec-t expected name)]))
(define (tc/app-hetero form expected) (define-syntax-class (tc/app-hetero* expected)
(syntax-parse form #:attributes (check)
#:literals (#%plain-app #:literals (vector-ref unsafe-vector-ref unsafe-vector*-ref
vector-ref unsafe-vector-ref unsafe-vector*-ref vector-set! unsafe-vector-set! unsafe-vector*-set!
vector-set! unsafe-vector-set! unsafe-vector*-set! unsafe-struct-ref unsafe-struct*-ref
unsafe-struct-ref unsafe-struct*-ref unsafe-struct-set! unsafe-struct*-set!
unsafe-struct-set! unsafe-struct*-set! vector-immutable vector)
vector-immutable vector) (pattern ((~or unsafe-struct-ref unsafe-struct*-ref) struct:expr index:expr)
;; unsafe struct-ref #:attr check
[(#%plain-app (~or unsafe-struct-ref unsafe-struct*-ref) struct:expr index:expr) (lambda ()
(match (single-value #'struct) (match (single-value #'struct)
[(tc-result1: (and struct-t (app resolve (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _)))) [(tc-result1: (and struct-t (app resolve (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _))))
(tc/hetero-ref #'index flds struct-t expected "struct")] (tc/hetero-ref #'index flds struct-t expected "struct")]
[s-ty #f])] [s-ty #f])))
;; vector-ref on het vectors ;; vector-ref on het vectors
[(#%plain-app (~or vector-ref unsafe-vector-ref unsafe-vector*-ref) vec:expr index:expr) (pattern ((~or vector-ref unsafe-vector-ref unsafe-vector*-ref) vec:expr index:expr)
(match (single-value #'vec) #:attr check
[(tc-result1: (and vec-t (app resolve (HeterogenousVector: es)))) (lambda ()
(tc/hetero-ref #'index es vec-t expected "vector")] (match (single-value #'vec)
[v-ty #f])] [(tc-result1: (and vec-t (app resolve (HeterogenousVector: es))))
;; unsafe struct-set! (tc/hetero-ref #'index es vec-t expected "vector")]
[(#%plain-app (~or unsafe-struct-set! unsafe-struct*-set!) s:expr index:expr val:expr) [v-ty #f])))
(match (single-value #'s) ;; unsafe struct-set!
[(tc-result1: (and struct-t (app resolve (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _)))) (pattern ((~or unsafe-struct-set! unsafe-struct*-set!) s:expr index:expr val:expr)
(tc/hetero-set! #'index flds #'val struct-t expected "struct")] #:attr check
[s-ty #f])] (lambda ()
;; vector-set! on het vectors (match (single-value #'s)
[(#%plain-app (~or vector-set! unsafe-vector-set! unsafe-vector*-set!) v:expr index:expr val:expr) [(tc-result1: (and struct-t (app resolve (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _))))
(match (single-value #'v) (tc/hetero-set! #'index flds #'val struct-t expected "struct")]
[(tc-result1: (and vec-t (app resolve (HeterogenousVector: es)))) [s-ty #f])))
(tc/hetero-set! #'index es #'val vec-t expected "vector")] ;; vector-set! on het vectors
[v-ty #f])] (pattern ((~or vector-set! unsafe-vector-set! unsafe-vector*-set!) v:expr index:expr val:expr)
[(#%plain-app (~or vector-immutable vector) args:expr ...) #:attr check
(match expected (lambda ()
[(tc-result1: (app resolve (Vector: t))) #f] (match (single-value #'v)
[(tc-result1: (app resolve (HeterogenousVector: ts))) [(tc-result1: (and vec-t (app resolve (HeterogenousVector: es))))
(unless (= (length ts) (length (syntax->list #'(args ...)))) (tc/hetero-set! #'index es #'val vec-t expected "vector")]
(tc-error/expr "expected vector with ~a elements, but got ~a" [v-ty #f])))
(length ts) (pattern (~and form ((~or vector-immutable vector) args:expr ...))
(make-HeterogenousVector (map tc-expr/t (syntax->list #'(args ...)))))) #:attr check
(for ([e (in-list (syntax->list #'(args ...)))] (lambda ()
[t (in-list ts)]) (match expected
(tc-expr/check e (ret t))) [(tc-result1: (app resolve (Vector: t))) #f]
expected] [(tc-result1: (app resolve (HeterogenousVector: ts)))
;; If the expected type is a union, then we examine just the parts (unless (= (length ts) (length (syntax->list #'(args ...))))
;; of the union that are vectors. If there's only one of those, (tc-error/expr "expected vector with ~a elements, but got ~a"
;; we re-run this whole algorithm with that. Otherwise, we treat (length ts)
;; it like any other expected type. (make-HeterogenousVector (map tc-expr/t (syntax->list #'(args ...))))))
[(tc-result1: (app resolve (Union: ts))) (=> continue) (for ([e (in-list (syntax->list #'(args ...)))]
(define u-ts (for/list ([t (in-list ts)] [t (in-list ts)])
#:when (eq? 'vector (Type-key t))) (tc-expr/check e (ret t)))
t)) expected]
(match u-ts ;; If the expected type is a union, then we examine just the parts
[(list t0) (tc/app/check form (ret t0))] ;; of the union that are vectors. If there's only one of those,
[_ (continue)])] ;; we re-run this whole algorithm with that. Otherwise, we treat
;; since vectors are mutable, if there is no expected type, we want to generalize the element type ;; it like any other expected type.
[(or #f (tc-result1: _)) [(tc-result1: (app resolve (Union: ts))) (=> continue)
(ret (make-HeterogenousVector (map (lambda (x) (generalize (tc-expr/t x))) (define u-ts (for/list ([t (in-list ts)]
(syntax->list #'(args ...)))))] #:when (eq? 'vector (Type-key t)))
[_ (int-err "bad expected: ~a" expected)])] t))
[_ #f])) (match u-ts
[(list t0) (tc/app/check #'(#%plain-app . form) (ret t0))]
[_ (continue)])]
;; since vectors are mutable, if there is no expected type, we want to generalize the element type
[(or #f (tc-result1: _))
(ret (make-HeterogenousVector (map (lambda (x) (generalize (tc-expr/t x)))
(syntax->list #'(args ...)))))]
[_ (int-err "bad expected: ~a" expected)]))))
(define tc/app-hetero (reify-syntax-class tc/app-hetero*))

74
collects/typed-racket/typecheck/tc-app/tc-app-keywords.rkt
View File

@ -4,6 +4,7 @@
(require (rename-in "../../utils/utils.rkt" [infer r:infer]) (require (rename-in "../../utils/utils.rkt" [infer r:infer])
"signatures.rkt" "signatures.rkt"
syntax/parse racket/match syntax/parse racket/match
syntax/parse/experimental/reflect
(typecheck signatures tc-app-helper tc-funapp tc-metafunctions) (typecheck signatures tc-app-helper tc-funapp tc-metafunctions)
(types abbrev utils union substitute subtype) (types abbrev utils union substitute subtype)
(rep type-rep) (rep type-rep)
@ -16,40 +17,45 @@
(import tc-expr^) (import tc-expr^)
(export tc-app-keywords^) (export tc-app-keywords^)
(define (tc/app-keywords form expected) (define-syntax-class (tc/app-keywords* expected)
(syntax-parse form #:attributes (check)
#:literals (#%plain-app list) #:literals (#%plain-app list)
[(#%plain-app (pattern (~and form
(#%plain-app cpce s-kp fn kpe kws num) ((#%plain-app cpce s-kp fn kpe kws num)
kw-list kw-list
(#%plain-app list . kw-arg-list) (#%plain-app list . kw-arg-list)
. pos-args) . pos-args))
#:declare cpce (id-from 'checked-procedure-check-and-extract 'racket/private/kw) #:declare cpce (id-from 'checked-procedure-check-and-extract 'racket/private/kw)
#:declare s-kp (id-from 'struct:keyword-procedure 'racket/private/kw) #:declare s-kp (id-from 'struct:keyword-procedure 'racket/private/kw)
#:declare kpe (id-from 'keyword-procedure-extract 'racket/private/kw) #:declare kpe (id-from 'keyword-procedure-extract 'racket/private/kw)
(match (tc-expr #'fn) #:attr check
[(tc-result1: (lambda ()
(Poly: vars
(Function: (list (and ar (arr: dom rng (and rest #f) (and drest #f) kw-formals)))))) (match (tc-expr #'fn)
(=> fail) [(tc-result1:
(unless (null? (fv/list kw-formals)) (Poly: vars
(fail)) (Function: (list (and ar (arr: dom rng (and rest #f) (and drest #f) kw-formals))))))
(match (map single-value (syntax->list #'pos-args)) (=> fail)
[(list (tc-result1: argtys-t) ...) (unless (null? (fv/list kw-formals))
(let* ([subst (infer vars null argtys-t dom rng (fail))
(and expected (tc-results->values expected)))]) (match (map single-value (syntax->list #'pos-args))
(unless subst (fail)) [(list (tc-result1: argtys-t) ...)
(tc-keywords form (list (subst-all subst ar)) (let* ([subst (infer vars null argtys-t dom rng
(type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected))])] (and expected (tc-results->values expected)))])
[(tc-result1: (Function: arities)) (unless subst (fail))
(tc-keywords form arities (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected)] (tc-keywords #'form (list (subst-all subst ar))
[(tc-result1: (Poly: _ (Function: _))) (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected))])]
(tc-error/expr #:return (ret (Un)) [(tc-result1: (Function: arities))
"Inference for polymorphic keyword functions not supported")] (tc-keywords #'(#%plain-app . form) arities (type->list (tc-expr/t #'kws))
[(tc-result1: t) #'kw-arg-list #'pos-args expected)]
(tc-error/expr #:return (ret (Un)) [(tc-result1: (Poly: _ (Function: _)))
"Cannot apply expression of type ~a, since it is not a function type" t)])] (tc-error/expr #:return (ret (Un))
[_ #f])) "Inference for polymorphic keyword functions not supported")]
[(tc-result1: t)
(tc-error/expr #:return (ret (Un))
"Cannot apply expression of type ~a, since it is not a function type" t)]))))
(define tc/app-keywords (reify-syntax-class tc/app-keywords*))
(define (tc-keywords/internal arity kws kw-args error?) (define (tc-keywords/internal arity kws kw-args error?)
(match arity (match arity

54
collects/typed-racket/typecheck/tc-app/tc-app-lambda.rkt
View File

@ -3,6 +3,7 @@
(require "../../utils/utils.rkt" (require "../../utils/utils.rkt"
"signatures.rkt" "signatures.rkt"
syntax/parse racket/match racket/list syntax/parse racket/match racket/list
syntax/parse/experimental/reflect
unstable/sequence unstable/sequence
(typecheck signatures tc-funapp check-below find-annotation ) (typecheck signatures tc-funapp check-below find-annotation )
(types abbrev utils generalize type-table) (types abbrev utils generalize type-table)
@ -15,40 +16,47 @@
(import tc-expr^ tc-let^ tc-lambda^) (import tc-expr^ tc-let^ tc-lambda^)
(export tc-app-lambda^) (export tc-app-lambda^)
(define (tc/app-lambda form expected) (define-syntax-class (tc/app-lambda* expected)
(syntax-parse form #:attributes (check)
#:literals (#%plain-app #%plain-lambda letrec-values) #:literals (#%plain-app #%plain-lambda letrec-values)
;; let loop ;; let loop
[(#%plain-app (letrec-values ([(lp) (~and lam (#%plain-lambda args . body))]) lp*) . actuals) (pattern (~and form ((letrec-values ([(lp) (~and lam (#%plain-lambda args . body))]) lp*) . actuals))
#:fail-unless expected #f #:fail-unless expected #f
#:fail-unless (not (andmap type-annotation (syntax->list #'(lp . args)))) #f #:fail-unless (not (andmap type-annotation (syntax->list #'(lp . args)))) #f
#:fail-unless (free-identifier=? #'lp #'lp*) #f #:fail-unless (free-identifier=? #'lp #'lp*) #f
(let-loop-check form #'lam #'lp #'actuals #'args #'body expected)] #:attr check
(lambda ()
(let-loop-check #'(#%plain-app . form) #'lam #'lp #'actuals #'args #'body expected)))
;; inference for ((lambda ;; inference for ((lambda
[(#%plain-app (#%plain-lambda (x ...) . body) args ...) (pattern ((#%plain-lambda (x ...) . body) args ...)
#:fail-unless (= (length (syntax->list #'(x ...))) #:fail-unless (= (length (syntax->list #'(x ...)))
(length (syntax->list #'(args ...)))) (length (syntax->list #'(args ...)))) #f
#f
#:fail-when (andmap type-annotation (syntax->list #'(x ...))) #f #:fail-when (andmap type-annotation (syntax->list #'(x ...))) #f
(tc/let-values #'((x) ...) #'(args ...) #'body #:attr check
#'(let-values ([(x) args] ...) . body) (lambda ()
expected)] (tc/let-values #'((x) ...) #'(args ...) #'body
#'(let-values ([(x) args] ...) . body)
expected)))
;; inference for ((lambda with dotted rest ;; inference for ((lambda with dotted rest
[(#%plain-app (#%plain-lambda (x ... . rst:id) . body) args ...) (pattern ((#%plain-lambda (x ... . rst:id) . body) args ...)
#:fail-unless (<= (length (syntax->list #'(x ...))) #:fail-unless (<= (length (syntax->list #'(x ...)))
(length (syntax->list #'(args ...)))) #f (length (syntax->list #'(args ...)))) #f
;; FIXME - remove this restriction - doesn't work because the annotation ;; FIXME - remove this restriction - doesn't work because the annotation
;; on rst is not a normal annotation, may have * or ... ;; on rst is not a normal annotation, may have * or ...
#:fail-when (type-annotation #'rst) #f #:fail-when (type-annotation #'rst) #f
#:fail-when (andmap type-annotation (syntax->list #'(x ...))) #f #:fail-when (andmap type-annotation (syntax->list #'(x ...))) #f
(let-values ([(fixed-args varargs) #:attr check
(split-at (syntax->list #'(args ...)) (length (syntax->list #'(x ...))))]) (lambda ()
(with-syntax ([(fixed-args ...) fixed-args] (let-values ([(fixed-args varargs)
[varg #`(#%plain-app list #,@varargs)]) (split-at (syntax->list #'(args ...)) (length (syntax->list #'(x ...))))])
(tc/let-values #'((x) ... (rst)) #`(fixed-args ... varg) #'body (with-syntax ([(fixed-args ...) fixed-args]
#'(let-values ([(x) fixed-args] ... [(rst) varg]) . body) [varg #`(#%plain-app list #,@varargs)])
expected)))] (tc/let-values #'((x) ... (rst)) #`(fixed-args ... varg) #'body
[_ #f])) #'(let-values ([(x) fixed-args] ... [(rst) varg]) . body)
expected))))))
(define tc/app-lambda (reify-syntax-class tc/app-lambda*))
(define (let-loop-check form lam lp actuals args body expected) (define (let-loop-check form lam lp actuals args body expected)
(syntax-parse #`(#,args #,body #,actuals) (syntax-parse #`(#,args #,body #,actuals)

28
collects/typed-racket/typecheck/tc-app/tc-app-objects.rkt
View File

@ -3,6 +3,7 @@
(require "../../utils/utils.rkt" (require "../../utils/utils.rkt"
"signatures.rkt" "signatures.rkt"
syntax/parse racket/match unstable/sequence syntax/parse racket/match unstable/sequence
syntax/parse/experimental/reflect
(typecheck signatures tc-funapp check-below) (typecheck signatures tc-funapp check-below)
(types abbrev union utils) (types abbrev union utils)
(rep type-rep) (rep type-rep)
@ -14,18 +15,25 @@
(import tc-expr^) (import tc-expr^)
(export tc-app-objects^) (export tc-app-objects^)
(define (tc/app-objects form expected)
(syntax-parse form (define-syntax-class (tc/app-objects* expected)
#:literals (#%plain-app list cons quote) #:attributes (check)
[(#%plain-app dmo b cl #:literals (#%plain-app list cons quote)
(#%plain-app list . pos-args)
(#%plain-app list (#%plain-app cons (quote names) named-args) ...)) (pattern (dmo b cl
(#%plain-app list . pos-args)
(#%plain-app list (#%plain-app cons (quote names) named-args) ...))
#:declare dmo (id-from 'do-make-object 'racket/private/class-internal) #:declare dmo (id-from 'do-make-object 'racket/private/class-internal)
(check-do-make-object #'b #'cl #'pos-args #'(names ...) #'(named-args ...))] #:attr check
[(#%plain-app dmo . args) (lambda ()
(check-do-make-object #'b #'cl #'pos-args #'(names ...) #'(named-args ...))))
(pattern (dmo . args)
#:declare dmo (id-from 'do-make-object 'racket/private/class-internal) #:declare dmo (id-from 'do-make-object 'racket/private/class-internal)
(int-err "unexpected arguments to do-make-object")] #:attr check
[_ #f])) (lambda ()
(int-err "unexpected arguments to do-make-object"))))
(define tc/app-objects (reify-syntax-class tc/app-objects*))
;; do-make-object now takes blame as its first argument, which isn't checked ;; do-make-object now takes blame as its first argument, which isn't checked
;; (it's just an s-expression) ;; (it's just an s-expression)

100
collects/typed-racket/typecheck/tc-app/tc-app-special.rkt
View File

@ -3,6 +3,7 @@
(require "../../utils/utils.rkt" (require "../../utils/utils.rkt"
"signatures.rkt" "signatures.rkt"
syntax/parse racket/match syntax/parse racket/match
syntax/parse/experimental/reflect
unstable/list unstable/list
(typecheck signatures tc-funapp check-below) (typecheck signatures tc-funapp check-below)
(types abbrev utils) (types abbrev utils)
@ -21,59 +22,66 @@
(import tc-expr^) (import tc-expr^)
(export tc-app-special^) (export tc-app-special^)
(define (tc/app-special form expected) (define-syntax-class (tc/app-special* expected)
(syntax-parse form #:attributes (check)
#:literals (#%plain-app #%plain-lambda extend-parameterization quote #:literals (#%plain-app #%plain-lambda extend-parameterization quote
false? not call-with-values list) false? not call-with-values list)
;; parameterize ;; parameterize
[(#%plain-app extend-parameterization pmz args ...) (pattern (extend-parameterization pmz args ...)
(let loop ([args (syntax->list #'(args ...))]) #:attr check
(if (null? args) (ret Univ) (lambda ()
(let* ([p (car args)] (let loop ([args (syntax->list #'(args ...))])
[pt (single-value p)] (if (null? args) (ret Univ)
[v (cadr args)] (let* ([p (car args)]
[vt (single-value v)]) [pt (single-value p)]
(match pt [v (cadr args)]
[(tc-result1: (Param: a b)) [vt (single-value v)])
(check-below vt a) (match pt
(loop (cddr args))] [(tc-result1: (Param: a b))
[(tc-result1: t) (check-below vt a)
(tc-error/expr #:return (or expected (ret Univ)) "expected Parameter, but got ~a" t) (loop (cddr args))]
(loop (cddr args))]))))] [(tc-result1: t)
(tc-error/expr #:return (or expected (ret Univ)) "expected Parameter, but got ~a" t)
(loop (cddr args))]))))))
;; use the additional but normally ignored first argument to make-sequence ;; use the additional but normally ignored first argument to make-sequence
;; to provide a better instantiation ;; to provide a better instantiation
[(#%plain-app (~var op (id-from 'make-sequence 'racket/private/for)) (pattern ((~var op (id-from 'make-sequence 'racket/private/for))
(~and quo (quote (i:id ...))) arg:expr) (~and quo (quote (i:id ...))) arg:expr)
#:when (andmap type-annotation (syntax->list #'(i ...))) #:when (andmap type-annotation (syntax->list #'(i ...)))
(match (single-value #'op) #:attr check
[(tc-result1: (and t Poly?)) (lambda ()
(tc-expr/check #'quo (ret Univ)) (match (single-value #'op)
(tc/funapp #'op #'(quo arg) [(tc-result1: (and t Poly?))
(ret (instantiate-poly t (extend (list Univ Univ) (tc-expr/check #'quo (ret Univ))
(map type-annotation (syntax->list #'(i ...))) (tc/funapp #'op #'(quo arg)
Univ))) (ret (instantiate-poly t (extend (list Univ Univ)
(list (ret Univ) (single-value #'arg)) (map type-annotation (syntax->list #'(i ...)))
expected)])] Univ)))
(list (ret Univ) (single-value #'arg))
expected)])))
;; special-case for not - flip the filters ;; special-case for not - flip the filters
[(#%plain-app (~or false? not) arg) (pattern ((~or false? not) arg)
(match (single-value #'arg) #:attr check
[(tc-result1: t (FilterSet: f+ f-) _) (lambda ()
(ret -Boolean (make-FilterSet f- f+))])] (match (single-value #'arg)
[(tc-result1: t (FilterSet: f+ f-) _)
(ret -Boolean (make-FilterSet f- f+))])))
;; special case for (current-contract-region)'s default expansion ;; special case for (current-contract-region)'s default expansion
;; just let it through without any typechecking, since module-name-fixup ;; just let it through without any typechecking, since module-name-fixup
;; is a private function from syntax/location, so this must have been ;; is a private function from syntax/location, so this must have been
;; (quote-module-name) originally. ;; (quote-module-name) originally.
[(#%plain-app op src path) (pattern (op src path)
#:declare op (id-from 'module-name-fixup 'syntax/location) #:declare op (id-from 'module-name-fixup 'syntax/location)
(ret Univ)] #:attr check
(lambda ()
(ret Univ)))
;; special case for `delay' ;; special case for `delay'
[(#%plain-app (pattern (mp1 (#%plain-lambda ()
mp1 (#%plain-app mp2 (#%plain-app call-with-values (#%plain-lambda () e) list))))
(#%plain-lambda () #:declare mp1 (id-from 'make-promise 'racket/promise)
(#%plain-app mp2 (#%plain-app call-with-values (#%plain-lambda () e) list)))) #:declare mp2 (id-from 'make-promise 'racket/promise)
#:declare mp1 (id-from 'make-promise 'racket/promise) #:attr check
#:declare mp2 (id-from 'make-promise 'racket/promise) (lambda ()
(ret (-Promise (tc-expr/t #'e)))] (ret (-Promise (tc-expr/t #'e))))))
(define tc/app-special (reify-syntax-class tc/app-special*))
[_ #f]))

83
collects/typed-racket/typecheck/tc-app/tc-app-values.rkt
View File

@ -3,6 +3,7 @@
(require "../../utils/utils.rkt" (require "../../utils/utils.rkt"
"signatures.rkt" "signatures.rkt"
syntax/parse racket/match syntax/parse racket/match
syntax/parse/experimental/reflect
(typecheck signatures tc-funapp check-below) (typecheck signatures tc-funapp check-below)
(types abbrev utils) (types abbrev utils)
(rep type-rep) (rep type-rep)
@ -13,40 +14,48 @@
(import tc-expr^) (import tc-expr^)
(export tc-app-values^) (export tc-app-values^)
(define (tc/app-values form expected) (define-syntax-class (tc/app-values* expected)
(syntax-parse form #:attributes (check)
#:literals (#%plain-app values call-with-values) #:literals (values call-with-values)
;; call-with-values ;; call-with-values
[(#%plain-app call-with-values prod con) (pattern (call-with-values prod con)
(match (tc/funapp #'prod #'() (single-value #'prod) null #f) #:attr check
[(tc-results: ts fs os) (lambda ()
(tc/funapp #'con #'(prod) (single-value #'con) (map ret ts fs os) expected)])] (match (tc/funapp #'prod #'() (single-value #'prod) null #f)
;; special case for `values' with single argument [(tc-results: ts fs os)
;; we just ignore the values, except that it forces arg to return one value (tc/funapp #'con #'(prod) (single-value #'con) (map ret ts fs os) expected)])))
[(#%plain-app values arg)
(match expected ;; special case for `values' with single argument
[#f (single-value #'arg)] ;; we just ignore the values, except that it forces arg to return one value
[(tc-result1: tp) (pattern (values arg)
(single-value #'arg expected)] #:attr check
[(tc-results: ts) (lambda ()
(single-value #'arg) ;Type check the argument, to find other errors (match expected
(tc-error/expr #:return expected [#f (single-value #'arg)]
"wrong number of values: expected ~a but got one" [(tc-result1: tp)
(length ts))])] (single-value #'arg expected)]
;; handle `values' specially [(tc-results: ts)
[(#%plain-app values . args) (single-value #'arg) ;Type check the argument, to find other errors
(match expected (tc-error/expr #:return expected
[(tc-results: ets efs eos) "wrong number of values: expected ~a but got one"
(match-let ([(list (tc-result1: ts fs os) ...) (length ts))])))
(for/list ([arg (syntax->list #'args)] ;; handle `values' specially
[et ets] [ef efs] [eo eos]) (pattern (values . args)
(single-value arg (ret et ef eo)))]) #:attr check
(if (= (length ts) (length ets) (length (syntax->list #'args))) (lambda ()
(ret ts fs os) (match expected
(tc-error/expr #:return expected "wrong number of values: expected ~a but got ~a" [(tc-results: ets efs eos)
(length ets) (length (syntax->list #'args)))))] (match-let ([(list (tc-result1: ts fs os) ...)
[_ (match-let ([(list (tc-result1: ts fs os) ...) (for/list ([arg (syntax->list #'args)]
(for/list ([arg (syntax->list #'args)]) [et ets] [ef efs] [eo eos])
(single-value arg))]) (single-value arg (ret et ef eo)))])
(ret ts fs os))])] (if (= (length ts) (length ets) (length (syntax->list #'args)))
[_ #f])) (ret ts fs os)
(tc-error/expr #:return expected "wrong number of values: expected ~a but got ~a"
(length ets) (length (syntax->list #'args)))))]
[_ (match-let ([(list (tc-result1: ts fs os) ...)
(for/list ([arg (syntax->list #'args)])
(single-value arg))])
(ret ts fs os))]))))
(define tc/app-values (reify-syntax-class tc/app-values*))