[MLton] cvs commit: change in handling of undetermined toplevel types

Stephen Weeks sweeks@mlton.org
Thu, 22 Jan 2004 22:38:40 -0800


sweeks      04/01/22 22:38:40

  Modified:    mlton/ast ast.fun ast.sig
               mlton/elaborate elaborate-core.fun elaborate-core.sig
                        elaborate.fun type-env.fun type-env.sig
               mlton/front-end ml.grm
               regression undetermined.sml
  Added:       regression/fail overloading-context.1.sml
                        overloading-context.2.sml undetermined.1.sml
                        undetermined.2.sml undetermined.3.sml
  Log:
  MAIL change in handling of undetermined toplevel types
  
  Changed the coalescing of topdecs so that a semicolon forces a
  toplevel declaration to be treated as two separate topdecs.  This is
  required by the restriction on page 14 of the Definition.  For
  example, the following program now fails, because the overloading is
  resolved for the double function without knowledge of its use.
  
  fun double x = x + x;
  val y = double 2.0
  
  This was implemented by changing Ast.Program.t slightly to keep track
  of where the semicolons are and change coalesce to only work between
  them.
  
  I also changed the handling of undetermined types at the top level.
  It used to be that after the elaboration of each core declaration, we
  would check for any undetermined types, and report an error if there
  were any.  This was incorrect because the determination should be done
  at the granularity of topdec, not core declaration.  Hence, the
  following example, given on page 90 of the Definition, now elaborates.
  
  structure A: sig val f: int -> int end =
     struct
        val f = (fn x => x) (fn x => x)
     end
  
  Second, in order to prevent mistakenly rejecting programs where a core
  dec has a free type variable, but it doesn't make it into the toplevel
  environment, I decided to go for the more conservative approach of
  instantiating the undetermined types with new type constructors.  So,
  now the following program elaborates, as required by the Definition.
  
  structure B : sig end =
  struct
      val a = ref nil
  end
  
  What will still be rejected, and correctly I believe, is programs
  where a type is determined across multiple topdecs.  For example, the
  following will be rejected.
  
  val x = ref [];
  val _ = 1 :: !x
  
  I am not sure if this is consistent with the Definition, but only
  because the error message reports the error as being in the second
  declaration (function applied to incorrect argument) rather than the
  first (refusal to allow undetermined types to enter the basis).

Revision  Changes    Path
1.11      +38 -29    mlton/mlton/ast/ast.fun

Index: ast.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- ast.fun	17 Jan 2004 00:22:36 -0000	1.10
+++ ast.fun	23 Jan 2004 06:38:39 -0000	1.11
@@ -399,15 +399,18 @@
 
 structure Program =
    struct
-      datatype t = T of Topdec.t list
+      datatype t = T of Topdec.t list list
 
       val empty = T []
 
       fun append (T ds1, T ds2) = T (ds1 @ ds2)
 
-      fun layout (T ds) = Layout.align (List.map (ds, Topdec.layout))
+      fun layout (T dss) =
+	 Layout.align (List.map (dss, fn ds =>
+				 Layout.paren 
+				 (Layout.align (List.map (ds, Topdec.layout)))))
 
-      fun coalesce (T ds) =
+      fun coalesce (T dss): t =
 	 let
 	    fun finish (sds, ac) =
 	       case sds of
@@ -430,29 +433,33 @@
 			Topdec.Strdec d => loop (ds, d :: sds, ac)
 		      | _ => loop (ds, [], d :: finish (sds, ac))
 	 in
-	    T (rev (loop (ds, [], [])))
+	    T (List.map (dss, fn ds => rev (loop (ds, [], []))))
 	 end
 
-      fun size (T ds): int =
+      val coalesce =
+	 Trace.trace ("Ast.Program.coalesce", layout, layout) coalesce
+
+      fun size (T dss): int =
 	 let
-	    open Dec Exp Strexp Strdec Topdec
 	    val n = ref 0
 	    fun inc () = n := 1 + !n
-
 	    fun dec (d: Dec.t): unit =
-	       case Dec.node d of
-		  Val {vbs, rvbs, ...} =>
-		     (Vector.foreach (vbs, exp o #exp)
-		      ; Vector.foreach (rvbs, match o #match))
-		| Fun (_, ds) =>
-		     Vector.foreach (ds, fn clauses =>
-				     Vector.foreach (clauses, exp o #body))
-		| Abstype {body, ...} => dec body
-		| Exception cs => Vector.foreach (cs, fn _ => inc ())
-		| SeqDec ds => Vector.foreach (ds, dec)
-		| Dec.Local (d, d') => (dec d; dec d')
-		| _ => ()
-
+	       let
+		  datatype z = datatype Dec.node
+	       in
+		  case Dec.node d of
+		     Abstype {body, ...} => dec body
+		   | Exception cs => Vector.foreach (cs, fn _ => inc ())
+		   | Fun (_, ds) =>
+			Vector.foreach (ds, fn clauses =>
+					Vector.foreach (clauses, exp o #body))
+		   | Local (d, d') => (dec d; dec d')
+		   | SeqDec ds => Vector.foreach (ds, dec)
+		   | Val {vbs, rvbs, ...} =>
+			(Vector.foreach (vbs, exp o #exp)
+			 ; Vector.foreach (rvbs, match o #match))
+		   | _ => ()
+	       end
 	    and exp (e: Exp.t): unit =
 	       let
 		  val _ = inc ()
@@ -476,16 +483,13 @@
 		   | While {test, expr} => (exp test; exp expr)
 		   | _ => ()
 	       end
-
 	    and exps es = Vector.foreach (es, exp)
-	       
 	    and match m =
 	       let
 		  val Match.T rules = Match.node m
 	       in
 		  Vector.foreach (rules, exp o #2)
 	       end
-		     
 	    fun strdec d =
 	       case Strdec.node d of
 		  Core d => dec d
@@ -502,12 +506,17 @@
 		| _ => ()
 
 	    fun topdec d =
-	       case Topdec.node d of
-		  Strdec d => strdec d
-		| Functor ds =>
-		     Vector.foreach (ds, fn {body, ...} => strexp body)
-		| _ => ()
-	 in List.foreach (ds, topdec);
+	       let
+		  datatype z = datatype Topdec.node
+	       in
+		  case Topdec.node d of
+		     Functor ds =>
+			Vector.foreach (ds, fn {body, ...} => strexp body)
+		   | Strdec d => strdec d
+		   | _ => ()
+	       end
+	    val _ = List.foreach (dss, fn ds => List.foreach (ds, topdec))
+	 in
 	    !n
 	 end
    end



1.7       +1 -1      mlton/mlton/ast/ast.sig

Index: ast.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- ast.sig	17 Jan 2004 00:22:36 -0000	1.6
+++ ast.sig	23 Jan 2004 06:38:39 -0000	1.7
@@ -172,7 +172,7 @@
 
       structure Program:
 	 sig
-	    datatype t = T of Topdec.t list
+	    datatype t = T of Topdec.t list list
 
 	    val append: t * t -> t
 	    val coalesce: t -> t



1.71      +9 -4      mlton/mlton/elaborate/elaborate-core.fun

Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.70
retrieving revision 1.71
diff -u -r1.70 -r1.71
--- elaborate-core.fun	23 Jan 2004 02:30:22 -0000	1.70
+++ elaborate-core.fun	23 Jan 2004 06:38:39 -0000	1.71
@@ -1067,7 +1067,10 @@
 		      (freeTyvarChecks,
 		       fn () =>
 		       Vector.foreach2
-		       (v, Scheme.haveFrees (Vector.map (v, #2)),
+		       (v,
+			Scheme.haveFrees (Vector.map (v, #2),
+					  fn () =>
+					  Env.newTycon ("X", Kind.Arity 0)),
 			fn ((x, s), b) =>
 			if b
 			   then
@@ -2218,11 +2221,13 @@
 			     Priority.<= (y, x)),
 			    fn (_,p) => (p (); ()))
       val _ = overloads := []
-      val _ = List.foreach (rev (!freeTyvarChecks), fn p => p ())
-      val _ = freeTyvarChecks := []
-      val _ = TypeEnv.closeTop (Adec.region d)
    in
       ds
    end
+
+fun reportUndeterminedTypes () =
+   (List.foreach (rev (!freeTyvarChecks), fn p => p ())
+    ; freeTyvarChecks := []
+    ; TypeEnv.closeTop ())
 
 end



1.7       +1 -0      mlton/mlton/elaborate/elaborate-core.sig

Index: elaborate-core.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- elaborate-core.sig	13 Oct 2003 19:23:36 -0000	1.6
+++ elaborate-core.sig	23 Jan 2004 06:38:39 -0000	1.7
@@ -31,4 +31,5 @@
 		      lookupConstant: string * ConstType.t -> CoreML.Const.t,
 		      nest: string list}
 	 -> Decs.t
+      val reportUndeterminedTypes: unit -> unit
    end



1.15      +5 -3      mlton/mlton/elaborate/elaborate.fun

Index: elaborate.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- elaborate.fun	17 Jan 2004 00:22:37 -0000	1.14
+++ elaborate.fun	23 Jan 2004 06:38:39 -0000	1.15
@@ -229,13 +229,15 @@
 	 fn d =>
 	 let
 	    val res = elabTopdec d
-	    val _ = Control.checkForErrors "elaborate"
+	    val _ = ElaborateCore.reportUndeterminedTypes ()
+(*	    val _ = Control.checkForErrors "elaborate" *)
 	 in
 	    res
 	 end
    in
-      List.fold (decs, Decs.empty, fn (d, decs) =>
-		 Decs.append (decs, elabTopdec d))
+      List.fold (decs, Decs.empty, fn (ds, decs) =>
+		 List.fold (ds, decs, fn (d, decs) =>
+			    Decs.append (decs, elabTopdec d)))
    end
 
 end



1.18      +11 -3     mlton/mlton/elaborate/type-env.fun

Index: type-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.fun,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- type-env.fun	15 Jan 2004 15:50:40 -0000	1.17
+++ type-env.fun	23 Jan 2004 06:38:39 -0000	1.18
@@ -1414,9 +1414,17 @@
 	    Type.unknown {canGeneralize = canGeneralize,
 			  equality = Equality.truee})))
 
-      fun haveFrees (v: t vector): bool vector =
+      val reportFrees = false
+      fun haveFrees (v: t vector, newTycon): bool vector =
 	 let
 	    exception Yes
+	    val unknown =
+	       if reportFrees
+		  then fn _ => raise Yes
+	       else (fn (t, _) =>
+		     (Type.unify (t, Type.con (newTycon (), Vector.new0 ()),
+				  fn () => Error.bug "haveFrees unify")
+		      ; ()))
 	    val {destroy, hom} =
 	       Type.makeHom {con = fn _ => (),
 			     expandOpaque = false,
@@ -1426,7 +1434,7 @@
 			     real = fn _ => (),
 			     record = fn _ => (),
 			     recursive = fn _ => (),
-			     unknown = fn _ => raise Yes,
+			     unknown = unknown,
 			     var = fn _ => (),
 			     word = fn _ => ()}
 	    val res =
@@ -1566,7 +1574,7 @@
       end
    end
 
-fun closeTop (r: Region.t): unit =
+fun closeTop (): unit =
    let
       val _ =
 	 List.foreach



1.11      +2 -2      mlton/mlton/elaborate/type-env.sig

Index: type-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.sig,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- type-env.sig	15 Jan 2004 15:50:41 -0000	1.10
+++ type-env.sig	23 Jan 2004 06:38:39 -0000	1.11
@@ -70,7 +70,7 @@
 	    val bound: t -> Tyvar.t vector
 	    val dest: t -> Tyvar.t vector * Type.t
 	    val fromType: Type.t -> t
-	    val haveFrees: t vector -> bool vector
+	    val haveFrees: t vector * (unit -> Tycon.t) -> bool vector
 	    val instantiate: t -> {args: unit -> Type.t vector,
 				   instance: Type.t}
 	    val layout: t -> Layout.t
@@ -93,7 +93,7 @@
 	 -> Type.t vector
 	 -> {bound: unit -> Tyvar.t vector,
 	     schemes: Scheme.t vector}
-      val closeTop: Region.t -> unit
+      val closeTop: unit -> unit
       val setOpaqueTyconExpansion: Tycon.t * (Type.t vector -> Type.t) -> unit
       val tyconAdmitsEquality: Tycon.t -> Tycon.AdmitsEquality.t ref
    end



1.28      +15 -10    mlton/mlton/front-end/ml.grm

Index: ml.grm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/ml.grm,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- ml.grm	23 Jan 2004 02:30:23 -0000	1.27
+++ ml.grm	23 Jan 2004 06:38:39 -0000	1.28
@@ -164,6 +164,11 @@
 (*      val seq = Trace.trace2 ("Spec.seq", layout, layout, layout) seq *)
    end
 
+fun consTopdec (d, dss) =
+   case dss of
+      [] => [[d]]
+    | ds :: dss => (d :: ds) :: dss
+
 type rule = Pat.t * Exp.t
 type clause = {pats : Pat.t vector,
 	       resultType : Type.t option,
@@ -318,7 +323,7 @@
        | idEqual of string * Region.t
        | idNoAsterisk of string * Region.t
        | int of IntInf.t
-       | leadExps of Topdec.t list
+       | leadExps of Topdec.t list list
        | longcon of Longcon.t
        | longid of string * Region.t
        | longidEqual of string * Region.t
@@ -388,7 +393,7 @@
        | tlabels  of (Field.t * Type.t) list
        | topdec of Topdec.t
        | topdecnode of Topdec.node
-       | topdecs of Topdec.t list
+       | topdecs of Topdec.t list list
        | tuple_ty of Type.t list
        | ty of Type.t
        | ty' of Type.t
@@ -474,16 +479,16 @@
         | leadExps                  (Program.T leadExps)
         |                           (Program.T [])
 	 
-leadExps: exp SEMICOLON leadExps   (Topdec.fromExp exp :: leadExps)
-        | exp SEMICOLON topdecs    (Topdec.fromExp exp :: topdecs)
-	| exp SEMICOLON            ([Topdec.fromExp exp])
+leadExps: exp SEMICOLON leadExps   ([Topdec.fromExp exp] :: leadExps)
+        | exp SEMICOLON topdecs    ([Topdec.fromExp exp] :: topdecs)
+	| exp SEMICOLON            ([[Topdec.fromExp exp]])
 	  
-topdecs : topdec                    ([topdec])
+topdecs : topdec                    ([[topdec]])
         | SEMICOLON                 ([])
-        | SEMICOLON topdecs         (topdecs)
-        | topdec topdecs            (topdec::topdecs)
-        | SEMICOLON exp SEMICOLON topdecs  (Topdec.fromExp exp :: topdecs)
-        | SEMICOLON exp SEMICOLON   ([Topdec.fromExp exp])
+        | SEMICOLON topdecs         ([] :: topdecs)
+        | topdec topdecs            (consTopdec (topdec, topdecs))
+        | SEMICOLON exp SEMICOLON topdecs  ([Topdec.fromExp exp] :: topdecs)
+        | SEMICOLON exp SEMICOLON   ([[Topdec.fromExp exp]])
 
 topdec : topdecnode (Topdec.makeRegion' (topdecnode,
 					 topdecnodeleft,



1.3       +67 -6     mlton/regression/undetermined.sml

Index: undetermined.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/undetermined.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- undetermined.sml	9 Oct 2003 18:17:35 -0000	1.2
+++ undetermined.sml	23 Jan 2004 06:38:40 -0000	1.3
@@ -2,15 +2,76 @@
 
 (* Checks inference for non-generalised types (aka "free type variables"). *)
 
-val a = ref nil
-val _ = a := [1];
+val f = (fn x => x) (fn x => x)
+structure A = struct end
+val y = f 7
+;
+
+structure A: sig val f: int -> int end =
+   struct
+      val f = (fn x => x) (fn x => x)
+   end
+;
 
 structure A : sig val a : int list ref end =
 struct
-    val a: int list ref = ref nil
-end;
+    val a = ref nil
+end
+;
 
 structure B : sig end =
 struct
-    val a: unit list ref = ref nil
-end;
+    val a = ref nil
+end
+;
+val x = ref nil
+val _ = 1 :: !x
+;
+;
+;
+val _ =
+   let
+      val x = ref nil
+      val _ = 1 :: !x
+   in
+      ()
+   end
+;
+val x = ref []
+;
+val _ = let val x = ref [] in () end
+;
+(* 1.sml *)
+val id = (fn x => x) (fn x => x)
+;
+(* 2.sml *)
+val id = (fn x => x) (fn x => x)
+val _ = id 13
+;
+structure X =
+struct
+    val id = (fn x => x) (fn x => x)
+    val _ = id 13
+end
+
+(* 4.sml *)
+val id = (fn x => x) (fn x => x)
+datatype t = T
+val _ = id T
+;
+(* 5.sml *)
+local
+   val id = (fn x => x) (fn x => x)
+in
+   val _ = id 13
+end
+;
+(* 6.sml *)
+val id = (fn x => x) (fn x => x)
+val id = ()
+;
+(* 7.sml *)
+val id = (fn x => x) (fn x => x)
+val _ = id 13
+val id = ()
+;



1.1                  mlton/regression/fail/overloading-context.1.sml

Index: overloading-context.1.sml
===================================================================
(* This must fail, because the overloading context can be no larger than the
 * smallest enclosing strdec.  So, the declaration of double must be resolved
 * (with type int -> int) before continuing.
 *)
structure S =
   struct
      fun double x = x + x
   end
val _ = S.double 2.0



1.1                  mlton/regression/fail/overloading-context.2.sml

Index: overloading-context.2.sml
===================================================================
(* This program must fail because the semicolon means that the declarations
 * must be treated as two topdecs, not a single topdec leading to two strdec's.
 * This follows from the restriction on page 14 of the Definition that states
 * "No topdec may contain as an initial segment, a strdec followed by a
 *  semicolon"
 *)
fun double x = x + x;
val y = double 2.0



1.1                  mlton/regression/fail/undetermined.1.sml

Index: undetermined.1.sml
===================================================================
(* This fails because the semicolon means that the program must be treated
 * as two topdecs.  Then, the first topdec must be elaborated, and the type
 * of x chosen, before the second can.  Hence, since we cannot know that x should
 * be an int list ref, we fail.
 *)
val x = ref [];
val _ = 1 :: !x



1.1                  mlton/regression/fail/undetermined.2.sml

Index: undetermined.2.sml
===================================================================
(* Fails because the signature means that it's treated as 3 topdecs. *)
val x = ref nil
signature S = sig end
val _ = 1 :: !x



1.1                  mlton/regression/fail/undetermined.3.sml

Index: undetermined.3.sml
===================================================================
val x = ref nil;
val _ = () :: !x