[MLton] cvs commit: interaction of elaboration controls and functor applications
Matthew Fluet
fluet@mlton.org
Sun, 13 Feb 2005 05:27:58 -0800
fluet 05/02/13 05:27:58
Modified: mlton/control control.sig control.sml
mlton/elaborate elaborate-env.fun
Log:
MAIL interaction of elaboration controls and functor applications
Due to the re-elaboration of a functor body at the point of
application, elaboration control dependent type-errors might only
appear at the point of application, not at the point of definition.
For example, consider the following:
a.sml:
functor F_A () =
struct
val r = ref 0
fun inc () = (r := !r + 1; !r)
fun f x y =
(inc ()
; x + y)
datatype t = A | B | C | D
fun g x =
case x of A => 1
end
b.sml:
structure B_S = F_A ()
z.mlb:
$(SML_LIB)/basis/basis.mlb
ann "sequenceUnit true" "warnMatch false" in
a.sml
end
ann "sequenceUnit true" "warnMatch true" in
b.sml
end
The old behavior would produce:
bash-2.05b$ mlton-stable -stop tc z.mlb
Error: a.sml 7.4.
Sequence expression not of type unit.
type: [int]
in: inc ()
Warning: a.sml 12.3.
Case is not exhaustive.
missing pattern: B | C | D
in: case x of (A) => (1)
compilation aborted: elaborate reported errors
Notice that the errors are a bit misleading: they point to a.sml, but
a.sml was clearly elaborated in a context with sequenceUnit false and
warnMatch false. We can confirm that it is due to the re-elaboration
in b.sml by commenting out b.sml from the .mlb:
z.mlb:
$(SML_LIB)/basis/basis.mlb
ann "sequenceUnit true" "warnMatch false" in
a.sml
end
ann "sequenceUnit true" "warnMatch true" in
(* b.sml *)
end
The new behavior is to snapshot the state of the elaboration controls
at the point of functor definition and (temporarily) reinstate those
controls for each application (i.e., re-elaboration of the body).
I think this is a more intuitive behavior.
Revision Changes Path
1.120 +1 -0 mlton/mlton/control/control.sig
Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.119
retrieving revision 1.120
diff -u -r1.119 -r1.120
--- control.sig 22 Dec 2004 05:11:25 -0000 1.119
+++ control.sig 13 Feb 2005 13:27:57 -0000 1.120
@@ -107,6 +107,7 @@
val processEnabled: string * bool -> bool
val withDef: (unit -> 'a) -> 'a
+ val snapshot: unit -> (unit -> 'a) -> 'a
end
(* stop after elaboration. So, no need for the elaborator to generate
1.157 +28 -4 mlton/mlton/control/control.sml
Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.156
retrieving revision 1.157
diff -u -r1.156 -r1.157
--- control.sml 12 Feb 2005 23:36:47 -0000 1.156
+++ control.sml 13 Feb 2005 13:27:57 -0000 1.157
@@ -175,7 +175,8 @@
parseArgs: string list -> 'args option},
{parseId: string -> Id.t option,
parseIdAndArgs: string -> (Id.t * Args.t) option,
- withDef: unit -> (unit -> unit)}) =
+ withDef: unit -> (unit -> unit),
+ snapshot: unit -> unit -> (unit -> unit)}) =
let
val ctrl as T {args = argsRef, cur, def,
id as Id.T {enabled, ...}, ...} =
@@ -246,11 +247,28 @@
; fn () => (cur := old
; restore ())
end
+ val snapshot : unit -> unit -> (unit -> unit) =
+ fn () =>
+ let
+ val withSaved = snapshot ()
+ val saved = !cur
+ in
+ fn () =>
+ let
+ val restore = withSaved ()
+ val old = !cur
+ in
+ cur := saved
+ ; fn () => (cur := old
+ ; restore ())
+ end
+ end
in
(ctrl,
{parseId = parseId,
parseIdAndArgs = parseIdAndArgs,
- withDef = withDef})
+ withDef = withDef,
+ snapshot = snapshot})
end
fun makeBool ({default: bool,
@@ -271,7 +289,8 @@
val ac =
{parseId = fn _ => NONE,
parseIdAndArgs = fn _ => NONE,
- withDef = fn () => (fn () => ())}
+ withDef = fn () => (fn () => ()),
+ snapshot = fn () => fn () => (fn () => ())}
val (allowConstant, ac) =
makeBool ({name = "allowConstant", default = false, expert = true}, ac)
val (allowExport, ac) =
@@ -316,7 +335,7 @@
makeBool ({name = "warnMatch", default = true, expert = false}, ac)
val (warnUnused, ac) =
makeBool ({name = "warnUnused", default = false, expert = false}, ac)
- val {parseId, parseIdAndArgs, withDef} = ac
+ val {parseId, parseIdAndArgs, withDef, snapshot} = ac
end
val processDefault = fn s =>
@@ -332,6 +351,11 @@
let val restore = withDef ()
in DynamicWind.wind (f, restore)
end
+ val snapshot : unit -> (unit -> 'a) -> 'a = fn () =>
+ let val withSaved = snapshot () in fn f =>
+ let val restore = withSaved ()
+ in DynamicWind.wind (f, restore)
+ end end
end
1.109 +6 -1 mlton/mlton/elaborate/elaborate-env.fun
Index: elaborate-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.fun,v
retrieving revision 1.108
retrieving revision 1.109
diff -u -r1.108 -r1.109
--- elaborate-env.fun 4 Feb 2005 00:42:38 -0000 1.108
+++ elaborate-env.fun 13 Feb 2005 13:27:57 -0000 1.109
@@ -3136,7 +3136,12 @@
val restore =
if !Control.elaborateOnly
then fn f => f ()
- else snapshot E
+ else let
+ val withSaved = Control.Elaborate.snapshot ()
+ val snapshot = snapshot E
+ in
+ fn f => snapshot (fn () => withSaved f)
+ end
fun apply (actual, nest) =
if not (!insideFunctor) andalso not (!Control.elaborateOnly)
then restore (fn () => makeBody (actual, nest))