Fix a bunch of types and function types

svn: r15133

original commit: 7d9f506760dd7d068641eea5f89c15e36a45d837

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

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)

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]

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)

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)