[MLton] cvs commit: warnExnMatch annotation
Matthew Fluet
fluet@mlton.org
Tue, 26 Jul 2005 11:41:51 -0700
fluet 05/07/26 11:41:50
Modified: mlton/ast prim-tycons.fun prim-tycons.sig
mlton/control control-flags.sig control-flags.sml
mlton/elaborate elaborate-core.fun type-env.fun type-env.sig
Log:
MAIL warnExnMatch annotation
Incorporated Vesa Karvonen's patch to suppress redundant/inexhaustive
match warnings for patterns of exception type.
I made one change, replaced:
+ warnMatch ()
+ andalso (not (1 = Vector.length argTypes
+ andalso Type.isExn
+ (Vector.sub (argTypes, 0)))
+ orelse warnExnMatch ())}
with the equivalent
+ warnMatch ()
+ andalso (not (Type.isExn
+ (Type.tuple argTypes))
+ orelse warnExnMatch ())}
Revision Changes Path
1.30 +3 -0 mlton/mlton/ast/prim-tycons.fun
Index: prim-tycons.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/prim-tycons.fun,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- prim-tycons.fun 19 Jun 2005 21:33:41 -0000 1.29
+++ prim-tycons.fun 26 Jul 2005 18:41:48 -0000 1.30
@@ -31,6 +31,9 @@
datatype z = datatype Kind.t
datatype z = datatype AdmitsEquality.t
+val isBool = fn c => equals (c, bool)
+val isExn = fn c => equals (c, exn)
+
local
fun 'a make (prefix: string,
all: 'a list,
1.17 +2 -0 mlton/mlton/ast/prim-tycons.sig
Index: prim-tycons.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/prim-tycons.sig,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- prim-tycons.sig 14 Jan 2005 01:23:36 -0000 1.16
+++ prim-tycons.sig 26 Jul 2005 18:41:48 -0000 1.17
@@ -45,7 +45,9 @@
val int: IntSize.t -> tycon
val ints: (tycon * IntSize.t) vector
val intInf: tycon
+ val isBool: tycon -> bool
val isCharX: tycon -> bool
+ val isExn: tycon -> bool
val isIntX: tycon -> bool
val isRealX: tycon -> bool
val isWordX: tycon -> bool
1.5 +1 -0 mlton/mlton/control/control-flags.sig
Index: control-flags.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control-flags.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- control-flags.sig 23 Jul 2005 11:55:39 -0000 1.4
+++ control-flags.sig 26 Jul 2005 18:41:49 -0000 1.5
@@ -72,6 +72,7 @@
(* in (e1; e2), require e1: unit. *)
val sequenceUnit: (bool,bool) t
val warnMatch: (bool,bool) t
+ val warnExnMatch: (bool,bool) t
val warnUnused: (bool,bool) t
val current: ('args, 'st) t -> 'st
1.6 +2 -0 mlton/mlton/control/control-flags.sml
Index: control-flags.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control-flags.sml,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- control-flags.sml 23 Jul 2005 11:55:39 -0000 1.5
+++ control-flags.sml 26 Jul 2005 18:41:49 -0000 1.6
@@ -334,6 +334,8 @@
makeBool ({name = "sequenceUnit", default = false, expert = false}, ac)
val (warnMatch, ac) =
makeBool ({name = "warnMatch", default = true, expert = false}, ac)
+ val (warnExnMatch, ac) =
+ makeBool ({name = "warnExnMatch", default = true, expert = false}, ac)
val (warnUnused, ac) =
makeBool ({name = "warnUnused", default = false, expert = false}, ac)
val {parseId, parseIdAndArgs, withDef, snapshot} = ac
1.154 +23 -17 mlton/mlton/elaborate/elaborate-core.fun
Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.153
retrieving revision 1.154
diff -u -r1.153 -r1.154
--- elaborate-core.fun 23 Jul 2005 11:55:40 -0000 1.153
+++ elaborate-core.fun 26 Jul 2005 18:41:49 -0000 1.154
@@ -17,6 +17,7 @@
val allowRebindEquals = fn () => current allowRebindEquals
val sequenceUnit = fn () => current sequenceUnit
val warnMatch = fn () => current warnMatch
+ val warnExnMatch = fn () => current warnExnMatch
end
local
@@ -996,10 +997,7 @@
(region, str "invalid type for _symbol object",
Type.layoutPretty elabedCbTy)
; CType.Pointer)
- val isBool =
- case Type.deConOpt expandedCbTy of
- NONE => false
- | SOME (c,_) => Tycon.equals (c, Tycon.bool)
+ val isBool = Type.isBool expandedCbTy
val ctypePtrTy =
case Type.toCType expandedPtrTy of
SOME {ctype = CType.Pointer, ...} => CType.Pointer
@@ -1057,10 +1055,7 @@
(region, str "invalid type for _symbol object",
Type.layoutPretty elabedCbTy)
; CType.Pointer)
- val isBool =
- case Type.deConOpt expandedCbTy of
- NONE => false
- | SOME (c,_) => Tycon.equals (c, Tycon.bool)
+ val isBool = Type.isBool expandedCbTy
val ctypePtrTy =
case Type.toCType expandedPtrTy of
SOME {ctype = CType.Pointer, ...} => CType.Pointer
@@ -1137,10 +1132,7 @@
(region, str "invalid type for import",
Type.layoutPretty elabedCbTy)
; CType.Pointer)
- val isBool =
- case Type.deConOpt expandedCbTy of
- NONE => false
- | SOME (c,_) => Tycon.equals (c, Tycon.bool)
+ val isBool = Type.isBool expandedCbTy
val addrExp =
address {ctypeCbTy = ctypeCbTy,
expandedPtrTy = Type.word (WordSize.pointer ()),
@@ -1909,7 +1901,11 @@
Cexp.tuple
(Vector.map2
(xs, argTypes, Cexp.var)),
- warnMatch = warnMatch ()}
+ warnMatch =
+ warnMatch ()
+ andalso (not (Type.isExn
+ (Type.tuple argTypes))
+ orelse warnExnMatch ())}
in
Cexp.enterLeave
(e, profileBody, sourceInfo)
@@ -2106,7 +2102,9 @@
region = region,
rules = rules,
test = Cexp.var (arg, argType),
- warnMatch = warnMatch ()},
+ warnMatch = warnMatch ()
+ andalso (not (Type.isExn argType)
+ orelse warnExnMatch ())},
profileBody,
fn () => SourceInfo.function {name = nest,
region = region})
@@ -2197,7 +2195,11 @@
(Cdec.Val {rvbs = rvbs,
tyvars = bound,
vbs = vbs,
- warnMatch = warnMatch ()})
+ warnMatch = warnMatch ()
+ andalso (not (Vector.forall
+ (vbs,
+ Type.isExn o Cexp.ty o #exp))
+ orelse warnExnMatch ())})
end
end) arg
and elabExp (arg: Aexp.t * Nest.t * string option): Cexp.t =
@@ -2279,7 +2281,9 @@
region = region,
rules = rules,
test = e,
- warnMatch = warnMatch ()}
+ warnMatch = warnMatch ()
+ andalso (not (Type.isExn argType)
+ orelse warnExnMatch ())}
end
| Aexp.Const c =>
elabConst
@@ -2911,7 +2915,9 @@
region = region,
rules = rules,
test = Cexp.var (arg, argType),
- warnMatch = warnMatch ()}
+ warnMatch = warnMatch ()
+ andalso (not (Type.isExn argType)
+ orelse warnExnMatch ())}
in
{arg = arg,
argType = argType,
1.57 +10 -0 mlton/mlton/elaborate/type-env.fun
Index: type-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.fun,v
retrieving revision 1.56
retrieving revision 1.57
diff -u -r1.56 -r1.57
--- type-env.fun 19 Jun 2005 21:33:58 -0000 1.56
+++ type-env.fun 26 Jul 2005 18:41:49 -0000 1.57
@@ -768,11 +768,21 @@
val unit = tuple (Vector.new0 ())
+ fun isBool t =
+ case toType t of
+ Con (c, _) => Tycon.isBool c
+ | _ => false
+
fun isCharX t =
case toType t of
Con (c, _) => Tycon.isCharX c
| Overload Overload.Char => true
| _ => false
+
+ fun isExn t =
+ case toType t of
+ Con (c, _) => Tycon.isExn c
+ | _ => false
fun isInt t =
case toType t of
1.30 +2 -0 mlton/mlton/elaborate/type-env.sig
Index: type-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.sig,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- type-env.sig 20 May 2005 16:34:27 -0000 1.29
+++ type-env.sig 26 Jul 2005 18:41:49 -0000 1.30
@@ -37,7 +37,9 @@
record: 'a SortedRecord.t -> 'a,
replaceSynonyms: bool,
var: Tyvar.t -> 'a} -> 'a
+ val isBool: t -> bool
val isCharX: t -> bool
+ val isExn: t -> bool
val isInt: t -> bool
val isUnit: t -> bool
val layout: t -> Layout.t