From c0227807daebe7c93239d583345e3156f38bc10f Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 12 Sep 2011 16:41:53 -0400 Subject: [PATCH] Add a field to base types to indicate if they are numeric types or not. original commit: 40456b4fd8119c1308cfd59effe9bf0afda65ad8 --- .../typed-racket/unit-tests/subtype-tests.rkt | 4 ++-- .../unit-tests/type-equal-tests.rkt | 2 +- collects/typed-racket/env/init-envs.rkt | 2 +- collects/typed-racket/infer/infer-unit.rkt | 6 +++--- .../typed-racket/private/type-contract.rkt | 4 ++-- collects/typed-racket/rep/type-rep.rkt | 18 ++++++++++-------- collects/typed-racket/types/abbrev.rkt | 8 ++++++-- collects/typed-racket/types/numeric-tower.rkt | 6 +++++- collects/typed-racket/types/printer.rkt | 10 +++++----- .../typed-racket/types/remove-intersect.rkt | 10 +++++----- collects/typed-racket/types/subtype.rkt | 16 ++++++++-------- 11 files changed, 48 insertions(+), 38 deletions(-) diff --git a/collects/tests/typed-racket/unit-tests/subtype-tests.rkt b/collects/tests/typed-racket/unit-tests/subtype-tests.rkt index 25494544..2b27f43a 100644 --- a/collects/tests/typed-racket/unit-tests/subtype-tests.rkt +++ b/collects/tests/typed-racket/unit-tests/subtype-tests.rkt @@ -112,12 +112,12 @@ [(-values (list -Number)) (-values (list Univ))] - [(-poly (b) ((Un (make-Base 'foo #'dummy values #'values) + [(-poly (b) ((Un (make-Base 'foo #'dummy values #'values #f) (-struct #'bar #f (list (make-fld -Number #'values #f) (make-fld b #'values #f)) #'values)) . -> . (-lst b))) - ((Un (make-Base 'foo #'dummy values #'values) (-struct #'bar #f (list (make-fld -Number #'values #f) (make-fld (-pair -Number (-v a)) #'values #f)) #'values)) + ((Un (make-Base 'foo #'dummy values #'values #f) (-struct #'bar #f (list (make-fld -Number #'values #f) (make-fld (-pair -Number (-v a)) #'values #f)) #'values)) . -> . (-lst (-pair -Number (-v a))))] [(-poly (b) ((-struct #'bar #f (list (make-fld -Number #'values #f) (make-fld b #'values #f)) #'values) . -> . (-lst b))) ((-struct #'bar #f (list (make-fld -Number #'values #f) (make-fld (-pair -Number (-v a)) #'values #f)) #'values) . -> . (-lst (-pair -Number (-v a))))] diff --git a/collects/tests/typed-racket/unit-tests/type-equal-tests.rkt b/collects/tests/typed-racket/unit-tests/type-equal-tests.rkt index c29bd204..969e3983 100644 --- a/collects/tests/typed-racket/unit-tests/type-equal-tests.rkt +++ b/collects/tests/typed-racket/unit-tests/type-equal-tests.rkt @@ -7,7 +7,7 @@ (provide type-equal-tests) -(define (-base x) (make-Base x #'dummy values #'values)) +(define (-base x) (make-Base x #'dummy values #'values #f)) (define-syntax (te-tests stx) diff --git a/collects/typed-racket/env/init-envs.rkt b/collects/typed-racket/env/init-envs.rkt index 0ccbb511..30e5406a 100644 --- a/collects/typed-racket/env/init-envs.rkt +++ b/collects/typed-racket/env/init-envs.rkt @@ -22,7 +22,7 @@ (string->symbol (string-append "make-" (substring (symbol->string sym) 7)))) (match v [(Union: elems) `(make-Union (sort (list ,@(map sub elems)) < #:key Type-seq))] - [(Base: n cnt pred marshaled) marshaled] + [(Base: n cnt pred marshaled _) marshaled] [(Name: stx) `(make-Name (quote-syntax ,stx))] [(fld: t acc mut) `(make-fld ,(sub t) (quote-syntax ,acc) ,mut)] [(Struct: name parent flds proc poly? pred-id cert maker-id) diff --git a/collects/typed-racket/infer/infer-unit.rkt b/collects/typed-racket/infer/infer-unit.rkt index b469536e..6ef67fbe 100644 --- a/collects/typed-racket/infer/infer-unit.rkt +++ b/collects/typed-racket/infer/infer-unit.rkt @@ -411,11 +411,11 @@ (cg t t*)))] [((Vector: t) (Sequence: (list t*))) (cg t t*)] - [((Base: 'String _ _ _) (Sequence: (list t*))) + [((Base: 'String _ _ _ _) (Sequence: (list t*))) (cg -Char t*)] - [((Base: 'Bytes _ _ _) (Sequence: (list t*))) + [((Base: 'Bytes _ _ _ _) (Sequence: (list t*))) (cg -Nat t*)] - [((Base: 'Input-Port _ _ _) (Sequence: (list t*))) + [((Base: 'Input-Port _ _ _ _) (Sequence: (list t*))) (cg -Nat t*)] [((Vector: t) (Sequence: (list t*))) (cg t t*)] diff --git a/collects/typed-racket/private/type-contract.rkt b/collects/typed-racket/private/type-contract.rkt index 7797514b..5336e972 100644 --- a/collects/typed-racket/private/type-contract.rkt +++ b/collects/typed-racket/private/type-contract.rkt @@ -175,7 +175,7 @@ (inexact-real? (real-part x))))))] [(== t:-Number type-equal?) #'(flat-named-contract 'Number number?)] - [(Base: sym cnt _ _) #`(flat-named-contract '#,sym (flat-contract-predicate #,cnt))] + [(Base: sym cnt _ _ _) #`(flat-named-contract '#,sym (flat-contract-predicate #,cnt))] [(Refinement: par p? cert) #`(and/c #,(t->c par) (flat-contract #,(cert p?)))] [(Union: elems) @@ -278,7 +278,7 @@ (maker fld-cnts ...))))]) rec))))] [else #`(flat-named-contract '#,(syntax-e pred?) #,(cert pred?))])] - [(Syntax: (Base: 'Symbol _ _ _)) #'identifier?] + [(Syntax: (Base: 'Symbol _ _ _ _)) #'identifier?] [(Syntax: t) #`(syntax/c #,(t->c t))] [(Value: v) #`(flat-named-contract #,(format "~a" v) (lambda (x) (equal? x '#,v)))] [(Param: in out) #`(parameter/c #,(t->c out))] diff --git a/collects/typed-racket/rep/type-rep.rkt b/collects/typed-racket/rep/type-rep.rkt index ba4a51da..5ad74889 100644 --- a/collects/typed-racket/rep/type-rep.rkt +++ b/collects/typed-racket/rep/type-rep.rkt @@ -161,15 +161,17 @@ ;; marshaled has to be a syntax object that refers to the base type ;; being created. this allows us to avoid reconstructing the base type ;; when using it from its marshaled representation -(def-type Base ([name symbol?] [contract syntax?] [predicate procedure?] [marshaled syntax?]) +(def-type Base ([name symbol?] [contract syntax?] [predicate procedure?] [marshaled syntax?] [numeric? boolean?]) [#:frees #f] [#:fold-rhs #:base] [#:intern name] - [#:key (case name - [(Number Integer) 'number] - [(Boolean) 'boolean] - [(String) 'string] - [(Symbol) 'symbol] - [(Keyword) 'keyword] - [else #f])]) + [#:key (if numeric? + 'number + (case name + [(Number Integer) 'number] + [(Boolean) 'boolean] + [(String) 'string] + [(Symbol) 'symbol] + [(Keyword) 'keyword] + [else #f]))]) ;; body is a Scope (def-type Mu ([body (scope-depth 1)]) #:no-provide [#:frees (λ (f) (f body))] diff --git a/collects/typed-racket/types/abbrev.rkt b/collects/typed-racket/types/abbrev.rkt index a8bccb77..7ecd8dbd 100644 --- a/collects/typed-racket/types/abbrev.rkt +++ b/collects/typed-racket/types/abbrev.rkt @@ -2,7 +2,7 @@ (require "../utils/utils.rkt") -(require (rep type-rep object-rep filter-rep rep-utils) +(require (rename-in (rep type-rep object-rep filter-rep rep-utils) [make-Base make-Base*]) "resolve.rkt" (utils tc-utils) racket/list @@ -20,10 +20,14 @@ ;; for base type predicates racket/promise racket/tcp racket/flonum) -(provide (except-out (all-defined-out) Promise) +(provide (except-out (all-defined-out) Promise make-Base) (rename-out [make-Listof -lst] [make-MListof -mlst])) +;; all the types defined here are not numeric +(define (make-Base name contract predicate marshaled) + (make-Base* name contract predicate marshaled #f)) + ;; convenient constructors diff --git a/collects/typed-racket/types/numeric-tower.rkt b/collects/typed-racket/types/numeric-tower.rkt index c7fb5497..651aa6ac 100644 --- a/collects/typed-racket/types/numeric-tower.rkt +++ b/collects/typed-racket/types/numeric-tower.rkt @@ -3,7 +3,7 @@ (require "../utils/utils.rkt") (require (types abbrev numeric-predicates) - (rep type-rep) + (rename-in (rep type-rep) [make-Base make-Base*]) racket/function unstable/function (for-template racket/base racket/contract racket/flonum (types numeric-predicates))) @@ -20,6 +20,10 @@ -ExactNumber -FloatComplex -SingleFlonumComplex -InexactComplex -Number (rename-out (-Int -Integer))) +;; all the types defined here are numeric +(define (make-Base name contract predicate marshaled) + (make-Base* name contract predicate marshaled #t)) + ;; Numeric hierarchy ;; All built as unions of non-overlapping base types. diff --git a/collects/typed-racket/types/printer.rkt b/collects/typed-racket/types/printer.rkt index 0f2bd311..b9e08939 100644 --- a/collects/typed-racket/types/printer.rkt +++ b/collects/typed-racket/types/printer.rkt @@ -218,7 +218,7 @@ [else (fp "~a" v)])] [(? tuple? t) (fp "~a" (cons 'List (tuple-elems t)))] - [(Base: n cnt _ _) (fp "~s" n)] + [(Base: n cnt _ _ _) (fp "~s" n)] [(Opaque: pred _) (fp "(Opaque ~a)" (syntax->datum pred))] [(Struct: (? (lambda (nm) (free-identifier=? promise-id nm))) #f (list (fld: t _ _)) _ _ _ _ _) @@ -269,10 +269,10 @@ #; [(Mu-unsafe: b) (fp "(unsafe-mu ~a ~a)" (Type-seq c) b)] [(Mu: x (Syntax: (Union: (list - (Base: 'Number _ _ _) - (Base: 'Boolean _ _ _) - (Base: 'Symbol _ _ _) - (Base: 'String _ _ _) + (Base: 'Number _ _ _ _) + (Base: 'Boolean _ _ _ _) + (Base: 'Symbol _ _ _ _) + (Base: 'String _ _ _ _) (Mu: var (Union: (list (Value: '()) (Pair: (F: x) (F: var))))) (Mu: y (Union: (list (F: x) diff --git a/collects/typed-racket/types/remove-intersect.rkt b/collects/typed-racket/types/remove-intersect.rkt index a0564e5f..3cecfda9 100644 --- a/collects/typed-racket/types/remove-intersect.rkt +++ b/collects/typed-racket/types/remove-intersect.rkt @@ -42,16 +42,16 @@ (ormap (lambda (t*) (overlap t t*)) e)] [(or (list _ (? Poly?)) (list (? Poly?) _)) #t] ;; these can have overlap, conservatively - [(list (Base: s1 _ _ _) (Base: s2 _ _ _)) (or (subtype t1 t2) (subtype t2 t1))] - [(list (Base: _ _ _ _) (Value: _)) (subtype t2 t1)] ;; conservative - [(list (Value: _) (Base: _ _ _ _)) (subtype t1 t2)] ;; conservative + [(list (Base: s1 _ _ _ _) (Base: s2 _ _ _ _)) (or (subtype t1 t2) (subtype t2 t1))] + [(list (Base: _ _ _ _ _) (Value: _)) (subtype t2 t1)] ;; conservative + [(list (Value: _) (Base: _ _ _ _ _)) (subtype t1 t2)] ;; conservative [(list (Syntax: t) (Syntax: t*)) (overlap t t*)] [(or (list (Syntax: _) _) (list _ (Syntax: _))) #f] - [(list (Base: _ _ _ _) _) #f] - [(list _ (Base: _ _ _ _)) #f] + [(list (Base: _ _ _ _ _) _) #f] + [(list _ (Base: _ _ _ _ _)) #f] [(list (Value: (? pair? v)) (Pair: _ _)) #t] [(list (Pair: _ _) (Value: (? pair? v))) #t] [(list (Pair: a b) (Pair: a* b*)) diff --git a/collects/typed-racket/types/subtype.rkt b/collects/typed-racket/types/subtype.rkt index 4e0c6466..c6195c63 100644 --- a/collects/typed-racket/types/subtype.rkt +++ b/collects/typed-racket/types/subtype.rkt @@ -261,7 +261,7 @@ ;; value types [((Value: v1) (Value: v2)) (=> unmatch) (if (equal? v1 v2) A0 (unmatch))] ;; values are subtypes of their "type" - [((Value: v) (Base: _ _ pred _)) (if (pred v) A0 (fail! s t))] + [((Value: v) (Base: _ _ pred _ _)) (if (pred v) A0 (fail! s t))] ;; tvars are equal if they are the same variable [((F: t) (F: t*)) (if (eq? t t*) A0 (fail! s t))] ;; Avoid needing to resolve things that refer to different structs. @@ -274,9 +274,9 @@ (fail! s t)] [else (unmatch)])] ;; similar case for structs and base types, which are obviously unrelated - [((Base: _ _ _ _) (or (? Struct? s1) (NameStruct: s1))) + [((Base: _ _ _ _ _) (or (? Struct? s1) (NameStruct: s1))) (fail! s t)] - [((or (? Struct? s1) (NameStruct: s1)) (Base: _ _ _ _)) + [((or (? Struct? s1) (NameStruct: s1)) (Base: _ _ _ _ _)) (fail! s t)] ;; same for all values. [((Value: (? (negate struct?) _)) (or (? Struct? s1) (NameStruct: s1))) @@ -284,8 +284,8 @@ [((or (? Struct? s1) (NameStruct: s1)) (Value: (? (negate struct?) _))) (fail! s t)] ;; just checking if s/t is a struct misses recursive/union/etc cases - [((? (lambda (_) (eq? ks 'struct))) (Base: _ _ _ _)) (fail! s t)] - [((Base: _ _ _ _) (? (lambda (_) (eq? kt 'struct)))) (fail! s t)] + [((? (lambda (_) (eq? ks 'struct))) (Base: _ _ _ _ _)) (fail! s t)] + [((Base: _ _ _ _ _) (? (lambda (_) (eq? kt 'struct)))) (fail! s t)] ;; sequences are covariant [((Sequence: ts) (Sequence: ts*)) (subtypes* A0 ts ts*)] @@ -297,11 +297,11 @@ (subtypes* A0 ts (map (λ _ t*) ts))] [((Vector: t) (Sequence: (list t*))) (subtype* A0 t t*)] - [((Base: 'String _ _ _) (Sequence: (list t*))) + [((Base: 'String _ _ _ _) (Sequence: (list t*))) (subtype* A0 -Char t*)] - [((Base: 'Bytes _ _ _) (Sequence: (list t*))) + [((Base: 'Bytes _ _ _ _) (Sequence: (list t*))) (subtype* A0 -Byte t*)] - [((Base: 'Input-Port _ _ _) (Sequence: (list t*))) + [((Base: 'Input-Port _ _ _ _) (Sequence: (list t*))) (subtype* A0 -Nat t*)] [((Hashtable: k v) (Sequence: (list k* v*))) (subtypes* A0 (list k v) (list k* v*))]