[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