suzanne.soy/typed-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Remove 'marshalled' field from Base type representation.

Browse Source 
Now obsoleted by `predefined-type-table`.

original commit: d4963473adecf771a16f49120f00fd9296acc6ff
This commit is contained in:
Sam Tobin-Hochstadt 2013-09-06 18:35:03 -04:00
parent a620d8c188
commit 053ba8c20a
10 changed files with 249 additions and 255 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/init-envs.rkt vendored
View File

@ -50,7 +50,7 @@
(match v
[(? Rep? (app (lambda (v) (hash-ref predefined-type-table (Rep-seq v) #f)) (? values id))) id]
[(Union: elems) `(make-Union (sort (list ,@(map sub elems)) < #:key Type-seq))]
[(Base: n cnt pred marshaled _) marshaled]
[(Base: n cnt pred _) (int-err "Base type not in predefined-type-table" n)]
[(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)

24
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/infer-unit.rkt
View File

@ -497,11 +497,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*)]
[((Value: (? exact-nonnegative-integer? n)) (Sequence: (list t*)))
(define possibilities
@ -516,7 +516,7 @@
((list pred? type)
(and (pred? n) type)))))
(cg type t*)]
[((Base: _ _ _ _ #t) (Sequence: (list t*)))
[((Base: _ _ _ #t) (Sequence: (list t*)))
(define type
(for/or ([t (in-list (list -Byte -Index -NonNegFixnum -Nat))])
(and (subtype S t) t)))
@ -609,21 +609,21 @@
(cg a a*)]
[((Evt: a) (Evt: a*))
(cg a a*)]
[((Base: 'Semaphore _ _ _ _) (Evt: t))
[((Base: 'Semaphore _ _ _) (Evt: t))
(cg S t)]
[((Base: 'Output-Port _ _ _ _) (Evt: t))
[((Base: 'Output-Port _ _ _) (Evt: t))
(cg S t)]
[((Base: 'Input-Port _ _ _ _) (Evt: t))
[((Base: 'Input-Port _ _ _) (Evt: t))
(cg S t)]
[((Base: 'TCP-Listener _ _ _ _) (Evt: t))
[((Base: 'TCP-Listener _ _ _) (Evt: t))
(cg S t)]
[((Base: 'Thread _ _ _ _) (Evt: t))
[((Base: 'Thread _ _ _) (Evt: t))
(cg S t)]
[((Base: 'Subprocess _ _ _ _) (Evt: t))
[((Base: 'Subprocess _ _ _) (Evt: t))
(cg S t)]
[((Base: 'Will-Executor _ _ _ _) (Evt: t))
[((Base: 'Will-Executor _ _ _) (Evt: t))
(cg S t)]
[((Base: 'LogReceiver _ _ _ _) (Evt: t ))
[((Base: 'LogReceiver _ _ _) (Evt: t ))
(cg (make-HeterogeneousVector
(list -Symbol -String Univ
(Un (-val #f) -Symbol)))

4
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt
View File

@ -336,7 +336,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?)
#`(and/c #,(t->c par) (flat-contract #,p?))]
[(Union: elems)
@ -450,7 +450,7 @@
#,fld-ctc))))))
#`(letrec ((struct-ctc (struct/c #,nm #,@field-contracts))) struct-ctc))]
[else #`(flat-named-contract '#,(syntax-e pred?) #,pred?)])]
[(Syntax: (Base: 'Symbol _ _ _ _)) #'identifier?]
[(Syntax: (Base: 'Symbol _ _ _)) #'identifier?]
[(Syntax: t)
#`(syntax/c #,(t->c t #:kind flat-sym))]
[(Value: v) #`(flat-named-contract '#,v (lambda (x) (equal? x '#,v)))]

8
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/rep/type-rep.rkt
View File

@ -182,7 +182,7 @@
(def-type Set ([elem Type/c])
[#:key 'set])
;; elem is a Type
;; result is a Type
(def-type Evt ([result Type/c])
[#:key #f])
@ -191,10 +191,8 @@
;; predicate is used to check (at compile-time) whether a value belongs
;; to that base type. This is used to check for subtyping between value
;; types and base types.
;; 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?] [numeric? boolean?])
;; numeric determines if the type is a numeric type
(def-type Base ([name symbol?] [contract syntax?] [predicate procedure?] [numeric? boolean?])
[#:frees #f] [#:fold-rhs #:base] [#:intern name]
[#:key (if numeric?
'number

183
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt
View File

@ -26,8 +26,8 @@
(all-from-out "base-abbrev.rkt" "match-expanders.rkt"))
;; all the types defined here are not numeric
(define (make-Base name contract predicate marshaled)
(make-Base* name contract predicate marshaled #f))
(define (make-Base name contract predicate)
(make-Base* name contract predicate #f))
;; convenient constructors
@ -84,29 +84,27 @@
(define -Listof (-poly (list-elem) (make-Listof list-elem)))
(define/decl -Boolean (Un (-val #t) (-val #f)))
(define -Undefined
(define/decl -Undefined
(make-Base 'Undefined
#'(lambda (x) (equal? (letrec ([y y]) y) x)) ; initial value of letrec bindings
(lambda (x) (equal? (letrec ([y y]) y) x))
#'-Undefined))
(define -Bytes (make-Base 'Bytes #'bytes? bytes? #'-Bytes))
(lambda (x) (equal? (letrec ([y y]) y) x))))
(define/decl -Bytes (make-Base 'Bytes #'bytes? bytes?))
(define -Base-Regexp (make-Base 'Base-Regexp
(define/decl -Base-Regexp (make-Base 'Base-Regexp
#'(and/c regexp? (not/c pregexp?))
(conjoin regexp? (negate pregexp?))
#'-Regexp))
(define -PRegexp (make-Base 'PRegexp
#'pregexp?
pregexp?
#'-PRegexp))
(define -Regexp (Un -PRegexp -Base-Regexp))
(conjoin regexp? (negate pregexp?))))
(define/decl -PRegexp (make-Base 'PRegexp
#'pregexp?
pregexp?))
(define/decl -Regexp (Un -PRegexp -Base-Regexp))
(define -Byte-Base-Regexp (make-Base 'Byte-Base-Regexp
#'(and/c byte-regexp? (not/c byte-pregexp?))
(conjoin byte-regexp? (negate byte-pregexp?))
#'-Byte-Base-Regexp))
(define -Byte-PRegexp (make-Base 'Byte-PRegexp #'byte-pregexp? byte-pregexp? #'-Byte-PRegexp))
(define -Byte-Regexp (Un -Byte-Base-Regexp -Byte-PRegexp))
(define/decl -Byte-Base-Regexp
(make-Base 'Byte-Base-Regexp
#'(and/c byte-regexp? (not/c byte-pregexp?))
(conjoin byte-regexp? (negate byte-pregexp?))))
(define/decl -Byte-PRegexp
(make-Base 'Byte-PRegexp #'byte-pregexp? byte-pregexp?))
(define/decl -Byte-Regexp (Un -Byte-Base-Regexp -Byte-PRegexp))
(define/decl -Pattern (Un -Bytes -Regexp -Byte-Regexp -String))
@ -117,41 +115,47 @@
(define -Keyword (make-Base 'Keyword #'keyword? keyword? #'-Keyword))
(define -Thread (make-Base 'Thread #'thread? thread? #'-Thread))
(define/decl -Module-Path (Un -Symbol -String
(-lst* (-val 'quote) -Symbol)
(-lst* (-val 'lib) -String)
(-lst* (-val 'file) -String)
(-pair (-val 'planet)
(Un (-lst* -Symbol)
(-lst* -String)
(-lst* -String (-lst* -String -String #:tail (make-Listof (Un -Nat (-lst* (Un -Nat (one-of/c '= '+ '-)) -Nat)))))))))
(define -Resolved-Module-Path (make-Base 'Resolved-Module-Path #'resolved-module-path? resolved-module-path? #'-Resolved-Module-Path))
(define -Module-Path-Index (make-Base 'Module-Path-Index #'module-path-index? module-path-index? #'-Module-Path-Index))
(define -Compiled-Module-Expression (make-Base 'Compiled-Module-Expression #'compiled-module-expression? compiled-module-expression? #'-Compiled-Module-Expression))
(define -Compiled-Non-Module-Expression
(define/decl -Keyword (make-Base 'Keyword #'keyword? keyword?))
(define/decl -Thread (make-Base 'Thread #'thread? thread?))
(define/decl -Module-Path
(Un -Symbol -String
(-lst* (-val 'quote) -Symbol)
(-lst* (-val 'lib) -String)
(-lst* (-val 'file) -String)
(-pair (-val 'planet)
(Un (-lst* -Symbol)
(-lst* -String)
(-lst* -String
(-lst*
-String -String
#:tail (make-Listof
(Un -Nat
(-lst* (Un -Nat (one-of/c '= '+ '-))
-Nat)))))))))
(define/decl -Resolved-Module-Path (make-Base 'Resolved-Module-Path #'resolved-module-path? resolved-module-path?))
(define/decl -Module-Path-Index (make-Base 'Module-Path-Index #'module-path-index? module-path-index?))
(define/decl -Compiled-Module-Expression (make-Base 'Compiled-Module-Expression #'compiled-module-expression? compiled-module-expression?))
(define/decl -Compiled-Non-Module-Expression
(make-Base 'Compiled-Non-Module-Expression
#'(and/c compiled-expression? (not/c compiled-module-expression?))
(conjoin compiled-expression? (negate compiled-module-expression?))
#'-Compiled-Non-Module-Expression))
(conjoin compiled-expression? (negate compiled-module-expression?))))
(define/decl -Compiled-Expression (Un -Compiled-Module-Expression -Compiled-Non-Module-Expression))
(define -Cont-Mark-Set (make-Base 'Continuation-Mark-Set #'continuation-mark-set? continuation-mark-set? #'-Cont-Mark-Set))
(define -Path (make-Base 'Path #'path? path? #'-Path))
(define -OtherSystemPath (make-Base 'OtherSystemPath
#'(and/c path-for-some-system? (not/c path?))
(conjoin path-for-some-system? (negate path?))
#'-OtherSystemPath))
(define -Namespace (make-Base 'Namespace #'namespace? namespace? #'-Namespace))
(define -Output-Port (make-Base 'Output-Port #'output-port? output-port? #'-Output-Port))
(define -Input-Port (make-Base 'Input-Port #'input-port? input-port? #'-Input-Port))
(define -TCP-Listener (make-Base 'TCP-Listener #'tcp-listener? tcp-listener? #'-TCP-Listener))
(define -UDP-Socket (make-Base 'UDP-Socket #'udp? udp? #'-UDP-Socket))
(define/decl -Cont-Mark-Set (make-Base 'Continuation-Mark-Set #'continuation-mark-set? continuation-mark-set?))
(define/decl -Path (make-Base 'Path #'path? path?))
(define/decl -OtherSystemPath
(make-Base 'OtherSystemPath
#'(and/c path-for-some-system? (not/c path?))
(conjoin path-for-some-system? (negate path?))))
(define/decl -Namespace (make-Base 'Namespace #'namespace? namespace?))
(define/decl -Output-Port (make-Base 'Output-Port #'output-port? output-port?))
(define/decl -Input-Port (make-Base 'Input-Port #'input-port? input-port?))
(define/decl -TCP-Listener (make-Base 'TCP-Listener #'tcp-listener? tcp-listener?))
(define/decl -UDP-Socket (make-Base 'UDP-Socket #'udp? udp?))
(define -FlVector (make-Base 'FlVector #'flvector? flvector? #'-FlVector))
(define/decl -FlVector (make-Base 'FlVector #'flvector? flvector?))
(define -Syntax make-Syntax)
(define In-Syntax
(define/decl In-Syntax
(-mu e
(Un (-val null) -Boolean -Symbol -String -Keyword -Char -Number
(make-Vector (-Syntax e))
@ -159,7 +163,7 @@
(make-Listof (-Syntax e))
(-pair (-Syntax e) (-Syntax e)))))
(define Any-Syntax (-Syntax In-Syntax))
(define/decl Any-Syntax (-Syntax In-Syntax))
(define (-Sexpof t)
(-mu sexp
@ -181,8 +185,8 @@
(define -HT make-Hashtable)
(define -HashTop (make-HashtableTop))
(define -VectorTop (make-VectorTop))
(define/decl -HashTop (make-HashtableTop))
(define/decl -VectorTop (make-VectorTop))
(define/decl -Port (Un -Output-Port -Input-Port))
@ -191,71 +195,72 @@
(define/decl -Pathlike (Un -String -Path))
(define/decl -SomeSystemPathlike (Un -String -SomeSystemPath))
(define/decl -Pathlike* (Un -String -Path (-val 'up) (-val 'same)))
(define/decl -SomeSystemPathlike* (Un -String -SomeSystemPath(-val 'up) (-val 'same)))
(define/decl -SomeSystemPathlike*
(Un -String -SomeSystemPath(-val 'up) (-val 'same)))
(define/decl -PathConventionType (Un (-val 'unix) (-val 'windows)))
(define -Pretty-Print-Style-Table
(make-Base 'Pretty-Print-Style-Table #'pretty-print-style-table? pretty-print-style-table? #'-Pretty-Print-Style-Table))
(define/decl -Pretty-Print-Style-Table
(make-Base 'Pretty-Print-Style-Table #'pretty-print-style-table? pretty-print-style-table?))
(define -Read-Table (make-Base 'Read-Table #'readtable? readtable? #'-Read-Table))
(define/decl -Read-Table
(make-Base 'Read-Table #'readtable? readtable?))
(define -Special-Comment
(make-Base 'Special-Comment #'special-comment? special-comment? #'-Special-Comment))
(define/decl -Special-Comment
(make-Base 'Special-Comment #'special-comment? special-comment?))
(define -Custodian (make-Base 'Custodian #'custodian? custodian? #'-Custodian))
(define/decl -Custodian (make-Base 'Custodian #'custodian? custodian?))
(define -Parameterization (make-Base 'Parameterization #'parameterization? parameterization? #'-Parameterization))
(define/decl -Parameterization (make-Base 'Parameterization #'parameterization? parameterization?))
(define -Inspector (make-Base 'Inspector #'inspector inspector? #'-Inspector))
(define/decl -Inspector (make-Base 'Inspector #'inspector inspector?))
(define -Namespace-Anchor (make-Base 'Namespace-Anchor #'namespace-anchor? namespace-anchor? #'-Namespace-Anchor))
(define/decl -Namespace-Anchor (make-Base 'Namespace-Anchor #'namespace-anchor? namespace-anchor?))
(define -Variable-Reference (make-Base 'Variable-Reference #'variable-reference? variable-reference? #'-Variable-Reference))
(define/decl -Variable-Reference (make-Base 'Variable-Reference #'variable-reference? variable-reference?))
(define -Internal-Definition-Context (make-Base 'Internal-Definition-Context
#'internal-definition-context?
internal-definition-context?
#'-Internal-Definition-Context))
(define/decl -Internal-Definition-Context
(make-Base 'Internal-Definition-Context
#'internal-definition-context?
internal-definition-context?))
(define -Subprocess
(make-Base 'Subprocess #'subprocess? subprocess? #'-Subprocess))
(define -Security-Guard
(make-Base 'Security-Guard #'security-guard? security-guard? #'-Security-Guard))
(define -Thread-Group
(make-Base 'Thread-Group #'thread-group? thread-group? #'-Thread-Group))
(define -Struct-Type-Property
(make-Base 'Struct-Type-Property #'struct-type-property? struct-type-property? #'-Struct-Type-Property))
(define -Impersonator-Property
(make-Base 'Impersonator-Property #'impersonator-property? impersonator-property? #'-Impersonator-Property))
(define/decl -Subprocess
(make-Base 'Subprocess #'subprocess? subprocess?))
(define/decl -Security-Guard
(make-Base 'Security-Guard #'security-guard? security-guard?))
(define/decl -Thread-Group
(make-Base 'Thread-Group #'thread-group? thread-group?))
(define/decl -Struct-Type-Property
(make-Base 'Struct-Type-Property #'struct-type-property? struct-type-property?))
(define/decl -Impersonator-Property
(make-Base 'Impersonator-Property #'impersonator-property? impersonator-property?))
(define -Semaphore (make-Base 'Semaphore #'semaphore? semaphore? #'-Semaphore))
(define -Bytes-Converter (make-Base 'Bytes-Converter #'bytes-converter? bytes-converter? #'-Bytes-Converter))
(define -Pseudo-Random-Generator
(make-Base 'Pseudo-Random-Generator #'pseudo-random-generator? pseudo-random-generator? #'-Pseudo-Random-Generator))
(define/decl -Semaphore (make-Base 'Semaphore #'semaphore? semaphore?))
(define/decl -Bytes-Converter (make-Base 'Bytes-Converter #'bytes-converter? bytes-converter?))
(define/decl -Pseudo-Random-Generator
(make-Base 'Pseudo-Random-Generator #'pseudo-random-generator? pseudo-random-generator?))
(define -Logger (make-Base 'Logger #'logger? logger? #'-Logger))
(define -Log-Receiver (make-Base 'LogReceiver #'log-receiver? log-receiver? #'-Log-Receiver))
(define/decl -Logger (make-Base 'Logger #'logger? logger?))
(define/decl -Log-Receiver (make-Base 'LogReceiver #'log-receiver? log-receiver?))
(define/decl -Log-Level (one-of/c 'fatal 'error 'warning 'info 'debug))
(define -Place
(make-Base 'Place #'place? place? #'-Place))
(define -Base-Place-Channel
(make-Base 'Base-Place-Channel #'(and/c place-channel? (not/c place?)) (conjoin place-channel? (negate place?)) #'-Base-Place-Channel))
(define/decl -Place (make-Base 'Place #'place? place?))
(define/decl -Base-Place-Channel
(make-Base 'Base-Place-Channel #'(and/c place-channel? (not/c place?)) (conjoin place-channel? (negate place?))))
(define/decl -Place-Channel (Un -Place -Base-Place-Channel))
(define -Will-Executor
(make-Base 'Will-Executor #'will-executor? will-executor? #'-Will-Executor))
(define/decl -Will-Executor
(make-Base 'Will-Executor #'will-executor? will-executor?))

27
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/base-abbrev.rkt
View File

@ -13,6 +13,13 @@
(rename-out [make-Listof -lst]
[make-MListof -mlst]))
;; This table maps types (or really, the sequence number of the type)
;; to identifiers that are those types. This allows us to avoid
;; reconstructing the type when using it from its marshaled
;; representation. The table is referenced in env/init-env.rkt
;;
;; For example, instead of marshalling a big union for `Integer`, we
;; simply emit `-Integer`, which evaluates to the right type.
(define predefined-type-table (make-hasheq))
(define-syntax-rule (declare-predefined-type! id)
(hash-set! predefined-type-table (Rep-seq id) #'id))
@ -24,26 +31,26 @@
;Top and error types
(define/decl Univ (make-Univ))
(define/decl -Bottom (make-Union null))
(define Err (make-Error))
(define/decl Err (make-Error))
;A Type that corresponds to the any contract for the
;return type of functions
(define ManyUniv (make-AnyValues))
(define/decl ManyUniv (make-AnyValues))
;;Convinient constructors
(define -val make-Value)
;; Char type and List type (needed because of how sequences are checked in subtype)
(define -Char (make-Base 'Char #'char? char? #'-Char #f))
(define/decl -Char (make-Base 'Char #'char? char? #f))
(define (make-Listof elem) (-mu list-rec (simple-Un (-val null) (make-Pair elem list-rec))))
(define (make-MListof elem) (-mu list-rec (simple-Un (-val null) (make-MPair elem list-rec))))
;; Needed for evt checking in subtype.rkt
(define -Symbol (make-Base 'Symbol #'symbol? symbol? #'-Symbol #f))
(define -String (make-Base 'String #'string? string? #'-String #f))
(define/decl -Symbol (make-Base 'Symbol #'symbol? symbol? #f))
(define/decl -String (make-Base 'String #'string? string? #f))
;; Void is needed for Params
(define -Void (make-Base 'Void #'void? void? #'-Void #f))
(define/decl -Void (make-Base 'Void #'void? void? #f))
;; -lst* Type is needed by substitute for ListDots
(define -pair make-Pair)
@ -97,10 +104,10 @@
(make-Result t f o))
;;Filters
(define -top (make-Top))
(define -bot (make-Bot))
(define -no-filter (make-FilterSet -top -top))
(define -no-obj (make-Empty))
(define/decl -top (make-Top))
(define/decl -bot (make-Bot))
(define/decl -no-filter (make-FilterSet -top -top))
(define/decl -no-obj (make-Empty))
(define/cond-contract (-FS + -)

198
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/numeric-tower.rkt
View File

@ -21,8 +21,8 @@
(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))
(define (make-Base name contract predicate)
(make-Base* name contract predicate #t))
;; Numeric hierarchy
@ -54,131 +54,119 @@
(define/decl -One (make-Value 1))
;; Integers
(define -Byte>1 (make-Base 'Byte-Larger-Than-One ; unsigned
#'(and/c byte? (lambda (x) (> x 1)))
(conjoin byte? (lambda (x) (> x 1)))
#'-Byte>1))
(define/decl -Byte>1 (make-Base 'Byte-Larger-Than-One ; unsigned
#'(and/c byte? (lambda (x) (> x 1)))
(conjoin byte? (lambda (x) (> x 1)))))
(define/decl -PosByte (*Un -One -Byte>1))
(define/decl -Byte (*Un -Zero -PosByte))
(define -PosIndexNotByte
(define/decl -PosIndexNotByte
(make-Base 'Positive-Index-Not-Byte
;; index? will be checked at runtime, can be platform-specific
;; portable-index? will be checked at compile-time, must be portable
#'(and/c index? positive? (not/c byte?))
(lambda (x) (and (portable-index? x)
(positive? x)
(not (byte? x))))
#'-PosIndexNotByte))
(not (byte? x))))))
(define/decl -PosIndex (*Un -One -Byte>1 -PosIndexNotByte))
(define/decl -Index (*Un -Zero -PosIndex))
(define -PosFixnumNotIndex
(define/decl -PosFixnumNotIndex
(make-Base 'Positive-Fixnum-Not-Index
#'(and/c fixnum? positive? (not/c index?))
(lambda (x) (and (portable-fixnum? x)
(positive? x)
(not (portable-index? x))))
#'-PosFixnumNotIndex))
(not (portable-index? x))))))
(define/decl -PosFixnum (*Un -PosFixnumNotIndex -PosIndex))
(define/decl -NonNegFixnum (*Un -PosFixnum -Zero))
(define -NegFixnum
(define/decl -NegFixnum
(make-Base 'Negative-Fixnum
#'(and/c fixnum? negative?)
(lambda (x) (and (portable-fixnum? x)
(negative? x)))
#'-NegFixnum))
(negative? x)))))
(define/decl -NonPosFixnum (*Un -NegFixnum -Zero))
(define/decl -Fixnum (*Un -NegFixnum -Zero -PosFixnum))
;; This type, and others like it, should *not* be exported, or used for
;; anything but building unions. Especially, no literals should be given
;; these types.
(define -PosIntNotFixnum
(define/decl -PosIntNotFixnum
(make-Base 'Positive-Integer-Not-Fixnum
#'(and/c exact-integer? positive? (not/c fixnum?))
(lambda (x) (and (exact-integer? x)
(positive? x)
(not (portable-fixnum? x))))
#'-PosIntNotFixnum))
(not (portable-fixnum? x))))))
(define/decl -PosInt (*Un -PosIntNotFixnum -PosFixnum))
(define/decl -NonNegInt (*Un -PosInt -Zero))
(define/decl -Nat -NonNegInt)
(define -NegIntNotFixnum
(define/decl -NegIntNotFixnum
(make-Base 'Negative-Integer-Not-Fixnum
#'(and/c exact-integer? negative? (not/c fixnum?))
(lambda (x) (and (exact-integer? x)
(negative? x)
(not (portable-fixnum? x))))
#'-NegIntNotFixnum))
(not (portable-fixnum? x))))))
(define/decl -NegInt (*Un -NegIntNotFixnum -NegFixnum))
(define/decl -NonPosInt (*Un -NegInt -Zero))
(define/decl -Int (*Un -NegInt -Zero -PosInt))
;; Rationals
(define -PosRatNotInt
(define/decl -PosRatNotInt
(make-Base 'Positive-Rational-Not-Integer
#'(and/c exact-rational? positive? (not/c integer?))
(lambda (x) (and (exact-rational? x)
(positive? x)
(not (exact-integer? x))))
#'-PosRatNotInt))
(not (exact-integer? x))))))
(define/decl -PosRat (*Un -PosRatNotInt -PosInt))
(define/decl -NonNegRat (*Un -PosRat -Zero))
(define -NegRatNotInt
(define/decl -NegRatNotInt
(make-Base 'Negative-Rational-Not-Integer
#'(and/c exact-rational? negative? (not/c integer?))
(lambda (x) (and (exact-rational? x)
(negative? x)
(not (exact-integer? x))))
#'-NegRatNotInt))
(not (exact-integer? x))))))
(define/decl -NegRat (*Un -NegRatNotInt -NegInt))
(define/decl -NonPosRat (*Un -NegRat -Zero))
(define/decl -Rat (*Un -NegRat -Zero -PosRat))
;; Floating-point numbers
;; NaN is included in all floating-point types
(define -FlonumNan (make-Base 'Float-Nan
#'(and/c flonum? (lambda (x) (eqv? x +nan.0)))
(lambda (x) (and (flonum? x) (eqv? x +nan.0)))
#'-FlonumNan))
(define -FlonumPosZero (make-Base 'Float-Positive-Zero
#'(lambda (x) (eqv? x 0.0))
(lambda (x) (eqv? x 0.0))
#'-FlonumPosZero))
(define -FlonumNegZero (make-Base 'Float-Negative-Zero
#'(lambda (x) (eqv? x -0.0))
(lambda (x) (eqv? x -0.0))
#'-FlonumNegZero))
(define/decl -FlonumNan
(make-Base 'Float-Nan
#'(and/c flonum? (lambda (x) (eqv? x +nan.0)))
(lambda (x) (and (flonum? x) (eqv? x +nan.0)))))
(define/decl -FlonumPosZero
(make-Base 'Float-Positive-Zero
#'(lambda (x) (eqv? x 0.0))
(lambda (x) (eqv? x 0.0))))
(define/decl -FlonumNegZero
(make-Base 'Float-Negative-Zero
#'(lambda (x) (eqv? x -0.0))
(lambda (x) (eqv? x -0.0))))
(define/decl -FlonumZero (*Un -FlonumPosZero -FlonumNegZero -FlonumNan))
(define -PosFlonumNoNan
(define/decl -PosFlonumNoNan
(make-Base 'Positive-Float-No-NaN
#'(and/c flonum? positive?)
(lambda (x) (and (flonum? x) (positive? x)))
#'-PosFlonumNoNan))
(lambda (x) (and (flonum? x) (positive? x)))))
(define/decl -PosFlonum (*Un -PosFlonumNoNan -FlonumNan))
(define/decl -NonNegFlonum (*Un -PosFlonum -FlonumZero))
(define -NegFlonumNoNan
(define/decl -NegFlonumNoNan
(make-Base 'Negative-Float-No-NaN
#'(and/c flonum? negative?)
(lambda (x) (and (flonum? x) (negative? x)))
#'-NegFlonumNoNan))
(lambda (x) (and (flonum? x) (negative? x)))))
(define/decl -NegFlonum (*Un -NegFlonumNoNan -FlonumNan))
(define/decl -NonPosFlonum (*Un -NegFlonum -FlonumZero))
(define/decl -Flonum (*Un -NegFlonumNoNan -FlonumNegZero -FlonumPosZero -PosFlonumNoNan -FlonumNan)) ; 64-bit floats
;; inexact reals can be flonums (64-bit floats) or 32-bit floats
(define -SingleFlonumNan (make-Base 'Single-Flonum-Nan
#'(and/c single-flonum? (lambda (x) (eqv? x +nan.f)))
(lambda (x) (and (single-flonum? x) (eqv? x +nan.f)))
#'-SingleFlonumNan))
(define -SingleFlonumPosZero ; disjoint from Flonum 0s
(define/decl -SingleFlonumNan
(make-Base 'Single-Flonum-Nan
#'(and/c single-flonum? (lambda (x) (eqv? x +nan.f)))
(lambda (x) (and (single-flonum? x) (eqv? x +nan.f)))))
(define/decl -SingleFlonumPosZero ; disjoint from Flonum 0s
(make-Base 'Single-Flonum-Positive-Zero
;; eqv? equates 0.0f0 with itself, but not eq?
#'(lambda (x) (eqv? x 0.0f0))
(lambda (x) (eqv? x 0.0f0))
#'-SingleFlonumPosZero))
(define -SingleFlonumNegZero
(lambda (x) (eqv? x 0.0f0))))
(define/decl -SingleFlonumNegZero
(make-Base 'Single-Flonum-Negative-Zero
#'(lambda (x) (eqv? x -0.0f0))
(lambda (x) (eqv? x -0.0f0))
#'-SingleFlonumNegZero))
(lambda (x) (eqv? x -0.0f0))))
(define/decl -SingleFlonumZero (*Un -SingleFlonumPosZero -SingleFlonumNegZero -SingleFlonumNan))
(define/decl -InexactRealNan (*Un -FlonumNan -SingleFlonumNan))
(define/decl -InexactRealPosZero (*Un -SingleFlonumPosZero -FlonumPosZero))
@ -186,11 +174,10 @@
(define/decl -InexactRealZero (*Un -InexactRealPosZero
-InexactRealNegZero
-InexactRealNan))
(define -PosSingleFlonumNoNan
(define/decl -PosSingleFlonumNoNan
(make-Base 'Positive-Single-Flonum-No-Nan
#'(and/c single-flonum? positive?)
(lambda (x) (and (single-flonum? x) (positive? x)))
#'-PosSingleFlonumNoNan))
(lambda (x) (and (single-flonum? x) (positive? x)))))
(define/decl -PosSingleFlonum (*Un -PosSingleFlonumNoNan -SingleFlonumNan))
(define/decl -PosInexactReal (*Un -PosSingleFlonum -PosFlonum))
(define/decl -NonNegSingleFlonum (*Un -PosSingleFlonum -SingleFlonumZero))
@ -198,8 +185,7 @@
(define/decl -NegSingleFlonumNoNan
(make-Base 'Negative-Single-Flonum-No-Nan
#'(and/c single-flonum? negative?)
(lambda (x) (and (single-flonum? x) (negative? x)))
#'-NegSingleFlonumNoNan))
(lambda (x) (and (single-flonum? x) (negative? x)))))
(define/decl -NegSingleFlonum (*Un -NegSingleFlonumNoNan -SingleFlonumNan))
(define/decl -NegInexactReal (*Un -NegSingleFlonum -NegFlonum))
(define/decl -NonPosSingleFlonum (*Un -NegSingleFlonum -SingleFlonumZero))
@ -228,7 +214,7 @@
;; Thus, the only possible kinds of complex numbers are:
;; Zero/Rat, Zero/Flonum, Zero/SingleFlonum.
;; Rat/Rat, Flonum/Flonum, SingleFlonum/SingleFlonum.
(define -ExactImaginary
(define/decl -ExactImaginary
(make-Base 'Exact-Imaginary
#'(and/c number?
(not/c real?)
@ -239,9 +225,8 @@
(lambda (x) (and (number? x)
(not (real? x))
(eqv? 0 (real-part x))
(exact? (imag-part x))))
#'-ExactImaginary))
(define -ExactComplex
(exact? (imag-part x))))))
(define/decl -ExactComplex
(make-Base 'Exact-Complex
#'(and/c number?
(not/c real?)
@ -254,51 +239,50 @@
(not (real? x))
(not (eqv? 0 (real-part x)))
(exact? (real-part x))
(exact? (imag-part x))))
#'-ExactComplex))
(define -FloatImaginary (make-Base 'Float-Imaginary
#'(and/c number?
(lambda (x)
(and (flonum? (imag-part x))
(eqv? 0 (real-part x)))))
(lambda (x)
(and (number? x)
(flonum? (imag-part x))
(eqv? 0 (real-part x))))
#'-FloatImaginary))
(define -SingleFlonumImaginary (make-Base 'Single-Flonum-Imaginary
#'(and/c number?
(lambda (x)
(and (single-flonum? (imag-part x))
(eqv? 0 (real-part x)))))
(lambda (x)
(and (number? x)
(single-flonum? (imag-part x))
(eqv? 0 (real-part x))))
#'-SingleFlonumImaginary))
(define -FloatComplex (make-Base 'Float-Complex
#'(and/c number?
(lambda (x)
(and (flonum? (imag-part x))
(flonum? (real-part x)))))
(lambda (x)
(and (number? x)
(flonum? (imag-part x))
(flonum? (real-part x))))
#'-FloatComplex))
(define -SingleFlonumComplex (make-Base 'Single-Flonum-Complex
#'(and/c number?
(lambda (x)
(and (single-flonum? (imag-part x))
(single-flonum? (real-part x)))))
(lambda (x)
(and (number? x)
(single-flonum? (imag-part x))
(single-flonum? (real-part x))))
#'-SingleFlonumComplex))
(exact? (imag-part x))))))
(define/decl -FloatImaginary
(make-Base 'Float-Imaginary
#'(and/c number?
(lambda (x)
(and (flonum? (imag-part x))
(eqv? 0 (real-part x)))))
(lambda (x)
(and (number? x)
(flonum? (imag-part x))
(eqv? 0 (real-part x))))))
(define/decl -SingleFlonumImaginary
(make-Base 'Single-Flonum-Imaginary
#'(and/c number?
(lambda (x)
(and (single-flonum? (imag-part x))
(eqv? 0 (real-part x)))))
(lambda (x)
(and (number? x)
(single-flonum? (imag-part x))
(eqv? 0 (real-part x))))))
(define/decl -FloatComplex
(make-Base 'Float-Complex
#'(and/c number?
(lambda (x)
(and (flonum? (imag-part x))
(flonum? (real-part x)))))
(lambda (x)
(and (number? x)
(flonum? (imag-part x))
(flonum? (real-part x))))))
(define/decl -SingleFlonumComplex
(make-Base 'Single-Flonum-Complex
#'(and/c number?
(lambda (x)
(and (single-flonum? (imag-part x))
(single-flonum? (real-part x)))))
(lambda (x)
(and (number? x)
(single-flonum? (imag-part x))
(single-flonum? (real-part x))))))
(define/decl -ExactNumber (*Un -ExactImaginary -ExactComplex -Rat))
(define/decl -InexactImaginary (*Un -FloatImaginary -SingleFlonumImaginary))
(define/decl -Imaginary (*Un -ExactImaginary -InexactImaginary))
(define/decl -InexactComplex (*Un -FloatComplex -SingleFlonumComplex))
(define/decl -Complex (*Un -Real -Imaginary -ExactComplex -InexactComplex))
(define -Number -Complex)
(define/decl -Number -Complex)

10
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/printer.rkt
View File

@ -298,7 +298,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: nm par (list (fld: t _ _) ...) proc _ _)
(fp "#(struct:~a ~a" nm t)
@ -357,10 +357,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)

10
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/remove-intersect.rkt
View File

@ -54,16 +54,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*))

38
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/subtype.rkt
View File

@ -253,7 +253,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 #f)]
[((Value: v) (Base: _ _ pred _)) (if (pred v) A0 #f)]
;; tvars are equal if they are the same variable
[((F: t) (F: t*)) (if (eq? t t*) A0 #f)]
;; Avoid needing to resolve things that refer to different structs.
@ -266,9 +266,9 @@
#f]
[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)))
#f]
[((or (? Struct? s1) (NameStruct: s1)) (Base: _ _ _ _ _))
[((or (? Struct? s1) (NameStruct: s1)) (Base: _ _ _ _))
#f]
;; same for all values.
[((Value: (? (negate struct?) _)) (or (? Struct? s1) (NameStruct: s1)))
@ -276,8 +276,8 @@
[((or (? Struct? s1) (NameStruct: s1)) (Value: (? (negate struct?) _)))
#f]
;; just checking if s/t is a struct misses recursive/union/etc cases
[((? (lambda (_) (eq? ks 'struct))) (Base: _ _ _ _ _)) #f]
[((Base: _ _ _ _ _) (? (lambda (_) (eq? kt 'struct)))) #f]
[((? (lambda (_) (eq? ks 'struct))) (Base: _ _ _ _)) #f]
[((Base: _ _ _ _) (? (lambda (_) (eq? kt 'struct)))) #f]
;; sequences are covariant
[((Sequence: ts) (Sequence: ts*))
(subtypes* A0 ts ts*)]
@ -300,11 +300,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*)]
[((Value: (? exact-nonnegative-integer? n)) (Sequence: (list t*)))
(define possibilities
@ -319,7 +319,7 @@
((list pred? type)
(and (pred? n) type)))))
(subtype* A0 type t*)]
[((Base: _ _ _ _ #t) (Sequence: (list t*)))
[((Base: _ _ _ #t) (Sequence: (list t*)))
(define type
;; FIXME: thread the store through here
(for/or ((t (in-list (list -Byte -Index -NonNegFixnum -Nat))))
@ -421,7 +421,7 @@
;; some special cases for better performance
;; first, if both types are numeric, they will be built from the same base types
;; so we can check for simple set inclusion of the union components
[((Base: _ _ _ _ _) (Union: l2))
[((Base: _ _ _ _) (Union: l2))
(=> unmatch)
(if (and (eq? ks 'number) (eq? kt 'number))
(if (memq s l2) A0 #f)
@ -478,21 +478,21 @@
[((Set: t) (Set: t*)) (subtype* A0 t t*)]
;; Evts are covariant
[((Evt: t) (Evt: t*)) (subtype* A0 t t*)]
[((Base: 'Semaphore _ _ _ _) (Evt: t))
[((Base: 'Semaphore _ _ _) (Evt: t))
(subtype* A0 s t)]
[((Base: 'Output-Port _ _ _ _) (Evt: t))
[((Base: 'Output-Port _ _ _) (Evt: t))
(subtype* A0 s t)]
[((Base: 'Input-Port _ _ _ _) (Evt: t))
[((Base: 'Input-Port _ _ _) (Evt: t))
(subtype* A0 s t)]
[((Base: 'TCP-Listener _ _ _ _) (Evt: t))
[((Base: 'TCP-Listener _ _ _) (Evt: t))
(subtype* A0 s t)]
[((Base: 'Thread _ _ _ _) (Evt: t))
[((Base: 'Thread _ _ _) (Evt: t))
(subtype* A0 s t)]
[((Base: 'Subprocess _ _ _ _) (Evt: t))
[((Base: 'Subprocess _ _ _) (Evt: t))
(subtype* A0 s t)]
[((Base: 'Will-Executor _ _ _ _) (Evt: t))
[((Base: 'Will-Executor _ _ _) (Evt: t))
(subtype* A0 s t)]
[((Base: 'LogReceiver _ _ _ _) (Evt: t))
[((Base: 'LogReceiver _ _ _) (Evt: t))
(subtype* A0
(make-HeterogeneousVector
(list -Symbol -String Univ
@ -605,4 +605,4 @@
;(subtype (make-poly '(a) (make-tvar 'a)) (make-lst N))
;;problem:
;; (subtype (make-Mu 'x (make-Syntax (make-Union (list (make-Base 'Number #'number? number? #'-Number) (make-F 'x))))) (make-Syntax (make-Univ)))
;; (subtype (make-Mu 'x (make-Syntax (make-Union (list (make-Base 'Number #'number? number?) (make-F 'x))))) (make-Syntax (make-Univ)))