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)

44
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,39 +76,47 @@
(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)
;; unsafe struct-ref (pattern ((~or unsafe-struct-ref unsafe-struct*-ref) struct:expr index:expr)
[(#%plain-app (~or unsafe-struct-ref unsafe-struct*-ref) struct:expr index:expr) #:attr check
(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)
#:attr check
(lambda ()
(match (single-value #'vec) (match (single-value #'vec)
[(tc-result1: (and vec-t (app resolve (HeterogenousVector: es)))) [(tc-result1: (and vec-t (app resolve (HeterogenousVector: es))))
(tc/hetero-ref #'index es vec-t expected "vector")] (tc/hetero-ref #'index es vec-t expected "vector")]
[v-ty #f])] [v-ty #f])))
;; unsafe struct-set! ;; unsafe struct-set!
[(#%plain-app (~or unsafe-struct-set! unsafe-struct*-set!) s:expr index:expr val:expr) (pattern ((~or unsafe-struct-set! unsafe-struct*-set!) s:expr index:expr val:expr)
#:attr check
(lambda ()
(match (single-value #'s) (match (single-value #'s)
[(tc-result1: (and struct-t (app resolve (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _)))) [(tc-result1: (and struct-t (app resolve (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _))))
(tc/hetero-set! #'index flds #'val struct-t expected "struct")] (tc/hetero-set! #'index flds #'val struct-t expected "struct")]
[s-ty #f])] [s-ty #f])))
;; vector-set! on het vectors ;; vector-set! on het vectors
[(#%plain-app (~or vector-set! unsafe-vector-set! unsafe-vector*-set!) v:expr index:expr val:expr) (pattern ((~or vector-set! unsafe-vector-set! unsafe-vector*-set!) v:expr index:expr val:expr)
#:attr check
(lambda ()
(match (single-value #'v) (match (single-value #'v)
[(tc-result1: (and vec-t (app resolve (HeterogenousVector: es)))) [(tc-result1: (and vec-t (app resolve (HeterogenousVector: es))))
(tc/hetero-set! #'index es #'val vec-t expected "vector")] (tc/hetero-set! #'index es #'val vec-t expected "vector")]
[v-ty #f])] [v-ty #f])))
[(#%plain-app (~or vector-immutable vector) args:expr ...) (pattern (~and form ((~or vector-immutable vector) args:expr ...))
#:attr check
(lambda ()
(match expected (match expected
[(tc-result1: (app resolve (Vector: t))) #f] [(tc-result1: (app resolve (Vector: t))) #f]
[(tc-result1: (app resolve (HeterogenousVector: ts))) [(tc-result1: (app resolve (HeterogenousVector: ts)))
@ -128,11 +137,12 @@
#:when (eq? 'vector (Type-key t))) #:when (eq? 'vector (Type-key t)))
t)) t))
(match u-ts (match u-ts
[(list t0) (tc/app/check form (ret t0))] [(list t0) (tc/app/check #'(#%plain-app . form) (ret t0))]
[_ (continue)])] [_ (continue)])]
;; since vectors are mutable, if there is no expected type, we want to generalize the element type ;; since vectors are mutable, if there is no expected type, we want to generalize the element type
[(or #f (tc-result1: _)) [(or #f (tc-result1: _))
(ret (make-HeterogenousVector (map (lambda (x) (generalize (tc-expr/t x))) (ret (make-HeterogenousVector (map (lambda (x) (generalize (tc-expr/t x)))
(syntax->list #'(args ...)))))] (syntax->list #'(args ...)))))]
[_ (int-err "bad expected: ~a" expected)])] [_ (int-err "bad expected: ~a" expected)]))))
[_ #f]))
(define tc/app-hetero (reify-syntax-class tc/app-hetero*))

24
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,17 +17,20 @@
(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)
#:attr check
(lambda ()
(match (tc-expr #'fn) (match (tc-expr #'fn)
[(tc-result1: [(tc-result1:
(Poly: vars (Poly: vars
@ -39,17 +43,19 @@
(let* ([subst (infer vars null argtys-t dom rng (let* ([subst (infer vars null argtys-t dom rng
(and expected (tc-results->values expected)))]) (and expected (tc-results->values expected)))])
(unless subst (fail)) (unless subst (fail))
(tc-keywords form (list (subst-all subst ar)) (tc-keywords #'form (list (subst-all subst ar))
(type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected))])] (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected))])]
[(tc-result1: (Function: arities)) [(tc-result1: (Function: arities))
(tc-keywords form arities (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected)] (tc-keywords #'(#%plain-app . form) arities (type->list (tc-expr/t #'kws))
#'kw-arg-list #'pos-args expected)]
[(tc-result1: (Poly: _ (Function: _))) [(tc-result1: (Poly: _ (Function: _)))
(tc-error/expr #:return (ret (Un)) (tc-error/expr #:return (ret (Un))
"Inference for polymorphic keyword functions not supported")] "Inference for polymorphic keyword functions not supported")]
[(tc-result1: t) [(tc-result1: t)
(tc-error/expr #:return (ret (Un)) (tc-error/expr #:return (ret (Un))
"Cannot apply expression of type ~a, since it is not a function type" t)])] "Cannot apply expression of type ~a, since it is not a function type" t)]))))
[_ #f]))
(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

30
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
#:attr check
(lambda ()
(tc/let-values #'((x) ...) #'(args ...) #'body (tc/let-values #'((x) ...) #'(args ...) #'body
#'(let-values ([(x) args] ...) . body) #'(let-values ([(x) args] ...) . body)
expected)] 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
#:attr check
(lambda ()
(let-values ([(fixed-args varargs) (let-values ([(fixed-args varargs)
(split-at (syntax->list #'(args ...)) (length (syntax->list #'(x ...))))]) (split-at (syntax->list #'(args ...)) (length (syntax->list #'(x ...))))])
(with-syntax ([(fixed-args ...) fixed-args] (with-syntax ([(fixed-args ...) fixed-args]
[varg #`(#%plain-app list #,@varargs)]) [varg #`(#%plain-app list #,@varargs)])
(tc/let-values #'((x) ... (rst)) #`(fixed-args ... varg) #'body (tc/let-values #'((x) ... (rst)) #`(fixed-args ... varg) #'body
#'(let-values ([(x) fixed-args] ... [(rst) varg]) . body) #'(let-values ([(x) fixed-args] ... [(rst) varg]) . body)
expected)))] expected))))))
[_ #f]))
(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)

22
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)
#:attributes (check)
#:literals (#%plain-app list cons quote) #:literals (#%plain-app list cons quote)
[(#%plain-app dmo b cl
(pattern (dmo b cl
(#%plain-app list . pos-args) (#%plain-app list . pos-args)
(#%plain-app list (#%plain-app cons (quote names) named-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)

40
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,12 +22,14 @@
(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 ...)
#:attr check
(lambda ()
(let loop ([args (syntax->list #'(args ...))]) (let loop ([args (syntax->list #'(args ...))])
(if (null? args) (ret Univ) (if (null? args) (ret Univ)
(let* ([p (car args)] (let* ([p (car args)]
@ -39,12 +42,14 @@
(loop (cddr args))] (loop (cddr args))]
[(tc-result1: t) [(tc-result1: t)
(tc-error/expr #:return (or expected (ret Univ)) "expected Parameter, but got ~a" t) (tc-error/expr #:return (or expected (ret Univ)) "expected Parameter, but got ~a" t)
(loop (cddr args))]))))] (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 ...)))
#:attr check
(lambda ()
(match (single-value #'op) (match (single-value #'op)
[(tc-result1: (and t Poly?)) [(tc-result1: (and t Poly?))
(tc-expr/check #'quo (ret Univ)) (tc-expr/check #'quo (ret Univ))
@ -53,27 +58,30 @@
(map type-annotation (syntax->list #'(i ...))) (map type-annotation (syntax->list #'(i ...)))
Univ))) Univ)))
(list (ret Univ) (single-value #'arg)) (list (ret Univ) (single-value #'arg))
expected)])] 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)
#:attr check
(lambda ()
(match (single-value #'arg) (match (single-value #'arg)
[(tc-result1: t (FilterSet: f+ f-) _) [(tc-result1: t (FilterSet: f+ f-) _)
(ret -Boolean (make-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-lambda ()
(#%plain-app mp2 (#%plain-app call-with-values (#%plain-lambda () e) list)))) (#%plain-app mp2 (#%plain-app call-with-values (#%plain-lambda () e) list))))
#:declare mp1 (id-from 'make-promise 'racket/promise) #:declare mp1 (id-from 'make-promise 'racket/promise)
#:declare mp2 (id-from 'make-promise 'racket/promise) #:declare mp2 (id-from 'make-promise 'racket/promise)
(ret (-Promise (tc-expr/t #'e)))] #:attr check
(lambda ()
(ret (-Promise (tc-expr/t #'e))))))
(define tc/app-special (reify-syntax-class tc/app-special*))
[_ #f]))

29
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,17 +14,22 @@
(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)
#:attr check
(lambda ()
(match (tc/funapp #'prod #'() (single-value #'prod) null #f) (match (tc/funapp #'prod #'() (single-value #'prod) null #f)
[(tc-results: ts fs os) [(tc-results: ts fs os)
(tc/funapp #'con #'(prod) (single-value #'con) (map ret ts fs os) expected)])] (tc/funapp #'con #'(prod) (single-value #'con) (map ret ts fs os) expected)])))
;; special case for `values' with single argument ;; special case for `values' with single argument
;; we just ignore the values, except that it forces arg to return one value ;; we just ignore the values, except that it forces arg to return one value
[(#%plain-app values arg) (pattern (values arg)
#:attr check
(lambda ()
(match expected (match expected
[#f (single-value #'arg)] [#f (single-value #'arg)]
[(tc-result1: tp) [(tc-result1: tp)
@ -32,9 +38,11 @@
(single-value #'arg) ;Type check the argument, to find other errors (single-value #'arg) ;Type check the argument, to find other errors
(tc-error/expr #:return expected (tc-error/expr #:return expected
"wrong number of values: expected ~a but got one" "wrong number of values: expected ~a but got one"
(length ts))])] (length ts))])))
;; handle `values' specially ;; handle `values' specially
[(#%plain-app values . args) (pattern (values . args)
#:attr check
(lambda ()
(match expected (match expected
[(tc-results: ets efs eos) [(tc-results: ets efs eos)
(match-let ([(list (tc-result1: ts fs os) ...) (match-let ([(list (tc-result1: ts fs os) ...)
@ -48,5 +56,6 @@
[_ (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)])
(single-value arg))]) (single-value arg))])
(ret ts fs os))])] (ret ts fs os))]))))
[_ #f]))
(define tc/app-values (reify-syntax-class tc/app-values*))