[MLton] cvs commit: added -default-ann switch

Matthew Fluet fluet@mlton.org
Tue, 3 Aug 2004 20:15:12 -0700


fluet       04/08/03 20:15:11

  Modified:    doc/examples/ffi Makefile
               doc/examples/finalizable Makefile
               mlton/control control.sig control.sml
               mlton/elaborate elaborate-core.fun elaborate-core.sig
                        elaborate-env.fun elaborate-env.sig
                        elaborate-mlbs.fun elaborate-mlbs.sig
                        elaborate-modules.fun elaborate-modules.sig
                        elaborate-programs.fun elaborate-programs.sig
                        elaborate.fun elaborate.sig sources.cm
               mlton/main compile.fun main.fun
  Removed:     mlton/elaborate elaborate-controls.fun
                        elaborate-controls.sig
  Log:
  MAIL added -default-ann switch
  
  Deprecated the following switches:
      -allow-export {false|true}
      -allow-import {false|true}
      -dead-code {true|false}
      -sequence-unit {false|true}
      -warn-match {true|false}
      -warn-unused {false|true}
  and replaced them with a single switch
      -default-ann <anns>
  so that instead of writing
      -allow-export true -sequence-unit true
  one would write
      -ann 'allowExport true, sequenceUnit true'
  
  Extended -{enable,disable}-ann to accept a comma delimited list of
  annotations to enable and disable.
  
  In doing so, migrated Elaborate.Ctrls to Control.Elaborate, which
  makes the controls accessible to Main.  Also moved all recognizing of
  annotation names and options into Control.Elaborate, which will ensure
  consistency between MLBs annotations and command line annotations.
  
  Not all annotations are accessible from the command line.  In
  particuler, the "expert" annotations allowConstant, allowPrim,
  allowOverload, allowRebindEquals cannot be defaulted or disabled.
  Also, the forceUsed annotation is not accessible from the command line
  -- it's not clear what effect defaulting or disabling it should have,
  although I may reconsider this choice.  Finally, the deadCode
  annotation can both be disabled and defaulted from the command-line.
  Disabling it gives the behavior of -dead-code false.  But, beware:
  compiling with -default-ann 'deadCode true' will have serious semantic
  consequences.  All other annotations are fully accessible from the
  command line.

Revision  Changes    Path
1.12      +1 -1      mlton/doc/examples/ffi/Makefile

Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/ffi/Makefile,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- Makefile	31 Jul 2004 02:04:46 -0000	1.11
+++ Makefile	4 Aug 2004 03:15:08 -0000	1.12
@@ -1,6 +1,6 @@
 PATH = ../../../build/bin:$(shell echo $$PATH)
 
-mlton = mlton -allow-export true -allow-import true
+mlton = mlton -default-ann 'allowExport true, allowImport true'
 
 .PHONY: all
 all: import export



1.5       +1 -1      mlton/doc/examples/finalizable/Makefile

Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/finalizable/Makefile,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- Makefile	31 Jul 2004 16:12:32 -0000	1.4
+++ Makefile	4 Aug 2004 03:15:09 -0000	1.5
@@ -1,6 +1,6 @@
 PATH = ../../../build/bin:$(shell echo $$PATH)
 
-mlton = mlton -allow-import true
+mlton = mlton -default-ann 'allowImport true'
 
 all:
 	$(mlton) finalizable.sml cons.c



1.106     +27 -17    mlton/mlton/control/control.sig

Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.105
retrieving revision 1.106
diff -u -r1.105 -r1.106
--- control.sig	29 Jul 2004 21:56:55 -0000	1.105
+++ control.sig	4 Aug 2004 03:15:09 -0000	1.106
@@ -21,11 +21,6 @@
       datatype align = Align4 | Align8
       val align: align ref
 
-      val allowExportAnn : bool ref
-      val allowExportDef : bool ref
-      val allowImportAnn : bool ref
-      val allowImportDef : bool ref
-
       val atMLtons: string vector ref
 
       val basisLibs: string list
@@ -52,8 +47,6 @@
 
       val contifyIntoMain: bool ref
 
-      val deadCodeAnn: bool ref
-	 
       (* Generate an executable with debugging info. *)
       val debug: bool ref
 
@@ -68,6 +61,33 @@
       (* List of optimization passes to skip. *)
       val dropPasses: Regexp.Compiled.t list ref
 
+      structure Elaborate :
+	 sig
+	    type 'a t
+
+	    val allowConstant: bool t
+	    val allowExport: bool t
+	    val allowImport: bool t
+	    val allowOverload: bool t
+	    val allowPrim: bool t
+	    val allowRebindEquals: bool t
+	    val deadCode: bool t
+	    val forceUsed: int t
+	    (* in (e1; e2), require e1: unit. *)
+	    val sequenceUnit: bool t
+	    val warnMatch: bool t
+	    val warnUnused: bool t
+
+	    val current: 'a t -> 'a
+	    val default: 'a t -> 'a ref
+	    val enabled: 'a t -> bool ref
+
+	    val withDef: (unit -> 'a) -> 'a
+	    val withAnn: string list -> (unit -> unit) option
+	    val setDef: string list -> bool
+	    val setAble: bool * string -> bool
+	 end
+
       (* stop after elaboration.  So, no need for the elaborator to generate
        * valid CoreML.
        *)
@@ -234,10 +254,6 @@
       (* Array bounds checking. *)
       val safe: bool ref
 
-      (* in (e1; e2), require e1: unit. *)
-      val sequenceUnitAnn: bool ref
-      val sequenceUnitDef: bool ref
-
       (* Show the basis library. *)
       val showBasis: File.t option ref
 	 
@@ -296,12 +312,6 @@
       val version: string
 
       val warnAnn: bool ref
-
-      val warnMatchAnn: bool ref
-      val warnMatchDef: bool ref
-
-      val warnUnusedAnn: bool ref
-      val warnUnusedDef: bool ref
 
       (* XML Passes *)
       val xmlPassesSet: (string -> string list Result.t) ref



1.132     +186 -40   mlton/mlton/control/control.sml

Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.131
retrieving revision 1.132
diff -u -r1.131 -r1.132
--- control.sml	29 Jul 2004 21:56:55 -0000	1.131
+++ control.sml	4 Aug 2004 03:15:09 -0000	1.132
@@ -26,20 +26,6 @@
 		     default = Align4,
 		     toString = Align.toString}
 
-val allowExportAnn = control {name = "allow _export (annotation)",
-			      default = true,
-			      toString = Bool.toString}
-val allowExportDef = control {name = "allow _export",
-			      default = false,
-			      toString = Bool.toString}
-val allowImportAnn = control {name = "allow _import (annotation)",
-			      default = true,
-			      toString = Bool.toString}
-val allowImportDef = control {name = "allow _import",
-			      default = false,
-			      toString = Bool.toString}
-
-
 val atMLtons = control {name = "atMLtons",
 			default = Vector.new0 (),
 			toString = fn v => Layout.toString (Vector.layout
@@ -97,10 +83,6 @@
 			       default = false,
 			       toString = Bool.toString}
 
-val deadCodeAnn = control {name = "dead code (annotation)",
-			   default = true,
-			   toString = Bool.toString}
-   
 val debug = control {name = "debug",
 		     default = false,
 		     toString = Bool.toString}
@@ -127,6 +109,191 @@
 	               (Layout.toString o
 			Regexp.Compiled.layout)}
 
+structure Elaborate =
+   struct
+      datatype 'a t = T of {cur: 'a ref,
+			    def: 'a ref,
+			    enabled: bool ref}
+      fun current (T {cur, ...}) = !cur
+      fun default (T {def, ...}) = def
+      fun enabled (T {enabled, ...}) = enabled
+
+      local
+	 fun make {name: string, 
+		   default: 'a, 
+		   toString: 'a -> string,
+		   expert: bool,
+		   options: string list -> 'b option,
+		   newCur: 'a * 'b -> 'a,
+		   newDef: 'a * 'b -> 'a,
+		   withDef: unit -> (unit -> unit),
+		   withAnn: string list -> (unit -> unit) option,
+		   setDef: string list -> bool,
+		   setAble: bool * string -> bool} =
+	    let
+	       val ctrl as T {cur, def, enabled} =
+		  T {cur = ref default,
+		     def = control {name = concat ["elaborate ",name,
+						   " (default)"],
+				    default = default,
+				    toString = toString},
+		     enabled = control {name = concat ["elaborate ",name,
+						       " (enabled)"],
+					default = true,
+					toString = Bool.toString}}
+	       val withDef : unit -> (unit -> unit) =
+		  fn () =>
+		  let
+		     val restore = withDef ()
+		     val old = !cur
+		  in
+		     cur := !def
+		     ; fn () => (cur := old
+				 ; restore ())
+		  end
+	       val withAnn : string list -> (unit -> unit) option = 
+		  fn ss' =>
+		  case ss' of
+		     s::ss => 
+			if String.equals(s, name)
+			   then 
+			      case options ss of
+				 SOME v => 
+				    if !enabled
+				       then let
+					       val old = !cur
+					       val new = newCur (old, v)
+					    in
+					       cur := new
+					       ; SOME (fn () => cur := old)
+					    end
+				       else SOME (fn () => ())
+			       | NONE => NONE
+			   else withAnn ss'
+		   | _ => NONE
+	       val setDef : string list -> bool =
+		  if expert
+		     then setDef
+		  else
+		  fn ss' =>
+		  case ss' of
+		     s::ss => if String.equals(s, name)
+				 then 
+				    case options ss of
+				       SOME v => 
+					  let
+					     val old = !def
+					     val new = newDef (old, v)
+					  in
+					     def := new
+					     ; true
+					  end
+				     | NONE => false
+				 else setDef ss'
+		   | _ => false
+	       val setAble : bool * string -> bool =
+		  if expert
+		     then setAble
+		  else
+		  fn (b, s) =>
+		  if String.equals(s, name)
+		     then (enabled := b; true)
+		     else setAble (b, s)
+	    in
+	       {ctrl = ctrl,
+		withDef = withDef,
+		withAnn = withAnn,
+		setDef = setDef,
+		setAble = setAble}
+	    end
+
+	 fun makeBool {name, default, expert,
+		       withDef: unit -> (unit -> unit),
+		       withAnn: string list -> (unit -> unit) option,
+		       setDef: string list -> bool,
+		       setAble: bool * string -> bool} =
+	    make {name = name,
+		  default = default, 
+		  toString = Bool.toString,
+		  expert = expert,
+		  options = fn ss => 
+		    case ss of 
+		       [s] => Bool.fromString s 
+		     | _ => NONE,
+		  newCur = fn (_,b) => b,
+		  newDef = fn (_,b) => b,
+		  withDef = withDef, withAnn = withAnn,
+		  setDef = setDef, setAble = setAble}
+      in
+	 val {withDef, withAnn, setDef, setAble} =
+	    {withDef = fn () => (fn () => ()),
+	     withAnn = fn _ => NONE,
+	     setDef = fn _ => false,
+	     setAble = fn _ => false}
+	 val {ctrl = allowConstant, withDef, withAnn, setDef, setAble} =
+	    makeBool {name = "allowConstant", default = false, expert = true,
+		      withDef = withDef, withAnn = withAnn,
+		      setDef = setDef, setAble = setAble}
+	 val {ctrl = allowExport, withDef, withAnn, setDef, setAble} =
+	    makeBool {name = "allowExport", default = false, expert = false,
+		      withDef = withDef, withAnn = withAnn,
+		      setDef = setDef, setAble = setAble}
+	 val {ctrl = allowImport, withDef, withAnn, setDef, setAble} =
+	    makeBool {name = "allowImport", default = false, expert = false,
+		      withDef = withDef, withAnn = withAnn,
+		      setDef = setDef, setAble = setAble}
+	 val {ctrl = allowPrim, withDef, withAnn, setDef, setAble} =
+	    makeBool {name = "allowPrim", default = false, expert = true,
+		      withDef = withDef, withAnn = withAnn,
+		      setDef = setDef, setAble = setAble}
+	 val {ctrl = allowOverload, withDef, withAnn, setDef, setAble} =
+	    makeBool {name = "allowOverload", default = false, expert = true,
+		      withDef = withDef, withAnn = withAnn,
+		      setDef = setDef, setAble = setAble}
+	 val {ctrl = allowRebindEquals, withDef, withAnn, setDef, setAble} =
+	    makeBool {name = "allowRebindEquals", default = false, expert = true,
+		      withDef = withDef, withAnn = withAnn,
+		      setDef = setDef, setAble = setAble}
+	 val {ctrl = deadCode, withDef, withAnn, setDef, setAble} =
+	    makeBool {name = "deadCode", default = false, expert = false,
+		      withDef = withDef, withAnn = withAnn,
+		      setDef = setDef, setAble = setAble}
+	 val {ctrl = forceUsed, withDef, withAnn, setDef, setAble} =
+	    make {name = "forceUsed",
+		  default = 0, 
+		  toString = Int.toString,
+		  expert = true,
+		  options = fn ss => 
+		    case ss of 
+		       [] => SOME ()
+		     | _ => NONE,
+		  newCur = fn (i,()) => i + 1,
+		  newDef = fn (_,()) => 0,
+		  withDef = withDef, withAnn = withAnn,
+		  setDef = setDef, setAble = setAble}
+	 val {ctrl = sequenceUnit, withDef, withAnn, setDef, setAble} =
+	    makeBool {name = "sequenceUnit", default = false, expert = false,
+		      withDef = withDef, withAnn = withAnn,
+		      setDef = setDef, setAble = setAble}
+	 val {ctrl = warnMatch, withDef, withAnn, setDef, setAble} =
+	    makeBool {name = "warnMatch", default = true, expert = false,
+		      withDef = withDef, withAnn = withAnn,
+		      setDef = setDef, setAble = setAble}
+	 val {ctrl = warnUnused, withDef, withAnn, setDef, setAble} =
+	    makeBool {name = "warnUnused", default = false, expert = false,
+		      withDef = withDef, withAnn = withAnn,
+		      setDef = setDef, setAble = setAble}
+      end
+
+      val withDef : (unit -> 'a) -> 'a = fn f =>
+	 let val restore = withDef ()
+	 in DynamicWind.wind (f, restore)
+	 end
+      val withAnn = withAnn
+      val setDef = setDef
+      val setAble = setAble
+   end
+
 val elaborateOnly =
    control {name = "elaborate only",
 	    default = false,
@@ -447,13 +614,6 @@
 		    default = true,
 		    toString = Bool.toString}
 
-val sequenceUnitAnn = control {name = "sequence unit (annotation)",
-			       default = true,
-			       toString = Bool.toString}
-val sequenceUnitDef = control {name = "sequence unit (default)",
-			       default = false,
-			       toString = Bool.toString}
-
 val showBasis = control {name = "show basis",
 			 default = NONE,
 			 toString = Option.toString File.toString}
@@ -584,23 +744,9 @@
 
 val version = "MLton MLTONVERSION"
 
-val warnAnn = control {name = "warn annotation",
+val warnAnn = control {name = "warn unrecognized annotation",
 		       default = true,
 		       toString = Bool.toString}
-
-val warnMatchAnn = control {name = "warn match (annotation)",
-			    default = true,
-			    toString = Bool.toString}
-val warnMatchDef = control {name = "warn match (default)",
-			    default = true,
-			    toString = Bool.toString}
-
-val warnUnusedAnn = control {name = "warn unused (annotation)",
-			     default = true,
-			     toString = Bool.toString}
-val warnUnusedDef = control {name = "warn unused (default)",
-			     default = false,
-			     toString = Bool.toString}
 
 val xmlPassesSet: (string -> string list Result.t) ref = 
    control {name = "xmlPassesSet",



1.112     +32 -16    mlton/mlton/elaborate/elaborate-core.fun

Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.111
retrieving revision 1.112
diff -u -r1.111 -r1.112
--- elaborate-core.fun	28 Jul 2004 21:05:12 -0000	1.111
+++ elaborate-core.fun	4 Aug 2004 03:15:09 -0000	1.112
@@ -11,6 +11,22 @@
 open S
 
 local
+   open Control.Elaborate
+in
+   val allowConstant = fn () => current allowConstant
+   val allowExport = fn () => current allowExport
+   val allowImport = fn () => current allowImport
+   val allowPrim = fn () => current allowPrim
+   val allowOverload = fn () => current allowOverload
+   val allowRebindEquals = fn () => current allowRebindEquals
+   val sequenceUnit = fn () => current sequenceUnit
+   val warnMatch = fn () => current warnMatch
+   val warnUnused = fn () => current warnUnused
+end
+val lookupConstant : (string * ConstType.t -> CoreML.Const.t) ref = 
+   ref (fn _ => Error.bug "lookupConstant not set")
+
+local
    open Ast
 in
    structure Acon = Con
@@ -323,7 +339,7 @@
    val eq = Avar.fromSymbol (Symbol.equal, Region.bogus)
 in
    fun ensureNotEquals x =
-      if not (!Ctrls.allowRebindEquals) andalso Avar.equals (x, eq)
+      if not (allowRebindEquals ()) andalso Avar.equals (x, eq)
 	 then
 	    let
 	       open Layout
@@ -1502,7 +1518,7 @@
 					     Cexp.tuple
 					     (Vector.map2
 					      (xs, argTypes, Cexp.var)),
-					     warnMatch = !Ctrls.warnMatch}
+					     warnMatch = warnMatch ()}
 				      in
 					 Cexp.enterLeave (e, sourceInfo)
 				      end
@@ -1580,7 +1596,7 @@
 		      Decs.empty
 		   end
 	      | Adec.Overload (p, x, tyvars, ty, xs) =>
-		   (if not (!Ctrls.allowOverload)
+		   (if not (allowOverload ())
 		       then let open Layout
 			    in Control.error (region, str "_overload disallowed", empty)
 			    end
@@ -1731,7 +1747,7 @@
 					     region = region,
 					     rules = rules,
 					     test = Cexp.var (arg, argType),
-					     warnMatch = !Ctrls.warnMatch},
+					     warnMatch = warnMatch ()},
 				 fn () => SourceInfo.function {name = nest,
 							       region = region})
 			     val lambda =
@@ -1810,7 +1826,7 @@
 		      Decs.single (Cdec.Val {rvbs = rvbs,
 					     tyvars = bound,
 					     vbs = vbs,
-					     warnMatch = !Ctrls.warnMatch})
+					     warnMatch = warnMatch ()})
 		   end
 	  end) arg
       and elabExp (arg: Aexp.t * Nest.t * string option): Cexp.t =
@@ -1892,7 +1908,7 @@
 				  region = region,
 				  rules = rules,
 				  test = e,
-				  warnMatch = !Ctrls.warnMatch}
+				  warnMatch = warnMatch ()}
 		   end
 	      | Aexp.Const c =>
 		   elabConst
@@ -2118,7 +2134,7 @@
 						(Cpat.tuple
 						 (Vector.map (vars, Cpat.var)))},
 					       test = Cexp.var (arg, argType),
-					       warnMatch = !Ctrls.warnMatch}
+					       warnMatch = warnMatch ()}
 					   end
 			       in
 				  Cexp.make (Cexp.Lambda
@@ -2168,7 +2184,7 @@
 					     else
 						bug ()
 				  val finish =
-				     let val lookupConstant = !Ctrls.lookupConstant
+				     let val lookupConstant = !lookupConstant
 				     in fn () => lookupConstant (name, ct)
 				     end
 			       in
@@ -2179,17 +2195,17 @@
 		   in
 		      case kind of
 			 BuildConst => 
-			    (if not (!Ctrls.allowConstant)
+			    (if not (allowConstant ())
 				then disallowed "_build_const"
 				else ()
 			     ; lookConst name)
 		       | Const => 
-			    (if not (!Ctrls.allowConstant)
+			    (if not (allowConstant ())
 				then disallowed "_const"
 				else ()
 			     ; lookConst name)
 		       | Export attributes =>
-			    (if not (!Ctrls.allowExport)
+			    (if not (allowExport ())
 				then disallowed "_export"
 				else ()
 			     ; let
@@ -2221,7 +2237,7 @@
 				  wrap (e, Type.arrow (ty, Type.unit))
 			       end)
 		       | Import attributes =>
-			    (if not (!Ctrls.allowImport)
+			    (if not (allowImport ())
 				then disallowed "_import"
 				else ()
 			     ; eta (import {attributes = attributes,
@@ -2229,7 +2245,7 @@
 					    region = region,
 					    ty = expandedTy}))
 		       | Prim => 
-			    (if not (!Ctrls.allowPrim)
+			    (if not (allowPrim ())
 				then disallowed "_prim"
 				else ()
 			     ; eta (Prim.fromString name))
@@ -2268,7 +2284,7 @@
 		       * unit.
 		       *)
 		      val _ =
-			 if not (!Ctrls.sequenceUnit)
+			 if not (sequenceUnit ())
 			    then ()
 			 else
 			    Vector.foreachi
@@ -2354,7 +2370,7 @@
 		      val expr = elab expr
 		      (* Error if expr is not of type unit. *)
 		      val _ =
-			 if not (!Ctrls.sequenceUnit)
+			 if not (sequenceUnit ())
 			    then ()
 			 else
 			    unify (Cexp.ty expr, Type.unit, fn (l, _) =>
@@ -2376,7 +2392,7 @@
 			   region = region,
 			   rules = rules,
 			   test = Cexp.var (arg, argType),
-			   warnMatch = !Ctrls.warnMatch}
+			   warnMatch = warnMatch ()}
 	 in
 	   {arg = arg,
 	    argType = argType,



1.10      +3 -4      mlton/mlton/elaborate/elaborate-core.sig

Index: elaborate-core.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.sig,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- elaborate-core.sig	28 Jul 2004 21:05:12 -0000	1.9
+++ elaborate-core.sig	4 Aug 2004 03:15:09 -0000	1.10
@@ -12,13 +12,11 @@
       structure Ast: AST
       structure ConstType: CONST_TYPE
       structure CoreML: CORE_ML
-      structure Ctrls: ELABORATE_CONTROLS
       structure Decs: DECS
       structure Env: ELABORATE_ENV
-      sharing Ast = Ctrls.Ast = Env.Ast
+      sharing Ast = Env.Ast
       sharing Ast.Tyvar = CoreML.Tyvar
-      sharing ConstType = Ctrls.ConstType
-      sharing CoreML = Ctrls.CoreML = Decs.CoreML = Env.CoreML
+      sharing CoreML = Decs.CoreML = Env.CoreML
       sharing Decs = Env.Decs
    end
 
@@ -30,5 +28,6 @@
       val elaborateDec:
 	 Ast.Dec.t * {env: Env.t, nest: string list}
 	 -> Decs.t
+      val lookupConstant: (string * ConstType.t -> CoreML.Const.t) ref
       val reportUndeterminedTypes: unit -> unit
    end



1.97      +10 -3     mlton/mlton/elaborate/elaborate-env.fun

Index: elaborate-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.fun,v
retrieving revision 1.96
retrieving revision 1.97
diff -u -r1.96 -r1.97
--- elaborate-env.fun	28 Jul 2004 21:05:12 -0000	1.96
+++ elaborate-env.fun	4 Aug 2004 03:15:09 -0000	1.97
@@ -13,6 +13,13 @@
 type int = Int.t
 
 local
+   open Control.Elaborate
+in
+   val warnMatch = fn () => current warnMatch
+   val warnUnused = fn () => current warnUnused
+end
+
+local
    open Ast
 in
    structure Basid = Basid
@@ -1656,7 +1663,7 @@
 			val uses = NameSpace.newUses (vals, Class.Con,
 						      Ast.Vid.fromCon name)
 			val () = 
-			   if not (!Ctrls.warnUnused) orelse forceUsed
+			   if not (warnUnused ()) orelse forceUsed
 			      then Uses.forceUsed uses
 			      else ()
 		     in
@@ -1879,7 +1886,7 @@
 	 let
 	    val u = NameSpace.newUses (ns, class range, domain)
 	    val () = 
-	       if not (!Ctrls.warnUnused) orelse forceUsed
+	       if not (warnUnused ()) orelse forceUsed
 		  then Uses.forceUsed u
 		  else ()
 	 in
@@ -2734,7 +2741,7 @@
 					      lay = fn _ => Layout.empty,
 					      pat = Pat.var (x, strType),
 					      patRegion = region}),
-				      warnMatch = !Ctrls.warnMatch})
+				      warnMatch = warnMatch ()})
 		      in
 			 Vid.Var x
 		      end



1.34      +0 -3      mlton/mlton/elaborate/elaborate-env.sig

Index: elaborate-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.sig,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- elaborate-env.sig	28 Jul 2004 21:05:12 -0000	1.33
+++ elaborate-env.sig	4 Aug 2004 03:15:09 -0000	1.34
@@ -9,13 +9,10 @@
    sig
       structure Ast: AST
       structure CoreML: CORE_ML
-      structure Ctrls: ELABORATE_CONTROLS
       structure TypeEnv: TYPE_ENV
-      sharing Ast = Ctrls.Ast
       sharing Ast.Record = CoreML.Record
       sharing Ast.SortedRecord = CoreML.SortedRecord
       sharing Ast.Tyvar = CoreML.Tyvar
-      sharing CoreML = Ctrls.CoreML
       sharing CoreML.Atoms = TypeEnv.Atoms
       sharing CoreML.Type = TypeEnv.Type
    end



1.2       +43 -8     mlton/mlton/elaborate/elaborate-mlbs.fun

Index: elaborate-mlbs.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-mlbs.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- elaborate-mlbs.fun	28 Jul 2004 21:05:13 -0000	1.1
+++ elaborate-mlbs.fun	4 Aug 2004 03:15:09 -0000	1.2
@@ -11,6 +11,41 @@
 open S
 
 local
+   open Control.Elaborate
+in
+   val withDef = withDef
+   fun withAnns (anns, f) =
+      let
+	 val restore = 
+	    List.fold
+	    (anns, fn () => (), fn ((ann,reg), restore) =>
+	     let
+		fun warn () =
+		   if !Control.warnAnn
+		      then let open Layout
+			   in
+			      Control.warning
+			      (reg,
+			       seq [str "unrecognized annotation: ",
+				    (seq o separate) (List.map (ann, str), " ")],
+			       empty)
+			   end
+		      else ()
+	     in
+		case withAnn ann of
+		   SOME restore' => restore o restore'
+		 | NONE => (warn (); restore)
+	     end)
+      in
+	 DynamicWind.wind (f, restore)
+      end
+
+   val allowPrim = fn () => current allowPrim
+   val deadCode = fn () => current deadCode
+   val forceUsed = fn () => current forceUsed
+end
+
+local
    open Ast
 in
    structure Basid = Basid
@@ -28,9 +63,9 @@
 structure ElaboratePrograms = ElaboratePrograms (structure Ast = Ast
 						 structure ConstType = ConstType
 						 structure CoreML = CoreML
-						 structure Ctrls = Ctrls
 						 structure Decs = Decs
 						 structure Env = Env)
+val lookupConstant = ElaboratePrograms.lookupConstant
 
 local
    open ElaboratePrograms
@@ -48,7 +83,7 @@
       val emptySnapshot : (unit -> Env.Basis.t) -> Env.Basis.t = 
 	 Env.snapshot E
       val emptySnapshot = fn f =>
-	 emptySnapshot (fn () => Ctrls.withDefault f)
+	 emptySnapshot (fn () => withDef f)
 	 
       val primBasis =
 	 emptySnapshot
@@ -136,7 +171,7 @@
 	       (Vector.map (basids, fn basid => Env.lookupBasid (E, basid)),
 		fn bo => Option.app (bo, fn b => Env.openBasis (E, b)))
 	  | Basdec.Prog (_, prog) =>
-	       Buffer.add (decs, (elabProg prog, !Ctrls.deadCode))
+	       Buffer.add (decs, (elabProg prog, deadCode ()))
 	  | Basdec.MLB (_, fid, basdec) =>
 	       let
 		  val fid = valOf fid
@@ -157,7 +192,7 @@
 		  Env.openBasis (E, B)
 	       end
 	  | Basdec.Prim => 
-	       (if not (!Ctrls.allowPrim)
+	       (if not (allowPrim ())
 		   then let open Layout
 			in Control.error (Basdec.region basdec, str "_prim disallowed", empty)
 			end
@@ -165,16 +200,16 @@
 		; Env.openBasis (E, primBasis))
 	  | Basdec.Ann (anns, basdec) =>
 	       let
-		  val old = !Ctrls.forceUsed
+		  val old = forceUsed ()
 	       in
-		  Ctrls.withAnns 
+		  withAnns 
 		  (anns, fn () => 
 		   (elabBasdec basdec
-		    ; if !Ctrls.forceUsed <> old
+		    ; if forceUsed () <> old
 			 then Env.forceUsed E
 			 else ()))
 	       end) basdec
-      val _ = Ctrls.withDefault (fn () => elabBasdec mlb)
+      val _ = withDef (fn () => elabBasdec mlb)
    in
       (E, Buffer.toVector decs)
    end



1.2       +4 -5      mlton/mlton/elaborate/elaborate-mlbs.sig

Index: elaborate-mlbs.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-mlbs.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- elaborate-mlbs.sig	28 Jul 2004 21:05:13 -0000	1.1
+++ elaborate-mlbs.sig	4 Aug 2004 03:15:09 -0000	1.2
@@ -10,13 +10,11 @@
       structure Ast: AST
       structure ConstType: CONST_TYPE
       structure CoreML: CORE_ML
-      structure Ctrls: ELABORATE_CONTROLS
       structure Decs: DECS
       structure Env: ELABORATE_ENV
-      sharing Ast = Ctrls.Ast = Env.Ast
+      sharing Ast = Env.Ast
       sharing Ast.Tyvar = CoreML.Tyvar
-      sharing ConstType = Ctrls.ConstType
-      sharing CoreML = Ctrls.CoreML = Decs.CoreML = Env.CoreML
+      sharing CoreML = Decs.CoreML = Env.CoreML
       sharing Decs = Env.Decs
    end
 
@@ -26,4 +24,5 @@
 
       val elaborateMLB:
 	 Ast.Basdec.t * {addPrim: Env.t -> Decs.t} -> Env.t * (Decs.t * bool) vector
-   end
+      val lookupConstant: (string * ConstType.t -> CoreML.Const.t) ref
+    end



1.2       +1 -1      mlton/mlton/elaborate/elaborate-modules.fun

Index: elaborate-modules.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-modules.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- elaborate-modules.fun	28 Jul 2004 21:05:13 -0000	1.1
+++ elaborate-modules.fun	4 Aug 2004 03:15:09 -0000	1.2
@@ -39,9 +39,9 @@
 structure ElaborateCore = ElaborateCore (structure Ast = Ast
 					 structure ConstType = ConstType
 					 structure CoreML = CoreML
-					 structure Ctrls = Ctrls
 					 structure Decs = Decs
 					 structure Env = Env)
+val lookupConstant = ElaborateCore.lookupConstant
 
 val elabStrdecInfo = Trace.info "elabStrdec"
 val elabTopdecInfo = Trace.info "elabTopdec"



1.2       +3 -4      mlton/mlton/elaborate/elaborate-modules.sig

Index: elaborate-modules.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-modules.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- elaborate-modules.sig	28 Jul 2004 21:05:13 -0000	1.1
+++ elaborate-modules.sig	4 Aug 2004 03:15:09 -0000	1.2
@@ -10,13 +10,11 @@
       structure Ast: AST
       structure ConstType: CONST_TYPE
       structure CoreML: CORE_ML
-      structure Ctrls: ELABORATE_CONTROLS
       structure Decs: DECS
       structure Env: ELABORATE_ENV
-      sharing Ast = Ctrls.Ast = Env.Ast
+      sharing Ast = Env.Ast
       sharing Ast.Tyvar = CoreML.Tyvar
-      sharing ConstType = Ctrls.ConstType
-      sharing CoreML = Ctrls.CoreML = Decs.CoreML = Env.CoreML
+      sharing CoreML = Decs.CoreML = Env.CoreML
       sharing Decs = Env.Decs
    end
 
@@ -26,4 +24,5 @@
 
       val elaborateTopdec:
 	 Ast.Topdec.t * {env: Env.t} -> Decs.t
+      val lookupConstant: (string * ConstType.t -> CoreML.Const.t) ref
    end



1.2       +1 -1      mlton/mlton/elaborate/elaborate-programs.fun

Index: elaborate-programs.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-programs.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- elaborate-programs.fun	28 Jul 2004 21:05:13 -0000	1.1
+++ elaborate-programs.fun	4 Aug 2004 03:15:09 -0000	1.2
@@ -13,9 +13,9 @@
 structure ElaborateModules = ElaborateModules (structure Ast = Ast
 					       structure ConstType = ConstType
 					       structure CoreML = CoreML
-					       structure Ctrls = Ctrls
 					       structure Decs = Decs
 					       structure Env = Env)
+val lookupConstant = ElaborateModules.lookupConstant
 
 fun elaborateProgram (program, {env = E: Env.t}) =
    let



1.2       +3 -4      mlton/mlton/elaborate/elaborate-programs.sig

Index: elaborate-programs.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-programs.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- elaborate-programs.sig	28 Jul 2004 21:05:13 -0000	1.1
+++ elaborate-programs.sig	4 Aug 2004 03:15:09 -0000	1.2
@@ -10,13 +10,11 @@
       structure Ast: AST
       structure ConstType: CONST_TYPE
       structure CoreML: CORE_ML
-      structure Ctrls: ELABORATE_CONTROLS
       structure Decs: DECS
       structure Env: ELABORATE_ENV
-      sharing Ast = Ctrls.Ast = Env.Ast
+      sharing Ast = Env.Ast
       sharing Ast.Tyvar = CoreML.Tyvar
-      sharing ConstType = Ctrls.ConstType
-      sharing CoreML = Ctrls.CoreML = Decs.CoreML = Env.CoreML
+      sharing CoreML = Decs.CoreML = Env.CoreML
       sharing Decs = Env.Decs
    end
 
@@ -26,4 +24,5 @@
 
       val elaborateProgram:
 	 Ast.Program.t * {env: Env.t} -> Decs.t
+      val lookupConstant: (string * ConstType.t -> CoreML.Const.t) ref
    end



1.28      +0 -6      mlton/mlton/elaborate/elaborate.fun

Index: elaborate.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate.fun,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- elaborate.fun	28 Jul 2004 21:05:13 -0000	1.27
+++ elaborate.fun	4 Aug 2004 03:15:09 -0000	1.28
@@ -21,13 +21,8 @@
 	  | Word => "Word"
    end
 
-structure Ctrls = ElaborateControls(structure Ast = Ast
-				    structure ConstType = ConstType
-				    structure CoreML = CoreML)
-
 structure Env = ElaborateEnv (structure Ast = Ast
 			      structure CoreML = CoreML
-			      structure Ctrls = Ctrls
 			      structure TypeEnv = TypeEnv)
 
 local
@@ -39,7 +34,6 @@
 structure ElaborateMLBs = ElaborateMLBs (structure Ast = Ast
 					 structure ConstType = ConstType
 					 structure CoreML = CoreML
-					 structure Ctrls = Ctrls
 					 structure Decs = Decs
 					 structure Env = Env)
 



1.10      +2 -2      mlton/mlton/elaborate/elaborate.sig

Index: elaborate.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate.sig,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- elaborate.sig	28 Jul 2004 21:05:13 -0000	1.9
+++ elaborate.sig	4 Aug 2004 03:15:09 -0000	1.10
@@ -22,10 +22,10 @@
       include ELABORATE_STRUCTS
 
       structure ConstType: CONST_TYPE
-      structure Ctrls: ELABORATE_CONTROLS
       structure Decs: DECS
       structure Env: ELABORATE_ENV
 
       val elaborateMLB:
 	 Ast.Basdec.t * {addPrim: Env.t -> Decs.t} -> Env.t * (Decs.t * bool) vector
-   end
+      val lookupConstant: (string * ConstType.t -> CoreML.Const.t) ref
+  end



1.9       +0 -2      mlton/mlton/elaborate/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/sources.cm,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- sources.cm	28 Jul 2004 21:05:13 -0000	1.8
+++ sources.cm	4 Aug 2004 03:15:09 -0000	1.9
@@ -27,8 +27,6 @@
 type-env.fun
 interface.sig
 interface.fun
-elaborate-controls.sig
-elaborate-controls.fun
 elaborate-env.sig
 elaborate-env.fun
 precedence-parse.sig



1.39      +1 -1      mlton/mlton/main/compile.fun

Index: compile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.fun,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -r1.38 -r1.39
--- compile.fun	3 Aug 2004 01:00:59 -0000	1.38
+++ compile.fun	4 Aug 2004 03:15:10 -0000	1.39
@@ -331,7 +331,7 @@
     style = Control.ML,
     thunk = fn () => 
     Ref.fluidLet
-    (Elaborate.Ctrls.lookupConstant, lookupConstant, fn () =>
+    (Elaborate.lookupConstant, lookupConstant, fn () =>
      elaborateMLB (lexAndParseMLB fs, {addPrim = addPrim})),
     display = displayEnvDecs}
    



1.52      +40 -26    mlton/mlton/main/main.fun

Index: main.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.fun,v
retrieving revision 1.51
retrieving revision 1.52
diff -u -r1.51 -r1.52
--- main.fun	30 Jul 2004 13:37:59 -0000	1.51
+++ main.fun	4 Aug 2004 03:15:11 -0000	1.52
@@ -127,10 +127,14 @@
 						 s]))))),
        (Expert, "allow-export", " {false|true}",
 	"allow _export expression in program",
-	boolRef allowExportDef),
+	Bool (fn b =>
+	      (warnDeprecated "allow-export"
+	       ; (Control.Elaborate.default Control.Elaborate.allowExport) := b))),
        (Expert, "allow-import", " {false|true}",
 	"allow _import expression in program",
-	boolRef allowImportDef),
+	Bool (fn b =>
+	      (warnDeprecated "allow-import"
+	       ; (Control.Elaborate.default Control.Elaborate.allowImport) := b))),
        (Expert, "basis", " {2002|1997|...}",
 	"select Basis Library revision to prefix to the program",
 	SpaceString (fn s =>
@@ -171,9 +175,17 @@
 	"annotated dead code elimination",
 	Bool (fn b =>
 	      (warnDeprecated "dead-code"
-	       ; deadCodeAnn := b))),
+	       ; (Control.Elaborate.enabled Control.Elaborate.deadCode) := b))),
        (Expert, "debug", " {false|true}", "produce executable with debug info",
 	boolRef debug),
+       (Expert, "default-ann", " <ann>", "annotation default",
+	SpaceString 
+	(fn s =>
+	 List.foreach
+	 (String.tokens (s, fn #"," => true | _ => false), fn s =>
+	  if Control.Elaborate.setDef (String.tokens (s, fn #" " => true | _ => false))
+	     then ()
+	     else usage (concat ["invalid -default-ann flag: ", s])))),
        (Normal, "detect-overflow", " {true|false}",
 	"overflow checking on integer arithmetic",
 	boolRef detectOverflow),
@@ -190,14 +202,12 @@
        (Expert, "disable-ann", " <ann>", "globally disable annotation",
 	SpaceString 
 	(fn s =>
-	 (case s of
-	     "allowExport" => allowExportAnn := false
-	   | "allowImport" => allowImportAnn := false
-	   | "deadCode" => deadCodeAnn := false
-	   | "sequenceUnit" => sequenceUnitAnn := false
-	   | "warnMatch" => warnMatchAnn := false
-	   | "warnUnused" => warnUnusedAnn := false
-	   | _ => usage (concat ["invalid -disable-ann flag: ", s])))),
+	 List.foreach
+	 (String.tokens (s, fn #"," => true | _ => false), fn s =>
+	  if Control.Elaborate.setAble 
+	     (false, String.deleteSurroundingWhitespace s)
+	     then ()
+	     else usage (concat ["invalid -disable-ann flag: ", s])))),
        (Expert, "drop-pass", " <pass>", "omit optimization pass",
 	SpaceString
 	(fn s => (case Regexp.fromString s of
@@ -211,14 +221,12 @@
        (Expert, "enable-ann", " <ann>", "globally enable annotation",
 	SpaceString 
 	(fn s =>
-	 (case s of
-	     "allowExport" => allowExportAnn := true
-	   | "allowImport" => allowImportAnn := true
-	   | "deadCode" => deadCodeAnn := true
-	   | "sequenceUnit" => sequenceUnitAnn := true
-	   | "warnMatch" => warnMatchAnn := true
-	   | "warnUnused" => warnUnusedAnn := true
-	   | _ => usage (concat ["invalid -enable-ann flag: ", s])))),
+	 List.foreach
+	 (String.tokens (s, fn #"," => true | _ => false), fn s =>
+	  if Control.Elaborate.setAble 
+	     (true, String.deleteSurroundingWhitespace s)
+	     then ()
+	     else usage (concat ["invalid -enable-ann flag: ", s])))),
        (Expert, "error-threshhold", " 20", "error threshhold",
 	intRef errorThreshhold),
        (Normal, "exn-history", " {false|true}", "enable Exn.history",
@@ -385,7 +393,9 @@
 	boolRef safe),
        (Normal, "sequence-unit", " {false|true}",
 	"in (e1; e2), require e1: unit",
-	boolRef sequenceUnitDef),
+	Bool (fn b =>
+	      (warnDeprecated "sequence-unit"
+	       ; (Control.Elaborate.default Control.Elaborate.sequenceUnit) := b))),
        (Normal, "show-basis", " <file>", "write out the final basis environment",
 	SpaceString (fn s => showBasis := SOME s)),
        (Normal, "show-def-use", " <file>", "write def-use information",
@@ -461,10 +471,14 @@
 	boolRef warnAnn),
        (Normal, "warn-match", " {true|false}",
 	"nonexhaustive and redundant match warnings",
-	boolRef warnMatchDef),
+	Bool (fn b =>
+	      (warnDeprecated "warn-match"
+	       ; (Control.Elaborate.default Control.Elaborate.warnMatch) := b))),
        (Normal, "warn-unused", " {false|true}",
 	"unused identifier warnings",
-	boolRef warnUnusedDef),
+	Bool (fn b =>
+	      (warnDeprecated "warn-unused"
+	       ; (Control.Elaborate.default Control.Elaborate.warnUnused) := b))),
        (Expert, "xml-passes", " <passes>", "xml optimization passes",
 	SpaceString
 	(fn s =>
@@ -590,11 +604,11 @@
 	 else ()
       val keepDefUse = 
 	 isSome (!showDefUse)
-	 orelse !warnUnusedAnn 
-	 orelse !warnUnusedDef
+	 orelse !(Control.Elaborate.enabled Control.Elaborate.warnUnused)
+	 orelse !(Control.Elaborate.default Control.Elaborate.warnUnused)
       val warnMatch =
-	 !warnMatchAnn 
-	 orelse !warnMatchDef
+	 !(Control.Elaborate.enabled Control.Elaborate.warnMatch)
+	 orelse !(Control.Elaborate.default Control.Elaborate.warnMatch)
       val _ = elaborateOnly := (stop = Place.TypeCheck
 				andalso not (warnMatch)
 				andalso not (keepDefUse))