diff --git a/collects/typed-racket/typecheck/signatures.rkt b/collects/typed-racket/typecheck/signatures.rkt index 177c7f1efb..099c37c5f6 100644 --- a/collects/typed-racket/typecheck/signatures.rkt +++ b/collects/typed-racket/typecheck/signatures.rkt @@ -7,7 +7,6 @@ (define-signature tc-expr^ ([cond-contracted tc-expr (syntax? . -> . tc-results/c)] - [cond-contracted tc-literal (->* (syntax?) ((or/c #f Type/c)) Type/c)] [cond-contracted tc-expr/check (syntax? tc-results/c . -> . tc-results/c)] [cond-contracted tc-expr/check/t (syntax? tc-results/c . -> . Type/c)] [cond-contracted tc-exprs ((listof syntax?) . -> . tc-results/c)] @@ -23,6 +22,9 @@ (define-signature tc-if^ ([cond-contracted tc/if-twoarm ((syntax? syntax? syntax?) (tc-results/c) . ->* . tc-results/c)])) +(define-signature tc-literal^ + ([cond-contracted tc-literal (->* (syntax?) ((or/c Type/c #f)) Type/c)])) + (define-signature tc-lambda^ ([cond-contracted tc/lambda (syntax? syntax? syntax? . -> . tc-results/c)] [cond-contracted tc/lambda/check (syntax? syntax? syntax? tc-results/c . -> . tc-results/c)] diff --git a/collects/typed-racket/typecheck/tc-app-combined.rkt b/collects/typed-racket/typecheck/tc-app-combined.rkt index 0446df4560..867eecd7a7 100644 --- a/collects/typed-racket/typecheck/tc-app-combined.rkt +++ b/collects/typed-racket/typecheck/tc-app-combined.rkt @@ -19,7 +19,7 @@ (provide tc-app-combined@) (define-compound-unit/infer tc-app-combined@ - (import tc-expr^ tc-lambda^ tc-let^ tc-apply^) + (import tc-expr^ tc-lambda^ tc-let^ tc-apply^ tc-literal^) (export tc-app^) (link tc-app-main@ diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt index d6b1efe5ba..6beb186529 100644 --- a/collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt +++ b/collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt @@ -15,7 +15,7 @@ (rep type-rep rep-utils) (for-template racket/unsafe/ops racket/base)) -(import tc-expr^ tc-app^) +(import tc-expr^ tc-app^ tc-literal^) (export tc-app-hetero^) diff --git a/collects/typed-racket/typecheck/tc-expr-unit.rkt b/collects/typed-racket/typecheck/tc-expr-unit.rkt index 6d99e48d00..82148912b5 100644 --- a/collects/typed-racket/typecheck/tc-expr-unit.rkt +++ b/collects/typed-racket/typecheck/tc-expr-unit.rkt @@ -20,109 +20,9 @@ (require (for-template racket/base racket/private/class-internal)) -(import tc-if^ tc-lambda^ tc-app^ tc-let^ check-subforms^) +(import tc-if^ tc-lambda^ tc-app^ tc-let^ check-subforms^ tc-literal^) (export tc-expr^) -;; return the type of a literal value -;; racket-value [type] -> type -(define (tc-literal v-stx [expected #f]) - (define-syntax-class exp - (pattern (~and i (~or :number :str :bytes)) - #:fail-unless expected #f - #:fail-unless (subtype (-val (syntax-e #'i)) expected) #f)) - (syntax-parse v-stx - [i:exp expected] - [i:boolean (-val (syntax-e #'i))] - [i:identifier (-val (syntax-e #'i))] - ;; Numbers - [0 -Zero] - [1 -One] - [(~var i (3d (conjoin byte? positive?))) -PosByte] - [(~var i (3d byte?)) -Byte] - [(~var i (3d (conjoin portable-index? positive?))) -PosIndex] - [(~var i (3d (conjoin portable-fixnum? positive?))) -PosFixnum] - [(~var i (3d (conjoin portable-fixnum? negative?))) -NegFixnum] - [(~var i (3d exact-positive-integer?)) -PosInt] - [(~var i (3d (conjoin exact-integer? negative?))) -NegInt] - [(~var i (3d (conjoin number? exact? rational? positive?))) -PosRat] - [(~var i (3d (conjoin number? exact? rational? negative?))) -NegRat] - [(~var i (3d (lambda (x) (eqv? x 0.0)))) -FlonumPosZero] - [(~var i (3d (lambda (x) (eqv? x -0.0)))) -FlonumNegZero] - [(~var i (3d (lambda (x) (eqv? x +nan.0)))) -FlonumNan] - [(~var i (3d(lambda (x) (eqv? x +inf.0)))) (-val +inf.0)] - [(~var i (3d (lambda (x) (eqv? x -inf.0)))) (-val -inf.0)] - [(~var i (3d (conjoin flonum? positive?))) -PosFlonum] - [(~var i (3d (conjoin flonum? negative?))) -NegFlonum] - [(~var i (3d flonum?)) -Flonum] ; for nan - [(~var i (3d (lambda (x) (eqv? x 0.0f0)))) -SingleFlonumPosZero] - [(~var i (3d (lambda (x) (eqv? x -0.0f0)))) -SingleFlonumNegZero] - [(~var i (3d (lambda (x) (eqv? x +nan.f)))) -SingleFlonumNan] - [(~var i (3d(lambda (x) (eqv? x +inf.f)))) (-val +inf.f)] - [(~var i (3d (lambda (x) (eqv? x -inf.f)))) (-val -inf.f)] - [(~var i (3d (conjoin single-flonum? positive?))) -PosSingleFlonum] - [(~var i (3d (conjoin single-flonum? negative?))) -NegSingleFlonum] - [(~var i (3d single-flonum?)) -SingleFlonum] ; for nan - [(~var i (3d inexact-real?)) -InexactReal] ; catch-all, just in case - [(~var i (3d real?)) -Real] ; catch-all, just in case - ;; a complex number can't have a float imaginary part and an exact real part - [(~var i (3d (conjoin number? exact?))) - -ExactNumber] - [(~var i (3d (conjoin number? (lambda (x) (and (flonum? (imag-part x)) - (flonum? (real-part x))))))) - -FloatComplex] - [(~var i (3d (conjoin number? (lambda (x) (and (single-flonum? (imag-part x)) - (single-flonum? (real-part x))))))) - -SingleFlonumComplex] - ;; can't have real and imaginary parts that are both inexact, but not the same precision - [(~var i (3d number?)) -Number] ; otherwise, Number - - [i:str -String] - [i:char -Char] - [i:keyword (-val (syntax-e #'i))] - [i:bytes -Bytes] - [i:byte-pregexp -Byte-PRegexp] - [i:byte-regexp -Byte-Regexp] - [i:pregexp -PRegexp] - [i:regexp -Regexp] - [(~and i ()) (-val '())] - [(i . r) - (match (and expected (restrict expected (-pair Univ Univ) 'orig)) - [(Pair: a-ty d-ty) - (-pair - (tc-literal #'i a-ty) - (tc-literal #'r d-ty))] - [t - (-pair (tc-literal #'i) (tc-literal #'r))])] - [(~var i (3d vector?)) - (match (and expected (restrict expected (-vec Univ) 'orig)) - [(Vector: t) - (make-Vector (apply Un - t ;; so that this isn't (Un) when we get no elems - (for/list ([l (in-vector (syntax-e #'i))]) - (tc-literal l t))))] - [(HeterogeneousVector: ts) - (make-HeterogeneousVector - (for/list ([l (in-vector (syntax-e #'i))] - [t (in-list ts)]) - check-below (tc-literal l t) t))] - [_ (make-HeterogeneousVector (for/list ([l (syntax-e #'i)]) - (generalize (tc-literal l #f))))])] - [(~var i (3d hash?)) - (match expected - [(Hashtable: k v) - (let* ([h (syntax-e #'i)] - [ks (hash-map h (lambda (x y) (tc-literal x k)))] - [vs (hash-map h (lambda (x y) (tc-literal y v)))]) - (check-below (apply Un ks) k) - (check-below (apply Un vs) v) - expected)] - [_ (let* ([h (syntax-e #'i)] - [ks (hash-map h (lambda (x y) (tc-literal x)))] - [vs (hash-map h (lambda (x y) (tc-literal y)))]) - (make-Hashtable (generalize (apply Un ks)) (generalize (apply Un vs))))])] - [_ Univ])) - - ;; do-inst : syntax type -> type (define (do-inst stx ty) (define inst (syntax-property stx 'type-inst)) diff --git a/collects/typed-racket/typecheck/tc-literal.rkt b/collects/typed-racket/typecheck/tc-literal.rkt new file mode 100644 index 0000000000..f190778bb9 --- /dev/null +++ b/collects/typed-racket/typecheck/tc-literal.rkt @@ -0,0 +1,117 @@ +#lang racket/unit + +(require "../utils/utils.rkt" + racket/match + (typecheck signatures check-below) + (types abbrev numeric-tower utils subtype union generalize) + (rep type-rep) + (only-in (infer infer) restrict) + (utils tc-utils stxclass-util) + syntax/parse + unstable/function) + +(import) +(export tc-literal^) + +;; return the type of a literal value +;; tc-literal: racket-value-syntax [type] -> type +(define (tc-literal v-stx [expected #f]) + (define-syntax-class exp + (pattern (~and i (~or :number :str :bytes)) + #:fail-unless expected #f + #:fail-unless (subtype (-val (syntax-e #'i)) expected) #f)) + (syntax-parse v-stx + [i:exp expected] + [i:boolean (-val (syntax-e #'i))] + [i:identifier (-val (syntax-e #'i))] + ;; Numbers + [0 -Zero] + [1 -One] + [(~var i (3d (conjoin byte? positive?))) -PosByte] + [(~var i (3d byte?)) -Byte] + [(~var i (3d (conjoin portable-index? positive?))) -PosIndex] + [(~var i (3d (conjoin portable-fixnum? positive?))) -PosFixnum] + [(~var i (3d (conjoin portable-fixnum? negative?))) -NegFixnum] + [(~var i (3d exact-positive-integer?)) -PosInt] + [(~var i (3d (conjoin exact-integer? negative?))) -NegInt] + [(~var i (3d (conjoin number? exact? rational? positive?))) -PosRat] + [(~var i (3d (conjoin number? exact? rational? negative?))) -NegRat] + [(~var i (3d (lambda (x) (eqv? x 0.0)))) -FlonumPosZero] + [(~var i (3d (lambda (x) (eqv? x -0.0)))) -FlonumNegZero] + [(~var i (3d (lambda (x) (eqv? x +nan.0)))) -FlonumNan] + [(~var i (3d(lambda (x) (eqv? x +inf.0)))) (-val +inf.0)] + [(~var i (3d (lambda (x) (eqv? x -inf.0)))) (-val -inf.0)] + [(~var i (3d (conjoin flonum? positive?))) -PosFlonum] + [(~var i (3d (conjoin flonum? negative?))) -NegFlonum] + [(~var i (3d flonum?)) -Flonum] ; for nan + [(~var i (3d (lambda (x) (eqv? x 0.0f0)))) -SingleFlonumPosZero] + [(~var i (3d (lambda (x) (eqv? x -0.0f0)))) -SingleFlonumNegZero] + [(~var i (3d (lambda (x) (eqv? x +nan.f)))) -SingleFlonumNan] + [(~var i (3d(lambda (x) (eqv? x +inf.f)))) (-val +inf.f)] + [(~var i (3d (lambda (x) (eqv? x -inf.f)))) (-val -inf.f)] + [(~var i (3d (conjoin single-flonum? positive?))) -PosSingleFlonum] + [(~var i (3d (conjoin single-flonum? negative?))) -NegSingleFlonum] + [(~var i (3d single-flonum?)) -SingleFlonum] ; for nan + [(~var i (3d inexact-real?)) -InexactReal] ; catch-all, just in case + [(~var i (3d real?)) -Real] ; catch-all, just in case + ;; a complex number can't have a float imaginary part and an exact real part + [(~var i (3d (conjoin number? exact?))) + -ExactNumber] + [(~var i (3d (conjoin number? (lambda (x) (and (flonum? (imag-part x)) + (flonum? (real-part x))))))) + -FloatComplex] + [(~var i (3d (conjoin number? (lambda (x) (and (single-flonum? (imag-part x)) + (single-flonum? (real-part x))))))) + -SingleFlonumComplex] + ;; can't have real and imaginary parts that are both inexact, but not the same precision + [(~var i (3d number?)) -Number] ; otherwise, Number + + [i:str -String] + [i:char -Char] + [i:keyword (-val (syntax-e #'i))] + [i:bytes -Bytes] + [i:byte-pregexp -Byte-PRegexp] + [i:byte-regexp -Byte-Regexp] + [i:pregexp -PRegexp] + [i:regexp -Regexp] + [(~and i ()) (-val '())] + [(i . r) + (match (and expected (restrict expected (-pair Univ Univ) 'orig)) + [(Pair: a-ty d-ty) + (-pair + (tc-literal #'i a-ty) + (tc-literal #'r d-ty))] + [t + (-pair (tc-literal #'i) (tc-literal #'r))])] + [(~var i (3d vector?)) + (match (and expected (restrict expected (-vec Univ) 'orig)) + [(Vector: t) + (make-Vector (apply Un + t ;; so that this isn't (Un) when we get no elems + (for/list ([l (in-vector (syntax-e #'i))]) + (tc-literal l t))))] + [(HeterogeneousVector: ts) + (make-HeterogeneousVector + (for/list ([l (in-vector (syntax-e #'i))] + [t (in-list ts)]) + check-below (tc-literal l t) t))] + [_ (make-HeterogeneousVector (for/list ([l (syntax-e #'i)]) + (generalize (tc-literal l #f))))])] + [(~var i (3d hash?)) + (match expected + [(Hashtable: k v) + (let* ([h (syntax-e #'i)] + [ks (hash-map h (lambda (x y) (tc-literal x k)))] + [vs (hash-map h (lambda (x y) (tc-literal y v)))]) + (check-below (apply Un ks) k) + (check-below (apply Un vs) v) + expected)] + [_ (let* ([h (syntax-e #'i)] + [ks (hash-map h (lambda (x y) (tc-literal x)))] + [vs (hash-map h (lambda (x y) (tc-literal y)))]) + (make-Hashtable (generalize (apply Un ks)) (generalize (apply Un vs))))])] + [_ Univ])) + + + + diff --git a/collects/typed-racket/typecheck/typechecker.rkt b/collects/typed-racket/typecheck/typechecker.rkt index 35be0b78ab..c2c7078ea4 100644 --- a/collects/typed-racket/typecheck/typechecker.rkt +++ b/collects/typed-racket/typecheck/typechecker.rkt @@ -9,10 +9,11 @@ "tc-app-combined.rkt" "tc-if.rkt" "tc-lambda-unit.rkt" "tc-let-unit.rkt" "tc-apply.rkt" + "tc-literal.rkt" "tc-expr-unit.rkt" "check-subforms-unit.rkt") -(provide-signature-elements tc-expr^ check-subforms^) +(provide-signature-elements tc-expr^ check-subforms^ tc-literal^) (define-values/invoke-unit/infer (link tc-if@ tc-lambda@ tc-app-combined@ tc-let@ tc-expr@ - check-subforms@ tc-apply@)) + check-subforms@ tc-apply@ tc-literal@))