Moved the rest of special cases to reified syntax classes.
original commit: ba7647d7e22a0c926755e6748b49a490e2a1fc4d
This commit is contained in:
Eric Dobson
Sam Tobin-Hochstadt
parent
cf3cdb4d9d
commit
5754267aa0
|
|
@ -24,18 +24,17 @@
|
|||
[(#%plain-app .
|
||||
(~or (~reflect v (tc/app-list 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))]
|
||||
[_ #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)))
|
||||
|
||||
|
||||
(define-syntax-class annotated-op
|
||||
(pattern i:identifier
|
||||
#:when (or (syntax-property #'i 'type-inst)
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
(require "../../utils/utils.rkt"
|
||||
(prefix-in c: (contract-req))
|
||||
syntax/parse racket/match
|
||||
syntax/parse/experimental/reflect
|
||||
"signatures.rkt"
|
||||
;; fixme - don't need to be bound in this phase - only to make tests work
|
||||
racket/unsafe/ops
|
||||
|
|
@ -75,64 +76,73 @@
|
|||
(single-value val-e)
|
||||
(index-error i-val i-bound i-e vec-t expected name)]))
|
||||
|
||||
(define (tc/app-hetero form expected)
|
||||
(syntax-parse form
|
||||
#:literals (#%plain-app
|
||||
vector-ref unsafe-vector-ref unsafe-vector*-ref
|
||||
vector-set! unsafe-vector-set! unsafe-vector*-set!
|
||||
unsafe-struct-ref unsafe-struct*-ref
|
||||
unsafe-struct-set! unsafe-struct*-set!
|
||||
vector-immutable vector)
|
||||
;; unsafe struct-ref
|
||||
[(#%plain-app (~or unsafe-struct-ref unsafe-struct*-ref) struct:expr index:expr)
|
||||
(match (single-value #'struct)
|
||||
[(tc-result1: (and struct-t (app resolve (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _))))
|
||||
(tc/hetero-ref #'index flds struct-t expected "struct")]
|
||||
[s-ty #f])]
|
||||
;; vector-ref on het vectors
|
||||
[(#%plain-app (~or vector-ref unsafe-vector-ref unsafe-vector*-ref) vec:expr index:expr)
|
||||
(match (single-value #'vec)
|
||||
[(tc-result1: (and vec-t (app resolve (HeterogenousVector: es))))
|
||||
(tc/hetero-ref #'index es vec-t expected "vector")]
|
||||
[v-ty #f])]
|
||||
;; unsafe struct-set!
|
||||
[(#%plain-app (~or unsafe-struct-set! unsafe-struct*-set!) s:expr index:expr val:expr)
|
||||
(match (single-value #'s)
|
||||
[(tc-result1: (and struct-t (app resolve (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _))))
|
||||
(tc/hetero-set! #'index flds #'val struct-t expected "struct")]
|
||||
[s-ty #f])]
|
||||
;; vector-set! on het vectors
|
||||
[(#%plain-app (~or vector-set! unsafe-vector-set! unsafe-vector*-set!) v:expr index:expr val:expr)
|
||||
(match (single-value #'v)
|
||||
[(tc-result1: (and vec-t (app resolve (HeterogenousVector: es))))
|
||||
(tc/hetero-set! #'index es #'val vec-t expected "vector")]
|
||||
[v-ty #f])]
|
||||
[(#%plain-app (~or vector-immutable vector) args:expr ...)
|
||||
(match expected
|
||||
[(tc-result1: (app resolve (Vector: t))) #f]
|
||||
[(tc-result1: (app resolve (HeterogenousVector: ts)))
|
||||
(unless (= (length ts) (length (syntax->list #'(args ...))))
|
||||
(tc-error/expr "expected vector with ~a elements, but got ~a"
|
||||
(length ts)
|
||||
(make-HeterogenousVector (map tc-expr/t (syntax->list #'(args ...))))))
|
||||
(for ([e (in-list (syntax->list #'(args ...)))]
|
||||
[t (in-list ts)])
|
||||
(tc-expr/check e (ret t)))
|
||||
expected]
|
||||
;; If the expected type is a union, then we examine just the parts
|
||||
;; of the union that are vectors. If there's only one of those,
|
||||
;; we re-run this whole algorithm with that. Otherwise, we treat
|
||||
;; it like any other expected type.
|
||||
[(tc-result1: (app resolve (Union: ts))) (=> continue)
|
||||
(define u-ts (for/list ([t (in-list ts)]
|
||||
#:when (eq? 'vector (Type-key t)))
|
||||
t))
|
||||
(match u-ts
|
||||
[(list t0) (tc/app/check 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)])]
|
||||
[_ #f]))
|
||||
(define-syntax-class (tc/app-hetero* expected)
|
||||
#:attributes (check)
|
||||
#:literals (vector-ref unsafe-vector-ref unsafe-vector*-ref
|
||||
vector-set! unsafe-vector-set! unsafe-vector*-set!
|
||||
unsafe-struct-ref unsafe-struct*-ref
|
||||
unsafe-struct-set! unsafe-struct*-set!
|
||||
vector-immutable vector)
|
||||
(pattern ((~or unsafe-struct-ref unsafe-struct*-ref) struct:expr index:expr)
|
||||
#:attr check
|
||||
(lambda ()
|
||||
(match (single-value #'struct)
|
||||
[(tc-result1: (and struct-t (app resolve (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _))))
|
||||
(tc/hetero-ref #'index flds struct-t expected "struct")]
|
||||
[s-ty #f])))
|
||||
;; vector-ref on het vectors
|
||||
(pattern ((~or vector-ref unsafe-vector-ref unsafe-vector*-ref) vec:expr index:expr)
|
||||
#:attr check
|
||||
(lambda ()
|
||||
(match (single-value #'vec)
|
||||
[(tc-result1: (and vec-t (app resolve (HeterogenousVector: es))))
|
||||
(tc/hetero-ref #'index es vec-t expected "vector")]
|
||||
[v-ty #f])))
|
||||
;; unsafe struct-set!
|
||||
(pattern ((~or unsafe-struct-set! unsafe-struct*-set!) s:expr index:expr val:expr)
|
||||
#:attr check
|
||||
(lambda ()
|
||||
(match (single-value #'s)
|
||||
[(tc-result1: (and struct-t (app resolve (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _))))
|
||||
(tc/hetero-set! #'index flds #'val struct-t expected "struct")]
|
||||
[s-ty #f])))
|
||||
;; vector-set! on het vectors
|
||||
(pattern ((~or vector-set! unsafe-vector-set! unsafe-vector*-set!) v:expr index:expr val:expr)
|
||||
#:attr check
|
||||
(lambda ()
|
||||
(match (single-value #'v)
|
||||
[(tc-result1: (and vec-t (app resolve (HeterogenousVector: es))))
|
||||
(tc/hetero-set! #'index es #'val vec-t expected "vector")]
|
||||
[v-ty #f])))
|
||||
(pattern (~and form ((~or vector-immutable vector) args:expr ...))
|
||||
#:attr check
|
||||
(lambda ()
|
||||
(match expected
|
||||
[(tc-result1: (app resolve (Vector: t))) #f]
|
||||
[(tc-result1: (app resolve (HeterogenousVector: ts)))
|
||||
(unless (= (length ts) (length (syntax->list #'(args ...))))
|
||||
(tc-error/expr "expected vector with ~a elements, but got ~a"
|
||||
(length ts)
|
||||
(make-HeterogenousVector (map tc-expr/t (syntax->list #'(args ...))))))
|
||||
(for ([e (in-list (syntax->list #'(args ...)))]
|
||||
[t (in-list ts)])
|
||||
(tc-expr/check e (ret t)))
|
||||
expected]
|
||||
;; If the expected type is a union, then we examine just the parts
|
||||
;; of the union that are vectors. If there's only one of those,
|
||||
;; we re-run this whole algorithm with that. Otherwise, we treat
|
||||
;; it like any other expected type.
|
||||
[(tc-result1: (app resolve (Union: ts))) (=> continue)
|
||||
(define u-ts (for/list ([t (in-list ts)]
|
||||
#:when (eq? 'vector (Type-key t)))
|
||||
t))
|
||||
(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*))
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
(require (rename-in "../../utils/utils.rkt" [infer r:infer])
|
||||
"signatures.rkt"
|
||||
syntax/parse racket/match
|
||||
syntax/parse/experimental/reflect
|
||||
(typecheck signatures tc-app-helper tc-funapp tc-metafunctions)
|
||||
(types abbrev utils union substitute subtype)
|
||||
(rep type-rep)
|
||||
|
|
@ -16,40 +17,45 @@
|
|||
(import tc-expr^)
|
||||
(export tc-app-keywords^)
|
||||
|
||||
(define (tc/app-keywords form expected)
|
||||
(syntax-parse form
|
||||
#:literals (#%plain-app list)
|
||||
[(#%plain-app
|
||||
(#%plain-app cpce s-kp fn kpe kws num)
|
||||
kw-list
|
||||
(#%plain-app list . kw-arg-list)
|
||||
. pos-args)
|
||||
#:declare cpce (id-from 'checked-procedure-check-and-extract 'racket/private/kw)
|
||||
#:declare s-kp (id-from 'struct:keyword-procedure 'racket/private/kw)
|
||||
#:declare kpe (id-from 'keyword-procedure-extract 'racket/private/kw)
|
||||
(match (tc-expr #'fn)
|
||||
[(tc-result1:
|
||||
(Poly: vars
|
||||
(Function: (list (and ar (arr: dom rng (and rest #f) (and drest #f) kw-formals))))))
|
||||
(=> fail)
|
||||
(unless (null? (fv/list kw-formals))
|
||||
(fail))
|
||||
(match (map single-value (syntax->list #'pos-args))
|
||||
[(list (tc-result1: argtys-t) ...)
|
||||
(let* ([subst (infer vars null argtys-t dom rng
|
||||
(and expected (tc-results->values expected)))])
|
||||
(unless subst (fail))
|
||||
(tc-keywords form (list (subst-all subst ar))
|
||||
(type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected))])]
|
||||
[(tc-result1: (Function: arities))
|
||||
(tc-keywords form arities (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected)]
|
||||
[(tc-result1: (Poly: _ (Function: _)))
|
||||
(tc-error/expr #:return (ret (Un))
|
||||
"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)])]
|
||||
[_ #f]))
|
||||
(define-syntax-class (tc/app-keywords* expected)
|
||||
#:attributes (check)
|
||||
#:literals (#%plain-app list)
|
||||
(pattern (~and form
|
||||
((#%plain-app cpce s-kp fn kpe kws num)
|
||||
kw-list
|
||||
(#%plain-app list . kw-arg-list)
|
||||
. pos-args))
|
||||
#:declare cpce (id-from 'checked-procedure-check-and-extract 'racket/private/kw)
|
||||
#:declare s-kp (id-from 'struct:keyword-procedure 'racket/private/kw)
|
||||
#:declare kpe (id-from 'keyword-procedure-extract 'racket/private/kw)
|
||||
#:attr check
|
||||
(lambda ()
|
||||
|
||||
(match (tc-expr #'fn)
|
||||
[(tc-result1:
|
||||
(Poly: vars
|
||||
(Function: (list (and ar (arr: dom rng (and rest #f) (and drest #f) kw-formals))))))
|
||||
(=> fail)
|
||||
(unless (null? (fv/list kw-formals))
|
||||
(fail))
|
||||
(match (map single-value (syntax->list #'pos-args))
|
||||
[(list (tc-result1: argtys-t) ...)
|
||||
(let* ([subst (infer vars null argtys-t dom rng
|
||||
(and expected (tc-results->values expected)))])
|
||||
(unless subst (fail))
|
||||
(tc-keywords #'form (list (subst-all subst ar))
|
||||
(type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected))])]
|
||||
[(tc-result1: (Function: arities))
|
||||
(tc-keywords #'(#%plain-app . form) arities (type->list (tc-expr/t #'kws))
|
||||
#'kw-arg-list #'pos-args expected)]
|
||||
[(tc-result1: (Poly: _ (Function: _)))
|
||||
(tc-error/expr #:return (ret (Un))
|
||||
"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?)
|
||||
(match arity
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
(require "../../utils/utils.rkt"
|
||||
"signatures.rkt"
|
||||
syntax/parse racket/match racket/list
|
||||
syntax/parse/experimental/reflect
|
||||
unstable/sequence
|
||||
(typecheck signatures tc-funapp check-below find-annotation )
|
||||
(types abbrev utils generalize type-table)
|
||||
|
|
@ -15,40 +16,47 @@
|
|||
(import tc-expr^ tc-let^ tc-lambda^)
|
||||
(export tc-app-lambda^)
|
||||
|
||||
(define (tc/app-lambda form expected)
|
||||
(syntax-parse form
|
||||
#:literals (#%plain-app #%plain-lambda letrec-values)
|
||||
(define-syntax-class (tc/app-lambda* expected)
|
||||
#:attributes (check)
|
||||
#:literals (#%plain-app #%plain-lambda letrec-values)
|
||||
;; let loop
|
||||
[(#%plain-app (letrec-values ([(lp) (~and lam (#%plain-lambda args . body))]) lp*) . actuals)
|
||||
#:fail-unless expected #f
|
||||
#:fail-unless (not (andmap type-annotation (syntax->list #'(lp . args)))) #f
|
||||
#:fail-unless (free-identifier=? #'lp #'lp*) #f
|
||||
(let-loop-check form #'lam #'lp #'actuals #'args #'body expected)]
|
||||
(pattern (~and form ((letrec-values ([(lp) (~and lam (#%plain-lambda args . body))]) lp*) . actuals))
|
||||
#:fail-unless expected #f
|
||||
#:fail-unless (not (andmap type-annotation (syntax->list #'(lp . args)))) #f
|
||||
#:fail-unless (free-identifier=? #'lp #'lp*) #f
|
||||
#:attr check
|
||||
(lambda ()
|
||||
(let-loop-check #'(#%plain-app . form) #'lam #'lp #'actuals #'args #'body expected)))
|
||||
;; inference for ((lambda
|
||||
[(#%plain-app (#%plain-lambda (x ...) . body) args ...)
|
||||
(pattern ((#%plain-lambda (x ...) . body) args ...)
|
||||
#:fail-unless (= (length (syntax->list #'(x ...)))
|
||||
(length (syntax->list #'(args ...))))
|
||||
#f
|
||||
(length (syntax->list #'(args ...)))) #f
|
||||
#:fail-when (andmap type-annotation (syntax->list #'(x ...))) #f
|
||||
(tc/let-values #'((x) ...) #'(args ...) #'body
|
||||
#'(let-values ([(x) args] ...) . body)
|
||||
expected)]
|
||||
#:attr check
|
||||
(lambda ()
|
||||
(tc/let-values #'((x) ...) #'(args ...) #'body
|
||||
#'(let-values ([(x) args] ...) . body)
|
||||
expected)))
|
||||
;; 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 ...)))
|
||||
(length (syntax->list #'(args ...)))) #f
|
||||
;; FIXME - remove this restriction - doesn't work because the annotation
|
||||
;; on rst is not a normal annotation, may have * or ...
|
||||
#:fail-when (type-annotation #'rst) #f
|
||||
#:fail-when (andmap type-annotation (syntax->list #'(x ...))) #f
|
||||
(let-values ([(fixed-args varargs)
|
||||
(split-at (syntax->list #'(args ...)) (length (syntax->list #'(x ...))))])
|
||||
(with-syntax ([(fixed-args ...) fixed-args]
|
||||
[varg #`(#%plain-app list #,@varargs)])
|
||||
(tc/let-values #'((x) ... (rst)) #`(fixed-args ... varg) #'body
|
||||
#'(let-values ([(x) fixed-args] ... [(rst) varg]) . body)
|
||||
expected)))]
|
||||
[_ #f]))
|
||||
#:attr check
|
||||
(lambda ()
|
||||
(let-values ([(fixed-args varargs)
|
||||
(split-at (syntax->list #'(args ...)) (length (syntax->list #'(x ...))))])
|
||||
(with-syntax ([(fixed-args ...) fixed-args]
|
||||
[varg #`(#%plain-app list #,@varargs)])
|
||||
(tc/let-values #'((x) ... (rst)) #`(fixed-args ... varg) #'body
|
||||
#'(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)
|
||||
(syntax-parse #`(#,args #,body #,actuals)
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
(require "../../utils/utils.rkt"
|
||||
"signatures.rkt"
|
||||
syntax/parse racket/match unstable/sequence
|
||||
syntax/parse/experimental/reflect
|
||||
(typecheck signatures tc-funapp check-below)
|
||||
(types abbrev union utils)
|
||||
(rep type-rep)
|
||||
|
|
@ -14,18 +15,25 @@
|
|||
(import tc-expr^)
|
||||
(export tc-app-objects^)
|
||||
|
||||
(define (tc/app-objects form expected)
|
||||
(syntax-parse form
|
||||
#:literals (#%plain-app list cons quote)
|
||||
[(#%plain-app dmo b cl
|
||||
(#%plain-app list . pos-args)
|
||||
(#%plain-app list (#%plain-app cons (quote names) named-args) ...))
|
||||
|
||||
(define-syntax-class (tc/app-objects* expected)
|
||||
#:attributes (check)
|
||||
#:literals (#%plain-app list cons quote)
|
||||
|
||||
(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)
|
||||
(check-do-make-object #'b #'cl #'pos-args #'(names ...) #'(named-args ...))]
|
||||
[(#%plain-app dmo . args)
|
||||
#:attr check
|
||||
(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)
|
||||
(int-err "unexpected arguments to do-make-object")]
|
||||
[_ #f]))
|
||||
#:attr check
|
||||
(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
|
||||
;; (it's just an s-expression)
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
(require "../../utils/utils.rkt"
|
||||
"signatures.rkt"
|
||||
syntax/parse racket/match
|
||||
syntax/parse/experimental/reflect
|
||||
unstable/list
|
||||
(typecheck signatures tc-funapp check-below)
|
||||
(types abbrev utils)
|
||||
|
|
@ -21,59 +22,66 @@
|
|||
(import tc-expr^)
|
||||
(export tc-app-special^)
|
||||
|
||||
(define (tc/app-special form expected)
|
||||
(syntax-parse form
|
||||
#:literals (#%plain-app #%plain-lambda extend-parameterization quote
|
||||
false? not call-with-values list)
|
||||
(define-syntax-class (tc/app-special* expected)
|
||||
#:attributes (check)
|
||||
#:literals (#%plain-app #%plain-lambda extend-parameterization quote
|
||||
false? not call-with-values list)
|
||||
;; parameterize
|
||||
[(#%plain-app extend-parameterization pmz args ...)
|
||||
(let loop ([args (syntax->list #'(args ...))])
|
||||
(if (null? args) (ret Univ)
|
||||
(let* ([p (car args)]
|
||||
[pt (single-value p)]
|
||||
[v (cadr args)]
|
||||
[vt (single-value v)])
|
||||
(match pt
|
||||
[(tc-result1: (Param: a b))
|
||||
(check-below vt a)
|
||||
(loop (cddr args))]
|
||||
[(tc-result1: t)
|
||||
(tc-error/expr #:return (or expected (ret Univ)) "expected Parameter, but got ~a" t)
|
||||
(loop (cddr args))]))))]
|
||||
(pattern (extend-parameterization pmz args ...)
|
||||
#:attr check
|
||||
(lambda ()
|
||||
(let loop ([args (syntax->list #'(args ...))])
|
||||
(if (null? args) (ret Univ)
|
||||
(let* ([p (car args)]
|
||||
[pt (single-value p)]
|
||||
[v (cadr args)]
|
||||
[vt (single-value v)])
|
||||
(match pt
|
||||
[(tc-result1: (Param: a b))
|
||||
(check-below vt a)
|
||||
(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
|
||||
;; to provide a better instantiation
|
||||
[(#%plain-app (~var op (id-from 'make-sequence 'racket/private/for))
|
||||
(~and quo (quote (i:id ...))) arg:expr)
|
||||
#:when (andmap type-annotation (syntax->list #'(i ...)))
|
||||
(match (single-value #'op)
|
||||
[(tc-result1: (and t Poly?))
|
||||
(tc-expr/check #'quo (ret Univ))
|
||||
(tc/funapp #'op #'(quo arg)
|
||||
(ret (instantiate-poly t (extend (list Univ Univ)
|
||||
(map type-annotation (syntax->list #'(i ...)))
|
||||
Univ)))
|
||||
(list (ret Univ) (single-value #'arg))
|
||||
expected)])]
|
||||
(pattern ((~var op (id-from 'make-sequence 'racket/private/for))
|
||||
(~and quo (quote (i:id ...))) arg:expr)
|
||||
#:when (andmap type-annotation (syntax->list #'(i ...)))
|
||||
#:attr check
|
||||
(lambda ()
|
||||
(match (single-value #'op)
|
||||
[(tc-result1: (and t Poly?))
|
||||
(tc-expr/check #'quo (ret Univ))
|
||||
(tc/funapp #'op #'(quo arg)
|
||||
(ret (instantiate-poly t (extend (list Univ Univ)
|
||||
(map type-annotation (syntax->list #'(i ...)))
|
||||
Univ)))
|
||||
(list (ret Univ) (single-value #'arg))
|
||||
expected)])))
|
||||
;; special-case for not - flip the filters
|
||||
[(#%plain-app (~or false? not) arg)
|
||||
(match (single-value #'arg)
|
||||
[(tc-result1: t (FilterSet: f+ f-) _)
|
||||
(ret -Boolean (make-FilterSet f- f+))])]
|
||||
(pattern ((~or false? not) arg)
|
||||
#:attr check
|
||||
(lambda ()
|
||||
(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
|
||||
;; just let it through without any typechecking, since module-name-fixup
|
||||
;; is a private function from syntax/location, so this must have been
|
||||
;; (quote-module-name) originally.
|
||||
[(#%plain-app op src path)
|
||||
#:declare op (id-from 'module-name-fixup 'syntax/location)
|
||||
(ret Univ)]
|
||||
(pattern (op src path)
|
||||
#:declare op (id-from 'module-name-fixup 'syntax/location)
|
||||
#:attr check
|
||||
(lambda ()
|
||||
(ret Univ)))
|
||||
;; special case for `delay'
|
||||
[(#%plain-app
|
||||
mp1
|
||||
(#%plain-lambda ()
|
||||
(#%plain-app mp2 (#%plain-app call-with-values (#%plain-lambda () e) list))))
|
||||
#:declare mp1 (id-from 'make-promise 'racket/promise)
|
||||
#:declare mp2 (id-from 'make-promise 'racket/promise)
|
||||
(ret (-Promise (tc-expr/t #'e)))]
|
||||
(pattern (mp1 (#%plain-lambda ()
|
||||
(#%plain-app mp2 (#%plain-app call-with-values (#%plain-lambda () e) list))))
|
||||
#:declare mp1 (id-from 'make-promise 'racket/promise)
|
||||
#:declare mp2 (id-from 'make-promise 'racket/promise)
|
||||
#:attr check
|
||||
(lambda ()
|
||||
(ret (-Promise (tc-expr/t #'e))))))
|
||||
|
||||
|
||||
[_ #f]))
|
||||
(define tc/app-special (reify-syntax-class tc/app-special*))
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
(require "../../utils/utils.rkt"
|
||||
"signatures.rkt"
|
||||
syntax/parse racket/match
|
||||
syntax/parse/experimental/reflect
|
||||
(typecheck signatures tc-funapp check-below)
|
||||
(types abbrev utils)
|
||||
(rep type-rep)
|
||||
|
|
@ -13,40 +14,48 @@
|
|||
(import tc-expr^)
|
||||
(export tc-app-values^)
|
||||
|
||||
(define (tc/app-values form expected)
|
||||
(syntax-parse form
|
||||
#:literals (#%plain-app values call-with-values)
|
||||
;; call-with-values
|
||||
[(#%plain-app call-with-values prod con)
|
||||
(match (tc/funapp #'prod #'() (single-value #'prod) null #f)
|
||||
[(tc-results: ts fs os)
|
||||
(tc/funapp #'con #'(prod) (single-value #'con) (map ret ts fs os) expected)])]
|
||||
;; special case for `values' with single argument
|
||||
;; we just ignore the values, except that it forces arg to return one value
|
||||
[(#%plain-app values arg)
|
||||
(match expected
|
||||
[#f (single-value #'arg)]
|
||||
[(tc-result1: tp)
|
||||
(single-value #'arg expected)]
|
||||
[(tc-results: ts)
|
||||
(single-value #'arg) ;Type check the argument, to find other errors
|
||||
(tc-error/expr #:return expected
|
||||
"wrong number of values: expected ~a but got one"
|
||||
(length ts))])]
|
||||
;; handle `values' specially
|
||||
[(#%plain-app values . args)
|
||||
(match expected
|
||||
[(tc-results: ets efs eos)
|
||||
(match-let ([(list (tc-result1: ts fs os) ...)
|
||||
(for/list ([arg (syntax->list #'args)]
|
||||
[et ets] [ef efs] [eo eos])
|
||||
(single-value arg (ret et ef eo)))])
|
||||
(if (= (length ts) (length ets) (length (syntax->list #'args)))
|
||||
(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))])]
|
||||
[_ #f]))
|
||||
(define-syntax-class (tc/app-values* expected)
|
||||
#:attributes (check)
|
||||
#:literals (values call-with-values)
|
||||
;; call-with-values
|
||||
(pattern (call-with-values prod con)
|
||||
#:attr check
|
||||
(lambda ()
|
||||
(match (tc/funapp #'prod #'() (single-value #'prod) null #f)
|
||||
[(tc-results: ts fs os)
|
||||
(tc/funapp #'con #'(prod) (single-value #'con) (map ret ts fs os) expected)])))
|
||||
|
||||
;; special case for `values' with single argument
|
||||
;; we just ignore the values, except that it forces arg to return one value
|
||||
(pattern (values arg)
|
||||
#:attr check
|
||||
(lambda ()
|
||||
(match expected
|
||||
[#f (single-value #'arg)]
|
||||
[(tc-result1: tp)
|
||||
(single-value #'arg expected)]
|
||||
[(tc-results: ts)
|
||||
(single-value #'arg) ;Type check the argument, to find other errors
|
||||
(tc-error/expr #:return expected
|
||||
"wrong number of values: expected ~a but got one"
|
||||
(length ts))])))
|
||||
;; handle `values' specially
|
||||
(pattern (values . args)
|
||||
#:attr check
|
||||
(lambda ()
|
||||
(match expected
|
||||
[(tc-results: ets efs eos)
|
||||
(match-let ([(list (tc-result1: ts fs os) ...)
|
||||
(for/list ([arg (syntax->list #'args)]
|
||||
[et ets] [ef efs] [eo eos])
|
||||
(single-value arg (ret et ef eo)))])
|
||||
(if (= (length ts) (length ets) (length (syntax->list #'args)))
|
||||
(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*))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user