From 9428ed0010550e6837c6c179aff9f97ccde493c2 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 10 Jun 2009 21:46:52 +0000 Subject: [PATCH] Fix a bunch of types and function types svn: r15133 original commit: 7d9f506760dd7d068641eea5f89c15e36a45d837 --- collects/typed-scheme/private/base-env.ss | 40 +++++++++++++++---- .../typed-scheme/private/base-special-env.ss | 3 +- collects/typed-scheme/private/base-types.ss | 4 +- collects/typed-scheme/ts-reference.scrbl | 3 ++ collects/typed-scheme/types/printer.ss | 8 ++-- 5 files changed, 43 insertions(+), 15 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index d190584a..f08805ad 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -61,7 +61,7 @@ [boolean? (make-pred-ty B)] [add1 (cl->* (-> -Integer -Integer) (-> N N))] -[sub1 (cl->* #;(-> -Integer -Integer) +[sub1 (cl->* (-> -Integer -Integer) (-> N N))] [eq? (-> Univ Univ B)] [eqv? (-> Univ Univ B)] @@ -486,13 +486,14 @@ [peek-char (cl->* [-> -Char] [-Input-Port . -> . -Char] - [-Input-Port N . -> . -Char] - [N . -> . -Char])] + [-Input-Port N . -> . -Char])] [peek-byte (cl->* [-> -Byte] [-Input-Port . -> . -Byte] - [-Input-Port N . -> . -Byte] - [N . -> . -Byte])] + [-Input-Port N . -> . -Byte])] +[read-char + (cl->* [-> (Un -Char (-val eof))] + [-Input-Port . -> . (Un -Char (-val eof))])] [make-pipe (cl->* [-> (-values (list -Input-Port -Output-Port))] [N . -> . (-values (list -Input-Port -Output-Port))])] @@ -536,9 +537,31 @@ [syntax-source (-> (-Syntax Univ) Univ)] [syntax-position (-> (-Syntax Univ) (-opt N))] -[datum->syntax (cl->* - (-> (-opt (-Syntax Univ)) Sym (-Syntax Sym)) - (-> (-opt (-Syntax Univ)) Univ (-Syntax Univ)))] +[datum->syntax + (-poly + (a) + (let* ([I (-Syntax Sym)] + [S (-Syntax Univ)] + [ctxt (-opt S)] + [srclist (-Tuple (list + Univ + (-opt -Number) + (-opt -Number) + (-opt -Number) + (-opt -Number)))] + [srcloc (Un S (-val #f) srclist)] + [prop (-opt S)] + [cert (-opt S)]) + (cl->* + (-> ctxt Sym I) + (-> ctxt Univ S) + (-> ctxt Sym srcloc I) + (-> ctxt Univ srcloc S) + (-> ctxt Sym srcloc prop I) + (-> ctxt Univ srcloc prop S) + (-> ctxt Sym srcloc prop cert I) + (-> ctxt Univ srcloc prop cert S))))] + [syntax->datum (-> (-Syntax Univ) Univ)] [syntax-e (-poly (a) (-> (-Syntax a) a))] [syntax-original? (-poly (a) (-> (-Syntax a) B))] @@ -560,6 +583,7 @@ [sort (-poly (a) ((-lst a) (a a . -> . B) . -> . (-lst a)))] [find-system-path (Sym . -> . -Path)] +[object-name (Univ . -> . Univ)] ;; scheme/cmdline [parse-command-line diff --git a/collects/typed-scheme/private/base-special-env.ss b/collects/typed-scheme/private/base-special-env.ss index 76a69213..fbfae79e 100644 --- a/collects/typed-scheme/private/base-special-env.ss +++ b/collects/typed-scheme/private/base-special-env.ss @@ -28,9 +28,10 @@ ([second : -Number] [minute : -Number] [hour : -Number] [day : -Number] [month : -Number] [year : -Number] [weekday : -Number] [year-day : -Number] [dst? : -Boolean] [time-zone-offset : -Number]) ()) - (d-s exn ([message : -String] [continuation-marks : Univ]) ()) + (d-s exn ([message : -String] [continuation-marks : -Cont-Mark-Set]) ()) (d-s (exn:fail exn) () (-String -Cont-Mark-Set)) (d-s (exn:fail:read exn:fail) ([srclocs : (-lst Univ)]) (-String -Cont-Mark-Set)) + (d-s (exn:fail:read:eof exn:fail:read) () (-String -Cont-Mark-Set (-lst Univ))) ) (provide (for-syntax initial-env/special-case initialize-others initialize-type-env) diff --git a/collects/typed-scheme/private/base-types.ss b/collects/typed-scheme/private/base-types.ss index 0d3d23ac..643892b2 100644 --- a/collects/typed-scheme/private/base-types.ss +++ b/collects/typed-scheme/private/base-types.ss @@ -16,9 +16,9 @@ [Input-Port -Input-Port] [Output-Port -Output-Port] [Bytes -Bytes] -#;[List (-lst Univ)] [EOF (-val eof)] [Syntax Any-Syntax] +[Syntaxof (-poly (a) (-Syntax a))] [Identifier Ident] [Procedure top-func] [Keyword -Keyword] @@ -29,4 +29,4 @@ [Promise (-poly (a) (-Promise a))] [Pair (-poly (a b) (-pair a b))] [Boxof (-poly (a) (make-Box a))] - +[Continuation-Mark-Set -Cont-Mark-Set] diff --git a/collects/typed-scheme/ts-reference.scrbl b/collects/typed-scheme/ts-reference.scrbl index 14e73bdb..32adc2d7 100644 --- a/collects/typed-scheme/ts-reference.scrbl +++ b/collects/typed-scheme/ts-reference.scrbl @@ -36,9 +36,11 @@ @defidform[Regexp] @defidform[PRegexp] @defidform[Syntax] +@defidform[Identifier] @defidform[Bytes] @defidform[Namespace] @defidform[EOF] +@defidform[Continuation-Mark-Set] @defidform[Char])]{ These types represent primitive Scheme data. Note that @scheme[Integer] represents exact integers.} @@ -48,6 +50,7 @@ The following base types are parameteric in their type arguments. @defform[(Listof t)]{Homogenous @rtech{lists} of @scheme[t]} @defform[(Boxof t)]{A @rtech{box} of @scheme[t]} +@defform[(Syntaxof t)]{A @rtech{syntax object} containing a @scheme[t]} @defform[(Vectorof t)]{Homogenous @rtech{vectors} of @scheme[t]} @defform[(Option t)]{Either @scheme[t] of @scheme[#f]} @defform*[[(Parameter t) diff --git a/collects/typed-scheme/types/printer.ss b/collects/typed-scheme/types/printer.ss index 55aefcd2..ced31998 100644 --- a/collects/typed-scheme/types/printer.ss +++ b/collects/typed-scheme/types/printer.ss @@ -9,7 +9,7 @@ ;; FIXME - currently broken (define print-poly-types? #f) ;; do we use simple type aliases in printing -(define print-aliases #f) +(define print-aliases #t) ;; does t have a type name associated with it currently? ;; has-name : Type -> Maybe[Symbol] @@ -183,14 +183,14 @@ (Mu: y (Union: (list (F: x) (Pair: (F: x) (F: y))))) (Vector: (F: x)) (Box: (F: x)))))) - (fp "SyntaxObject")] + (fp "Syntax")] [(Mu-name: name body) (fp "(Rec ~a ~a)" name body)] ;; FIXME - this should not be used #; [(Scope: sc) (fp "(Scope ~a)" sc)] [(B: idx) (fp "(B ~a)" idx)] - [(Syntax: t) (fp "(Syntax ~a)" t)] + [(Syntax: t) (fp "(Syntaxof ~a)" t)] [(Instance: t) (fp "(Instance ~a)" t)] [(Class: pf nf ms) (fp "(Class)")] [(Result: t (LFilterSet: (list) (list)) (LEmpty:)) (fp "~a" t)] @@ -199,7 +199,7 @@ [(Refinement: parent p? _) (fp "(Refinement ~a ~a)" parent (syntax-e p?))] [(Error:) (fp "Error")] - [else (fp "Unknown Type: ~a" (struct->vector c))] + [else (fp "(Unknown Type: ~a)" (struct->vector c))] )) (set-box! print-type* print-type)