[MLton-commit] r5774
Matthew Fluet
fluet at mlton.org
Fri Jul 13 13:02:31 PDT 2007
Added MLton.Exn.{default,get,set}TopLevelHandler.
Discussed at:
http://mlton.org/pipermail/mlton/2007-June/029811.html
----------------------------------------------------------------------
U mlton/trunk/basis-library/libs/basis-extra/basis-extra.mlb
U mlton/trunk/basis-library/mlton/exn.sig
U mlton/trunk/basis-library/mlton/exn.sml
U mlton/trunk/basis-library/mlton/mlton.sml
U mlton/trunk/basis-library/primitive/check-real.sml
U mlton/trunk/basis-library/primitive/prim1.sml
U mlton/trunk/doc/changelog
U mlton/trunk/mlton/atoms/hash-type.fun
U mlton/trunk/mlton/atoms/prim.fun
U mlton/trunk/mlton/atoms/prim.sig
U mlton/trunk/mlton/xml/implement-exceptions.fun
U mlton/trunk/mlton/xml/implement-suffix.fun
----------------------------------------------------------------------
Modified: mlton/trunk/basis-library/libs/basis-extra/basis-extra.mlb
===================================================================
--- mlton/trunk/basis-library/libs/basis-extra/basis-extra.mlb 2007-07-13 12:54:14 UTC (rev 5773)
+++ mlton/trunk/basis-library/libs/basis-extra/basis-extra.mlb 2007-07-13 20:02:28 UTC (rev 5774)
@@ -9,7 +9,7 @@
"deadCode true"
"sequenceNonUnit warn"
"nonexhaustiveMatch warn" "redundantMatch warn"
- "warnUnused false" "forceUsed"
+ "warnUnused true" "forceUsed"
in
local
../../build/sources.mlb
Modified: mlton/trunk/basis-library/mlton/exn.sig
===================================================================
--- mlton/trunk/basis-library/mlton/exn.sig 2007-07-13 12:54:14 UTC (rev 5773)
+++ mlton/trunk/basis-library/mlton/exn.sig 2007-07-13 20:02:28 UTC (rev 5774)
@@ -9,5 +9,9 @@
sig
val addExnMessager: (exn -> string option) -> unit
val history: exn -> string list
+
+ val defaultTopLevelHandler: exn -> 'a (* does not return *)
+ val getTopLevelHandler: unit -> (exn -> unit)
+ val setTopLevelHandler: (exn -> unit) -> unit
val topLevelHandler: exn -> 'a (* does not return *)
end
Modified: mlton/trunk/basis-library/mlton/exn.sml
===================================================================
--- mlton/trunk/basis-library/mlton/exn.sml 2007-07-13 12:54:14 UTC (rev 5773)
+++ mlton/trunk/basis-library/mlton/exn.sml 2007-07-13 20:02:28 UTC (rev 5774)
@@ -43,21 +43,29 @@
local
val message = PrimitiveFFI.Stdio.print
- in
- fun 'a topLevelHandler (exn: exn): 'a =
- (message (concat ["unhandled exception: ", exnMessage exn, "\n"])
- ; (case history exn of
- [] => ()
- | l =>
- (message "with history:\n"
- ; (List.app (fn s => message (concat ["\t", s, "\n"]))
- l)))
+ fun 'a wrapHandler (handler: exn -> unit) exn : 'a =
+ (handler exn
+ ; message "Top-level handler returned.\n"
; Exit.exit Exit.Status.failure)
- handle _ => (message "Toplevel handler raised exception.\n"
+ handle _ => (message "Top-level handler raised exception.\n"
; Primitive.MLton.halt Exit.Status.failure
- (* The following raise is unreachable, but must be there
- * so that the expression is of type 'a.
- *)
- ; raise Fail "bug")
+ ; raise Fail "MLton.Exn.wrapHandler")
+ in
+ val getTopLevelHandler = Primitive.TopLevel.getHandler
+ val setTopLevelHandler = Primitive.TopLevel.setHandler o wrapHandler
+ fun 'a defaultTopLevelHandler (exn: exn): 'a =
+ wrapHandler
+ (fn exn =>
+ (message (concat ["unhandled exception: ", exnMessage exn, "\n"])
+ ; (case history exn of
+ [] => ()
+ | l =>
+ (message "with history:\n"
+ ; List.app (fn s => message (concat ["\t", s, "\n"])) l))
+ ; Exit.exit Exit.Status.failure))
+ exn
+ fun 'a topLevelHandler (exn: exn) : 'a =
+ (getTopLevelHandler () exn
+ ; raise Fail "MLton.Exn.topLevelHandler")
end
end
Modified: mlton/trunk/basis-library/mlton/mlton.sml
===================================================================
--- mlton/trunk/basis-library/mlton/mlton.sml 2007-07-13 12:54:14 UTC (rev 5773)
+++ mlton/trunk/basis-library/mlton/mlton.sml 2007-07-13 20:02:28 UTC (rev 5774)
@@ -134,7 +134,7 @@
end
val _ =
- (Primitive.TopLevel.setHandler MLtonExn.topLevelHandler
+ (Primitive.TopLevel.setHandler MLtonExn.defaultTopLevelHandler
; Primitive.TopLevel.setSuffix
(fn () => MLtonProcess.exit MLtonProcess.Status.success))
end
Modified: mlton/trunk/basis-library/primitive/check-real.sml
===================================================================
--- mlton/trunk/basis-library/primitive/check-real.sml 2007-07-13 12:54:14 UTC (rev 5773)
+++ mlton/trunk/basis-library/primitive/check-real.sml 2007-07-13 20:02:28 UTC (rev 5774)
@@ -7,7 +7,7 @@
*)
local
- fun 'a check (x: 'a, y: 'a) : unit = ()
+ fun 'a check (_: 'a, _: 'a) : unit = ()
local
structure R1 = Primitive.Real32
Modified: mlton/trunk/basis-library/primitive/prim1.sml
===================================================================
--- mlton/trunk/basis-library/primitive/prim1.sml 2007-07-13 12:54:14 UTC (rev 5773)
+++ mlton/trunk/basis-library/primitive/prim1.sml 2007-07-13 20:02:28 UTC (rev 5774)
@@ -76,6 +76,8 @@
structure TopLevel =
struct
+ val getHandler = _prim "TopLevel_getHandler": unit -> (exn -> unit);
+ val getSuffix = _prim "TopLevel_getSuffix": unit -> (unit -> unit);
val setHandler = _prim "TopLevel_setHandler": (exn -> unit) -> unit;
val setSuffix = _prim "TopLevel_setSuffix": (unit -> unit) -> unit;
end
Modified: mlton/trunk/doc/changelog
===================================================================
--- mlton/trunk/doc/changelog 2007-07-13 12:54:14 UTC (rev 5773)
+++ mlton/trunk/doc/changelog 2007-07-13 20:02:28 UTC (rev 5774)
@@ -1,5 +1,8 @@
Here are the changes since version 20051202.
+* 2007-07-13
+ - Added MLton.Exn.{default,get,set}TopLevelHandler.
+
* 2007-07-12
- Restored native option to -codegen flag.
Modified: mlton/trunk/mlton/atoms/hash-type.fun
===================================================================
--- mlton/trunk/mlton/atoms/hash-type.fun 2007-07-13 12:54:14 UTC (rev 5773)
+++ mlton/trunk/mlton/atoms/hash-type.fun 2007-07-13 20:02:28 UTC (rev 5774)
@@ -344,6 +344,8 @@
| Thread_copyCurrent => done ([], unit)
| Thread_returnToC => done ([], unit)
| Thread_switchTo => done ([thread], unit)
+ | TopLevel_getHandler => done ([unit], arrow (exn, unit))
+ | TopLevel_getSuffix => done ([unit], arrow (unit, unit))
| TopLevel_setHandler => done ([arrow (exn, unit)], unit)
| TopLevel_setSuffix => done ([arrow (unit, unit)], unit)
| Vector_length => oneTarg (fn t => ([vector t], seqIndex))
Modified: mlton/trunk/mlton/atoms/prim.fun
===================================================================
--- mlton/trunk/mlton/atoms/prim.fun 2007-07-13 12:54:14 UTC (rev 5773)
+++ mlton/trunk/mlton/atoms/prim.fun 2007-07-13 20:02:28 UTC (rev 5774)
@@ -151,6 +151,8 @@
* on the stack.
*)
| Thread_switchTo (* ssa to rssa *)
+ | TopLevel_getHandler (* implement exceptions *)
+ | TopLevel_getSuffix (* implement suffix *)
| TopLevel_setHandler (* implement exceptions *)
| TopLevel_setSuffix (* implement suffix *)
| Vector_length (* ssa to rssa *)
@@ -314,6 +316,8 @@
| Thread_copyCurrent => "Thread_copyCurrent"
| Thread_returnToC => "Thread_returnToC"
| Thread_switchTo => "Thread_switchTo"
+ | TopLevel_getHandler => "TopLevel_getHandler"
+ | TopLevel_getSuffix => "TopLevel_getSuffix"
| TopLevel_setHandler => "TopLevel_setHandler"
| TopLevel_setSuffix => "TopLevel_setSuffix"
| Vector_length => "Vector_length"
@@ -459,6 +463,8 @@
| (Thread_copyCurrent, Thread_copyCurrent) => true
| (Thread_returnToC, Thread_returnToC) => true
| (Thread_switchTo, Thread_switchTo) => true
+ | (TopLevel_getHandler, TopLevel_getHandler) => true
+ | (TopLevel_getSuffix, TopLevel_getSuffix) => true
| (TopLevel_setHandler, TopLevel_setHandler) => true
| (TopLevel_setSuffix, TopLevel_setSuffix) => true
| (Vector_length, Vector_length) => true
@@ -614,6 +620,8 @@
| Thread_copyCurrent => Thread_copyCurrent
| Thread_returnToC => Thread_returnToC
| Thread_switchTo => Thread_switchTo
+ | TopLevel_getHandler => TopLevel_getHandler
+ | TopLevel_getSuffix => TopLevel_getSuffix
| TopLevel_setHandler => TopLevel_setHandler
| TopLevel_setSuffix => TopLevel_setSuffix
| Vector_length => Vector_length
@@ -854,6 +862,8 @@
| Thread_copyCurrent => SideEffect
| Thread_returnToC => SideEffect
| Thread_switchTo => SideEffect
+ | TopLevel_getHandler => DependsOnState
+ | TopLevel_getSuffix => DependsOnState
| TopLevel_setHandler => SideEffect
| TopLevel_setSuffix => SideEffect
| Vector_length => Functional
@@ -1024,6 +1034,8 @@
Thread_copyCurrent,
Thread_returnToC,
Thread_switchTo,
+ TopLevel_getHandler,
+ TopLevel_getSuffix,
TopLevel_setHandler,
TopLevel_setSuffix,
Vector_length,
Modified: mlton/trunk/mlton/atoms/prim.sig
===================================================================
--- mlton/trunk/mlton/atoms/prim.sig 2007-07-13 12:54:14 UTC (rev 5773)
+++ mlton/trunk/mlton/atoms/prim.sig 2007-07-13 20:02:28 UTC (rev 5774)
@@ -141,6 +141,8 @@
* on the stack.
*)
| Thread_switchTo (* ssa to rssa *)
+ | TopLevel_getHandler (* implement exceptions *)
+ | TopLevel_getSuffix (* implement suffix *)
| TopLevel_setHandler (* implement exceptions *)
| TopLevel_setSuffix (* implement suffix *)
| Vector_length (* ssa to ssa2 *)
Modified: mlton/trunk/mlton/xml/implement-exceptions.fun
===================================================================
--- mlton/trunk/mlton/xml/implement-exceptions.fun 2007-07-13 12:54:14 UTC (rev 5773)
+++ mlton/trunk/mlton/xml/implement-exceptions.fun 2007-07-13 20:02:28 UTC (rev 5774)
@@ -428,6 +428,11 @@
| PrimApp {args, prim, ...} =>
let
datatype z = datatype Prim.Name.t
+ fun deref (var, ty) =
+ primExp
+ (PrimApp {prim = Prim.deref,
+ targs = Vector.new1 ty,
+ args = Vector.new1 (VarExp.mono var)})
fun assign (var, ty) =
primExp
(PrimApp {prim = Prim.assign,
@@ -444,6 +449,9 @@
| Exn_setExtendExtra =>
assign (extendExtraVar, extendExtraType)
| Exn_setInitExtra => primExp (Tuple (Vector.new0 ()))
+ | TopLevel_getHandler =>
+ deref (topLevelHandler,
+ Type.arrow (Type.exn, Type.unit))
| TopLevel_setHandler =>
assign (topLevelHandler,
Type.arrow (Type.exn, Type.unit))
Modified: mlton/trunk/mlton/xml/implement-suffix.fun
===================================================================
--- mlton/trunk/mlton/xml/implement-suffix.fun 2007-07-13 12:54:14 UTC (rev 5773)
+++ mlton/trunk/mlton/xml/implement-suffix.fun 2007-07-13 20:02:28 UTC (rev 5774)
@@ -63,6 +63,11 @@
| PrimApp {args, prim, ...} =>
let
datatype z = datatype Prim.Name.t
+ fun deref (var, ty) =
+ primExp
+ (PrimApp {prim = Prim.deref,
+ targs = Vector.new1 ty,
+ args = Vector.new1 (VarExp.mono var)})
fun assign (var, ty) =
primExp
(PrimApp {prim = Prim.assign,
@@ -71,7 +76,10 @@
Vector.sub (args, 0))})
in
case Prim.name prim of
- TopLevel_setSuffix =>
+ TopLevel_getSuffix =>
+ deref (topLevelSuffix,
+ Type.arrow (Type.unit, Type.unit))
+ | TopLevel_setSuffix =>
assign (topLevelSuffix,
Type.arrow (Type.unit, Type.unit))
| _ => keep ()
More information about the MLton-commit
mailing list