Whitespace fixes.
original commit: 1801efe66afa21797be3a5efe92bc18975dd5a8f
This commit is contained in:
Sam Tobin-Hochstadt
parent
b4a0b7e8b2
commit
8149914d6b
|
|
@ -49,7 +49,8 @@
|
|||
(define (eqv?-able e) (or (eq?-able e) (number? e)))
|
||||
(define (equal?-able e) #t)
|
||||
(define (ok? val)
|
||||
(define-syntax-rule (alt nm pred ...) (and (free-identifier=? #'nm comparator) (or (pred val) ...)))
|
||||
(define-syntax-rule (alt nm pred ...)
|
||||
(and (free-identifier=? #'nm comparator) (or (pred val) ...)))
|
||||
(or (alt symbol=? symbol?)
|
||||
(alt string=? string?)
|
||||
(alt eq? eq?-able)
|
||||
|
|
@ -189,7 +190,8 @@
|
|||
[(list tname tfty opt?)
|
||||
(let ([s (cond [(assq tname name-assoc) => cadr]
|
||||
[(not opt?)
|
||||
(tc-error/delayed "value not provided for named init arg ~a" tname)
|
||||
(tc-error/delayed "value not provided for named init arg ~a"
|
||||
tname)
|
||||
#f]
|
||||
[else #f])])
|
||||
(if s
|
||||
|
|
@ -200,7 +202,8 @@
|
|||
tnflds)
|
||||
(ret (make-Instance c))]
|
||||
[(tc-result1: t)
|
||||
(tc-error/expr #:return (ret (Un)) "expected a class value for object creation, got: ~a" t)]))))
|
||||
(tc-error/expr #:return (ret (Un))
|
||||
"expected a class value for object creation, got: ~a" t)]))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; let loop
|
||||
|
|
@ -265,7 +268,8 @@
|
|||
(define (tc/app/internal form expected)
|
||||
(syntax-parse form
|
||||
#:literals (#%plain-app #%plain-lambda letrec-values quote
|
||||
values apply k:apply not false? list list* call-with-values do-make-object module-name-fixup cons
|
||||
values apply k:apply not false? list list* call-with-values
|
||||
do-make-object module-name-fixup cons
|
||||
map andmap ormap reverse k:reverse extend-parameterization
|
||||
vector-ref unsafe-vector-ref unsafe-vector*-ref
|
||||
vector-set! unsafe-vector-set! unsafe-vector*-set!
|
||||
|
|
@ -284,8 +288,10 @@
|
|||
[(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 ((~literal quote) (i:id ...))) arg:expr)
|
||||
;; 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 ((~literal quote) (i:id ...))) arg:expr)
|
||||
#:when (andmap type-annotation (syntax->list #'(i ...)))
|
||||
(match (single-value #'op)
|
||||
[(tc-result1: (and t Poly?))
|
||||
|
|
@ -321,15 +327,19 @@
|
|||
(ret (list-ref flds ival)))])
|
||||
(if expected (check-below result expected) result))]
|
||||
[(not (and (integer? ival) (exact? ival)))
|
||||
(tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for struct index, but got ~a" ival)]
|
||||
(tc-error/expr #:stx #'e #:return (or expected (ret (Un)))
|
||||
"expected exact integer for struct index, but got ~a" ival)]
|
||||
[(< ival 0)
|
||||
(tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too small for struct ~a" ival t)]
|
||||
(tc-error/expr #:stx #'e #:return (or expected (ret (Un)))
|
||||
"index ~a too small for struct ~a" ival t)]
|
||||
[(not (<= ival (sub1 (length flds))))
|
||||
(tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too large for struct ~a" ival t)]))]
|
||||
(tc-error/expr #:stx #'e #:return (or expected (ret (Un)))
|
||||
"index ~a too large for struct ~a" ival t)]))]
|
||||
[s-ty
|
||||
(let ([arg-tys (list s-ty e-t)])
|
||||
(tc/funapp #'op #'(s e) (single-value #'op) arg-tys expected))]))]
|
||||
[(#%plain-app (~and op (~or (~literal unsafe-struct-set!) (~literal unsafe-struct*-set!))) s e:expr val:expr)
|
||||
[(#%plain-app (~and op (~or (~literal unsafe-struct-set!) (~literal unsafe-struct*-set!)))
|
||||
s e:expr val:expr)
|
||||
(let ([e-t (single-value #'e)])
|
||||
(match (single-value #'s)
|
||||
[(tc-result1: (and t (or (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _)
|
||||
|
|
@ -341,9 +351,11 @@
|
|||
[(tc-result1: (Value: (? number? i))) i]
|
||||
[_ #f]))])
|
||||
(cond [(not ival)
|
||||
(tc-error/expr #:stx #'e
|
||||
#:return (or expected (ret -Void))
|
||||
"expected statically known index for unsafe struct mutation, but got ~a" (match e-t [(tc-result1: t) t]))]
|
||||
(tc-error/expr
|
||||
#:stx #'e
|
||||
#:return (or expected (ret -Void))
|
||||
"expected statically known index for unsafe struct mutation, but got ~a"
|
||||
(match e-t [(tc-result1: t) t]))]
|
||||
[(and (integer? ival) (exact? ival) (<= 0 ival (sub1 (length flds))))
|
||||
(tc-expr/check #'val (ret (list-ref flds ival)))
|
||||
(if expected
|
||||
|
|
@ -351,18 +363,25 @@
|
|||
(ret -Void))]
|
||||
[(not (and (integer? ival) (exact? ival)))
|
||||
(single-value #'val)
|
||||
(tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for unsafe struct mutation, but got ~a" ival)]
|
||||
(tc-error/expr
|
||||
#:stx #'e #:return (or expected (ret (Un)))
|
||||
"expected exact integer for unsafe struct mutation, but got ~a" ival)]
|
||||
[(< ival 0)
|
||||
(single-value #'val)
|
||||
(tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too small for struct ~a" ival t)]
|
||||
(tc-error/expr #:stx #'e #:return (or expected (ret (Un)))
|
||||
"index ~a too small for struct ~a" ival t)]
|
||||
[(not (<= ival (sub1 (length flds))))
|
||||
(single-value #'val)
|
||||
(tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too large for struct ~a" ival t)]))]
|
||||
(tc-error/expr #:stx #'e #:return (or expected (ret (Un)))
|
||||
"index ~a too large for struct ~a" ival t)]))]
|
||||
[s-ty
|
||||
(let ([arg-tys (list s-ty e-t (single-value #'val))])
|
||||
(tc/funapp #'op #'(s e val) (single-value #'op) arg-tys expected))]))]
|
||||
;; vector-ref on het vectors
|
||||
[(#%plain-app (~and op (~or (~literal vector-ref) (~literal unsafe-vector-ref) (~literal unsafe-vector*-ref))) v e:expr)
|
||||
[(#%plain-app (~and op (~or (~literal vector-ref)
|
||||
(~literal unsafe-vector-ref)
|
||||
(~literal unsafe-vector*-ref)))
|
||||
v e:expr)
|
||||
(let ([e-t (single-value #'e)])
|
||||
(let loop ((v-t (single-value #'v)))
|
||||
(match v-t
|
||||
|
|
@ -381,17 +400,23 @@
|
|||
(check-below (ret (list-ref es ival)) expected)
|
||||
(ret (list-ref es ival)))]
|
||||
[(not (and (integer? ival) (exact? ival)))
|
||||
(tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for vector index, but got ~a" ival)]
|
||||
(tc-error/expr #:stx #'e #:return (or expected (ret (Un)))
|
||||
"expected exact integer for vector index, but got ~a" ival)]
|
||||
[(< ival 0)
|
||||
(tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too small for vector ~a" ival t)]
|
||||
(tc-error/expr #:stx #'e #:return (or expected (ret (Un)))
|
||||
"index ~a too small for vector ~a" ival t)]
|
||||
[(not (<= ival (sub1 (length es))))
|
||||
(tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too large for vector ~a" ival t)]))]
|
||||
(tc-error/expr #:stx #'e #:return (or expected (ret (Un)))
|
||||
"index ~a too large for vector ~a" ival t)]))]
|
||||
[(tc-result1: (? needs-resolving? e) f o)
|
||||
(loop (ret (resolve-once e) f o))]
|
||||
[v-ty
|
||||
(let ([arg-tys (list v-ty e-t)])
|
||||
(tc/funapp #'op #'(v e) (single-value #'op) arg-tys expected))])))]
|
||||
[(#%plain-app (~and op (~or (~literal vector-set!) (~literal unsafe-vector-set!) (~literal unsafe-vector*-set!))) v e:expr val:expr)
|
||||
[(#%plain-app (~and op (~or (~literal vector-set!)
|
||||
(~literal unsafe-vector-set!)
|
||||
(~literal unsafe-vector*-set!)))
|
||||
v e:expr val:expr)
|
||||
(let ([e-t (single-value #'e)])
|
||||
(let loop ((v-t (single-value #'v)))
|
||||
(match v-t
|
||||
|
|
@ -401,9 +426,10 @@
|
|||
[(tc-result1: (Value: (? number? i))) i]
|
||||
[_ #f]))])
|
||||
(cond [(not ival)
|
||||
(tc-error/expr #:stx #'e
|
||||
#:return (or expected (ret -Void))
|
||||
"expected statically known index for heterogeneous vector, but got ~a" (match e-t [(tc-result1: t) t]))]
|
||||
(tc-error/expr
|
||||
#:stx #'e #:return (or expected (ret -Void))
|
||||
"expected statically known index for heterogeneous vector, but got ~a"
|
||||
(match e-t [(tc-result1: t) t]))]
|
||||
[(and (integer? ival) (exact? ival) (<= 0 ival (sub1 (length es))))
|
||||
(tc-expr/check #'val (ret (list-ref es ival)))
|
||||
(if expected
|
||||
|
|
@ -411,13 +437,16 @@
|
|||
(ret -Void))]
|
||||
[(not (and (integer? ival) (exact? ival)))
|
||||
(single-value #'val)
|
||||
(tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for vector index, but got ~a" ival)]
|
||||
(tc-error/expr #:stx #'e #:return (or expected (ret (Un)))
|
||||
"expected exact integer for vector index, but got ~a" ival)]
|
||||
[(< ival 0)
|
||||
(single-value #'val)
|
||||
(tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too small for vector ~a" ival t)]
|
||||
(tc-error/expr #:stx #'e #:return (or expected (ret (Un)))
|
||||
"index ~a too small for vector ~a" ival t)]
|
||||
[(not (<= ival (sub1 (length es))))
|
||||
(single-value #'val)
|
||||
(tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too large for vector ~a" ival t)]))]
|
||||
(tc-error/expr #:stx #'e #:return (or expected (ret (Un)))
|
||||
"index ~a too large for vector ~a" ival t)]))]
|
||||
[(tc-result1: (? needs-resolving? e) f o)
|
||||
(loop (ret (resolve-once e) f o))]
|
||||
[v-ty
|
||||
|
|
@ -452,12 +481,14 @@
|
|||
(tc/funapp #'op #'(args ...) (single-value #'op) arg-tys expected))
|
||||
(check-below (for/first ([t ts]) (loop (ret t)))
|
||||
expected))]
|
||||
;; 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: _))
|
||||
(ret (make-HeterogenousVector (map (lambda (x) (generalize (tc-expr/t x)))
|
||||
(syntax->list #'(args ...)))))]
|
||||
[_ (int-err "bad expected: ~a" expected)]))]
|
||||
;; 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
|
||||
[(#%plain-app (~and op (~literal make-vector)) n elt)
|
||||
(match expected
|
||||
[(tc-result1: (Vector: t))
|
||||
|
|
@ -495,14 +526,17 @@
|
|||
[(subtype t -PosFixnum) (ret -NonNegFixnum)]
|
||||
[(subtype t -NonNegFixnum) (ret -Fixnum)]
|
||||
[(subtype t -PosInt) (ret -Nat)]
|
||||
[else (tc/funapp #'op #'(v arg2) (single-value #'op) (list (ret t) (single-value #'arg2)) expected)]))]
|
||||
[else (tc/funapp #'op #'(v arg2) (single-value #'op)
|
||||
(list (ret t) (single-value #'arg2)) expected)]))]
|
||||
;; idem for fx-
|
||||
[(#%plain-app (~and op (~or (~literal fx-) (~literal unsafe-fx-))) v (~and arg2 ((~literal quote) 1)))
|
||||
[(#%plain-app (~and op (~or (~literal fx-) (~literal unsafe-fx-)))
|
||||
v (~and arg2 ((~literal quote) 1)))
|
||||
(add-typeof-expr #'arg2 (ret -PosFixnum))
|
||||
(match-let ([(tc-result1: t) (single-value #'v)])
|
||||
(cond
|
||||
[(subtype t -PosInt) (ret -NonNegFixnum)]
|
||||
[else (tc/funapp #'op #'(v arg2) (single-value #'op) (list (ret t) (single-value #'arg2)) expected)]))]
|
||||
[else (tc/funapp #'op #'(v arg2) (single-value #'op)
|
||||
(list (ret t) (single-value #'arg2)) expected)]))]
|
||||
;; call-with-values
|
||||
[(#%plain-app call-with-values prod con)
|
||||
(match (tc/funapp #'prod #'() (single-value #'prod) null #f)
|
||||
|
|
@ -511,7 +545,8 @@
|
|||
;; in eq? cases, call tc/eq
|
||||
[(#%plain-app eq?:comparator v1 v2)
|
||||
;; make sure the whole expression is type correct
|
||||
(match* ((tc/funapp #'eq? #'(v1 v2) (single-value #'eq?) (map single-value (syntax->list #'(v1 v2))) expected)
|
||||
(match* ((tc/funapp #'eq? #'(v1 v2) (single-value #'eq?)
|
||||
(map single-value (syntax->list #'(v1 v2))) expected)
|
||||
;; check thn and els with the eq? info
|
||||
(tc/eq #'eq? #'v1 #'v2))
|
||||
[((tc-result1: t) (tc-result1: t* f o))
|
||||
|
|
@ -528,10 +563,12 @@
|
|||
[(tc-result1: (List: ts)) (ret ts)]
|
||||
[_ (tc/apply #'values #'(e))])]
|
||||
;; rewrite this so that it takes advantages of all the special cases
|
||||
[(#%plain-app k:apply . args) (tc/app/internal (syntax/loc form (#%plain-app apply . args)) expected)]
|
||||
[(#%plain-app k:apply . args)
|
||||
(tc/app/internal (syntax/loc form (#%plain-app apply . args)) expected)]
|
||||
;; handle apply specially
|
||||
[(#%plain-app apply f . args) (tc/apply #'f #'args)]
|
||||
;; special case for `values' with single argument - we just ignore the values, except that it forces arg to return one value
|
||||
;; 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)]
|
||||
|
|
@ -568,14 +605,16 @@
|
|||
#: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))))))
|
||||
[(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)))])
|
||||
(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))])]
|
||||
|
|
@ -584,8 +623,9 @@
|
|||
[(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)])]
|
||||
[(tc-result1: t)
|
||||
(tc-error/expr #:return (ret (Un))
|
||||
"Cannot apply expression of type ~a, since it is not a function type" t)])]
|
||||
;; even more special case for match
|
||||
[(#%plain-app (letrec-values ([(lp) (~and lam (#%plain-lambda args . body))]) lp*) . actuals)
|
||||
#:fail-unless expected #f
|
||||
|
|
@ -599,7 +639,9 @@
|
|||
[(#%plain-app module-name-fixup src path)
|
||||
(ret Univ)]
|
||||
;; special cases for classes
|
||||
[(#%plain-app do-make-object b cl (#%plain-app list . pos-args) (#%plain-app list (#%plain-app cons 'names named-args) ...))
|
||||
[(#%plain-app do-make-object b cl
|
||||
(#%plain-app list . pos-args)
|
||||
(#%plain-app list (#%plain-app cons 'names named-args) ...))
|
||||
(check-do-make-object #'b #'cl #'pos-args #'(names ...) #'(named-args ...))]
|
||||
[(#%plain-app do-make-object args ...)
|
||||
(int-err "unexpected arguments to do-make-object")]
|
||||
|
|
@ -609,8 +651,10 @@
|
|||
[((tc-result1: (ListDots: t0 bound0))
|
||||
(list (tc-result1: (or (and (ListDots: t bound) (app (λ _ #f) var))
|
||||
;; a devious hack - just generate #f so the test below succeeds
|
||||
;; have to explicitly bind `var' since otherwise `var' appears on only one side of the or
|
||||
;; NOTE: safe to include these, `map' will error if any list is not the same length as all the others
|
||||
;; have to explicitly bind `var' since otherwise `var' appears
|
||||
;; on only one side of the or
|
||||
;; NOTE: safe to include these, `map' will error if any list is
|
||||
;; not the same length as all the others
|
||||
(and (Listof: t var) (app (λ _ #f) bound))))
|
||||
...))
|
||||
(=> fail)
|
||||
|
|
@ -624,7 +668,8 @@
|
|||
"Expected one value, but got ~a" (-values ts))])]
|
||||
;; otherwise, if it's not a ListDots, defer to the regular function typechecking
|
||||
[(res0 res)
|
||||
(tc/funapp #'map-expr #'(f arg0 arg ...) (single-value #'map-expr) (list* (tc-expr #'f) res0 res) expected)])]
|
||||
(tc/funapp #'map-expr #'(f arg0 arg ...) (single-value #'map-expr)
|
||||
(list* (tc-expr #'f) res0 res) expected)])]
|
||||
;; ormap/andmap of ... argument
|
||||
[(#%plain-app (~and fun (~or (~literal andmap) (~literal ormap))) f arg)
|
||||
;; check the arguments
|
||||
|
|
@ -710,7 +755,8 @@
|
|||
;; 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 ...))))])
|
||||
(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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user