[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