(* For ElabMain.sml, I pulled pulled out some structures from the SML/NJ 110.42
 * source distribution and removed unnecessary definitions. 
 * This allows a smaller ElabMain.cm file.
 * I could probably do more work here.
 * AD 3-Jun-2003
 *
 * This code is modified from code in SML/NJ.  Their copyright, not mine.
 * I don't think that one can copyright elisions!
 *)

signature MCCONTROL =
sig
  val printArgs : bool ref
  val printRet : bool ref
  val bindNoVariableWarn : bool ref
  val bindNonExhaustiveWarn : bool ref
  val matchNonExhaustiveWarn : bool ref
  val matchNonExhaustiveError : bool ref
  val matchRedundantWarn : bool ref
  val matchRedundantError : bool ref
(*
  val expandResult : bool ref
*)
end

structure Control_MC : MCCONTROL =
struct
    val priority = [10, 10, 4]
    val obscurity = 2
    val prefix = "compiler-mc"

    val registry = ControlRegistry.new { help = "match compiler settings" }

    val _ = BasicControl.nest (prefix, registry, priority)

    val bool_cvt = ControlUtil.Cvt.bool

    val nextpri = ref 0

    fun flag (n, h, d) = let
	val r = ref d
	val p = !nextpri
	val ctl = Controls.control { name = n,
				     pri = [p],
				     obscurity = obscurity,
				     help = h,
				     ctl = r }
    in
	nextpri := p + 1;
	ControlRegistry.register
	    registry
	    { ctl = Controls.stringControl bool_cvt ctl,
	      envName = SOME (ControlUtil.EnvName.toUpper "COMPILER_MC_" n) };
	r
    end

    val printArgs = flag ("print-args", "arguments print mode", false)
    val printRet = flag ("print-ret", "return print mode", false)
    val bindNoVariableWarn =
	flag ("nobind-warn", "whether to warn if no variables get bound",
	      false)
    val bindNonExhaustiveWarn =
	flag ("warn-non-exhaustive-bind",
	      "whether to warn on non-exhaustive bind", true)
    val matchNonExhaustiveWarn =
	flag ("warn-non-exhaustive-match",
	      "whether to warn on non-exhaustive match", true)
    val matchNonExhaustiveError =
	flag ("error-non-exhaustive-match",
	      "whether non-exhaustive match is an error", false)
    (* matchExhaustiveError overrides matchExhaustiveWarn *)
    val matchRedundantWarn =
	flag ("warn-redundant", "whether to warn on redundant matches", true)
    val matchRedundantError =
	flag ("error-redundant", "whether a redundant match is an error", true)
    (* matchRedundantError overrides matchRedundantWarn *)
(*
    val expandResult =
	flag ("expand-result", "whether to expand result of match", false)
*)
end

structure Control = 
  struct
    structure Print : PRINTCONTROL = Control_Print
    structure FLINT = (*FLINT_Control*)
      struct
	val checkDatatypes = ref false
	val print = ref false
      end
    structure MC : MCCONTROL = Control_MC
    structure CG = 
      struct
	val tmdebugging = ref false
      end
    val trackExn = ref true
    val polyEqWarn = ref true
  end

(* Copyright 1989 by AT&T Bell Laboratories *)
structure SortedList =
struct

fun enter(new:int,l) =
  let fun f [] = [new]
	| f (l as h::t) = if new<h then new::l else if new>h then h::f t else l
  in  f l
  end

fun merge(a,[]) = a
  | merge([],a) = a
  | merge(l as (i:int)::a, m as j::b) = 
      if j<i then j::merge(l,b) else i::merge(a,if i<j then m else b)

local fun loop (a::b::rest) = loop(merge(a,b)::loop rest)
        | loop l = l
in fun foldmerge l = hd(loop l) handle Hd => []
end

fun uniq l =
    let fun split([],l,r) = (l,r)
	  | split(h::t,l,r) = split(t,r,h::l)
        fun sort [] = []
          | sort (l as [_]) = l
          | sort (l as [x : int,y : int]) = 
             if x = y then [x] else if x < y then l else [y,x]
          | sort l = let val (l,r) = split(l,[],[])
                     in  merge(sort l, sort r) end
    in  sort l
    end

fun remove(x as (xl:int)::xr, y as yl::yr) =
    if xl>yl then yl::remove(x,yr) else remove(xr,if xl<yl then y else yr)
  | remove(_,y) = y

fun rmv (x : int,l) =
    let fun loop nil = nil
	  | loop (a::b) = if x=a then b else a::loop b
    in loop l
    end

fun member l (e:int) =
  let fun f [] = false
	| f (h::t) = if h<e then f t else e=h
  in  f l
  end

fun intersect(nil,_) = nil
  | intersect(_,nil) = nil
  | intersect(l as (a:int)::b,r as c::d) =
	if a=c then a::intersect(b,d)
	else if a<c then intersect(b,r)
	else intersect(l,d)

fun difference(nil,_) = nil
  | difference(l,nil) = l
  | difference(l as (a:int)::b,r as c::d) =
	if a=c then difference(b,d)
	else if a<c then a::difference(b,r)
	else difference(l,d)	
end