[MLton-devel] cvs commit: new front end

Stephen Weeks sweeks@users.sourceforge.net
Thu, 09 Oct 2003 11:17:35 -0700


sweeks      03/10/09 11:17:35

  Modified:    basis-library/io fast-imperative-io.fun stream-io.fun
               basis-library/libs/basis-2002/top-level top-level.sml
               basis-library/misc primitive.sml
               basis-library/text string-cvt.sml
               benchmark benchmark.cm
               benchmark/tests model-elimination.sml
               mlton    mlton-stubs.cm
               mlton/ast ast-atoms.fun ast-atoms.sig ast-const.fun
                        ast-const.sig ast-core.fun ast-core.sig ast.fun
                        ast.sig prim-cons.fun prim-tycons.fun
                        prim-tycons.sig sources.cm tyvar.fun
               mlton/atoms atoms.fun atoms.sig c-type.sig const.fun
                        const.sig hash-type.fun hash-type.sig id.fun id.sig
                        int-x.fun prim.fun prim.sig sources.cm tycon.fun
                        tycon.sig type-ops.fun type-ops.sig type.fun
                        type.sig var.fun var.sig
               mlton/backend representation.fun ssa-to-rssa.fun
               mlton/closure-convert abstract-value.fun abstract-value.sig
                        closure-convert.fun
               mlton/codegen/c-codegen c-codegen.fun
               mlton/codegen/x86-codegen x86.fun
               mlton/control control.sml source-pos.sml sources.cm
               mlton/core-ml core-ml.fun core-ml.sig sources.cm
               mlton/elaborate decs.fun decs.sig elaborate-core.fun
                        elaborate-core.sig elaborate-env.fun
                        elaborate-env.sig elaborate.fun elaborate.sig
                        scope.fun sources.cm
               mlton/front-end ml.grm
               mlton/main compile.sig main.sig main.sml sources.cm
               mlton/ssa constant-propagation.fun direct-exp.fun
                        flatten.fun local-flatten.fun local-ref.fun
                        shrink.fun simplify-types.fun ssa-tree.fun
                        type-check.fun useless.fun
               mlton/xml implement-exceptions.fun monomorphise.fun
                        polyvariance.fun scc-funs.fun shrink.fun
                        simplify-types.fun type-check.fun xml-tree.fun
                        xml-tree.sig
               regression .cvsignore 6.sml asterisk.sml exnHistory.ok
                        exnHistory2.ok exnHistory3.ok flexrecord.sml
                        undetermined.sml valrec.ok valrec.sml
               runtime  libmlton.c
  Added:       mlton/ast tycon-kind.fun tycon-kind.sig
               mlton/atoms con.fun con.sig
               mlton/control layout.sml pretty.sig pretty.sml
               mlton/defunctorize defunctorize.fun defunctorize.sig
                        sources.cm
               mlton/elaborate const-type.sig type-env.fun type-env.sig
               mlton/main compile.fun lookup-constant.fun
                        lookup-constant.sig main.fun
               mlton/match-compile match-compile.fun match-compile.sig
                        nested-pat.fun nested-pat.sig sources.cm
  Removed:     mlton/atoms cons.fun cons.sig
               mlton/core-ml lookup-constant.fun lookup-constant.sig
               mlton/main compile.sml
               mlton/type-inference infer.fun infer.sig match-compile.fun
                        match-compile.sig nested-pat.fun nested-pat.sig
                        sources.cm type-env.fun type-env.sig
  Log:
  This checkin is the next phase in getting a proper front end for
  MLton.  It does type checking of core SML programs correctly.  It
  still does type checking after defunctorization and ignores types in
  signature.  That will be fixed in the next phase.
  
  I am pleased to report that the front end is quite fast.  For example,
  it can lex, parse, and type check all of MLton (118K lines) in under
  10 seconds on my 1.6GHz machine.
  
  I am very interested in receiving bug reports and suggestions on how
  to improve the front end.  In decreasing order of importance, I would
  like to hear about:
  
  1. Programs that are rejected but should be accepted.
  2. Programs that are accepted but should be rejected.
  3. Confusing type error messages.
  4. Improvements to type error messages.
  
  I would appreciate everyone starting to test this front end while
  developing SML code.  If building MLton from the CVS is an impediment
  to doing this, let me know and I will make an experimental release.
  
  There is one kind of problem that I am aware of that will not be fixed
  until the module-level checking is there.  MLton will now reject some
  valid SML programs like the following.
  
  	structure S:
  	   sig
  	      val f: 'a list -> 'a list
  	   end =
  	   struct
  	      fun f _ = []
  	   end
  
  	val z = S.f [1, 2, 3]
  
  The problem MLton has with this program is that the inferred type for
  f is more general than the type given in the signature.  Then, at the
  call to S.f, type inference is unable to deduce the result type.
  Since the expression is expansive, MLton is unable to generalize the
  free type variable, and reports an error.  I had to patch MLton in a
  couple of places and a couple of the benchmarks and regressions to
  work around this bug.
  
  Here's an overview of what I did and how things now work.
  
  All of the type inference code has been moved from operating on CoreML
  to operating on Ast.   Here's how the front end now works.
  
       elaborate           convert
  Ast -----------> CoreML ---------> XML
  
  * Ast is as before, the raw, implicitly typed SML source.
  * CoreML is changed and is now explicitly typed, polymorphic,
    direct-style, with nested patterns, and has no module-level
    constructs.
  * XML is as before, explicitly typed, polymorphic, A-normal, and has
    flat patterns.
  
  At the module level, the elaborate pass
  * duplicates functors
  * cuts structures according to signatures
  * eliminates longids
  
  Then within each structure or functor body, for each declaration
  (<dec> in the SML grammar), the elaborate pass does three steps:
  1. * type variable scope inference
  2. * precedence parsing
     * _{ex,im}port expansion
     * profiling insertion
     * unification
  3. * overloaded {constant, function, record pattern} resolution
  
  Then, the convert pass does the following, all in a single step:
  * linearization
  * match compilation
  * lookup constants
  * polymorphic val dec expansion
  * moves datatypes to toplevel
  
  One consequence of doing overloading resolution on a per declaration
  level instead of over the whole program means that some programs that
  used to be accepted will now be rejected.  For example,
  
  	val x = ref NONE
  	structure S = struct end
  	val _ = x := SOME 13
  
  I did add a pass to the elaborator to combine declarations into as
  large a block of <dec> as possible.  So, for example, the following
  program is accepted.
  
  	local
  	   val r = ref NONE
  	in
  	   val _ = r := SOME 13
  	end
  
  Without that pass, the front end would treat this as a local <strdec>
  instead of a local <dec>, and would doing overloading resolution on
  the "val r" dec before the unificaiton for the "val _" dec, which
  would result in an error.
  
  Lookup constants is now a bit tricky.  The _build_const and _const
  declarations are turned into thunks by the elaborator.  These thunks
  are thawed during the conversion from CoreML to XML.  To build the
  constants, we elaborate the basis library and convert to XML, using
  the thunks to keep track of all the constants that are produced.
  Then, we write these constants out the the C file.  When processing a
  normal program, we use the thunks to lookup the constant in a hash
  table produced from lib/<target>/constants.
  
  Now, for a few other minor points.
  
  Moved {compile,main}.sml to {compile,main}.fun to be more consistent.
  
  Changed how equality is handled.  Instead of being magically added
  in compile.fun, it is added via _prim in the basis library.
  
  Took out Ast from Atoms.  Now, pretty printing of ILs is handled by
  directly producing Layouts instead of first converting to Ast.
  
  Removed the type information associated with primitives in
  Prim.fun.
  
  Changed the formatting of front-end error messages.
  
  Made the naming of some type operators more consistent.
  
  	dearray --> deArray
  	dearrow --> deArrow
  	deref --> deRef
  	...

Revision  Changes    Path
1.8       +0 -2      mlton/basis-library/io/fast-imperative-io.fun

Index: fast-imperative-io.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/io/fast-imperative-io.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- fast-imperative-io.fun	24 Sep 2003 17:45:25 -0000	1.7
+++ fast-imperative-io.fun	9 Oct 2003 18:17:29 -0000	1.8
@@ -174,8 +174,6 @@
 						     function = function,
 						     cause = cause}
 
-      val empty = V.fromList []
-
       (*---------------*)
       (*   outstream   *)
       (*---------------*)



1.16      +1 -1      mlton/basis-library/io/stream-io.fun

Index: stream-io.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/io/stream-io.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- stream-io.fun	25 Sep 2003 01:43:25 -0000	1.15
+++ stream-io.fun	9 Oct 2003 18:17:29 -0000	1.16
@@ -45,7 +45,7 @@
 						     function = function,
 						     cause = cause}
 
-      val hasLine = V.exists isLine
+      val hasLine = fn z => V.exists isLine z
 
       (*---------------*)
       (*   outstream   *)



1.7       +2 -0      mlton/basis-library/libs/basis-2002/top-level/top-level.sml

Index: top-level.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/basis-2002/top-level/top-level.sml,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- top-level.sml	27 Jun 2003 00:15:34 -0000	1.6
+++ top-level.sml	9 Oct 2003 18:17:30 -0000	1.7
@@ -45,3 +45,5 @@
 structure Unsafe = Unsafe
 
 open Basis2002
+
+val op = = op =



1.81      +46 -43    mlton/basis-library/misc/primitive.sml

Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.80
retrieving revision 1.81
diff -u -r1.80 -r1.81
--- primitive.sml	26 Sep 2003 05:21:08 -0000	1.80
+++ primitive.sml	9 Oct 2003 18:17:30 -0000	1.81
@@ -13,6 +13,10 @@
  * script produces type-correct SML code.
  *)
 
+infix 4 = <> > >= < <=
+
+val op = = fn z => _prim "MLton_equal": 'a * 'a -> bool; z
+
 type 'a array = 'a array
 structure Bool =
    struct
@@ -170,10 +174,10 @@
 
       structure Char =
 	 struct
-	    val < = _prim "Char_lt": char * char -> bool;
-	    val <= = _prim "Char_le": char * char -> bool;
-	    val > = _prim "Char_gt": char * char -> bool;
-	    val >= = _prim "Char_ge": char * char -> bool;
+	    val op < = _prim "Char_lt": char * char -> bool;
+	    val op <= = _prim "Char_le": char * char -> bool;
+	    val op > = _prim "Char_gt": char * char -> bool;
+	    val op >= = _prim "Char_ge": char * char -> bool;
 	    val chr = _prim "Char_chr": int -> char;
 	    val ord = _prim "Char_ord": char -> int;
 	    val toWord8 = _prim "Char_toWord8": char -> Word8.word;
@@ -317,10 +321,10 @@
 	       if detectOverflow
 		  then _prim "Int8_subCheck": int * int -> int;
 	       else -?
-	    val < = _prim "Int8_lt": int * int -> bool;
-	    val <= = _prim "Int8_le": int * int -> bool;
-	    val > = _prim "Int8_gt": int * int -> bool;
-	    val >= = _prim "Int8_ge": int * int -> bool;
+	    val op < = _prim "Int8_lt": int * int -> bool;
+	    val op <= = _prim "Int8_le": int * int -> bool;
+	    val op > = _prim "Int8_gt": int * int -> bool;
+	    val op >= = _prim "Int8_ge": int * int -> bool;
 	    val quot = _prim "Int8_quot": int * int -> int;
 	    val rem = _prim "Int8_rem": int * int -> int;
 	    val ~? = _prim "Int8_neg": int -> int; 
@@ -354,10 +358,10 @@
 	       if detectOverflow
 		  then _prim "Int16_subCheck": int * int -> int;
 	       else -?
-	    val < = _prim "Int16_lt": int * int -> bool;
-	    val <= = _prim "Int16_le": int * int -> bool;
-	    val > = _prim "Int16_gt": int * int -> bool;
-	    val >= = _prim "Int16_ge": int * int -> bool;
+	    val op < = _prim "Int16_lt": int * int -> bool;
+	    val op <= = _prim "Int16_le": int * int -> bool;
+	    val op > = _prim "Int16_gt": int * int -> bool;
+	    val op >= = _prim "Int16_ge": int * int -> bool;
 	    val quot = _prim "Int16_quot": int * int -> int;
 	    val rem = _prim "Int16_rem": int * int -> int;
 	    val ~? = _prim "Int16_neg": int -> int; 
@@ -390,10 +394,10 @@
 	       if detectOverflow
 		  then _prim "Int32_subCheck": int * int -> int;
 	       else -?
-	    val < = _prim "Int32_lt": int * int -> bool;
-	    val <= = _prim "Int32_le": int * int -> bool;
-	    val > = _prim "Int32_gt": int * int -> bool;
-	    val >= = _prim "Int32_ge": int * int -> bool;
+	    val op < = _prim "Int32_lt": int * int -> bool;
+	    val op <= = _prim "Int32_le": int * int -> bool;
+	    val op > = _prim "Int32_gt": int * int -> bool;
+	    val op >= = _prim "Int32_ge": int * int -> bool;
 	    val quot = _prim "Int32_quot": int * int -> int;
 	    val rem = _prim "Int32_rem": int * int -> int;
 	    val ~? = _prim "Int32_neg": int -> int; 
@@ -409,7 +413,6 @@
 	 struct
 	    infix 7 *?
 	    infix 6 +? -?
-	    infix 4 = <> > >= < <=
 
 	    type int = Int64.int
 
@@ -814,11 +817,11 @@
 	    val + = _prim "Real64_add": real * real -> real;
 	    val - = _prim "Real64_sub": real * real -> real;
 	    val / = _prim "Real64_div": real * real -> real;
-	    val < = _prim "Real64_lt": real * real -> bool;
-	    val <= = _prim "Real64_le": real * real -> bool;
+	    val op < = _prim "Real64_lt": real * real -> bool;
+	    val op <= = _prim "Real64_le": real * real -> bool;
 	    val == = _prim "Real64_equal": real * real -> bool;
-	    val > = _prim "Real64_gt": real * real -> bool;
-	    val >= = _prim "Real64_ge": real * real -> bool;
+	    val op > = _prim "Real64_gt": real * real -> bool;
+	    val op >= = _prim "Real64_ge": real * real -> bool;
 	    val ?= = _prim "Real64_qequal": real * real -> bool;
 	    val abs = _prim "Real64_abs": real -> real;
 	    val class = _import "Real64_class": real -> int;
@@ -908,11 +911,11 @@
 	    val + = _prim "Real32_add": real * real -> real;
 	    val - = _prim "Real32_sub": real * real -> real;
 	    val / = _prim "Real32_div": real * real -> real;
-	    val < = _prim "Real32_lt": real * real -> bool;
-	    val <= = _prim "Real32_le": real * real -> bool;
+	    val op < = _prim "Real32_lt": real * real -> bool;
+	    val op <= = _prim "Real32_le": real * real -> bool;
 	    val == = _prim "Real32_equal": real * real -> bool;
-	    val > = _prim "Real32_gt": real * real -> bool;
-	    val >= = _prim "Real32_ge": real * real -> bool;
+	    val op > = _prim "Real32_gt": real * real -> bool;
+	    val op >= = _prim "Real32_ge": real * real -> bool;
 	    val ?= = _prim "Real32_qequal": real * real -> bool;
 	    val abs = _prim "Real32_abs": real -> real;
 	    val class = _import "Real32_class": real -> int;
@@ -1180,11 +1183,11 @@
 	    val div = _prim "Word8_div": word * word -> word;
 	    val fromInt = _prim "Int32_toWord8": int -> word;
 	    val fromLarge = _import "Word64_toWord8": LargeWord.word -> word;
-	    val >= = _prim "Word8_ge": word * word -> bool;
-	    val > = _prim "Word8_gt" : word * word -> bool;
-	    val <= = _prim "Word8_le": word * word -> bool;
+	    val op >= = _prim "Word8_ge": word * word -> bool;
+	    val op > = _prim "Word8_gt" : word * word -> bool;
+	    val op <= = _prim "Word8_le": word * word -> bool;
 	    val << = _prim "Word8_lshift": word * Word.word -> word;
-	    val < = _prim "Word8_lt" : word * word -> bool;
+	    val op < = _prim "Word8_lt" : word * word -> bool;
 	    val mod = _prim "Word8_mod": word * word -> word;
 	    val * = _prim "Word8_mul": word * word -> word;
 	    val mulCheck = _prim "Word8_mulCheck": word * word -> word;
@@ -1236,11 +1239,11 @@
 	    val div = _prim "Word16_div": word * word -> word;
 	    val fromInt = _prim "Int32_toWord16": int -> word;
 	    val fromLarge = _import "Word64_toWord16": LargeWord.word -> word;
-	    val >= = _prim "Word16_ge": word * word -> bool;
-	    val > = _prim "Word16_gt" : word * word -> bool;
-	    val <= = _prim "Word16_le": word * word -> bool;
+	    val op >= = _prim "Word16_ge": word * word -> bool;
+	    val op > = _prim "Word16_gt" : word * word -> bool;
+	    val op <= = _prim "Word16_le": word * word -> bool;
 	    val << = _prim "Word16_lshift": word * Word.word -> word;
-	    val < = _prim "Word16_lt" : word * word -> bool;
+	    val op < = _prim "Word16_lt" : word * word -> bool;
 	    val mod = _prim "Word16_mod": word * word -> word;
 	    val * = _prim "Word16_mul": word * word -> word;
 	    val mulCheck = _prim "Word16_mulCheck": word * word -> word;
@@ -1270,11 +1273,11 @@
 	    val div = _prim "Word32_div": word * word -> word;
 	    val fromInt = _prim "Int32_toWord32": int -> word;
 	    val fromLarge = _import "Word64_toWord32": LargeWord.word -> word;
-	    val >= = _prim "Word32_ge": word * word -> bool;
-	    val > = _prim "Word32_gt" : word * word -> bool;
-	    val <= = _prim "Word32_le": word * word -> bool;
+	    val op >= = _prim "Word32_ge": word * word -> bool;
+	    val op > = _prim "Word32_gt" : word * word -> bool;
+	    val op <= = _prim "Word32_le": word * word -> bool;
 	    val << = _prim "Word32_lshift": word * word -> word;
-	    val < = _prim "Word32_lt" : word * word -> bool;
+	    val op < = _prim "Word32_lt" : word * word -> bool;
 	    val mod = _prim "Word32_mod": word * word -> word;
 	    val * = _prim "Word32_mul": word * word -> word;
 	    val mulCheck = _prim "Word32_mulCheck": word * word -> word;
@@ -1305,11 +1308,11 @@
 	    val div = _import "Word64_div": word * word -> word;
 	    val fromInt = _import "Int32_toWord64": int -> word;
 	    val fromLarge: LargeWord.word -> word = fn x => x
-	    val >= = _import "Word64_ge": word * word -> bool;
-	    val > = _import "Word64_gt" : word * word -> bool;
-	    val <= = _import "Word64_le": word * word -> bool;
+	    val op >= = _import "Word64_ge": word * word -> bool;
+	    val op > = _import "Word64_gt" : word * word -> bool;
+	    val op <= = _import "Word64_le": word * word -> bool;
 	    val << = _import "Word64_lshift": word * Word.word -> word;
-	    val < = _import "Word64_lt" : word * word -> bool;
+	    val op < = _import "Word64_lt" : word * word -> bool;
 	    val mod = _import "Word64_mod": word * word -> word;
 	    val * = _import "Word64_mul": word * word -> word;
 (*	    val mulCheck = _import "Word64_mulCheck": word * word -> word; *)
@@ -1345,7 +1348,7 @@
 	    open Int8
 	       
 	    local
-	       fun make f (i: int, i': int): bool =
+	       fun make f (i: Int.int, i': Int.int): bool =
 		  f (Primitive.Word8.fromInt i, Primitive.Word8.fromInt i')
 	    in
 	       val geu = make Primitive.Word8.>=
@@ -1357,7 +1360,7 @@
 	    open Int16
 	       
 	    local
-	       fun make f (i: int, i': int): bool =
+	       fun make f (i: Int.int, i': Int.int): bool =
 		  f (Primitive.Word16.fromInt i, Primitive.Word16.fromInt i')
 	    in
 	       val geu = make Primitive.Word16.>=



1.5       +6 -3      mlton/basis-library/text/string-cvt.sml

Index: string-cvt.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/text/string-cvt.sml,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- string-cvt.sml	4 Dec 2002 00:29:01 -0000	1.4
+++ string-cvt.sml	9 Oct 2003 18:17:30 -0000	1.5
@@ -35,9 +35,12 @@
       structure String = String0
 
       local
-	 fun pad f c i s =
-	    let val n = String.size s
-	    in if n >= i then s
+	 fun pad f (c: char) i s =
+	    let
+	       val n = String.size s
+	    in
+	       if n >= i
+		  then s
 	       else f (s, String0.vector (i -? n, c))
 	    end
       in



1.10      +2 -2      mlton/benchmark/benchmark.cm

Index: benchmark.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/benchmark/benchmark.cm,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- benchmark.cm	23 Jun 2003 04:58:54 -0000	1.9
+++ benchmark.cm	9 Oct 2003 18:17:30 -0000	1.10
@@ -123,8 +123,6 @@
 ../lib/mlton/basic/file-desc.sig
 ../lib/mlton/basic/file-desc.sml
 ../lib/mlton/basic/signal.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
 ../lib/mlton/basic/function.sig
 ../lib/mlton/basic/function.sml
 ../lib/mlton/basic/dir.sig
@@ -135,6 +133,8 @@
 ../lib/mlton/basic/justify.sml
 ../lib/mlton/basic/popt.sig
 ../lib/mlton/basic/popt.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
 ../lib/mlton/basic/escape.sig
 ../lib/mlton/basic/escape.sml
 ../lib/mlton/basic/choice-pattern.sig



1.5       +2 -0      mlton/benchmark/tests/model-elimination.sml

Index: model-elimination.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/benchmark/tests/model-elimination.sml,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- model-elimination.sml	24 Sep 2003 17:45:26 -0000	1.4
+++ model-elimination.sml	9 Oct 2003 18:17:30 -0000	1.5
@@ -2521,6 +2521,8 @@
 fun finished S.NIL = ((), S.NIL)
   | finished (S.CONS _) = raise Noparse;
 
+val finished: ('a, unit) parser = finished
+
 fun some p = maybe (fn x => if p x then SOME x else NONE);
 
 fun any input = some (K true) input;



1.32      +68 -63    mlton/mlton/mlton-stubs.cm

Index: mlton-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs.cm,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- mlton-stubs.cm	24 Sep 2003 17:54:02 -0000	1.31
+++ mlton-stubs.cm	9 Oct 2003 18:17:30 -0000	1.32
@@ -5,22 +5,19 @@
 ../lib/mlyacc/parser2.sml
 ../lib/mlyacc/join.sml
 upgrade-basis.sml
+../lib/mlton/basic/error.sig
+../lib/mlton/basic/error.sml
 ../lib/mlton-stubs/int-inf.sml
 ../lib/mlton-stubs/real.sml
 ../lib/mlton/pervasive/pervasive.sml
 ../lib/mlton/basic/dynamic-wind.sig
 ../lib/mlton/basic/dynamic-wind.sml
-../lib/mlton/basic/error.sig
-../lib/mlton/basic/error.sml
 ../lib/mlton/basic/outstream0.sml
 ../lib/mlton/basic/relation0.sml
 ../lib/mlton/basic/char0.sml
 ../lib/mlton/basic/string0.sml
 ../lib/mlton/basic/layout.sig
 ../lib/mlton/basic/layout.sml
-../lib/mlton/basic/instream0.sml
-../lib/mlton/basic/fold.sig
-../lib/mlton/basic/fold.fun
 ../lib/mlton-stubs/thread.sml
 ../lib/mlton-stubs/random.sig
 ../lib/mlton-stubs/random.sml
@@ -52,12 +49,17 @@
 ../lib/mlton-stubs/itimer.sig
 ../lib/mlton-stubs/mlton.sig
 ../lib/mlton-stubs/mlton.sml
-../lib/mlton/basic/word.sig
-../lib/mlton/basic/word8.sml
 ../lib/mlton/basic/assert.sig
 ../lib/mlton/basic/assert.sml
+../lib/mlton/basic/fold.sig
+../lib/mlton/basic/fold.fun
 ../lib/mlton/basic/list.sig
 ../lib/mlton/basic/list.sml
+../lib/mlton/basic/option.sig
+../lib/mlton/basic/option.sml
+../lib/mlton/basic/string-map.sig
+../lib/mlton/basic/word.sig
+../lib/mlton/basic/word8.sml
 ../lib/mlton/basic/word32.sig
 ../lib/mlton/basic/word.sml
 ../lib/mlton/basic/string1.sml
@@ -67,29 +69,15 @@
 ../lib/mlton/basic/outstream.sml
 ../lib/mlton/basic/relation.sig
 ../lib/mlton/basic/relation.sml
-../lib/mlton/basic/ring.sig
-../lib/mlton/basic/ring-with-identity.sig
-../lib/mlton/basic/promise.sig
-../lib/mlton/basic/promise.sml
-../lib/mlton/basic/stream.sig
-../lib/mlton/basic/stream.sml
-../lib/mlton/basic/euclidean-ring.sig
-../lib/mlton/basic/integer.sig
-../lib/mlton/basic/ring.fun
-../lib/mlton/basic/ordered-ring.sig
-../lib/mlton/basic/ordered-ring.fun
-../lib/mlton/basic/power.sml
-../lib/mlton/basic/string-map.sig
 ../lib/mlton/basic/order0.sig
 ../lib/mlton/basic/order.sig
 ../lib/mlton/basic/time.sig
 ../lib/mlton/basic/time.sml
+../lib/mlton/basic/instream0.sml
 ../lib/mlton/basic/computation.sig
 ../lib/mlton/basic/intermediate-computation.sig
 ../lib/mlton/basic/intermediate-computation.sml
 ../lib/mlton/basic/string-map.sml
-../lib/mlton/basic/option.sig
-../lib/mlton/basic/option.sml
 ../lib/mlton/basic/pid.sig
 ../lib/mlton/basic/pid.sml
 ../lib/mlton/basic/date.sig
@@ -101,12 +89,29 @@
 ../lib/mlton/basic/unit.sml
 ../lib/mlton/basic/trace.sig
 ../lib/mlton/basic/trace.sml
-../lib/mlton/basic/ring-with-identity.fun
 ../lib/mlton/basic/bool.sig
 ../lib/mlton/basic/bool.sml
+../lib/mlton/basic/ring.sig
+../lib/mlton/basic/ring-with-identity.sig
+../lib/mlton/basic/promise.sig
+../lib/mlton/basic/promise.sml
+../lib/mlton/basic/stream.sig
+../lib/mlton/basic/stream.sml
+../lib/mlton/basic/euclidean-ring.sig
+../lib/mlton/basic/integer.sig
+../lib/mlton/basic/ring.fun
+../lib/mlton/basic/ordered-ring.sig
+../lib/mlton/basic/ordered-ring.fun
+../lib/mlton/basic/power.sml
+../lib/mlton/basic/ring-with-identity.fun
 ../lib/mlton/basic/euclidean-ring.fun
 ../lib/mlton/basic/integer.fun
 ../lib/mlton/basic/int.sml
+../lib/mlton/basic/vector.sig
+../lib/mlton/basic/vector.fun
+../lib/mlton/basic/vector.sml
+../lib/mlton/set/set.sig
+../lib/mlton/set/unordered.fun
 ../lib/mlton/basic/property-list.sig
 ../lib/mlton/basic/property.sig
 ../lib/mlton/basic/het-container.sig
@@ -121,12 +126,9 @@
 ../lib/mlton/basic/ref.sml
 ../lib/mlton/basic/property-list.fun
 ../lib/mlton/basic/property.fun
-../lib/mlton/basic/vector.sig
 ../lib/mlton/basic/array.sig
-../lib/mlton/basic/vector.fun
 ../lib/mlton/basic/random.sig
 ../lib/mlton/basic/random.sml
-../lib/mlton/basic/vector.sml
 ../lib/mlton/basic/array.fun
 ../lib/mlton/basic/array.sml
 ../lib/mlton/basic/hash-set.sig
@@ -145,39 +147,36 @@
 control/source-pos.sml
 control/region.sig
 control/region.sml
-../lib/mlton/set/set.sig
-../lib/mlton/basic/large-word.sml
-ast/word-size.sig
 ast/wrapped.sig
 ast/tyvar.sig
 ast/field.sig
 ast/record.sig
+../lib/mlton/basic/large-word.sml
+ast/word-size.sig
 ast/real-size.sig
 ../lib/mlton/basic/int-inf.sig
 ../lib/mlton/basic/int-inf.sml
 ast/int-size.sig
+ast/tycon-kind.sig
 ast/prim-tycons.sig
-ast/prim-cons.sig
-ast/ast-id.sig
-ast/longid.sig
-ast/ast-const.sig
-ast/ast-atoms.sig
-ast/ast-core.sig
-ast/ast.sig
-atoms/word-x.sig
 atoms/id.sig
-atoms/var.sig
 atoms/tycon.sig
-atoms/source-info.sig
 atoms/type-ops.sig
 atoms/type.sig
+atoms/type-ops.fun
+atoms/type.fun
 atoms/generic-scheme.sig
 atoms/scheme.sig
+atoms/generic-scheme.fun
+atoms/word-x.sig
+atoms/var.sig
+atoms/source-info.sig
 atoms/real-x.sig
 atoms/profile-exp.sig
 atoms/c-type.sig
 atoms/c-function.sig
-atoms/cons.sig
+ast/prim-cons.sig
+atoms/con.sig
 atoms/int-x.sig
 atoms/const.sig
 atoms/prim.sig
@@ -188,6 +187,8 @@
 xml/xml-tree.sig
 xml/sxml-tree.sig
 xml/sxml-tree.fun
+core-ml/core-ml.sig
+core-ml/dead-code.sig
 ../lib/mlton/basic/counter.sig
 ../lib/mlton/basic/counter.sml
 ../lib/mlton/basic/dot-color.sml
@@ -231,6 +232,7 @@
 cm/parse.sml
 cm/cm.sig
 cm/cm.sml
+main/main.sig
 ast/tyvar.fun
 ../lib/mlton/basic/quick-sort.sig
 ../lib/mlton/basic/insertion-sort.sig
@@ -238,8 +240,17 @@
 ../lib/mlton/basic/quick-sort.sml
 ast/record.fun
 ast/field.fun
+control/pretty.sig
+control/pretty.sml
+ast/ast-id.sig
+ast/longid.sig
+ast/ast-const.sig
+ast/ast-atoms.sig
+ast/ast-core.sig
+ast/ast.sig
 ast/ast-const.fun
 ast/word-size.fun
+ast/tycon-kind.fun
 ast/real-size.fun
 ast/prim-tycons.fun
 ast/prim-cons.fun
@@ -249,22 +260,18 @@
 ast/ast-atoms.fun
 ast/ast-core.fun
 ast/ast.fun
-../lib/mlton/set/unordered.fun
 atoms/word-x.fun
 atoms/id.fun
 atoms/var.fun
-atoms/type-ops.fun
-atoms/type.fun
 atoms/tycon.fun
 atoms/source-info.fun
 atoms/real-x.fun
 atoms/profile-exp.fun
 atoms/prim.fun
 atoms/int-x.fun
-atoms/generic-scheme.fun
 atoms/ffi.fun
 atoms/const.fun
-atoms/cons.fun
+atoms/con.fun
 atoms/c-type.fun
 atoms/c-function.fun
 atoms/atoms.fun
@@ -462,22 +469,26 @@
 codegen/x86-codegen/x86-validate.sig
 codegen/x86-codegen/x86-validate.fun
 codegen/x86-codegen/x86-codegen.fun
-core-ml/core-ml.sig
 core-ml/core-ml.fun
-core-ml/dead-code.sig
-core-ml/dead-code.fun
-core-ml/lookup-constant.sig
-core-ml/lookup-constant.fun
+match-compile/nested-pat.sig
+match-compile/nested-pat.fun
+../lib/mlton/env/mono-env.sig
+../lib/mlton/env/basic-env-to-env.fun
+../lib/mlton/env/mono-env.fun
+match-compile/match-compile.sig
+match-compile/match-compile.fun
+defunctorize/defunctorize.sig
+defunctorize/defunctorize.fun
+elaborate/type-env.sig
+elaborate/type-env.fun
 elaborate/decs.sig
 elaborate/elaborate-env.sig
+elaborate/const-type.sig
 elaborate/elaborate.sig
 elaborate/decs.fun
 elaborate/elaborate-env.fun
 elaborate/elaborate-sigexp.sig
 elaborate/elaborate-sigexp.fun
-../lib/mlton/env/mono-env.sig
-../lib/mlton/env/basic-env-to-env.fun
-../lib/mlton/env/mono-env.fun
 atoms/use-name.fun
 elaborate/scope.sig
 elaborate/scope.fun
@@ -493,16 +504,10 @@
 front-end/ml.grm.sml
 front-end/ml.lex.sml
 front-end/front-end.fun
-type-inference/type-env.sig
-type-inference/type-env.fun
-type-inference/nested-pat.sig
-type-inference/nested-pat.fun
-type-inference/match-compile.sig
-type-inference/match-compile.fun
-type-inference/infer.sig
-type-inference/infer.fun
 main/compile.sig
-main/compile.sml
-main/main.sig
+main/lookup-constant.sig
+main/lookup-constant.fun
+main/compile.fun
+main/main.fun
 main/main.sml
 call-main.sml



1.6       +5 -2      mlton/mlton/ast/ast-atoms.fun

Index: ast-atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-atoms.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- ast-atoms.fun	23 Jun 2003 04:58:55 -0000	1.5
+++ ast-atoms.fun	9 Oct 2003 18:17:30 -0000	1.6
@@ -5,7 +5,7 @@
  * MLton is released under the GNU General Public License (GPL).
  * Please see the file MLton-LICENSE for license information.
  *)
-functor AstAtoms (S: AST_ATOMS_STRUCTS) :> AST_ATOMS = 
+functor AstAtoms (S: AST_ATOMS_STRUCTS): AST_ATOMS = 
 struct
 
 open S
@@ -15,6 +15,8 @@
 structure RealSize = RealSize ()
 structure WordSize = WordSize ()
 
+structure Kind = TyconKind ()
+
 structure Tycon =
    struct
       structure Id = AstId (val className = "tycon")
@@ -22,10 +24,11 @@
 
       structure P =
 	 PrimTycons (structure IntSize = IntSize
+		     structure Kind = Kind
 		     structure RealSize = RealSize
 		     structure WordSize = WordSize
 		     open Id
-		     val fromString = fn s => fromString (s, Region.bogus))
+		     fun fromString s = Id.fromString (s, Region.bogus))
       open P
    end
 



1.4       +6 -6      mlton/mlton/ast/ast-atoms.sig

Index: ast-atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-atoms.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- ast-atoms.sig	21 Jul 2003 21:53:50 -0000	1.3
+++ ast-atoms.sig	9 Oct 2003 18:17:30 -0000	1.4
@@ -90,16 +90,16 @@
 	    include WRAPPED sharing type node' = node
 			    sharing type obj = t
 
-	    val var: Tyvar.t -> t
-	    val con: Tycon.t * t vector -> t
-	    val record: t SortedRecord.t -> t
 	    val arrow: t * t -> t
+	    val con: Tycon.t * t vector -> t
 	    val exn:  t
-	    val tuple: t vector -> t
-	    val unit: t
 	    val layout: t -> Layout.t
-	    val layoutOption: t option -> Layout.t
 	    val layoutApp: Layout.t * 'a vector * ('a -> Layout.t) -> Layout.t
+	    val layoutOption: t option -> Layout.t
+	    val record: t SortedRecord.t -> t
+	    val tuple: t vector -> t
+	    val unit: t
+	    val var: Tyvar.t -> t
 	 end
       structure TypBind:
 	 sig



1.5       +5 -3      mlton/mlton/ast/ast-const.fun

Index: ast-const.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-const.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- ast-const.fun	23 Jun 2003 04:58:55 -0000	1.4
+++ ast-const.fun	9 Oct 2003 18:17:30 -0000	1.5
@@ -5,12 +5,13 @@
  * MLton is released under the GNU General Public License (GPL).
  * Please see the file MLton-LICENSE for license information.
  *)
-functor AstConst (S: AST_CONST_STRUCTS) :> AST_CONST =
+functor AstConst (S: AST_CONST_STRUCTS): AST_CONST =
 struct
 
 open Region.Wrap
 datatype node =
-   Char of char
+   Bool of bool
+ | Char of char
  | Int of IntInf.t
  | Real of string
  | String of string
@@ -27,7 +28,8 @@
 in
    fun layout c =
       case node c of
-	 Char c => wrap ("#\"", "\"", String.implode [c])
+	 Bool b => if b then str "true" else str "false"
+       | Char c => wrap ("#\"", "\"", String.implode [c])
        | Int s => str (IntInf.toString s)
        | Real l => String.layout l
        | String s => wrap ("\"", "\"", s)



1.5       +2 -1      mlton/mlton/ast/ast-const.sig

Index: ast-const.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-const.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- ast-const.sig	23 Jun 2003 04:58:55 -0000	1.4
+++ ast-const.sig	9 Oct 2003 18:17:30 -0000	1.5
@@ -19,7 +19,8 @@
 
       type t
       datatype node =
-	 Char of char
+	 Bool of bool
+       | Char of char
        | Int of IntInf.t
        | Real of string
        | String of string



1.14      +114 -102  mlton/mlton/ast/ast-core.fun

Index: ast-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-core.fun,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- ast-core.fun	21 Jul 2003 21:53:50 -0000	1.13
+++ ast-core.fun	9 Oct 2003 18:17:30 -0000	1.14
@@ -60,14 +60,6 @@
       NONE => e
     | SOME ty => layoutConstraint (e, ty)
 
-fun nest (prefix, x, y) =
-   align [seq [str prefix, x],
-	      seq [str "in ", y],
-	      str "end"]
-
-fun layoutLet (d, e) = nest ("let ", d, e)
-fun layoutLocal (d, d') = nest ("local ", d, d')
-
 fun layoutLongvid x =
    str (let val s = Longvid.toString x
 	in if s = "*" then " * "
@@ -76,6 +68,13 @@
 		else s
 	end)
 
+structure Vector =
+   struct
+      open Vector
+
+      fun cons (x, v) = concat [new1 x, v]
+   end
+
 (*---------------------------------------------------*)
 (*                     Patterns                      *)
 (*---------------------------------------------------*)
@@ -92,7 +91,7 @@
 		     var: Var.t,
 		     constraint: Type.t option,
 		     pat: t}
-       | List of t list
+       | List of t vector
        | Record of {flexible: bool,
 		    items: item vector}
        | Tuple of t vector
@@ -119,7 +118,7 @@
       val constraint = make o Constraint
       val layered = make o Layered
 
-      val emptyList = make (List [])
+      val emptyList = make (List (Vector.new0 ()))
 
       fun longvid x = make (Var {name = x, fixop = Fixop.None})
       val var = longvid o Longvid.short o Vid.fromVar
@@ -129,21 +128,25 @@
 	 else longvid (Longvid.short (Vid.fromCon c))
 		     
       fun app (c, p) =
-	 let val default = make (App (Longcon.short c, p))
-	 in if Con.equals (c, Con.cons)
-	       then (case node p of
-			Tuple ps =>
-			   if 2 = Vector.length ps
-			      then
-				 let
-				    val p0 = Vector.sub (ps, 0)
-				    val p1 = Vector.sub (ps, 1)
-				 in case node p1 of
-				     List ps => make (List (p0 :: ps))
-				   | _ => default
-				 end
-			   else default
-		      | _ => default)
+	 let
+	    val default = make (App (Longcon.short c, p))
+	 in
+	    if Con.equals (c, Con.cons)
+	       then
+		  case node p of
+		     Tuple ps =>
+			if 2 = Vector.length ps
+			   then
+			      let
+				 val p0 = Vector.sub (ps, 0)
+				 val p1 = Vector.sub (ps, 1)
+			      in
+				 case node p1 of
+				    List ps => make (List (Vector.cons (p0, ps)))
+				  | _ => default
+			      end
+			else default
+		   | _ => default
 	    else default
 	 end
       
@@ -182,7 +185,7 @@
 		      then str (if Vector.isEmpty items then "..." else ", ...")
 		   else empty,
 		   str "}"]
-	  | List ps => Layout.list (List.map (ps, layoutT))
+	  | List ps => Layout.vector (Vector.map (ps, layoutT))
 	  | FlatApp ps => delimit (layoutFlatApp ps)
 	  | App (c, p) => delimit (mayAlign [Longcon.layout c,
 					     layoutF p])
@@ -273,11 +276,11 @@
   | Seq of exp vector
   | Const of Const.t
   | Record of expNode Wrap.t Record.t (* the Kit barfs on exp Record.t *)
-  | List of exp list
+  | List of exp vector
   | Selector of Field.t
   | Constraint of exp * Type.t
   | Handle of exp * match
-  | Raise of {exn: exp, filePos: string}
+  | Raise of exp
   | If of exp * exp * exp
   | Andalso of exp * exp
   | Orelse of exp * exp
@@ -292,32 +295,34 @@
   | Exception of Eb.t vector
   | Fix of {fixity: Fixity.t,
 	    ops: Vid.t vector}
-  | Fun of Tyvar.t vector * {clauses: {body: exp,
-				       pats: Pat.t vector,
-				       resultType: Type.t option} vector,
-			     filePos: string} vector
+  | Fun of Tyvar.t vector * {body: exp,
+			     pats: Pat.t vector,
+			     resultType: Type.t option} vector vector
   | Local of dec * dec
   | Open of Longstrid.t vector
-  | Overload of Var.t * Type.t * Longvar.t vector
+  | Overload of Var.t * Tyvar.t vector * Type.t * Longvar.t vector
   | SeqDec of dec vector
   | Type of TypBind.t
   | Val of {tyvars: Tyvar.t vector,
 	    vbs: {exp: exp,
-		  filePos: string,
 		  pat: Pat.t} vector,
 	    rvbs: {match: match,
 		   pat: Pat.t} vector}
-and match = T of {filePos: string,
-		  rules: (Pat.t * exp) vector}
+and matchNode = T of (Pat.t * exp) vector
 withtype
-   exp = expNode Wrap.t
-and dec = decNode Wrap.t
+    dec = decNode Wrap.t
+and exp = expNode Wrap.t
+and match = matchNode Wrap.t
 
 open Wrap
 
 structure Match =
    struct
-      datatype t = datatype match
+      open Wrap
+      type t = match
+      datatype node = datatype matchNode
+      type node' = node
+      type obj = t
    end
 
 fun layoutAndsTyvars (prefix, (tyvars, xs), layoutX) =
@@ -330,7 +335,36 @@
 		| [] => [],
 	      fn (prefix, x) => seq [prefix, x])
 
-fun layoutExp (e, isDelimited) =
+fun expNodeName e =
+   case node e of
+      Andalso _ => "Andalso"
+    | App _ => "App"
+    | Case _ => "Case"
+    | Const _ => "Const"
+    | Constraint _ => "Constraint"
+    | FlatApp _ => "FlatApp"
+    | Fn _ => "Fn"
+    | Handle _ => "Handle"
+    | If _ => "If"
+    | Let _ => "Let"
+    | List _ => "List"
+    | Orelse _ => "Orelse"
+    | Prim _ => "Prim"
+    | Raise _ => "Raise"
+    | Record _ => "Record"
+    | Selector _ => "Selector"
+    | Seq _ => "Seq"
+    | Var _ => "Var"
+    | While _ => "While"
+
+val traceLayoutExp =
+   Trace.traceInfo' (Trace.info "layoutExp",
+		     fn (e, b: bool) => Layout.str (expNodeName e),
+		     Layout.ignore: Layout.t -> Layout.t)
+   
+fun layoutExp arg =
+   traceLayoutExp
+   (fn (e, isDelimited) =>
    let
       fun delimit t = if isDelimited then t else paren t
    in
@@ -344,7 +378,7 @@
 	    delimit (align [seq [str "case ", layoutExpT expr,
 				 str " of"],
 			    indent (layoutMatch match, 2)])
-       | Let (dec, expr) => layoutLet (layoutDec dec, layoutExpT expr)
+       | Let (dec, expr) => Pretty.lett (layoutDec dec, layoutExpT expr)
        | Seq es => paren (align (separateRight (layoutExpsT es, " ;")))
        | Const c => Const.layout c
        | Record r =>
@@ -355,19 +389,19 @@
 		  else tuple (layoutExpsT es)
 	    in
 	       Record.layout {record = r,
-			      separator = " =",
+			      separator = " = ",
 			      extra = "",
 			      layoutTuple = layoutTuple,
 			      layoutElt = layoutExpT}
 	    end
-       | List es => list (List.map (es, layoutExpT))
+       | List es => vector (Vector.map (es, layoutExpT))
        | Selector f => seq [str "#", Field.layout f]
        | Constraint (expr, constraint) =>
 	    delimit (layoutConstraint (layoutExpF expr, constraint))
        | Handle (try, match) =>
 	    delimit (align [layoutExpF try,
 			    seq [str "handle ", layoutMatch match]])
-       | Raise {exn, ...} => delimit (seq [str "raise ", layoutExpF exn])
+       | Raise exn => delimit (seq [str "raise ", layoutExpF exn])
        | If (test, thenCase, elseCase) =>
 	    delimit (mayAlign [seq [str "if ", layoutExpT test],
 			       seq [str "then ", layoutExpT thenCase],
@@ -382,13 +416,17 @@
 	    delimit (align [seq [str "while ", layoutExpT test],
 			    seq [str "do ", layoutExpT expr]])
        | Prim {name, ...} => str name
-   end
+   end) arg
 and layoutExpsT es = Vector.toListMap (es, layoutExpT)
 and layoutExpT e = layoutExp (e, true)
 and layoutExpF e = layoutExp (e, false)
 
-and layoutMatch (Match.T {rules, ...}) =
-   alignPrefix (Vector.toListMap (rules, layoutRule), "| ")
+and layoutMatch m =
+   let
+      val Match.T rules = node m
+   in
+      alignPrefix (Vector.toListMap (rules, layoutRule), "| ")
+   end
    
 and layoutRule (pat, exp) =
    mayAlign [seq [Pat.layoutF pat, str " =>"],
@@ -396,40 +434,40 @@
       
 and layoutDec d =
    case node d of
-      Local (d, d') => layoutLocal (layoutDec d, layoutDec d')
-    | SeqDec ds => align (Vector.toListMap (ds, layoutDec))
-    | Val {tyvars, vbs, rvbs} =>
-	 align [layoutAndsTyvars ("val", (tyvars, vbs), layoutVb),
-		layoutAndsTyvars ("val rec", (tyvars, rvbs), layoutRvb)]
-    | Fun fbs => layoutAndsTyvars ("fun", fbs, layoutFb)
-    | Type typBind => TypBind.layout typBind
-    | Datatype rhs => DatatypeRhs.layout rhs
-    | Abstype {datBind, body} =>
+      Abstype {datBind, body} =>
 	 align [DatBind.layout ("abstype", datBind),
 		seq [str "with ", layoutDec body],
 		str "end"]
+    | Datatype rhs => DatatypeRhs.layout rhs
     | Exception ebs =>
 	 layoutAnds ("exception", Vector.toList ebs,
 		     fn (prefix, eb) => seq [prefix, Eb.layout eb])
+    | Fix {fixity, ops} =>
+	 seq [Fixity.layout fixity, str " ",
+	      seq (separate (Vector.toListMap (ops, Vid.layout), " "))]
+    | Fun fbs => layoutAndsTyvars ("fun", fbs, layoutFb)
+    | Local (d, d') => Pretty.locall (layoutDec d, layoutDec d')
     | Open ss => seq [str "open ",
 		      seq (separate (Vector.toListMap (ss, Longstrid.layout),
 				     " "))]
-    | Overload (x, t, xs) =>
+    | Overload (x, _, t, xs) =>
 	 seq [str "_overload ",
 	      align [layoutConstraint (Var.layout x, t),
 		     layoutAnds ("as", Vector.toList xs, fn (prefix, x) =>
 				 seq [prefix, Longvar.layout x])]]
-    | Fix {fixity, ops} =>
-	 seq [Fixity.layout fixity, str " ",
-	      seq (separate (Vector.toListMap (ops, Vid.layout), " "))]
+    | SeqDec ds => align (Vector.toListMap (ds, layoutDec))
+    | Type typBind => TypBind.layout typBind
+    | Val {tyvars, vbs, rvbs} =>
+	 align [layoutAndsTyvars ("val", (tyvars, vbs), layoutVb),
+		layoutAndsTyvars ("val rec", (tyvars, rvbs), layoutRvb)]
 
-and layoutVb {pat, exp, filePos} =
+and layoutVb {pat, exp} =
    bind (Pat.layoutT pat, layoutExpT exp)
 
 and layoutRvb {pat, match, ...} =
    bind (Pat.layout pat, seq [str "fn ", layoutMatch match])
    
-and layoutFb {clauses, filePos} =
+and layoutFb clauses =
    alignPrefix (Vector.toListMap (clauses, layoutClause), "| ")
    
 and layoutClause ({pats, resultType, body}) =
@@ -452,7 +490,8 @@
       fun make n = makeRegion (n, Region.bogus)
       val const = make o Const
       val constraint = make o Constraint
-      val fnn = make o Fn
+      fun fnn rs =
+	 make (Fn (Match.makeRegion (Match.T rs, Region.bogus)))
       val handlee = make o Handle
       val raisee = make o Raise
       val record = make o Record
@@ -468,17 +507,20 @@
 	    case node e of
 	       Var {name=x', ...} => Longvid.equals (x, x')
 	     | _ => false
-      in val isTrue = isLongvid Longvid.truee
+      in
 	 val isFalse = isLongvid Longvid.falsee
+	 val isTrue = isLongvid Longvid.truee
       end
-   
+			    
       fun iff (a: t, b: t, c: t): t =
 	 make (if isTrue b then Orelse (a, c)
 	      else if isFalse c then Andalso (a, b)
 		   else If (a, b, c))
 		 
-      fun casee (e: t, m as Match.T {rules, ...}) =
-	 let val default = make (Case (e, m))
+      fun casee (e: t, m: Match.t) =
+	 let
+	    val Match.T rules = Match.node m
+	    val default = make (Case (e, m))
 	 in
 	    if 2 = Vector.length rules
 	       then
@@ -495,7 +537,7 @@
 	    else default
 	 end
 
-      val emptyList: t = make (List [])
+      val emptyList: t = make (List (Vector.new0 ()))
 	 
       fun con c: t = if Con.equals (c, Con.nill) then emptyList
 		      else longvid (Longvid.short (Vid.fromCon c))
@@ -520,7 +562,9 @@
 					   val es = Vector.sub (v, 1)
 					in
 					   case node es of
-					      List es => make (List (e1 :: es))
+					      List es =>
+						 make (List (Vector.cons
+							     (e1, es)))
 					    | _ => e
 					end
 				  else e
@@ -570,19 +614,6 @@
 
       val unit: t = tuple (Vector.new0 ())
 
-      fun delay (e: t): t =
-	 fnn (Match.T {rules = Vector.new1 (Pat.tuple (Vector.new0 ()), e),
-		       filePos = ""})
-(*	 
- *      val handleFunc =
- *	 let val e = Var.fromString "e"
- *	    val f = Var.fromString "f"
- *	    val x = Var.fromString "x"
- *	 in fnn (rules [(Pat.tuple [Pat.var e, Pat.var f],
- *		       make (Handle (app (var e, unit),
- *				   rules [(Pat.var x, app (var f, var x))])))])
- *	 end
- *)
       val layout = layoutExpT
    end
 
@@ -598,24 +629,6 @@
 	 
       val openn = make o Open
 
-      fun funn (tyvars, rvbs): t =
-	 make
-	 (Fun (tyvars,
-	       Vector.map
-	       (rvbs, fn {var,
-			  match = Match.T {rules, filePos},
-			  resultTy} =>
-		let
-		   val vp = Pat.longvid (Longvid.short (Vid.fromVar var))
-		in
-		   {clauses =
-		    Vector.map (rules, fn (pat, exp) =>
-				{pats = Vector.new2 (vp, pat),
-				 body = exp,
-				 resultType = NONE}),
-		    filePos = filePos}
-		end)))
-	     
       fun exceptionn (exn: Con.t, to: Type.t option): t =
 	 make (Exception (Vector.new1 (exn, make (Eb.Rhs.Gen to))))
 
@@ -634,8 +647,7 @@
 
       fun vall (tyvars, var, exp): t =
 	 make (Val {tyvars = tyvars,
-		    vbs = Vector.new1 {pat = Pat.var var, exp = exp,
-				       filePos = ""},
+		    vbs = Vector.new1 {exp = exp, pat = Pat.var var},
 		    rvbs = Vector.new0 ()})
 
       local



1.10      +14 -20    mlton/mlton/ast/ast-core.sig

Index: ast-core.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-core.sig,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- ast-core.sig	21 Jul 2003 21:53:50 -0000	1.9
+++ ast-core.sig	9 Oct 2003 18:17:30 -0000	1.10
@@ -54,7 +54,7 @@
 			   fixop: Fixop.t,
 			   pat: t,
 			   var: Var.t}
-	     | List of t list
+	     | List of t vector
 	     | Record of {flexible: bool,
 			  items: Item.t vector}
 	     | Tuple of t vector
@@ -113,13 +113,12 @@
 	     | Handle of t * match
 	     | If of t * t * t
 	     | Let of dec * t
-	     | List of t list
+	     | List of t vector
 	     | Orelse of t * t
 	     | Prim of {kind: PrimKind.t,
 			name: string,
 			ty: Type.t}
-	     | Raise of {exn: t,
-			 filePos: string}
+	     | Raise of t
 	     | Record of t Record.t
 	     | Selector of Record.Field.t
 	     | Seq of t vector
@@ -136,13 +135,13 @@
 	    val con: Con.t -> t
 	    val const: Const.t -> t
 	    val constraint: t * Type.t -> t
-	    val fnn: match -> t
+	    val fnn: (Pat.t * t) vector -> t
 	    val handlee: t * match -> t
 	    val iff: t * t * t -> t
 	    val layout: t -> Layout.t
 	    val lett: dec vector * t -> t
 	    val longvid: Longvid.t -> t
-	    val raisee: {exn: t, filePos: string} -> t
+	    val raisee: t -> t
 	    val record: t Record.t -> t
 	    val select: {tuple: t, offset: int} -> t
 	    val seq: t vector -> t
@@ -153,8 +152,11 @@
 
       structure Match:
 	 sig
-	    datatype t = T of {filePos: string,
-			       rules: (Pat.t * Exp.t) vector}
+	    type t
+	    datatype node = T of (Pat.t * Exp.t) vector
+	    include WRAPPED
+	    sharing type node' = node
+            sharing type obj = t
 	 end where type t = Exp.match
       
       structure EbRhs:
@@ -177,20 +179,18 @@
 	     | Exception of (Con.t * EbRhs.t) vector
 	     | Fix of {fixity: Fixity.t,
 		       ops: Vid.t vector}
-	     | Fun of Tyvar.t vector * {clauses: {pats: Pat.t vector,
-						  resultType: Type.t option,
-						  body: Exp.t} vector,
-					filePos: string} vector
+	     | Fun of Tyvar.t vector * {pats: Pat.t vector,
+					resultType: Type.t option,
+					body: Exp.t} vector vector
 	     | Local of t * t
 	     | Open of Longstrid.t vector
-	     | Overload of Var.t * Type.t * Longvar.t vector
+	     | Overload of Var.t * Tyvar.t vector * Type.t * Longvar.t vector
 	     | SeqDec of t vector
 	     | Type of TypBind.t
 	     | Val of {rvbs: {match: Match.t,
 			      pat: Pat.t} vector,
 		       tyvars: Tyvar.t vector,
 		       vbs: {exp: Exp.t,
-			     filePos: string,
 			     pat: Pat.t} vector}
 	    include WRAPPED sharing type node' = node
 			    sharing type obj = t
@@ -201,15 +201,9 @@
             val empty: t
 	    val exceptionn: Con.t * Type.t option -> t
 	    val fromExp: Exp.t -> t
-	    val funn: Tyvar.t vector * {var: Var.t,
-					match: Match.t,
-					resultTy: Type.t option} vector -> t
 	    val layout: t -> Layout.t
 	    val openn: Longstrid.t vector -> t
 	    val vall: Tyvar.t vector * Var.t * Exp.t -> t
 	 end
       sharing type Dec.t = Exp.dec
-
-      val layoutLet: Layout.t * Layout.t -> Layout.t
-      val layoutLocal: Layout.t * Layout.t -> Layout.t
    end



1.7       +116 -28   mlton/mlton/ast/ast.fun

Index: ast.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- ast.fun	24 Nov 2002 01:19:43 -0000	1.6
+++ ast.fun	9 Oct 2003 18:17:30 -0000	1.7
@@ -11,12 +11,6 @@
 open S
 
 structure Const = AstConst ()
-structure Field = Field ()
-structure Record = Record (val isSorted = false
-			   structure Field = Field)
-structure SortedRecord = Record (val isSorted = true
-				 structure Field = Field)
-structure Tyvar = Tyvar ()
    
 structure AstAtoms = AstAtoms (structure Const = Const
 			       structure Record = Record
@@ -225,7 +219,7 @@
 			   | _ => Split 3,
 				seq [Strid.layout name, SigConst.layout constraint],
 				layoutStrexp def))
-    | Local (d, d') => layoutLocal (layoutStrdec d, layoutStrdec d')
+    | Local (d, d') => Pretty.locall (layoutStrdec d, layoutStrdec d')
     | Seq ds => align (layoutStrdecs ds)
     | Core d => Dec.layout d
 
@@ -240,7 +234,7 @@
     | Constrained (e, c) => mayAlign [layoutStrexp e, SigConst.layout c]
     | App (f, e) =>
 	 seq [Fctid.layout f, str "(", layoutStrexp e, str ")"]
-    | Let (dec, strexp) => layoutLet (layoutStrdec dec, layoutStrexp strexp)
+    | Let (dec, strexp) => Pretty.lett (layoutStrdec dec, layoutStrexp strexp)
 	 
 structure Strexp =
    struct
@@ -270,6 +264,7 @@
 
       fun make n = makeRegion (n, Region.bogus)
       val structuree = make o Structure
+
       val locall = make o Local
       val core = make o Core
       val seq = make o Seq
@@ -279,6 +274,64 @@
       val layout = layoutStrdec
 
       val fromExp = core o Dec.fromExp
+
+      val trace = Trace.trace ("coalesce", layout, layout)
+      fun coalesce (d: t): t =
+	 trace
+	 (fn d =>
+	 case node d of
+	    Core _ => d
+	  | Local (d1, d2) =>
+	       let
+		  val d1 = coalesce d1
+		  val d2 = coalesce d2
+		  val node = 
+		     case (node d1, node d2) of
+			(Core d1', Core d2') =>
+			   Core (Dec.makeRegion
+				 (Dec.Local (d1', d2'),
+				  Region.append (region d1, region d2)))
+		      | _ => Local (d1, d2)
+	       in
+		  makeRegion (node, region d)
+	       end
+	  | Seq ds =>
+	       let
+		  fun finish (ds: Dec.t list, ac: t list): t list =
+		     case ds of
+			[] => ac
+		      | _ =>
+			   let
+			      val d =
+				 makeRegion (Core (Dec.makeRegion
+						   (Dec.SeqDec (Vector.fromListRev ds),
+						    Region.bogus)),
+					     Region.bogus)
+			   in
+			      d :: ac
+			   end
+		  fun loop (ds, cores, ac) =
+		     case ds of
+			[] => finish (cores, ac)
+		      | d :: ds =>
+			   let
+			      val d = coalesce d
+			   in
+			      case node d of
+				 Core d => loop (ds, d :: cores, ac)
+			       | Seq ds' => loop (ds' @ ds, cores, ac)
+			       | _ => loop (ds, [], d :: finish (cores, ac))
+			   end
+		  val r = region d
+	       in
+		  case loop (ds, [], []) of
+		     [] => makeRegion (Core (Dec.makeRegion
+					     (Dec.SeqDec (Vector.new0 ()), r)),
+				       r)
+		   | [d] => d
+		   | ds => makeRegion (Seq (rev ds), r)
+	       end
+	  | Structure _ => d) d
    end
 
 structure FctArg =
@@ -348,6 +401,32 @@
 
       fun layout (T ds) = Layout.align (List.map (ds, Topdec.layout))
 
+      fun coalesce (T ds) =
+	 let
+	    fun finish (sds, ac) =
+	       case sds of
+		  [] => ac
+		| _ =>
+		     let
+			val t =
+			   Topdec.makeRegion
+			   (Topdec.Strdec (Strdec.makeRegion
+					   (Strdec.Seq (rev sds), Region.bogus)),
+			    Region.bogus)
+		     in
+			t :: ac
+		     end
+	    fun loop (ds, sds, ac) =
+	       case ds of
+		  [] => finish (sds, ac)
+		| d :: ds =>
+		     case Topdec.node d of
+			Topdec.Strdec d => loop (ds, d :: sds, ac)
+		      | _ => loop (ds, [], d :: finish (sds, ac))
+	 in
+	    T (rev (loop (ds, [], [])))
+	 end
+
       fun size (T ds): int =
 	 let
 	    open Dec Exp Strexp Strdec Topdec
@@ -360,7 +439,7 @@
 		     (Vector.foreach (vbs, exp o #exp)
 		      ; Vector.foreach (rvbs, match o #match))
 		| Fun (_, ds) =>
-		     Vector.foreach (ds, fn {clauses, ...} =>
+		     Vector.foreach (ds, fn clauses =>
 				     Vector.foreach (clauses, exp o #body))
 		| Abstype {body, ...} => dec body
 		| Exception cs => Vector.foreach (cs, fn _ => inc ())
@@ -369,28 +448,37 @@
 		| _ => ()
 
 	    and exp (e: Exp.t): unit =
-	       (inc ();
-		case Exp.node e of
-		   Fn m => match m
-		 | FlatApp es => exps es
-		 | Exp.App (e, e') => (exp e; exp e')
-		 | Case (e, m) => (exp e; match m)
-		 | Exp.Let (d, e) => (dec d; exp e)
-		 | Exp.Seq es => exps es
-		 | Record r => Record.foreach (r, exp)
-		 | List es => List.foreach (es, exp)
-		 | Constraint (e, _) => exp e
-		 | Handle (e, m) => (exp e; match m)
-		 | Raise {exn, ...} => exp exn
-		 | If (e1, e2, e3) => (exp e1; exp e2; exp e3)
-		 | Andalso (e1, e2) => (exp e1; exp e2)
-		 | Orelse (e1, e2) => (exp e1; exp e2)
-		 | While {test, expr} => (exp test; exp expr)
-		 | _ => ())
+	       let
+		  val _ = inc ()
+		  datatype z = datatype Exp.node
+	       in
+		  case Exp.node e of
+		     Andalso (e1, e2) => (exp e1; exp e2)
+		   | App (e, e') => (exp e; exp e')
+		   | Case (e, m) => (exp e; match m)
+		   | Constraint (e, _) => exp e
+		   | FlatApp es => exps es
+		   | Fn m => match m
+		   | Handle (e, m) => (exp e; match m)
+		   | If (e1, e2, e3) => (exp e1; exp e2; exp e3)
+		   | Let (d, e) => (dec d; exp e)
+		   | List es => Vector.foreach (es, exp)
+		   | Orelse (e1, e2) => (exp e1; exp e2)
+		   | Raise exn => exp exn
+		   | Record r => Record.foreach (r, exp)
+		   | Seq es => exps es
+		   | While {test, expr} => (exp test; exp expr)
+		   | _ => ()
+	       end
 
 	    and exps es = Vector.foreach (es, exp)
 	       
-	    and match (Match.T {rules, ...}) = Vector.foreach (rules, exp o #2)
+	    and match m =
+	       let
+		  val Match.T rules = Match.node m
+	       in
+		  Vector.foreach (rules, exp o #2)
+	       end
 		     
 	    fun strdec d =
 	       case Strdec.node d of



1.4       +16 -10    mlton/mlton/ast/ast.sig

Index: ast.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- ast.sig	24 Nov 2002 01:19:43 -0000	1.3
+++ ast.sig	9 Oct 2003 18:17:30 -0000	1.4
@@ -7,6 +7,10 @@
  *)
 signature AST_STRUCTS =
    sig
+      structure Record: RECORD
+      structure SortedRecord: RECORD
+      sharing Record.Field = SortedRecord.Field
+      structure Tyvar: TYVAR
    end
 
 signature AST =
@@ -90,11 +94,11 @@
 
 	    type t
 	    datatype node =
-	       Var of Longstrid.t
-	     | Struct of strdec
+	       App of Fctid.t * t
              | Constrained of t * SigConst.t
-	     | App of Fctid.t * t
 	     | Let of strdec * t
+	     | Struct of strdec
+	     | Var of Longstrid.t
 
 	    include WRAPPED sharing type node' = node
 			    sharing type obj = t
@@ -112,16 +116,17 @@
 	 sig
 	    type t
 	    datatype node =
-	       Structure of {name: Strid.t,
+	       Core of Dec.t
+	     | Local of t * t
+	     | Seq of t list
+	     | Structure of {name: Strid.t,
 			     def: Strexp.t,
 			     constraint: SigConst.t} list
-	     | Seq of t list
-	     | Local of t * t
-	     | Core of Dec.t
 
 	    include WRAPPED sharing type node' = node
 			    sharing type obj = t
 
+            val coalesce: t -> t
             val core: Dec.t -> t
 	    val layout: t -> Layout.t
 	    val locall: t * t -> t
@@ -147,12 +152,12 @@
 	 sig
 	    type t
 	    datatype node =
-	       Strdec of Strdec.t
-	     | Signature of (Sigid.t * Sigexp.t) list
-	     | Functor of {name: Fctid.t,
+	       Functor of {name: Fctid.t,
 			   arg: FctArg.t,
 			   result: SigConst.t,
 			   body: Strexp.t} list
+	     | Signature of (Sigid.t * Sigexp.t) list
+	     | Strdec of Strdec.t
 
 	    include WRAPPED sharing type node' = node
 			    sharing type obj = t
@@ -172,6 +177,7 @@
 	    datatype t = T of Topdec.t list
 
 	    val append: t * t -> t
+	    val coalesce: t -> t
 	    val empty: t
 	    val size: t -> int
 	    val layout: t -> Layout.t



1.3       +1 -1      mlton/mlton/ast/prim-cons.fun

Index: prim-cons.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/prim-cons.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- prim-cons.fun	10 Apr 2002 07:02:18 -0000	1.2
+++ prim-cons.fun	9 Oct 2003 18:17:30 -0000	1.3
@@ -5,7 +5,7 @@
  * MLton is released under the GNU General Public License (GPL).
  * Please see the file MLton-LICENSE for license information.
  *)
-functor PrimCons(S: PRIM_CONS_STRUCTS) :> PRIM_CONS where type con = S.t =
+functor PrimCons (S: PRIM_CONS_STRUCTS): PRIM_CONS =
    struct
       open S
 



1.9       +42 -6     mlton/mlton/ast/prim-tycons.fun

Index: prim-tycons.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/prim-tycons.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- prim-tycons.fun	11 Sep 2003 00:51:07 -0000	1.8
+++ prim-tycons.fun	9 Oct 2003 18:17:30 -0000	1.9
@@ -56,14 +56,34 @@
     (word16, W16),
     (word32, W32),
     (word64, W64)]
+
+datatype z = datatype Kind.t
    
 val prims =
-   [array, arrow, bool, char, exn,
-    int8, int16, int32, int64, intInf,
-    list, pointer, preThread,
-    real32, real64,
-    reff, thread, tuple, vector, weak,
-    word8, word16, word32, word64]
+   [(array, Arity 1),
+    (arrow, Arity 2),
+    (bool, Arity 0),
+    (char, Arity 0),
+    (exn, Arity 0),
+    (int8, Arity 0),
+    (int16, Arity 0),
+    (int32, Arity 0),
+    (int64, Arity 0),
+    (intInf, Arity 0),
+    (list, Arity 1),
+    (pointer, Arity 0),
+    (preThread, Arity 0),
+    (real32, Arity 0),
+    (real64, Arity 0),
+    (reff, Arity 1),
+    (thread, Arity 0),
+    (tuple, Nary),
+    (vector, Arity 1),
+    (weak, Arity 1),
+    (word8, Arity 0),
+    (word16, Arity 0),
+    (word32, Arity 0),
+    (word64, Arity 0)]
    
 val int =
    fn I8 => int8
@@ -92,6 +112,22 @@
    val isRealX = is [real32, real64]
    val isWordX = is [word8, word16, word32, word64]
 end
+
+fun layoutApp (c, ts) =
+   let
+      val tuple' = tuple
+      open Layout
+   in
+      if equals (c, arrow)
+	 then seq [Vector.sub (ts, 0), str " -> ", Vector.sub (ts, 1)]
+      else if equals (c, tuple')
+	      then tuple (Vector.toList ts)
+	   else
+	      case Vector.length ts of
+		 0 => layout c
+	       | 1 => seq [Vector.sub (ts, 0), str " ", layout c]
+	       | _ => seq [tuple (Vector.toList ts), str " ", layout c]
+   end
 
 end
 	  



1.7       +6 -2      mlton/mlton/ast/prim-tycons.sig

Index: prim-tycons.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/prim-tycons.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- prim-tycons.sig	23 Jun 2003 04:58:55 -0000	1.6
+++ prim-tycons.sig	9 Oct 2003 18:17:30 -0000	1.7
@@ -8,6 +8,7 @@
 signature PRIM_TYCONS_STRUCTS =
    sig
       structure IntSize: INT_SIZE
+      structure Kind: TYCON_KIND
       structure RealSize: REAL_SIZE
       structure WordSize: WORD_SIZE
 
@@ -15,14 +16,16 @@
 
       val fromString: string -> t
       val equals: t * t -> bool
+      val layout: t -> Layout.t
    end
 
 signature PRIM_TYCONS =
    sig
       structure IntSize: INT_SIZE
+      structure Kind: TYCON_KIND
       structure RealSize: REAL_SIZE
       structure WordSize: WORD_SIZE
-
+     
       type tycon
 
       val array: tycon
@@ -39,10 +42,11 @@
       val isIntX: tycon -> bool
       val isRealX: tycon -> bool
       val isWordX: tycon -> bool
+      val layoutApp: tycon * Layout.t vector -> Layout.t
       val list: tycon
       val pointer: tycon
       val preThread: tycon
-      val prims: tycon list
+      val prims: (tycon * Kind.t) list
       val real: RealSize.t -> tycon
       val reals: (tycon * RealSize.t) list
       val reff: tycon



1.5       +8 -1      mlton/mlton/ast/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/sources.cm,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- sources.cm	23 Jun 2003 04:58:55 -0000	1.4
+++ sources.cm	9 Oct 2003 18:17:30 -0000	1.5
@@ -8,20 +8,25 @@
 Group
 
 signature AST
-signature AST_ID
+signature FIELD
 signature INT_SIZE
 signature LONGID
 signature PRIM_CONS
 signature PRIM_TYCONS
 signature REAL_SIZE
 signature RECORD
+signature TYCON_KIND
 signature TYVAR
 signature WORD_SIZE
 signature WRAPPED
 
 functor Ast
+functor Field
 functor PrimCons
 functor PrimTycons
+functor Record
+functor TyconKind
+functor Tyvar
    
 is
 
@@ -52,6 +57,8 @@
 real-size.sig
 record.fun
 record.sig
+tycon-kind.fun
+tycon-kind.sig
 tyvar.fun
 tyvar.sig
 word-size.fun



1.5       +1 -1      mlton/mlton/ast/tyvar.fun

Index: tyvar.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/tyvar.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- tyvar.fun	10 Apr 2002 07:02:18 -0000	1.4
+++ tyvar.fun	9 Oct 2003 18:17:30 -0000	1.5
@@ -5,7 +5,7 @@
  * MLton is released under the GNU General Public License (GPL).
  * Please see the file MLton-LICENSE for license information.
  *)
-functor Tyvar (S: TYVAR_STRUCTS) :> TYVAR = 
+functor Tyvar (S: TYVAR_STRUCTS): TYVAR = 
 struct
 
 open S



1.1                  mlton/mlton/ast/tycon-kind.fun

Index: tycon-kind.fun
===================================================================
functor TyconKind (S: TYCON_KIND_STRUCTS): TYCON_KIND = 
struct

open S

datatype t =
   Arity of int
 | Nary

val layout =
   fn Arity n => Int.layout n
    | Nary => Layout.str "n-ary"
	 
end




1.1                  mlton/mlton/ast/tycon-kind.sig

Index: tycon-kind.sig
===================================================================
type int = Int.t

signature TYCON_KIND_STRUCTS = 
   sig
   end

signature TYCON_KIND = 
   sig
      include TYCON_KIND_STRUCTS
      
      datatype t =
	 Arity of int
       | Nary

      val layout: t -> Layout.t
   end



1.11      +4 -31     mlton/mlton/atoms/atoms.fun

Index: atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- atoms.fun	21 Jul 2003 21:53:50 -0000	1.10
+++ atoms.fun	9 Oct 2003 18:17:31 -0000	1.11
@@ -14,32 +14,12 @@
 
       structure SourceInfo = SourceInfo ()
       structure ProfileExp = ProfileExp (structure SourceInfo = SourceInfo)
-      structure Var = Var (structure AstId = Ast.Var)
-      structure Tycon = Tycon (structure AstId = Ast.Tycon
-			       structure IntSize = IntSize
+      structure Var = Var ()
+      structure Tycon = Tycon (structure IntSize = IntSize
 			       structure RealSize = RealSize
 			       structure WordSize = WordSize)
       fun f (x: IntSize.t): Tycon.IntSize.t = x
-      structure Type =
-	 Type (structure Ast = Ast
-	       structure IntSize = IntSize
-	       structure Record = Ast.SortedRecord
-	       structure Tyvar = Ast.Tyvar
-	       structure Tycon = Tycon
-	       structure WordSize = WordSize)
-      structure Scheme: SCHEME =
-	 struct
-	    structure Arg =
-	       struct
-		  structure Tycon = Tycon
-		  structure Tyvar = Ast.Tyvar
-		  structure Type = Type
-	       end
-	    structure S = GenericScheme (Arg)
-	    open S Arg
-	 end
-      structure Con = Con (structure AstId = Ast.Con
-			  structure Var = Var)
+      structure Con = Con (structure Var = Var)
       structure CType = CType (structure IntSize = IntSize
 			       structure RealSize = RealSize
 			       structure WordSize = WordSize)
@@ -49,8 +29,7 @@
       structure IntX = IntX (structure IntSize = IntSize)
       structure RealX = RealX (structure RealSize = RealSize)
       structure WordX = WordX (structure WordSize = WordSize)
-      structure Const = Const (structure Ast = Ast
-			       structure IntX = IntX
+      structure Const = Const (structure IntX = IntX
 			       structure RealX = RealX
 			       structure WordX = WordX)
       structure Prim = Prim (structure CFunction = CFunction
@@ -58,14 +37,8 @@
 			     structure Con = Con
 			     structure Const = Const
 			     structure IntSize = IntSize
-			     structure Longid = Ast.Longvid
 			     structure RealSize = RealSize
-			     structure Scheme = Scheme
-			     structure Type = Type
 			     structure WordSize = WordSize)
-      structure Record = Ast.Record
-      structure SortedRecord = Ast.SortedRecord
-      structure Tyvar = Ast.Tyvar
       structure Tyvars = UnorderedSet (Tyvar)
       structure Vars = UnorderedSet (Var)
       structure Cons = UnorderedSet (Con)



1.11      +16 -16    mlton/mlton/atoms/atoms.sig

Index: atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.sig,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- atoms.sig	21 Jul 2003 21:53:50 -0000	1.10
+++ atoms.sig	9 Oct 2003 18:17:31 -0000	1.11
@@ -7,10 +7,14 @@
  *)
 signature ATOMS_STRUCTS =
    sig
-      structure Ast: AST
+      structure Field: FIELD
       structure IntSize: INT_SIZE
       structure RealSize: REAL_SIZE
+      structure Record: RECORD
+      structure SortedRecord: RECORD
+      structure Tyvar: TYVAR
       structure WordSize: WORD_SIZE
+      sharing Field = Record.Field = SortedRecord.Field
    end
 
 signature ATOMS' =
@@ -27,39 +31,26 @@
       structure Prim: PRIM 
       structure ProfileExp: PROFILE_EXP
       structure RealX: REAL_X
-      structure Record: RECORD
-      structure Scheme: SCHEME
-      structure SortedRecord: RECORD
       structure SourceInfo: SOURCE_INFO
       structure Tycon: TYCON
       structure Tycons: SET
-      structure Tyvar: TYVAR
       structure Var: VAR
       structure Vars: SET
       structure Tyvars: SET
       structure WordX: WORD_X
 
-      sharing Ast = Const.Ast = Prim.Type.Ast
-      sharing Ast.Con = Con.AstId
-      sharing Ast.Tycon = Tycon.AstId
-      sharing Ast.Tyvar = Scheme.Tyvar
-      sharing Ast.Var = Var.AstId
       sharing CFunction = Ffi.CFunction = Prim.CFunction
       sharing CFunction.CType = CType = Ffi.CType = Prim.CType
       sharing Con = Prim.Con
       sharing Const = Prim.Const
+      sharing Field = Record.Field = SortedRecord.Field
       sharing IntSize = CType.IntSize = IntX.IntSize = Prim.IntSize =
 	 Tycon.IntSize
       sharing IntX = Const.IntX
       sharing RealSize = CType.RealSize = Prim.RealSize = RealX.RealSize
 	 = Tycon.RealSize
       sharing RealX = Const.RealX
-      sharing Record = Ast.Record
-      sharing Scheme = Prim.Scheme
-      sharing SortedRecord = Ast.SortedRecord
       sharing SourceInfo = ProfileExp.SourceInfo
-      sharing Tycon = Scheme.Tycon
-      sharing Tyvar = Ast.Tyvar
       sharing WordSize = CType.WordSize = Prim.WordSize = Tycon.WordSize
 	 = WordX.WordSize
       sharing WordX = Const.WordX
@@ -75,14 +66,21 @@
 	 
       include ATOMS'
 
-      sharing Ast = Atoms.Ast
+      sharing CFunction = Atoms.CFunction
+      sharing CType = Atoms.CType
       sharing Con = Atoms.Con
       sharing Cons = Atoms.Cons
       sharing Const = Atoms.Const
       sharing Ffi = Atoms.Ffi
+      sharing Field = Atoms.Field
+      sharing IntSize = Atoms.IntSize
+      sharing IntX = Atoms.IntX
       sharing Prim = Atoms.Prim
       sharing ProfileExp = Atoms.ProfileExp
+      sharing RealSize = Atoms.RealSize
+      sharing RealX = Atoms.RealX
       sharing Record = Atoms.Record
+      sharing SortedRecord = Atoms.SortedRecord
       sharing SourceInfo = Atoms.SourceInfo
       sharing Tycon = Atoms.Tycon
       sharing Tycons = Atoms.Tycons
@@ -90,4 +88,6 @@
       sharing Tyvars = Atoms.Tyvars
       sharing Var = Atoms.Var
       sharing Vars = Atoms.Vars
+      sharing WordSize = Atoms.WordSize
+      sharing WordX = Atoms.WordX
    end



1.3       +1 -1      mlton/mlton/atoms/c-type.sig

Index: c-type.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-type.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- c-type.sig	25 Jul 2003 20:14:46 -0000	1.2
+++ c-type.sig	9 Oct 2003 18:17:31 -0000	1.3
@@ -29,7 +29,7 @@
       val equals: t * t -> bool
       val isPointer: t -> bool
       val memo: (t -> 'a) -> t -> 'a
-      (* name: R{32,64} I[8,16,32,64] P W[8,16,32] *)
+      (* name: R{32,64} I[8,16,32,64] P W[8,16,32,64] *)
       val name: t -> string
       val pointer: t
       val layout: t -> Layout.t



1.12      +0 -21     mlton/mlton/atoms/const.fun

Index: const.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/const.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- const.fun	12 Sep 2003 01:22:55 -0000	1.11
+++ const.fun	9 Oct 2003 18:17:31 -0000	1.12
@@ -11,11 +11,6 @@
 open S
 
 local
-   open Ast
-in
-   structure Aconst = Const
-end
-local
    open IntX
 in
    structure IntSize = IntSize
@@ -93,22 +88,6 @@
        | Word8Vector v => String.hash (Word8.vectorToString v)
 end
    
-fun 'a toAst (make: Ast.Const.t -> 'a, constrain: 'a * Ast.Type.t -> 'a) c =
-   let
-      val aconst =
-	 case c of
-	    Int i => Aconst.Int (IntX.toIntInf i)
-	  | IntInf i => Aconst.Int i
-	  | Real r => Aconst.Real (RealX.toString r)
-	  | Word w => Aconst.Word (WordX.toIntInf w)
-	  | Word8Vector v => Aconst.String (Word8.vectorToString v)
-   in
-      make (Ast.Const.makeRegion (aconst, Region.bogus))
-   end
-
-val toAstExp = toAst (Ast.Exp.const, Ast.Exp.constraint)
-val toAstPat = toAst (Ast.Pat.const, Ast.Pat.constraint)
-
 fun equals (c, c') =
    case (c, c') of
       (Int i, Int i') => IntX.equals (i, i')



1.9       +0 -3      mlton/mlton/atoms/const.sig

Index: const.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/const.sig,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- const.sig	2 Jul 2003 15:08:16 -0000	1.8
+++ const.sig	9 Oct 2003 18:17:31 -0000	1.9
@@ -10,7 +10,6 @@
    
 signature CONST_STRUCTS = 
    sig
-      structure Ast: AST
       structure IntX: INT_X
       structure RealX: REAL_X
       structure WordX: WORD_X
@@ -41,8 +40,6 @@
       val layout: t -> Layout.t
       val real: RealX.t -> t
       val string: string -> t
-      val toAstExp: t -> Ast.Exp.t
-      val toAstPat: t -> Ast.Pat.t
       val toString: t -> string
       val word: WordX.t -> t
       val word8: Word8.t -> t



1.8       +5 -45     mlton/mlton/atoms/hash-type.fun

Index: hash-type.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/hash-type.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- hash-type.fun	23 Jun 2003 04:58:55 -0000	1.7
+++ hash-type.fun	9 Oct 2003 18:17:31 -0000	1.8
@@ -47,7 +47,7 @@
 	 end
       open Dest
 
-      fun deconOpt t =
+      fun deConOpt t =
 	 case dest t of
 	    Con x => SOME x
 	  | _ => NONE
@@ -86,18 +86,10 @@
 	 in res
 	 end
 
-      local
-	 structure Atype = Ast.Type
-      in
-	 fun toAst t =
-	    hom {ty = t,
-		 var = Atype.var,
-		 con = fn (c, ts) =>
-		 if Tycon.equals (c, Tycon.tuple) then Atype.tuple ts
-		 else Atype.con (Tycon.toAst c, ts)}
-      end
-   
-      val layout = Ast.Type.layout o toAst
+      fun layout (ty: t): Layout.t =
+	 hom {con = Tycon.layoutApp,
+	      ty = ty,
+	      var = Tyvar.layout}
 
       val toString = Layout.toString o layout
 	 
@@ -165,22 +157,6 @@
    
 structure Plist = PropertyList
 
-local structure Type = Ast.Type
-in
-   fun toAst (t: t): Type.t =
-      case dest t of
-	 Var a => Type.var a
-       | Con (c, ts) =>
-	    let
-	       val ts = Vector.map (ts, toAst)
-	    in
-	       if Tycon.equals (c, Tycon.tuple) then Type.tuple ts
-	       else Type.con (Tycon.toAst c, ts)
-	    end
-end
-
-fun optionToAst z = Option.map (z, toAst)
-
 fun ofConst c =
    let
       datatype z = datatype Const.t
@@ -237,22 +213,6 @@
        ; Layout.output (lay, out)
        ; print "\n"
        ; raise TypeError)
-end
-
-local
-   structure Ptype = Prim.Type
-in
-   fun fromPrims ts = Vector.map (ts, fromPrim)
-   and fromPrim t =
-      case t of
-	 Ptype.Var a => var a
-       | Ptype.Con (c, ts) => con (c, fromPrims ts)
-       | Ptype.Record r =>
-	    con (Tycon.tuple, fromPrims (SortedRecord.range r))
-
-   fun toPrim t = hom {ty = t,
-		       var = Ptype.var,
-		       con = Ptype.con}
 end
 
 fun tycon t =



1.5       +0 -5      mlton/mlton/atoms/hash-type.sig

Index: hash-type.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/hash-type.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- hash-type.sig	23 Jun 2003 04:58:55 -0000	1.4
+++ hash-type.sig	9 Oct 2003 18:17:31 -0000	1.5
@@ -32,7 +32,6 @@
       val equals: t * t -> bool
       (* for reporting type errors *)
       val error: string * Layout.t -> 'a
-      val fromPrim: Prim.Type.t -> t
       val hash: t -> Word.t
       val hom: {ty: t,
 		var: Tyvar.t -> 'a,
@@ -49,7 +48,6 @@
 	 -> {hom: t -> 'a,
 	     destroy: unit -> unit}
       val ofConst: Const.t -> t
-      val optionToAst: t option -> Ast.Type.t option
       val plist: t -> PropertyList.t
       val stats: unit -> Layout.t
       val string: t (* synonym for word8Vector *)
@@ -58,9 +56,6 @@
        * The ai's are not required to contain every free variable in t
        *)
       val substitute: t * (Tyvar.t * t) vector -> t
-      (* conversion to Ast *)
-      val toAst: t -> Ast.Type.t
-      val toPrim: t -> Prim.Type.t
       val toString: t -> string
       val tycon: t -> Tycon.t
       val var: Tyvar.t -> t



1.6       +0 -10     mlton/mlton/atoms/id.fun

Index: id.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/id.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- id.fun	7 Dec 2002 02:21:51 -0000	1.5
+++ id.fun	9 Oct 2003 18:17:31 -0000	1.6
@@ -122,11 +122,6 @@
    open I
 end
    
-val fromAst = newString o AstId.toString
-fun fromAsts l = List.map (l, fromAst)
-fun toAst id = AstId.fromString (toString id, Region.bogus)
-fun toAsts l = List.map (l, toAst)
-
 end
 
 functor HashId (S: ID_STRUCTS): HASH_ID =
@@ -228,11 +223,6 @@
       printName = ref NONE,
       hash = Random.word (),
       plist = Plist.new ()}
-
-val fromAst = newString o AstId.toString
-fun fromAsts l = List.map (l, fromAst)
-fun toAst id = AstId.fromString (toString id, Region.bogus)
-fun toAsts l = List.map (l, toAst)
 
 val clear = Plist.clear o plist
    



1.4       +0 -7      mlton/mlton/atoms/id.sig

Index: id.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/id.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- id.sig	7 Dec 2002 02:21:51 -0000	1.3
+++ id.sig	9 Oct 2003 18:17:31 -0000	1.4
@@ -33,18 +33,11 @@
 signature ID_STRUCTS =
    sig
       include ID_NO_AST_STRUCTS
-      structure AstId: AST_ID
    end
 
 signature ID =
    sig
       include ID_NO_AST
-      structure AstId: AST_ID
-	 
-      val fromAst: AstId.t -> t
-      val fromAsts: AstId.t list -> t list
-      val toAst: t -> AstId.t
-      val toAsts: t list -> AstId.t list
    end
 
 signature HASH_ID =



1.4       +2 -2      mlton/mlton/atoms/int-x.fun

Index: int-x.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/int-x.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- int-x.fun	12 Sep 2003 01:22:55 -0000	1.3
+++ int-x.fun	9 Oct 2003 18:17:31 -0000	1.4
@@ -4,10 +4,10 @@
 open S
 
 datatype z = datatype IntSize.t
-   
+
 datatype t = T of {int: IntInf.t,
 		   size: IntSize.t}
-
+   
 local
    fun make f (T r) = f r
 in



1.64      +104 -248  mlton/mlton/atoms/prim.fun

Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.63
retrieving revision 1.64
diff -u -r1.63 -r1.64
--- prim.fun	12 Sep 2003 01:22:55 -0000	1.63
+++ prim.fun	9 Oct 2003 18:17:31 -0000	1.64
@@ -25,12 +25,6 @@
    structure IntX = IntX
    structure WordX = WordX
 end
-local
-   open Type
-in
-   structure Tycon = Tycon
-   structure Tyvar = Tyvar
-end
 
 structure Kind =
    struct
@@ -50,7 +44,6 @@
        | Array_sub (* backend *)
        | Array_toVector (* backend *)
        | Array_update (* backend *)
-       | BuildConstant of string (* type inference *)
        | C_CS_charArrayToWord8Array (* type inference *)
        | Char_chr (* type inference *)
        | Char_ge (* type inference *)
@@ -59,7 +52,6 @@
        | Char_lt (* type inference *)
        | Char_ord (* type inference *)
        | Char_toWord8 (* type inference *)
-       | Constant of string (* type inference *)
        | Cpointer_isNull (* codegen *)
        | Exn_extra (* implement exceptions *)
        | Exn_keepHistory (* a compile-time boolean *)
@@ -459,9 +451,7 @@
 	 
       fun toString n =
 	 case n of
-	    BuildConstant s => s
-	  | Constant s => s
-	  | FFI f => CFunction.name f
+	    FFI f => CFunction.name f
 	  | FFI_Symbol {name, ...} => name
 	  | _ => (case List.peek (strings, fn (n', _, _) => n = n') of
 		     NONE => Error.bug "Prim.toString missing name"
@@ -473,17 +463,13 @@
 datatype t =
    T of {name: Name.t,
 	 nameString: string,
-	 scheme: Scheme.t,
-	 kind: Kind.t,
-	 numArgs: int option}
+	 kind: Kind.t}
 
 local
    fun make sel (T r) = sel r
 in
    val kind = make #kind
    val name = make #name
-   val numArgs = make #numArgs
-   val scheme = make #scheme
    val toString = make #nameString
 end
 
@@ -501,270 +487,136 @@
 val mayOverflow = Name.mayOverflow o name
 val mayRaise = Name.mayRaise o name
 
-structure CType =
-   struct
-      open CType
+fun make (n: Name.t, k: Kind.t): t =
+   T {kind = k,
+      name = n,
+      nameString = Name.toString n}
 
-      val toType =
-	 memo (fn t =>
-	       case t of
-		  Int s => Type.int s
-		| Pointer => Type.pointer
-		| Real s => Type.real s
-		| Word s => Type.word s)
-   end
+fun equals (p, p') = Name.equals (name p, name p')
 
-structure Scheme =
-   struct
-      open Scheme
-	 
-      fun numArgs (s: t): int option =
-	 case Type.dearrowOpt (ty s) of
-	    NONE => NONE
-	  | SOME (t, _) => (case Type.detupleOpt t of
-			      NONE => SOME 1
-			    | SOME ts => SOME (Vector.length ts))
+val new: Name.t -> t =
+   fn n =>
+   let
+      val k =
+	 case n of
+	    Name.FFI _ => Kind.SideEffect
+	  | Name.FFI_Symbol _ => Kind.DependsOnState
+	  | _ => (case List.peek (Name.strings, fn (n', _, _) => n = n') of
+		     NONE => Error.bug (concat ["strange name: ",
+						Name.toString n])
+		   | SOME (_, k, _) => k)
+   in
+      make (n, k)
    end
 
-fun new (n: Name.t, k: Kind.t, s: Scheme.t): t =
-   T {
-      kind = k,
-      name = n,
-      nameString = Name.toString n,
-      numArgs = Scheme.numArgs s,
-      scheme = s
-      }
+val array = new Name.Array_array
+val assign = new Name.Ref_assign
+val bogus = new Name.MLton_bogus
+val bug = new Name.MLton_bug
+val deref = new Name.Ref_deref
+val deserialize = new Name.MLton_deserialize
+val eq = new Name.MLton_eq
+val equal = new Name.MLton_equal
+val gcCollect = new Name.GC_collect
+val intInfEqual = new Name.IntInf_equal
+val intInfNeg = new Name.IntInf_neg
+val intInfNotb = new Name.IntInf_notb
+val reff = new Name.Ref_ref
+val serialize = new Name.MLton_serialize
+val vectorLength = new Name.Vector_length
+val vectorSub = new Name.Vector_sub
 
 local
-   fun make f (name: string, s: Scheme.t): t =
-      new (f name, Kind.Functional, s)
+   fun make n = IntSize.memoize (new o n)
 in
-   val buildConstant = make Name.BuildConstant
-   val constant = make Name.Constant
+   val intAdd = make Name.Int_add
+   val intAddCheck = make Name.Int_addCheck
+   val intEqual = make Name.Int_equal
+   val intNeg = make Name.Int_neg
+   val intNegCheck = make Name.Int_negCheck
+   val intMul = make Name.Int_mul
+   val intMulCheck = make Name.Int_mulCheck
+   val intSub = make Name.Int_sub
+   val intSubCheck = make Name.Int_subCheck
 end
 
-fun equals (p, p') = Name.equals (name p, name p')
-
 local
-   val newPrim = new
-   open Type Scheme
-   val new = newPrim
-   val --> = arrow
-   infix -->
+   fun make n = WordSize.memoize (new o n)
+in
+   val wordAdd = make Name.Word_add
+   val wordAddCheck = make Name.Word_addCheck
+   val wordAndb = make Name.Word_andb
+   val wordEqual = make Name.Word_equal
+   val wordGe = make Name.Word_ge
+   val wordGt = make Name.Word_gt
+   val wordLe = make Name.Word_le
+   val wordLt = make Name.Word_lt
+   val wordMul = make Name.Word_mul
+   val wordMulCheck = make Name.Word_mulCheck
+   val wordNeg = make Name.Word_neg
+   val wordNotb = make Name.Word_notb
+   val wordRshift = make Name.Word_rshift
+   val wordSub = make Name.Word_sub
+end
 
-   val new =
-      fn (n: Name.t, s: Scheme.t) =>
+local
+   fun make (name, memo, memo') =
       let
-	 val k =
-	    case n of
-	       Name.FFI _ => Kind.SideEffect
-	     | Name.FFI_Symbol _ => Kind.DependsOnState
-	     | _ => (case List.peek (Name.strings, fn (n', _, _) => n = n') of
-			NONE => Error.bug (concat ["strange name: ",
-						   Name.toString n])
-		      | SOME (_, k, _) => k)
+	 val f = memo (fn s => memo' (fn s' => name (s, s')))
       in
-	 new (n, k, s)
+	 fn (s, s') => new (f s s')
       end
-   val tuple = tuple o Vector.fromList
+   val int = IntSize.memoize
+   val word = WordSize.memoize
 in
-   val array = new (Name.Array_array, make1 (fn a => int I32 --> array a))
-   val assign =
-      new (Name.Ref_assign, make1 (fn a => tuple [reff a, a] --> unit))
-   val bogus = new (Name.MLton_bogus, make1 (fn a => a))
-   val bug = new (Name.MLton_bug, make0 (word8Vector --> unit))
-   val deref = new (Name.Ref_deref, make1 (fn a => reff a --> a))
-   val deserialize =
-      new (Name.MLton_deserialize, make1 (fn a => vector (word W8) --> a))
-   val eq = new (Name.MLton_eq, makeEqual1 (fn a => tuple [a, a] --> bool))
-   val equal = new (Name.MLton_equal, makeEqual1 (fn a => tuple [a, a] --> bool))
-   val gcCollect = new (Name.GC_collect, make0 (tuple [word W32, bool] --> unit))
-   val reff = new (Name.Ref_ref, make1 (fn a => a --> reff a))
-   val serialize = new (Name.MLton_serialize,
-			make1 (fn a => a --> vector (word W8)))
-   val vectorLength =
-      new (Name.Vector_length, make1 (fn a => vector a --> int I32))
-   val vectorSub =
-      new (Name.Vector_sub, make1 (fn a => tuple [vector a, int I32] --> a))
-
-   fun new0 (name, ty) = new (name, make0 ty)
-
-   fun intEqual s = new0 (Name.Int_equal s, tuple [int s, int s] --> bool)
-   fun intNeg s = new0 (Name.Int_neg s, int s --> int s)
-   fun intNegCheck s = new0 (Name.Int_negCheck s, int s --> int s)
-   val intInfNeg =
-      new0 (Name.IntInf_neg, tuple [intInf, word W32] --> intInf)
-   val intInfNotb =
-      new0 (Name.IntInf_notb, tuple [intInf, word W32] --> intInf)
-   val intInfEqual = new0 (Name.IntInf_equal, tuple [intInf, intInf] --> bool)
-
-   fun wordEqual s = new0 (Name.Word_equal s, tuple [word s, word s] --> bool)
-   fun wordNotb (s: WordSize.t) = new0 (Name.Word_notb s, word s --> word s)
-   fun wordNeg (s: WordSize.t) = new0 (Name.Word_neg s, word s --> word s)
-
-   local
-      fun make n =
-	 IntSize.memoize (fn s => new0 (n s, tuple [int s, int s] --> int s))
-   in
-      val intAdd = make Name.Int_add
-      val intAddCheck = make Name.Int_addCheck
-      val intMul = make Name.Int_mul
-      val intMulCheck = make Name.Int_mulCheck
-      val intSub = make Name.Int_sub
-      val intSubCheck = make Name.Int_subCheck
-   end
-
-   local
-      fun make n =
-	 WordSize.memoize
-	 (fn s => new0 (n s, tuple [word s, word s] --> word s))
-   in
-      val wordAdd = make Name.Word_add
-      val wordAddCheck = make Name.Word_addCheck
-      val wordAndb = make Name.Word_andb
-      val wordMul = make Name.Word_mul
-      val wordMulCheck = make Name.Word_mulCheck
-      val wordRshift = make Name.Word_rshift
-      val wordSub = make Name.Word_sub
-   end
-
-   local
-      fun make n =
-	 WordSize.memoize
-	 (fn s => new0 (n s, tuple [word s, word s] --> bool))
-   in
-      val wordGe = make Name.Word_ge
-      val wordGt = make Name.Word_gt
-      val wordLe = make Name.Word_le
-      val wordLt = make Name.Word_lt
-   end
-
-   local
-      fun make (name, (ty, memo), (ty', memo')) =
-	 let
-	    val f =
-	       memo (fn s => memo' (fn s' => new0 (name (s, s'),
-						   ty s --> ty' s')))
-      in
-	 fn (s, s') => f s s'
-      end
-      val int = (int, IntSize.memoize)
-      val word = (word, WordSize.memoize)
-   in
-      val intToWord = make (Name.Int_toWord, int, word)
-      val wordToInt = make (Name.Word_toInt, word, int)
-      val wordToIntX = make (Name.Word_toIntX, word, int)
-   end
-      
-   fun ffi (f: CFunction.t, s: Scheme.t) =
-      new (Name.FFI f, s)
-
-   fun newNullary f = new0 (Name.FFI f, unit --> unit)
-
-   val allocTooLarge = newNullary CFunction.allocTooLarge
-
-   fun ffiSymbol (z as {ty, ...}) =
-      new (Name.FFI_Symbol z, Scheme.fromType (CType.toType ty))
+   val intToWord = make (Name.Int_toWord, int, word)
+   val wordToInt = make (Name.Word_toInt, word, int)
+   val wordToIntX = make (Name.Word_toIntX, word, int)
 end
+      
+val ffi = new o Name.FFI
+   
+fun newNullary f = new (Name.FFI f)
+   
+val allocTooLarge = newNullary CFunction.allocTooLarge
+   
+fun ffiSymbol z = new (Name.FFI_Symbol z)
 
-val new: string * Scheme.t -> t =
-   fn (name, scheme) =>
+val new: string -> t =
+   fn name =>
    let
       val (name, kind) =
 	 case List.peek (Name.strings, fn (_, _, s) => s = name) of
 	    NONE => Error.bug (concat ["unknown primitive: ", name])
 	  | SOME (n, k, _) => (n, k)
    in
-      new (name, kind, scheme)
+      make (name, kind)
    end
 
-val new = Trace.trace2 ("Prim.new", String.layout, Scheme.layout, layout) new
-   
-fun 'a checkApp {prim, targs, args,
-		 con, detupleOpt, dearrowOpt, equals, isUnit}
-   : 'a option =
-   let
-      val error = NONE
-      val Scheme.T {tyvars, ty} = scheme prim
-      fun show s =
-	 if true
-	    then ()
-	 else Out.print s
-   in
-      if Vector.length targs <> Vector.length tyvars
-	 then
-	    (show (concat ["primapp error, #targs=",
-			   Int.toString (Vector.length targs),
-			   ", #tyvars=",
-			   Int.toString (Vector.length tyvars), "\n"])
-	     ; error)
-      else
-	 let
-	    val con = fn (c, ts) =>
-	       let
-		  val c = if Tycon.equals (c, Tycon.char)
-			     then Tycon.word W8
-			  else c
-	       in
-		  con (c, ts)
-	       end
-	    val env = Vector.zip (tyvars, targs)
-	    fun var a =
-	       case Vector.peek (env, fn (a', _) => Tyvar.equals (a, a')) of
-		  NONE => Error.bug "prim scheme with free tyvar"
-		| SOME (_, t) => t
-	    val ty = Type.hom {ty = ty, var = var, con = con}
-	 in
-	    case numArgs prim of
-	       NONE => if Vector.isEmpty args
-			  then SOME ty
-		       else (show "primapp error, no numArgs\n"
-			     ; error)
-	     | SOME n =>
-		  case dearrowOpt ty of
-		     NONE => error
-		   | SOME (argType, result) =>
-			case (n, Vector.length args) of
-			   (0, 0) => SOME result
-			 | (1, 1) =>
-			      if equals (argType, Vector.sub (args, 0))
-				 then SOME result
-			      else error
-			 | _ => 
-			      case detupleOpt argType of
-				 NONE => error
-			       | SOME argTypes =>
-				    if Vector.equals (args, argTypes, equals)
-				       then SOME result
-				    else error
-	 end
-   end
+val new = Trace.trace ("Prim.new", String.layout, layout) new
 
-fun returnsBool p =
-   case Type.dearrowOpt (Scheme.ty (scheme p)) of
-      SOME (_, Type.Con (tycon, _)) => Tycon.equals (tycon, Tycon.bool)
-    | _ => false
-
-fun 'a extractTargs {prim, args, result,
-		     dearray,
-		     dearrow: 'a -> 'a * 'a,
-		     deref,
-		     devector,
-		     deweak} =
+fun 'a extractTargs {args: 'a vector,
+		     deArray: 'a -> 'a,
+		     deArrow: 'a -> 'a * 'a,
+		     deRef: 'a -> 'a,
+		     deVector: 'a -> 'a,
+		     deWeak: 'a -> 'a,
+		     prim: t,
+		     result: 'a} =
    let
       val one = Vector.new1
       fun arg i = Vector.sub (args, i)
       datatype z = datatype Name.t
    in
       case name prim of
-	 Array_array => one (dearray result)
-       | Array_array0Const => one (dearray result)
+	 Array_array => one (deArray result)
+       | Array_array0Const => one (deArray result)
        | Array_sub => one result
-       | Array_toVector => one (dearray (arg 0))
+       | Array_toVector => one (deArray (arg 0))
        | Array_update => one (arg 2)
-       | Array_length => one (dearray (arg 0))
+       | Array_length => one (deArray (arg 0))
        | Exn_extra => one result
-       | Exn_setExtendExtra => one (#2 (dearrow (arg 0)))
+       | Exn_setExtendExtra => one (#2 (deArrow (arg 0)))
        | Exn_setInitExtra => one (arg 0)
        | FFI_getPointer => one result
        | FFI_setPointer => one (arg 0)
@@ -773,18 +625,22 @@
        | MLton_eq => one (arg 0)
        | MLton_equal => one (arg 0)
        | MLton_serialize => one (arg 0)
-       | MLton_size => one (deref (arg 0))
+       | MLton_size => one (deRef (arg 0))
        | MLton_touch => one (arg 0)
        | Ref_assign => one (arg 1)
        | Ref_deref => one result
        | Ref_ref => one (arg 0)
-       | Vector_length => one (devector (arg 0))
+       | Vector_length => one (deVector (arg 0))
        | Vector_sub => one result
-       | Weak_canGet => one (deweak (arg 0))
+       | Weak_canGet => one (deWeak (arg 0))
        | Weak_get => one result
        | Weak_new => one (arg 0)
        | _ => Vector.new0 ()
    end
+
+val extractTargs =
+   fn z =>
+   Trace.trace ("extractTargs", layout o #prim, Layout.ignore) extractTargs z
 
 structure SmallIntInf = Const.SmallIntInf
 



1.48      +11 -32    mlton/mlton/atoms/prim.sig

Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -r1.47 -r1.48
--- prim.sig	31 Jul 2003 20:32:59 -0000	1.47
+++ prim.sig	9 Oct 2003 18:17:31 -0000	1.48
@@ -15,16 +15,11 @@
       structure Const: CONST
       structure IntSize: INT_SIZE
       structure RealSize: REAL_SIZE
-      structure Scheme: SCHEME
-      structure Type: TYPE
       structure WordSize: WORD_SIZE
       sharing CFunction.CType = CType
-      sharing IntSize = CType.IntSize = Const.IntX.IntSize = Type.Tycon.IntSize
+      sharing IntSize = CType.IntSize = Const.IntX.IntSize
       sharing RealSize = CType.RealSize = Const.RealX.RealSize
-	 = Type.Tycon.RealSize
-      sharing Type = Scheme.Type
       sharing WordSize = CType.WordSize = Const.WordX.WordSize
-	 = Type.Tycon.WordSize
    end
 
 signature PRIM = 
@@ -40,7 +35,6 @@
 	     | Array_sub (* backend *)
 	     | Array_toVector (* backend *)
 	     | Array_update (* backend *)
-	     | BuildConstant of string (* type inference *)
 	     | C_CS_charArrayToWord8Array (* type inference *)
 	     | Char_chr (* type inference *)
 	     | Char_ge (* type inference *)
@@ -49,7 +43,6 @@
 	     | Char_lt (* type inference *)
 	     | Char_ord (* type inference *)
 	     | Char_toWord8 (* type inference *)
-	     | Constant of string (* type inference *)
 	     | Cpointer_isNull (* codegen *)
 	     | Exn_extra (* implement exceptions *)
 	     | Exn_keepHistory (* a compile-time boolean *)
@@ -246,32 +239,20 @@
       val assign: t
       val bogus: t
       val bug: t
-      val buildConstant: string * Scheme.t -> t
-      val checkApp: {
-		     prim: t,
-		     targs: 'a vector,
-		     args: 'a vector,
-		     con: Type.Tycon.t * 'a vector -> 'a,
-		     equals: 'a * 'a -> bool,
-		     dearrowOpt: 'a -> ('a * 'a) option,
-		     detupleOpt: 'a -> 'a vector option,
-		     isUnit: 'a -> bool
-		     } -> 'a option
-      val constant: string * Scheme.t -> t
       val deref: t
       val deserialize: t
       val eq: t    (* pointer equality *)
       val equal: t (* polymorphic equality *)
       val equals: t * t -> bool (* equality of names *)
-      val extractTargs: {prim: t,
-			 args: 'a vector,
-			 result: 'a,
-			 dearray: 'a -> 'a,
-			 dearrow: 'a -> 'a * 'a,
-			 deref: 'a -> 'a,
-			 devector: 'a -> 'a,
-			 deweak: 'a -> 'a} -> 'a vector
-      val ffi: CFunction.t * Scheme.t -> t
+      val extractTargs: {args: 'a vector,
+			 deArray: 'a -> 'a,
+			 deArrow: 'a -> 'a * 'a,
+			 deRef: 'a -> 'a,
+			 deVector: 'a -> 'a,
+			 deWeak: 'a -> 'a,
+			 prim: t,
+			 result: 'a} -> 'a vector
+      val ffi: CFunction.t -> t
       val ffiSymbol: {name: string, ty: CType.t} -> t
       val gcCollect: t
       val intInfEqual: t
@@ -302,11 +283,9 @@
        *)
       val maySideEffect: t -> bool
       val name: t -> Name.t
-      val new: string * Scheme.t -> t
+      val new: string -> t
       val newNullary: CFunction.t -> t (* new of type unit -> unit *)
-      val numArgs: t -> int option
       val reff: t
-      val scheme: t -> Scheme.t
       val serialize: t
       val toString: t -> string
       val vectorLength: t



1.15      +2 -2      mlton/mlton/atoms/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/sources.cm,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- sources.cm	19 Jul 2003 01:23:26 -0000	1.14
+++ sources.cm	9 Oct 2003 18:17:31 -0000	1.15
@@ -53,8 +53,8 @@
 c-function.fun
 c-type.sig
 c-type.fun
-cons.fun
-cons.sig
+con.fun
+con.sig
 const.fun
 const.sig
 ffi.fun



1.4       +5 -3      mlton/mlton/atoms/tycon.fun

Index: tycon.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/tycon.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- tycon.fun	23 Jun 2003 04:58:55 -0000	1.3
+++ tycon.fun	9 Oct 2003 18:17:31 -0000	1.4
@@ -10,11 +10,13 @@
 
 open S
 
-structure Id = HashId (structure AstId = AstId
-		       val noname = "t")
+structure Id = HashId (val noname = "t")
 open Id
 
+structure Kind = TyconKind ()
+   
 structure P = PrimTycons (structure IntSize = IntSize
+			  structure Kind = Kind
 			  structure RealSize = RealSize
 			  structure WordSize = WordSize
 			  open Id)
@@ -24,7 +26,7 @@
    let open Layout
    in
       align
-      (List.map (prims, fn c =>
+      (List.map (prims, fn (c, _) =>
 		 seq [layout c, str " size is ",
 		      Int.layout (MLton.size c),
 		      str " plist length is ",



1.4       +5 -2      mlton/mlton/atoms/tycon.sig

Index: tycon.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/tycon.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- tycon.sig	23 Jun 2003 04:58:55 -0000	1.3
+++ tycon.sig	9 Oct 2003 18:17:31 -0000	1.4
@@ -5,9 +5,11 @@
  * MLton is released under the GNU General Public License (GPL).
  * Please see the file MLton-LICENSE for license information.
  *)
+type int = Int.t
+type word = Word.t
+   
 signature TYCON_STRUCTS = 
    sig
-      structure AstId: AST_ID
       structure IntSize: INT_SIZE
       structure RealSize: REAL_SIZE
       structure WordSize: WORD_SIZE
@@ -16,7 +18,8 @@
 signature TYCON =
    sig
       include HASH_ID
-      include PRIM_TYCONS where type tycon = t
+      include PRIM_TYCONS	 
+      sharing type t = tycon
 
       val stats: unit -> Layout.t
    end



1.8       +37 -36    mlton/mlton/atoms/type-ops.fun

Index: type-ops.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type-ops.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- type-ops.fun	5 Jul 2003 23:30:25 -0000	1.7
+++ type-ops.fun	9 Oct 2003 18:17:31 -0000	1.8
@@ -62,25 +62,25 @@
 val arrow = Trace.trace ("arrow", Layout.tuple2 (layout, layout), layout) arrow
 
 fun deUnaryOpt tycon t =
-   case deconOpt t of
+   case deConOpt t of
       SOME (c, ts) => if Tycon.equals (c, tycon)
 			 then SOME (Vector.sub (ts, 0))
 		      else NONE
     | _ => NONE
 
-val dearrayOpt = deUnaryOpt Tycon.array
-val derefOpt = deUnaryOpt Tycon.reff
-val deweakOpt = deUnaryOpt Tycon.weak
+val deArrayOpt = deUnaryOpt Tycon.array
+val deRefOpt = deUnaryOpt Tycon.reff
+val deWeakOpt = deUnaryOpt Tycon.weak
 
 fun deUnary tycon t =
    case deUnaryOpt tycon t of
       SOME t => t
     | NONE => Error.bug "deUnary"
 
-val dearray = deUnary Tycon.array
-val deref = deUnary Tycon.reff
-val devector = deUnary Tycon.vector
-val deweak = deUnary Tycon.weak
+val deArray = deUnary Tycon.array
+val deRef = deUnary Tycon.reff
+val deVector = deUnary Tycon.vector
+val deWeak = deUnary Tycon.weak
    
 fun tuple ts =
    if 1 = Vector.length ts
@@ -89,57 +89,58 @@
 
 val unit = tuple (Vector.new0 ())
 
-fun detupleOpt t =
-   case deconOpt t of
+fun deTupleOpt t =
+   case deConOpt t of
       SOME (c, ts) => if Tycon.equals (c, Tycon.tuple) then SOME ts else NONE
     | NONE => NONE
 
-val isTuple = Option.isSome o detupleOpt
+val isTuple = Option.isSome o deTupleOpt
 
-fun detuple t =
-   case detupleOpt t of
+fun deTuple t =
+   case deTupleOpt t of
       SOME t => t
     | NONE => Error.bug "detuple"
 
-fun nth (t, n) = Vector.sub (detuple t, n)
+fun nth (t, n) = Vector.sub (deTuple t, n)
 
 val unitRef = reff unit
 
-fun detycon t =
-   case deconOpt t of
+fun deTycon t =
+   case deConOpt t of
       SOME (c, _) => c
     | NONE => Error.bug "detycon"
 
-fun deconConstOpt t =
-   case deconOpt t of
-      SOME (c, ts) => SOME (c, Vector.map (ts, fn t =>
-					   case deconOpt t of
-					      SOME (c, _) => c
-					    | NONE => Error.bug "deconConstOpt"))
-    | NONE => NONE
-fun deconConst t =
-   case deconOpt t of
-      SOME (c, ts) => (c, Vector.map (ts, fn t =>
-				      case deconOpt t of
-					 SOME (c, _) => c
-				       | NONE => Error.bug "deconConst"))
-    | NONE => Error.bug "deconConst"
+fun deConConstOpt t =
+   Option.map
+   (deConOpt t, fn (c, ts) =>
+    (c, Vector.map (ts, fn t =>
+		    case deConOpt t of
+		       SOME (c, _) => c
+		     | NONE => Error.bug "deConConstOpt")))
+
+fun deConConst t =
+   case deConOpt t of
+      NONE => Error.bug "deConConst"
+    | SOME (c, ts) => (c, Vector.map (ts, fn t =>
+				      case deConOpt t of
+					 NONE => Error.bug "deConConst"
+				       | SOME (c, _) => c))
 
 
-fun dearrowOpt t =
-   case deconOpt t of
+fun deArrowOpt t =
+   case deConOpt t of
       SOME (c, ts) => if Tycon.equals (c, Tycon.arrow)
 			       then SOME (Vector.sub (ts, 0), Vector.sub (ts, 1))
 			    else NONE
     | _ => NONE
 
-fun dearrow t =
-   case dearrowOpt t of
+fun deArrow t =
+   case deArrowOpt t of
       SOME x => x
-    | NONE => Error.bug "Type.dearrow"
+    | NONE => Error.bug "Type.deArrow"
 
 val dearrow =
-   Trace.trace ("dearrow", layout, Layout.tuple2 (layout, layout)) dearrow
+   Trace.trace ("deArrow", layout, Layout.tuple2 (layout, layout)) deArrow
 
 val arg = #1 o dearrow
 val result = #2 o dearrow



1.8       +16 -16    mlton/mlton/atoms/type-ops.sig

Index: type-ops.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type-ops.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- type-ops.sig	5 Jul 2003 23:30:25 -0000	1.7
+++ type-ops.sig	9 Oct 2003 18:17:31 -0000	1.8
@@ -15,7 +15,7 @@
       type t
 
       val con: Tycon.t * t vector -> t
-      val deconOpt: t -> (Tycon.t * t vector) option
+      val deConOpt: t -> (Tycon.t * t vector) option
       val layout: t -> Layout.t
    end
 
@@ -36,24 +36,24 @@
       val arrow: t * t -> t
       val bool: t
       val con: tycon * t vector -> t
-      val dearray: t -> t
-      val dearrayOpt: t -> t option
-      val dearrow: t -> t * t
-      val dearrowOpt: t -> (t * t) option
-      val deconOpt: t -> (tycon * t vector) option
-      val deconConstOpt: t -> (tycon * tycon vector) option
-      val deconConst: t -> (tycon * tycon vector)
+      val deArray: t -> t
+      val deArrayOpt: t -> t option
+      val deArrow: t -> t * t
+      val deArrowOpt: t -> (t * t) option
+      val deConOpt: t -> (tycon * t vector) option
+      val deConConstOpt: t -> (tycon * tycon vector) option
+      val deConConst: t -> (tycon * tycon vector)
+      val deRef: t -> t
+      val deRefOpt: t -> t option
+      val deTuple: t -> t vector
+      val deTupleOpt: t -> t vector option
+      val deTycon: t -> tycon
+      val deVector: t -> t
+      val deWeak: t -> t
+      val deWeakOpt: t -> t option
       val defaultInt: t
       val defaultReal: t
       val defaultWord: t
-      val deref: t -> t
-      val derefOpt: t -> t option
-      val detuple: t -> t vector
-      val detupleOpt: t -> t vector option
-      val detycon: t -> tycon
-      val devector: t -> t
-      val deweak: t -> t
-      val deweakOpt: t -> t option
       val exn: t
       val int: intSize -> t
       val intInf: t



1.4       +2 -10     mlton/mlton/atoms/type.fun

Index: type.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- type.fun	23 Jun 2003 04:58:55 -0000	1.3
+++ type.fun	9 Oct 2003 18:17:31 -0000	1.4
@@ -33,20 +33,14 @@
 	    
       val record = Record
 
-      val deconOpt =
+      val deConOpt =
 	 fn Con (c, ts) => SOME (c, ts)
 	  | Record r => (case Record.detupleOpt r of
 			    NONE => NONE
 			  | SOME ts => SOME (Tycon.tuple, ts))
 	  | _ => NONE
 
-      fun toAst t =
-	 case t of
-	    Var a => Ast.Type.var a
-	  | Con (c, ts) => Ast.Type.con (Tycon.toAst c, Vector.map (ts, toAst))
-	  | Record r => Ast.Type.record (Record.map (r, toAst))
-
-      val layout = Ast.Type.layout o toAst
+      val layout = fn _ => Layout.str "<type>"
    end
 
 structure Ops = TypeOps (structure Tycon = Tycon
@@ -75,8 +69,6 @@
 		      Tyvars.union (ac, tyvars t))
 	 
 val tyvars = Tyvars.toList o tyvars
-
-fun optionToAst z = Option.map (z, toAst)
 
 fun substitute (t, sub) =
    let



1.5       +0 -6      mlton/mlton/atoms/type.sig

Index: type.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- type.sig	23 Jun 2003 04:58:55 -0000	1.4
+++ type.sig	9 Oct 2003 18:17:31 -0000	1.5
@@ -7,13 +7,9 @@
  *)
 signature TYPE_STRUCTS =
    sig
-      structure Ast: AST
       structure Record: RECORD
       structure Tycon: TYCON
       structure Tyvar: TYVAR
-      sharing Record = Ast.SortedRecord
-      sharing Tyvar = Ast.Tyvar
-      sharing Ast.Tycon = Tycon.AstId
    end
 
 signature TYPE = 
@@ -36,13 +32,11 @@
 		var: Tyvar.t -> 'a,
 		con: Tycon.t * 'a vector -> 'a} -> 'a
       val layout: t -> Layout.t
-      val optionToAst: t option -> Ast.Type.t option
       val record: t Record.t -> t
       (* substitute(t, [(a1, t1), ..., (an, tn)]) performs simultaneous
        * substitution of the ti for ai in t.
        *)
       val substitute: t * (Tyvar.t * t) vector -> t
-      val toAst: t -> Ast.Type.t
       (* tyvars returns a list (without duplicates) of all the type variables
        * in a type.
        *)



1.3       +2 -3      mlton/mlton/atoms/var.fun

Index: var.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/var.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- var.fun	10 Apr 2002 07:02:19 -0000	1.2
+++ var.fun	9 Oct 2003 18:17:31 -0000	1.3
@@ -5,13 +5,12 @@
  * MLton is released under the GNU General Public License (GPL).
  * Please see the file MLton-LICENSE for license information.
  *)
-functor Var(S: VAR_STRUCTS): VAR = 
+functor Var (S: VAR_STRUCTS): VAR = 
 struct
 
 open S
 
-structure V = HashId(structure AstId = AstId
-		     val noname = "x")
+structure V = HashId (val noname = "x")
 open V
    
 end



1.3       +0 -1      mlton/mlton/atoms/var.sig

Index: var.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/var.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- var.sig	10 Apr 2002 07:02:19 -0000	1.2
+++ var.sig	9 Oct 2003 18:17:31 -0000	1.3
@@ -7,7 +7,6 @@
  *)
 signature VAR_STRUCTS =
    sig
-      structure AstId: AST_ID
    end
 
 signature VAR =



1.4       +10 -13    mlton/mlton/atoms/con.fun




1.3       +6 -3      mlton/mlton/atoms/con.sig




1.18      +1 -1      mlton/mlton/backend/representation.fun

Index: representation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/representation.fun,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- representation.fun	19 Jul 2003 01:23:26 -0000	1.17
+++ representation.fun	9 Oct 2003 18:17:32 -0000	1.18
@@ -558,7 +558,7 @@
 		       SOME (pointer {fin = fn r => setTupleRep (t, r),
 				      isNormal = true,
 				      mutable = false,
-				      tys = S.Type.detuple t})
+				      tys = S.Type.deTuple t})
 	       | Vector t => SOME (array {mutable = false, ty = t})
 	       | Weak t =>
 		    (case toRtype t of



1.49      +1 -4      mlton/mlton/backend/ssa-to-rssa.fun

Index: ssa-to-rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/ssa-to-rssa.fun,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -r1.48 -r1.49
--- ssa-to-rssa.fun	11 Sep 2003 00:51:07 -0000	1.48
+++ ssa-to-rssa.fun	9 Oct 2003 18:17:32 -0000	1.49
@@ -1148,10 +1148,7 @@
 				    (case targ () of
 					NONE => none ()
 				      | SOME ty => arrayUpdate ty)
-			       | FFI f =>
-				    if Option.isNone (Prim.numArgs prim)
-				       then normal ()
-				    else simpleCCall f
+			       | FFI f => simpleCCall f
 			       | FFI_getPointer =>
 				    simpleCCall CFunction.getPointer
 			       | FFI_setPointer =>



1.10      +19 -18    mlton/mlton/closure-convert/abstract-value.fun

Index: abstract-value.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/abstract-value.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- abstract-value.fun	12 Sep 2003 00:44:33 -0000	1.9
+++ abstract-value.fun	9 Oct 2003 18:17:32 -0000	1.10
@@ -276,27 +276,29 @@
 
 fun select (v, i) =
    case tree v of
-      Type t => fromType (Vector.sub (Type.detuple t, i))
+      Type t => fromType (Vector.sub (Type.deTuple t, i))
     | Tuple vs => Vector.sub (vs, i)
     | _ => Error.bug "Value.select expected tuple"
 
-fun deref v =
+fun deRef v =
    case tree v of
-      Type t => fromType (Type.deref t)
+      Type t => fromType (Type.deRef t)
     | Unify (_, v) => v
-    | _ => Error.bug "Value.deref"
+    | _ => Error.bug "Value.deRef"
 
-fun deweak v =
+val deRef = Trace.trace ("Value.deRef", layout, layout) deRef
+
+fun deWeak v =
    case tree v of
-      Type t => fromType (Type.deweak t)
+      Type t => fromType (Type.deWeak t)
     | Unify (_, v) => v
-    | _ => Error.bug "Value.deweak"
+    | _ => Error.bug "Value.deWeak"
 
-fun dearray v =
+fun deArray v =
    case tree v of
-      Type t => fromType (Type.dearray t)
+      Type t => fromType (Type.deArray t)
     | Unify (_, v) => v
-    | _ => Error.bug "Value.dearray"
+    | _ => Error.bug "Value.deArray"
 
 fun lambda (l: Sxml.Lambda.t, t: Type.t): t =
    new (Lambdas (LambdaNode.lambda l), t)       
@@ -309,15 +311,14 @@
    else let val t = tree v
 	    val t' = tree v'
 	in Dset.union (v, v')
-	   ; (case (t,             t') of
-		 (Type t,        Type t')        => if Type.equals (t, t')
-						       then ()
-						    else Error.bug "unify"
+	   ; (case (t, t') of
+		 (Type t, Type t') => if Type.equals (t, t')
+					 then ()
+				      else Error.bug "unify"
 	       | (Unify (_, v), Unify (_, v')) => unify (v, v')
-	       | (Tuple vs,      Tuple vs')      =>
-		    Vector.foreach2 (vs, vs', unify)
-	       | (Lambdas l,     Lambdas l')     => LambdaNode.unify (l, l')
-	       | _                               => Error.bug "impossible unify")
+	       | (Tuple vs, Tuple vs') => Vector.foreach2 (vs, vs', unify)
+	       | (Lambdas l, Lambdas l') => LambdaNode.unify (l, l')
+	       | _ => Error.bug "impossible unify")
 	end
 
 val unify = Trace.trace2 ("Value.unify", layout, layout, Unit.layout) unify



1.5       +3 -3      mlton/mlton/closure-convert/abstract-value.sig

Index: abstract-value.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/abstract-value.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- abstract-value.sig	18 Apr 2003 22:45:00 -0000	1.4
+++ abstract-value.sig	9 Oct 2003 18:17:32 -0000	1.5
@@ -48,12 +48,12 @@
       val addHandler: t * (Lambda.t -> unit) -> unit
       val coerce: {from: t, to: t} -> unit
       val ssaType: t -> Ssa.Type.t option ref
-      val dearray: t -> t
-      val deref: t -> t
+      val deArray: t -> t
+      val deRef: t -> t
+      val deWeak: t -> t
       val dest: t -> dest
       (* Destroy info associated with Sxml.Type used to keep track of arrows. *)
       val destroy: unit -> unit
-      val deweak: t -> t
       val equals: t * t -> bool
       val fromType: Sxml.Type.t -> t
       val isEmpty: t -> bool (* no possible values correspond to me *) 



1.28      +12 -10    mlton/mlton/closure-convert/closure-convert.fun

Index: closure-convert.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/closure-convert.fun,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- closure-convert.fun	23 Jun 2003 04:58:58 -0000	1.27
+++ closure-convert.fun	9 Oct 2003 18:17:32 -0000	1.28
@@ -901,7 +901,7 @@
 				  let
 				     val a = varExpInfo (arg 0)
 				     val y = varExpInfo (arg 2)
-				     val v = Value.dearray (VarInfo.value a)
+				     val v = Value.deArray (VarInfo.value a)
 				  in
 				     primApp (v1 (valueType v),
 					      v3 (convertVarInfo a,
@@ -927,12 +927,14 @@
 				      | _ => doit ()
 				  end
 			     | MLton_handlesSignals =>
-				  if handlesSignals then Dexp.truee else Dexp.falsee
+				  if handlesSignals
+				     then Dexp.truee
+				  else Dexp.falsee
 			     | Ref_assign =>
 				  let
 				     val r = varExpInfo (arg 0)
 				     val y = varExpInfo (arg 1)
-				     val v = Value.deref (VarInfo.value r)
+				     val v = Value.deRef (VarInfo.value r)
 				  in
 				     primApp (v1 (valueType v),
 					      v2 (convertVarInfo r,
@@ -942,7 +944,7 @@
 			     | Ref_ref =>
 				  let
 				     val y = varExpInfo (arg 0)
-				     val v = Value.deref v
+				     val v = Value.deRef v
 				  in
 				     primApp (v1 (valueType v),
 					      v1 (coerce (convertVarInfo y,
@@ -961,7 +963,7 @@
 			     | Weak_new =>
 				  let
 				     val y = varExpInfo (arg 0)
-				     val v = Value.deweak v
+				     val v = Value.deWeak v
 				  in
 				     primApp (v1 (valueType v),
 					      v1 (coerce (convertVarInfo y,
@@ -976,11 +978,11 @@
 				      {prim = prim,
 				       args = Vector.map (args, varInfoType),
 				       result = ty,
-				       dearray = Type.dearray,
-				       dearrow = Type.dearrow,
-				       deref = Type.deref,
-				       devector = Type.devector,
-				       deweak = Type.deweak},
+				       deArray = Type.deArray,
+				       deArrow = Type.deArrow,
+				       deRef = Type.deRef,
+				       deVector = Type.deVector,
+				       deWeak = Type.deWeak},
 				      Vector.map (args, convertVarInfo))
 				  end)
 			end



1.69      +1 -46     mlton/mlton/codegen/c-codegen/c-codegen.fun

Index: c-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/c-codegen/c-codegen.fun,v
retrieving revision 1.68
retrieving revision 1.69
diff -u -r1.68 -r1.69
--- c-codegen.fun	10 Sep 2003 01:00:10 -0000	1.68
+++ c-codegen.fun	9 Oct 2003 18:17:32 -0000	1.69
@@ -242,9 +242,7 @@
     }: unit =
    let
       fun declareExports () =
-	 if Ffi.numExports () > 0
-	    then Ffi.declareExports {print = print}
-	 else ()
+	 Ffi.declareExports {print = print}
       fun declareLoadSaveGlobals () =
 	 let
 	    val _ =
@@ -437,49 +435,6 @@
 	     | Word s => word s
 	     | _ => Error.bug (concat ["Type.toC strange type: ", toString t])
       end
-   end
-
-structure Prim =
-   struct
-      open Prim
-      structure Type =
-	 struct
-	    open Type
-
-	    local
-	       val {get: Tycon.t -> string option, set, ...} =
-		  Property.getSetOnce (Tycon.plist, Property.initConst NONE)
-	       val tycons =
-		  List.map
-		  (IntSize.all, fn s =>
-		   (Tycon.int s, concat ["Int", IntSize.toString s]))
-		  @ [(Tycon.intInf, "Pointer"),
-		     (Tycon.pointer, "Pointer"),
-		     (Tycon.preThread, "Pointer")]
-		  @ (List.map
-		     (RealSize.all, fn s =>
-		      (Tycon.real s, concat ["Real", RealSize.toString s])))
-		  @ [(Tycon.reff, "Pointer"),
-		     (Tycon.thread, "Pointer"),
-		     (Tycon.tuple, "Pointer"),
-		     (Tycon.vector, "Pointer"),
-		     (Tycon.weak, "Pointer")]
-		  @ (List.map
-		     (WordSize.all, fn s =>
-		      (Tycon.word s, concat ["Word", WordSize.toString s])))
-	       val _ =
-		  List.foreach (tycons, fn (tycon, s) => set (tycon, SOME s))
-	    in
-	       fun toC (ty: t): string =
-		  case ty of
-		     Con (c, _) =>
-			(case get c of
-			    NONE => Error.bug (concat ["strange tycon: ",
-						       Tycon.toString c])
-			  | SOME s => s)
-		   | _ => Error.bug "strange type"
-	    end
-	 end
    end
 
 fun contents (ty, z) = concat ["C", C.args [Type.toC ty, z]]



1.46      +2 -1      mlton/mlton/codegen/x86-codegen/x86.fun

Index: x86.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86.fun,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -r1.45 -r1.46
--- x86.fun	10 Sep 2003 01:00:11 -0000	1.45
+++ x86.fun	9 Oct 2003 18:17:32 -0000	1.46
@@ -570,7 +570,8 @@
 	   | (Const c1, ImmedBinExp _) => LESS
 	   | (Label l1, Label l2) 
 	   => lexical [fn () => EQUAL,
-		       fn () => Label.AstId.compare(Label.toAst l1, Label.toAst l2)]
+		       fn () => String.compare (Label.toString l1,
+						Label.toString l2)]
 	   | (Label l1, ImmedUnExp _) => LESS
 	   | (Label l1, ImmedBinExp _) => LESS
 	   | (ImmedUnExp {oper = oper1, exp = exp1},



1.98      +5 -1      mlton/mlton/control/control.sml

Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.97
retrieving revision 1.98
diff -u -r1.97 -r1.98
--- control.sml	29 Aug 2003 00:25:21 -0000	1.97
+++ control.sml	9 Oct 2003 18:17:32 -0000	1.98
@@ -715,7 +715,11 @@
    let
       val _ = Int.inc numErrors
       open Layout
-      val _ = outputl (align [seq [Region.layout r, str " Error: ", msg],
+      val p =
+	 case Region.left r of
+	    NONE => "<bogus>"
+	  | SOME p => SourcePos.toString p
+      val _ = outputl (align [seq [str "Error: ", str p, str ": ", msg],
 			      indent (extra, 3)],
 		       Out.error)
    in



1.6       +1 -1      mlton/mlton/control/source-pos.sml

Index: source-pos.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/source-pos.sml,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- source-pos.sml	11 Feb 2003 18:44:03 -0000	1.5
+++ source-pos.sml	9 Oct 2003 18:17:32 -0000	1.6
@@ -45,7 +45,7 @@
 	       line = ~1}
 
 fun toString (p as T {column, line, ...}) =
-   concat [file p, ":", Int.toString line, ".", Int.toString column]
+   concat [file p, " ", Int.toString line, ".", Int.toString column]
 
 fun posToString (T {line, column, ...}) =
    concat [Int.toString line, ".", Int.toString column]



1.5       +3 -0      mlton/mlton/control/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/sources.cm,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- sources.cm	12 Dec 2002 01:14:22 -0000	1.4
+++ sources.cm	9 Oct 2003 18:17:32 -0000	1.5
@@ -10,6 +10,7 @@
 signature REGION
    
 structure Control
+structure Pretty
 structure Region
 structure Source
 structure SourcePos
@@ -21,6 +22,8 @@
 
 control.sig
 control.sml
+pretty.sig
+pretty.sml
 region.sig
 region.sml
 source-pos.sig



1.1                  mlton/mlton/control/layout.sml

Index: layout.sml
===================================================================
structure Code =
   struct
      fun nest (prefix, x, y) =
   align [seq [str prefix, x],
	      seq [str "in ", y],
	      str "end"]

fun layoutLet (d, e) = nest ("let ", d, e)
fun layoutLocal (d, d') = nest ("local ", d, d')




1.1                  mlton/mlton/control/pretty.sig

Index: pretty.sig
===================================================================
signature PRETTY =
   sig
      type t = Layout.t

      val casee: {default: t option,
		  rules: (t * t) vector,
		  test: t} -> t
      val conApp: {arg: t option,
		   con: Layout.t,
		   targs: Layout.t vector} -> t
      val handlee: {catch: t,
		    handler: t,
		    try: t} -> t
      val lett: t * t -> t
      val locall: t * t -> t
      val primApp: {args: t vector,
		    prim: t,
		    targs: t vector} -> t
      val raisee: t -> t
      val seq: t vector -> t
      val var: {targs: t vector,
		var: t} -> t
   end



1.1                  mlton/mlton/control/pretty.sml

Index: pretty.sml
===================================================================
structure Pretty: PRETTY =
struct

open Layout
	 
fun casee {default, rules, test} =
   align [seq [str "case ", test, str " of"],
	  indent (alignPrefix (Vector.toListMap
			       (rules, fn (lhs, rhs) =>
				mayAlign [seq [lhs, str " =>"], rhs]),
			       "| "),
		  2)]

fun conApp {arg, con, targs} =
   seq [con,
	if !Control.showTypes
	   then tuple (Vector.toList targs)
	else empty,
	case arg of
	   NONE => empty
	 | SOME x => seq [str " ", x]]

fun handlee {catch, handler, try} =
   align [try,
	  seq [str "handle ", catch, str " => ", handler]]

fun nest (prefix, x, y) =
   align [seq [str prefix, x],
	  str "in",
	  indent (y, 3),
	  str "end"]

fun lett (d, e) = nest ("let ", d, e)
	 
fun locall (d, d') = nest ("local ", d, d')

fun primApp {args, prim, targs} =
   seq [prim,
	if !Control.showTypes
	   andalso 0 < Vector.length targs
	   then list (Vector.toList targs)
	else empty,
	str " ",
	tuple (Vector.toList args)]

fun raisee exn = seq [str "raise ", exn]

fun var {targs, var} =
   if !Control.showTypes
      then seq [var, tuple (Vector.toList targs)]
   else var
      
fun seq es = mayAlign (separateLeft (Vector.toList es, ";"))

end



1.11      +334 -501  mlton/mlton/core-ml/core-ml.fun

Index: core-ml.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/core-ml.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- core-ml.fun	14 Jan 2003 00:08:16 -0000	1.10
+++ core-ml.fun	9 Oct 2003 18:17:32 -0000	1.11
@@ -10,578 +10,411 @@
 
 open S
 
-local open Ast
-in
-   structure Adec = Dec
-   structure Apat = Pat
-end
+structure Field = Record.Field
 
-structure Wrap = Region.Wrap
-
-fun makeList (con, app, tuple) (l, r) =
-   List.foldr (l, Wrap.makeRegion (con Con.nill, r), fn (x1, x2) =>
-	       Wrap.makeRegion (app (Con.cons, tuple (Vector.new2 (x1, x2), r)),
-				r))
+fun maybeConstrain (x, t) =
+   let
+      open Layout
+   in
+      if !Control.showTypes
+	 then seq [x, str ": ", Type.layout t]
+      else x
+   end
 
 structure Pat =
    struct
-      open Wrap
-	 
-      datatype node =
-	 Wild
-       | Var of Var.t
-       | Const of Ast.Const.t
-       | Con of {con: Con.t, arg: t option}
-       | Record of {flexible: bool, record: t Record.t}
-       | Constraint of t * Type.t
+      datatype t = T of {node: node,
+			 ty: Type.t}
+      and node =
+	 Con of {arg: t option,
+		 con: Con.t,
+		 targs: Type.t vector}
+       | Const of unit -> Const.t
        | Layered of Var.t * t
-      withtype t = node Wrap.t
-      type node' = node
-      type obj = t
+       | List of t vector
+       | Record of t Record.t
+       | Tuple of t vector
+       | Var of Var.t
+       | Wild
 
       local
-	 structure Pat = Ast.Pat
+	 fun make f (T r) = f r
       in
-	 fun toAst p =
-	    case node p of
-	       Wild => Pat.wild
-	     | Var x => Pat.var (Var.toAst x)
-	     | Const c => Pat.const c
-	     | Record {record, flexible} =>
-		  (case (flexible, Record.detupleOpt record) of
-		      (false, SOME ps) => Pat.tuple (Vector.map (ps, toAst))
-		    | _ =>
-			 Pat.makeRegion
-			 (Pat.Record
-			  {flexible = flexible,
-			   items = (Vector.map
-				    (Record.toVector record, fn (field, p) =>
-				     Pat.Item.Field (field, toAst p)))},
-			  Region.bogus))
-	     | Con {con, arg} =>
-		  let
-		     val con = Con.toAst con
-		  in
-		     case arg of
-			NONE => Pat.con con
-		      | SOME p => Pat.app (con, toAst p)
-		  end
-	     | Constraint (p, t) => Pat.constraint (toAst p,  Type.toAst t)
-	     | Layered (x, p) =>
-		  Pat.layered {fixop = Ast.Fixop.None,
-			       var = Var.toAst x,
-			       constraint = NONE,
-			       pat = toAst p}
-
-	 val layout = Pat.layout o toAst
+	 val dest = make (fn {node, ty} => (node, ty))
+	 val node = make #node
+	 val ty = make #ty
       end
 
-      fun isWild p =
-	 case node p of
-	    Wild => true
-	  | _ => false
-	 
-      fun isRefutable p =
-	 case node p of
-	    Wild => false
-	  | Var _ => false
-	  | Const _ => true
-	  | Con _ => true
-	  | Record {record, ...} => Record.exists (record, isRefutable)
-	  | Constraint (p, _) => isRefutable p
-	  | Layered (_, p) => isRefutable p
-
-      fun vars'(p, l) =
-	 case node p of
-	    Wild => l
-	  | Var x => x :: l
-	  | Const _ => l
-	  | Con {arg, ...} => (case arg of
-				  NONE => l
-				| SOME p => vars'(p, l))
-	  | Record {record, ...} => Record.fold (record, l, vars')
-	  | Constraint (p, _) => vars'(p, l)
-	  | Layered (x, p) => vars'(p, x :: l)
-
-      fun vars p = vars'(p, [])
+      fun make (n, t) = T {node = n, ty = t}
 
-      fun removeVarsPred (p: t, pred: Var.t -> bool): t =
+      fun layout p =
 	 let
-	    fun loop p =
-	       let
-		  fun doit n = makeRegion (n, region p)
-	       in
-		  case node p of
-		     Wild => p
-		   | Const _ => p
-		   | Var x => if pred x
-				 then doit Wild
-			      else p
-		   | Record {flexible, record} =>
-			doit (Record {flexible = flexible,
-				      record = Record.map (record, loop)})
-		   | Con {con, arg} =>
-			doit (Con {con = con,
-				   arg = (case arg of
-					     NONE => NONE
-					   | SOME p => SOME (loop p))})
-		   | Constraint (p, t) => doit (Constraint (loop p, t))
-		   | Layered (_, p) => loop p
-	       end
-	 in loop p
-	 end
-
-      fun removeVars p = removeVarsPred (p, fn _ => true)
-
-      fun removeOthersReplace (p, x, y) =
-	 let
-	    fun loop p =
-	       let
-		  fun doit n = makeRegion (n, region p)
-	       in
-		  case node p of
-		     Wild => doit Wild
-		   | Const _ => p
-		   | Var x' =>
-			doit (if Var.equals (x, x') then Var y else Wild)
-		   | Record {record, flexible} =>
-			doit (Record {flexible = flexible,
-				      record = Record.map (record, loop)})
-		   | Con {con, arg} =>
-			doit (Con {con = con,
-				   arg = (case arg of
-					     NONE => NONE
-					   | SOME p => SOME (loop p))})
-		   | Constraint (p, _) => loop p
-		   | Layered (x', p) =>
-			if Var.equals (x, x')
-			   then doit (Var y)
-			else loop p
-	       end
+	    val t = ty p
+	    open Layout
 	 in
-	    loop p
+	    case node p of
+	       Con {arg, con, targs} =>
+		  seq [Con.layout con,
+		       if !Control.showTypes andalso 0 < Vector.length targs
+			  then tuple (Vector.toListMap (targs, Type.layout))
+		       else empty,
+		       case arg of
+			  NONE => empty
+			| SOME p => seq [str " ", layout p]]
+	     | Const f => Const.layout (f ())
+	     | Layered (x, p) =>
+		  seq [maybeConstrain (Var.layout x, t), str " as ", layout p]
+	     | List ps => list (Vector.toListMap (ps, layout))
+	     | Record r =>
+		  record (Vector.toListMap
+			  (Record.toVector r, fn (f, p) =>
+			   (Field.toString f, layout p)))
+	     | Tuple ps => tuple (Vector.toListMap (ps, layout))
+	     | Var x => maybeConstrain (Var.layout x, t)
+	     | Wild => str "_"
 	 end
 
-      val removeOthersReplace =
-	 Trace.trace3 ("Pat.removeOthersReplace",
-		       layout, Var.layout, Var.layout, layout)
-	 removeOthersReplace
-
-      fun tuple (ps, region)  =
-	 if 1 = Vector.length ps
-	    then Vector.sub (ps, 0)
-	 else makeRegion (Record {flexible = false, record = Record.tuple ps},
-			  region)
+      fun var (x, t) = make (Var x, t)
 
-      fun unit r = tuple (Vector.new0 (), r)
+      fun tuple ps = make (Tuple ps, Type.tuple (Vector.map (ps, ty)))
 	 
-      val list =
-	 makeList (fn c => Con {con = c, arg = NONE},
-		   fn (c, p) => Con {con = c, arg = SOME p},
-		   tuple)
-
-      fun var (x, r) = makeRegion (Var x, r)
-	 
-      fun record {flexible, record, region} =
-	 makeRegion (Record {flexible = flexible, record = record},
-		     region)
-
       local
-	 fun make c r = makeRegion (Con {con = c, arg = NONE}, r)
+	 fun bool c = make (Con {arg = NONE, con = c, targs = Vector.new0 ()},
+			    Type.bool)
       in
-	 val truee = make Con.truee
-	 val falsee = make Con.falsee
+	 val falsee: t = bool Con.falsee
+	 val truee: t = bool Con.truee
       end
-
-      fun foreachVar (p, f) =
-	 let
-	    fun loop p =
-	       case node p of
-		  Var x => f x
-		| Con {arg = SOME p, ...} => loop p
-		| Record {record, ...} => Record.foreach (record, loop)
-		| Constraint (p, _) => loop p
-		| Layered (x, p) => (f x; loop p)
-		| _ => ()
-	 in loop p
-	 end
+   
+      fun isWild (p: t): bool =
+	 case node p of
+	    Wild => true
+	  | _ => false
+	 
+      fun isRefutable (p: t): bool =
+	 case node p of
+	    Con _ => true
+	  | Const _ => true
+	  | Layered (_, p) => isRefutable p
+	  | List _ => true
+	  | Record r => Record.exists (r, isRefutable)
+	  | Tuple ps => Vector.exists (ps, isRefutable)
+	  | Var _ => false
+	  | Wild => false
    end
 
-datatype decNode =
-   Val of {exp: exp,
-	   filePos: string,
-	   pat: Pat.t,
-	   tyvars: Tyvar.t vector}
-  | Fun of {tyvars: Tyvar.t vector,
-	    decs: {match: match,
-		   profile: SourceInfo.t option,
-		   types: Type.t vector,
-		   var: Var.t} vector}
-  | Datatype of {
-		 tyvars: Tyvar.t vector,
-		 tycon: Tycon.t,
-		 cons: {
-			con: Con.t,
-			arg: Type.t option
-			} vector
-		 } vector
-  | Exception of {
-		  con: Con.t,
-		  arg: Type.t option
-		  }
-  | Overload of {var: Var.t,
-		 scheme: Scheme.t,
-		 ovlds: Var.t vector}
-and expNode =
-   Var of Var.t
-  | Prim of Prim.t
-  | Const of Ast.Const.t
-  | Con of Con.t
-  | Record of exp Record.t
-  | Fn of {match: match,
-	   profile: SourceInfo.t option}
-  | App of exp * exp
-  | Let of dec vector * exp
-  | Constraint of exp * Type.t
-  | Handle of exp * match
-  | Raise of {exn: exp, filePos: string}
-and match = Match of {filePos: string,
-		      rules: (Pat.t * exp) vector}
-withtype exp = expNode Wrap.t
-and dec = decNode Wrap.t
-
-structure Match =
+structure NoMatch =
    struct
-      type t = match
+      datatype t = Impossible | RaiseAgain | RaiseBind | RaiseMatch
 
-      local
-	 fun make f m =
-	    let
-	       val Match r = m
-	    in
-	       f r
-	    end
-      in
-	 val filePos = make #filePos
-	 val rules = make #rules
-      end
+      val toString =
+	 fn Impossible => "Impossible"
+	  | RaiseAgain => "RaiseAgain"
+	  | RaiseBind => "RaiseBind"
+	  | RaiseMatch => "RaiseMatch"
 
-      fun region m =
-	 Wrap.region (#1 (Vector.sub (rules m, 0)))
-		     
-
-      fun new {filePos, rules} =
-	 Match {filePos = filePos,
-		rules = rules}
+      val layout = Layout.str o toString
    end
 
+datatype noMatch = datatype NoMatch.t
+
+datatype dec =
+   Datatype of {cons: {arg: Type.t option,
+		       con: Con.t} vector,
+		tycon: Tycon.t,
+		tyvars: Tyvar.t vector} vector
+ | Exception of {arg: Type.t option,
+		 con: Con.t}
+ | Fun of {decs: {lambda: lambda,
+		  var: Var.t} vector,
+	   tyvars: unit -> Tyvar.t vector}
+ | Val of {rvbs: {lambda: lambda,
+		  var: Var.t} vector,
+	   tyvars: unit -> Tyvar.t vector,
+	   vbs: {exp: exp,
+		 pat: Pat.t,
+		 patRegion: Region.t} vector}
+and exp = Exp of {node: expNode,
+		  ty: Type.t}
+and expNode =
+   App of exp * exp
+  | Case of  {noMatch: noMatch,
+	      region: Region.t,
+	      rules: (Pat.t * exp) vector,
+	      test: exp}
+  | Con of Con.t * Type.t vector
+  | Const of unit -> Const.t
+  | EnterLeave of exp * SourceInfo.t
+  | Handle of {catch: Var.t * Type.t,
+	       handler: exp,
+	       try: exp}
+  | Lambda of lambda
+  | Let of dec vector * exp
+  | List of exp vector
+  | PrimApp of {args: exp vector,
+		prim: Prim.t,
+		targs: Type.t vector}
+  | Raise of {exn: exp,
+	      region: Region.t}
+  | Record of exp Record.t
+  | Seq of exp vector
+  | Var of (unit -> Var.t) * (unit -> Type.t vector)
+and lambda = Lam of {arg: Var.t,
+		     argType: Type.t,
+		     body: exp}
+
 local
-   local
-      open Ast
-   in
-      structure Dec = Dec
-      structure Exp = Exp
-      structure Longvar = Longvar
-   end
+   open Layout
 in
-   fun astDatatype ds =
-      Dec.datatypee
-      (Vector.map
-       (ds, fn {tyvars, tycon, cons} =>
-	{tyvars = tyvars,
-	 tycon = Tycon.toAst tycon,
-	 cons = Vector.map (cons, fn {con, arg} =>
-			    (Con.toAst con, Type.optionToAst arg))}))
-      
-   fun decToAst (d: dec) =
-      let
-	 fun doit n = Dec.makeRegion (n, Region.bogus)
-      in
-	 case Wrap.node d of
-	    Val {pat, filePos, tyvars, exp} =>
-	       doit (Dec.Val {tyvars = tyvars,
-			      vbs = Vector.new1 {pat = Pat.toAst pat,
-						 exp = expToAst exp,
-						 filePos = filePos},
-			      rvbs = Vector.new0 ()})
-	  | Fun {tyvars, decs} =>
-	       doit (Dec.Val
-		     {tyvars = tyvars,
-		      vbs = Vector.new0 (),
-		      rvbs = (Vector.map
-			      (decs, fn {match, types, var, ...} =>
-			       {pat = (Vector.fold
-				       (types, Apat.var (Var.toAst var),
-					fn (t, p) =>
-					Apat.constraint (p, Type.toAst t))),
-				match = matchToAst match}))})
-	  | Datatype ds => astDatatype ds
-	  | Exception {con, arg} =>
-	       Dec.exceptionn (Con.toAst con, Type.optionToAst arg)
-	  | Overload {var, scheme, ovlds} =>
-	       doit (Dec.Overload
-		     (Var.toAst var,
-		      Type.toAst (Scheme.ty scheme),
-		      Vector.map (ovlds, fn x =>
-				  Longvar.short (Var.toAst x))))
-      end
-   and expToAst e =
-      case Wrap.node e of
-	 App (e1, e2) => Exp.app (expToAst e1, expToAst e2)
-       | Con c => Exp.con (Con.toAst c)
-       | Const c => Exp.const c
-       | Constraint (e, t) => Exp.constraint (expToAst e, Type.toAst t)
-       | Fn {match, ...} => Exp.fnn (matchToAst match)
-       | Handle (try, match) => Exp.handlee (expToAst try, matchToAst match)
-       | Let (ds, e) => Exp.lett (Vector.map (ds, decToAst), expToAst e)
-       | Prim p => Exp.longvid (Ast.Longvid.short
-				(Ast.Longvid.Id.fromString (Prim.toString p,
-							    Region.bogus)))
-       | Raise {exn, filePos} =>
-	    Exp.raisee {exn = expToAst exn, filePos = filePos}
-       | Record r => Exp.record (Record.map (r, expToAst))
-       | Var x => Exp.var (Var.toAst x)
-
-   and matchToAst m =
-      let
-	 val Match {rules, filePos} = m
-      in
-	 Ast.Match.T
-	 {filePos = filePos,
-	  rules = Vector.map (rules, fn (p, e) => (Pat.toAst p, expToAst e))}
-      end
+   fun layoutTyvars ts =
+      case Vector.length ts of
+	 0 => empty
+       | 1 => seq [str " ", Tyvar.layout (Vector.sub (ts, 0))]
+       | _ => seq [str " ", tuple (Vector.toListMap (ts, Tyvar.layout))]
+	 
+   fun layoutConArg {arg, con} =
+      seq [Con.layout con,
+	   case arg of
+	      NONE => empty
+	    | SOME t => seq [str " of ", Type.layout t]]
+
+   fun layoutDec d =
+      case d of
+	 Datatype v =>
+	    seq [str "datatype",
+		 align
+		 (Vector.toListMap
+		  (v, fn {cons, tycon, tyvars} =>
+		   seq [layoutTyvars tyvars, Tycon.layout tycon, str " = ",
+			align
+			(separateLeft (Vector.toListMap (cons, layoutConArg),
+				       "| "))]))]
+       | Exception ca =>
+	    seq [str "exception ", layoutConArg ca]
+       | Fun {decs, tyvars, ...} => layoutFuns (tyvars, decs)
+       | Val {rvbs, tyvars, vbs, ...} =>
+	    align [layoutFuns (tyvars, rvbs),
+		   align (Vector.toListMap
+			  (vbs, fn {exp, pat, ...} =>
+			   seq [str "val",
+				mayAlign [seq [layoutTyvars (tyvars ()),
+					       str " ", Pat.layout pat,
+					       str " ="],
+					  layoutExp exp]]))]
+   and layoutExp (Exp {node, ...}) =
+      case node of
+	 App (e1, e2) => paren (seq [layoutExp e1, str " ", layoutExp e2])
+       | Case {noMatch, rules, test, ...} =>
+	    Pretty.casee {default = NONE,
+			  rules = Vector.map (rules, fn (p, e) =>
+					      (Pat.layout p, layoutExp e)),
+			  test = layoutExp test}
+       | Con (c, _) => Con.layout c
+       | Const f => Const.layout (f ())
+       | EnterLeave (e, _) => layoutExp e
+       | Handle {catch, handler, try} =>
+	    Pretty.handlee {catch = Var.layout (#1 catch),
+			    handler = layoutExp handler,
+			    try = layoutExp try}
+       | Lambda l => layoutLambda l
+       | Let (ds, e) =>
+	    Pretty.lett (align (Vector.toListMap (ds, layoutDec)),
+			 layoutExp e)
+       | List es => list (Vector.toListMap (es, layoutExp))
+       | PrimApp {args, prim, targs} =>
+	    Pretty.primApp {args = Vector.map (args, layoutExp),
+			    prim = Prim.layout prim,
+			    targs = Vector.map (targs, Type.layout)}
+       | Raise {exn, ...} => Pretty.raisee (layoutExp exn)
+       | Record r =>
+	    Record.layout
+	    {extra = "",
+	     layoutElt = layoutExp,
+	     layoutTuple = fn es => tuple (Vector.toListMap (es, layoutExp)),
+	     record = r,
+	     separator = " = "}
+       | Seq es => Pretty.seq (Vector.map (es, layoutExp))
+       | Var (x, targs) => Var.layout (x ())
+   and layoutFuns (tyvars, decs)  =
+      if 0 = Vector.length decs
+	 then empty
+      else
+	 align [seq [str "val rec", layoutTyvars (tyvars ())],
+		indent (align (Vector.toListMap
+			       (decs, fn {lambda, var} =>
+				align [seq [Var.layout var, str " = "],
+				       indent (layoutLambda lambda, 3)])),
+			3)]
+   and layoutLambda (Lam {arg, argType, body}) =
+      paren (align [seq [str "fn ", Var.layout arg, str " =>"],
+		    layoutExp body])
 end
 
-fun makeForeachVar f =
-   let
-      fun exp e =
-	 case Wrap.node e of
-	    App (e1, e2) => (exp e1; exp e2)
-	  | Constraint (e, _) => exp e
-	  | Fn {match = m, ...} => match m
-	  | Handle (e, m) => (exp e; match m)
-	  | Let (ds, e) => (Vector.foreach (ds, dec); exp e)
-	  | Raise {exn, ...} => exp exn
-	  | Record r => Record.foreach (r, exp)
-	  | Var x => f x
-	  | _ => ()
-      and match m = Vector.foreach (Match.rules m, exp o #2)
-      and dec d =
-	 case Wrap.node d of
-	    Fun {decs, ...} => Vector.foreach (decs, match o #match)
-	  | Overload {ovlds, ...} => Vector.foreach (ovlds, f)
-	  | Val {exp = e, ...} => exp e
-	  | _ => ()
-   in
-      {exp = exp, dec = dec}
+structure Lambda =
+   struct
+      datatype t = datatype lambda
+
+      val layout = layoutLambda
+
+      val make = Lam
+
+      fun dest (Lam r) = r
    end
 
 structure Exp =
    struct
-      open Wrap
       type dec = dec
-      type match = match
+      type lambda = lambda
+      datatype t = datatype exp
       datatype node = datatype expNode
-      type t = exp
-      type node' = node
-      type obj = t
-
-      val toAst = expToAst
-
-      fun foreachVar (e, f) = #exp (makeForeachVar f) e
 
-      fun fnn (m, r) = makeRegion (Fn m, r)
+      datatype noMatch = datatype noMatch
+	    
+      val layout = layoutExp
 
-      fun fn1 {exp, pat, profile, region}= 
-	 fnn ({match = Match.new {filePos = "",
-				  rules = Vector.new1 (pat, exp)},
-	       profile = profile},
-	      region)
+      local
+	 fun make f (Exp r) = f r
+      in
+	 val dest = make (fn {node, ty} => (node, ty))
+	 val node = make #node
+	 val ty = make #ty
+      end
+	    
+      fun make (n, t) = Exp {node = n,
+			     ty = t}
 
-      fun isExpansive e =
+      fun enterLeave (e, si) = make (EnterLeave (e, si), ty e)
+	 
+      fun var (x: Var.t, ty: Type.t): t =
+	 make (Var (fn () => x, fn () => Vector.new0 ()), ty)
+	 
+      fun isExpansive (e: t): bool =
 	 case node e of
-	    Var _ => false
-	  | Const _ => false
-	  | Con _ => false
-	  | Fn _ => false
-	  | Prim _ => false
-	  | Record r => Record.exists (r, isExpansive)
-	  | Constraint (e, _) => isExpansive e
-	  | App (e1, e2) =>
+	    App (e1, e2) =>
 	       (case node e1 of
-		   Con c => Con.equals (c, Con.reff) orelse isExpansive e2
+		   Con (c, _) => Con.equals (c, Con.reff) orelse isExpansive e2
 		 | _ => true)
-	  | _ => true
-
-      fun record (record, r) = makeRegion (Record record, r)
-	 
-      fun lambda (x, e, p, r) =
-	 fn1 {exp = e,
-	      pat = makeRegion (Pat.Var x, r),
-	      profile = p,
-	      region = r}
-
-      fun casee (test, rules, r) =
-	 makeRegion (App (makeRegion (Fn {match = rules,
-					  profile = NONE},
-				      r),
-			  test),
-		     r)
+	  | Case _ => true
+	  | Con _ => false
+	  | Const _ => false
+	  | EnterLeave _ => true
+	  | Handle _ => true
+	  | Lambda _ => false
+	  | Let _ => true
+	  | List es => Vector.exists (es, isExpansive)
+	  | PrimApp _ => true
+	  | Raise _ => true
+	  | Record r => Record.exists (r, isExpansive)
+	  | Seq _ => true
+	  | Var _ => false
 
-      fun tuple (es, r) =
+      fun tuple es =
 	 if 1 = Vector.length es
 	    then Vector.sub (es, 0)
-	 else record (Record.tuple es, r)
+	 else make (Record (Record.tuple es),
+		    Type.tuple (Vector.map (es, ty)))
 
-      fun unit r = tuple (Vector.new0 (), r)
+      val unit = tuple (Vector.new0 ())
 
-      fun seq (es, r) =
-	 if 1 = Vector.length es
-	    then Vector.sub (es, 0)
-	 else
-	    let
-	       val (es, e) = Vector.splitLast es
-	    in
-	       makeRegion
-	       (Let (Vector.map (es, fn e =>
-				 makeRegion (Val {pat = makeRegion (Pat.Wild, r),
-						  tyvars = Vector.new0 (),
-						  exp = e,
-						  filePos = ""},
-					     r)),
-		     e),
-		r)
-	    end
+      local
+	 fun bool c = make (Con (c, Vector.new0 ()), Type.bool)
+      in
+	 val falsee: t = bool Con.falsee
+	 val truee: t = bool Con.truee
+      end
 
-      fun force (e, r) = makeRegion (App (e, unit r), r)
-	 
-      fun list (l, r) =
-	 makeList (Con, fn (c, e) => App (makeRegion (Con c, r), e), tuple)
-	 (l, r)
+      fun lambda (l as Lam {argType, body, ...}) =
+	 make (Lambda l, Type.arrow (argType, ty body))
 
-      fun var (x, r) = makeRegion (Var x, r)
-	 
-      fun selector (f, r) =
-	 let
-	    val x = Var.newNoname ()
-	 in
-	    fn1 {exp = var (x, r),
-		 pat = (Pat.record
-			{flexible = true,
-			 record = Record.fromVector (Vector.new1
-						     (f, Pat.var (x, r))),
-			 region = r}),
-		 profile = NONE,
-		 region = r}
-	 end
+      fun casee (z as {rules, ...}) =
+	 if 0 = Vector.length rules
+	    then Error.bug "CoreML.casee"
+	 else make (Case z, ty (#2 (Vector.sub (rules, 0))))
+			  
+      fun iff (test, thenCase, elseCase): t =
+	 casee {noMatch = Impossible,
+		region = Region.bogus,
+		rules = Vector.new2 ((Pat.truee, thenCase),
+				     (Pat.falsee, elseCase)),
+		test = test}
 
-      fun iff (test, thenCase, elseCase, r) =
-	 casee (test,
-		Match.new {filePos = "",
-			   rules = Vector.new2 ((Pat.truee r, thenCase),
-						(Pat.falsee r, elseCase))},
-		r)
-
-      fun con (c, r) = makeRegion (Con c, r)
-      fun truee r = con (Con.truee, r)
-      fun falsee r = con (Con.falsee, r)
+      fun andAlso (e1, e2) = iff (e1, e2, falsee)
 	 
-      fun andAlso (e1, e2, r) = iff (e1, e2, falsee r, r)
-      fun orElse (e1, e2, r) = iff (e1, truee r, e2, r)
+      fun orElse (e1, e2) = iff (e1, truee, e2)
 
-      fun whilee {test, expr, region = r} =
+      fun whilee {expr, test} =
 	 let
 	    val loop = Var.newNoname ()
-	    val call = makeRegion (App (var (loop, r), unit r), r)
-	    val match =
-	       Match.new {filePos = "",
-			  rules = (Vector.new1
-				   (Pat.tuple (Vector.new0 (), r),
-				    iff (test,
-					 seq (Vector.new2 (expr, call), r),
-					 unit r,
-					 r)))}
+	    val loopTy = Type.arrow (Type.unit, Type.unit)
+	    val call = make (App (var (loop, loopTy), unit), Type.unit)
+	    val lambda =
+	       Lambda.make
+	       {arg = Var.newNoname (),
+		argType = Type.unit,
+		body = iff (test,
+			    make (Seq (Vector.new2 (expr, call)),
+				  Type.unit),
+			    unit)}
 	 in
-	    makeRegion
-	    (Let (Vector.new1
-		  (makeRegion
-		   (Fun {tyvars = Vector.new0 (),
-			 decs = (Vector.new1
-				 {match = match,
-				  profile = SOME (SourceInfo.anonymous r),
-				  types = Vector.new0 (),
-				  var = loop})},
-		    r)),
+	    make
+	    (Let (Vector.new1 (Fun {decs = Vector.new1 {lambda = lambda,
+							var = loop},
+				    tyvars = fn () => Vector.new0 ()}),
 		  call),
-	     r)
+	     Type.unit)
 	 end
 
-      val layout = Ast.Exp.layout o toAst
    end
 
 structure Dec =
    struct
-      open Wrap
-      type t = dec
-      datatype node = datatype decNode
-      type node' = node
-      type obj = t
-
-      fun isExpansive d =
-	 case node d of
-	    Val {exp, ...} => Exp.isExpansive exp
-	  | _ => false
+      datatype t = datatype dec
 
-      val toAst = decToAst
-
-      val layout = Adec.layout o toAst
+      val layout = layoutDec
    end
 
 structure Program =
    struct
       datatype t = T of {decs: Dec.t vector}
 
-      fun toAst (T {decs, ...}) =
-	 Adec.makeRegion
-	 (Adec.Local
-	  (Adec.makeRegion (Adec.SeqDec (Vector.map (decs, Dec.toAst)),
-			    Region.bogus),
-	   Adec.empty),
-	  Region.bogus)
-
-      val layout = Adec.layout o toAst
+      fun layout (T {decs, ...}) =
+	 Layout.align (Vector.toListMap (decs, Dec.layout))
 
-      fun size (T {decs = ds, ...}): int =
-	 let
-	    val n = ref 0
-	    fun inc () = n := 1 + !n
-	    fun exp e =
-	       (inc ()
-		; (case Exp.node e of
-		      App (e, e') => (exp e; exp e')
-		    | Constraint (e, _) => exp e
-		    | Fn {match = m, ...} => match m
-		    | Handle (e, m) => (exp e; match m)
-		    | Let (ds, e) => (Vector.foreach (ds, dec); exp e)
-		    | Raise {exn, ...} => exp exn
-		    | Record r => Record.foreach (r, exp)
-		    | _ => ()))
-	    and match m = Vector.foreach (Match.rules m, exp o #2)
-	    and dec d =
-	       case Dec.node d of
-		  Exception _ => inc ()
-		| Fun {decs, ...} => Vector.foreach (decs, match o #match)
-		| Val {exp = e, ...} => exp e
-		| _ => ()
-	    val _ = Vector.foreach (ds, dec)
-	 in
-	    !n
-	 end
-      
-      fun layoutStats p =
-	 let open Layout
-	 in seq [str "size = ", Int.layout (size p)]
-	 end
+(*       fun typeCheck (T {decs, ...}) =
+ * 	 let
+ * 	    fun checkExp (e: Exp.t): Ty.t =
+ * 	       let
+ * 		  val (n, t) = Exp.dest e
+ * 		  val 
+ * 		  datatype z = datatype Exp.t
+ * 		  val t' =
+ * 		     case n of
+ * 			App (e1, e2) =>
+ * 			   let
+ * 			      val t1 = checkExp e1
+ * 			      val t2 = checkExp e2
+ * 			   in
+ * 			      case Type.deArrowOpt t1 of
+ * 				 NONE => error "application of non-function"
+ * 			       | SOME (u1, u2) =>
+ * 				    if Type.equals (u1, t2)
+ * 				       then t2
+ * 				    else error "function/argument mismatch"
+ * 			   end
+ * 		      | Case {rules, test} =>
+ * 			   let
+ * 			      val {pat, exp} = Vector.sub (rules, 0)
+ * 			   in
+ * 			      Vector.foreach (rules, fn {pat, exp} =>
+ * 					      Type.equals
+ * 					      (checkPat pat, 
+ * 			   end
+ * 	       in
+ * 				     
+ * 	       end
+ * 	 in
+ * 	 end
+ *)
    end
 
 end



1.9       +91 -94    mlton/mlton/core-ml/core-ml.sig

Index: core-ml.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/core-ml.sig,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- core-ml.sig	14 Jan 2003 00:08:16 -0000	1.8
+++ core-ml.sig	9 Oct 2003 18:17:32 -0000	1.9
@@ -11,8 +11,20 @@
 signature CORE_ML_STRUCTS = 
    sig
       include ATOMS
-      structure Type: TYPE
-      sharing Type = Prim.Type
+      structure Type:
+	 sig
+	    type t
+
+	    val arrow: t * t -> t
+	    val bool: t
+	    val deConOpt: t -> (Tycon.t * t vector) option
+	    val deRecord: t -> (Record.Field.t * t) vector
+	    val hom: {con: Tycon.t * 'a vector -> 'a,
+		      var: Tyvar.t -> 'a} -> t -> 'a
+	    val layout: t -> Layout.t
+	    val tuple: t vector -> t
+	    val unit: t
+	 end
    end
 
 signature CORE_ML = 
@@ -23,133 +35,119 @@
 	 sig
 	    type t
 	    datatype node =
-	       Con of {
+	       Con of {arg: t option,
 		       con: Con.t,
-		       arg: t option
-		      }
-	     | Const of Ast.Const.t
-	     | Constraint of t * Type.t
+		       targs: Type.t vector}
+	     | Const of unit -> Const.t
 	     | Layered of Var.t * t
-	     | Record of {
-			  flexible: bool,
-			  record: t Record.t
-			 }
+	     | List of t vector
+	     | Record of t Record.t
+	     | Tuple of t vector
 	     | Var of Var.t
 	     | Wild
-	    include WRAPPED sharing type node' = node
-		            sharing type obj = t
 
-	    val foreachVar: t * (Var.t -> unit) -> unit
+	    val dest: t -> node * Type.t
+	    val falsee: t 
 	    (* true if pattern contains a constant, constructor or variable *)
 	    val isRefutable: t -> bool
 	    val isWild: t -> bool
 	    val layout: t -> Layout.t
-	    val list: t list * Region.t -> t
-	    val record: {flexible: bool,
-			 record: t Record.t,
-			 region: Region.t} -> t
-	    (* removeOthersReplace(pat, old,new) replaces all variables in pat
-	     * with Wild, except for old, which it replaces with new
-	     *)
-	    val removeOthersReplace: t * Var.t * Var.t -> t
-	    val removeVars: t -> t 	    (* replace all variables with Wild *)
-	    val toAst: t -> Ast.Pat.t	    (* conversion to Ast *)
-	    val tuple: t vector * Region.t -> t
-	    val unit: Region.t -> t
-	    (* a list (without duplicates) of variables occurring in a pattern *)
-	    val vars: t -> Var.t list 
+	    val make: node * Type.t -> t
+	    val node: t -> node
+	    val var: Var.t * Type.t -> t
+	    val truee: t
+	    val tuple: t vector -> t
+	    val ty: t -> Type.t
 	 end
 
       structure Exp:
 	 sig
 	    type dec
-	    type match
+	    type lambda
 	    type t
+	    datatype noMatch = Impossible | RaiseAgain | RaiseBind | RaiseMatch
 	    datatype node =
 	       App of t * t
-	     | Con of Con.t
-	     | Const of Ast.Const.t
-	     | Constraint of t * Type.t
-	     | Fn of {match: match,
-		      profile: SourceInfo.t option}
-	     | Handle of t * match
+	     | Case of {noMatch: noMatch,
+			region: Region.t,
+			rules: (Pat.t * t) vector,
+			test: t}
+	     | Con of Con.t * Type.t vector
+	     | Const of unit -> Const.t
+	     | EnterLeave of t * SourceInfo.t
+	     | Handle of {catch: Var.t * Type.t,
+			  handler: t,
+			  try: t}
+	     | Lambda of lambda
 	     | Let of dec vector * t
-	     | Prim of Prim.t
+	     | List of t vector
+	     | PrimApp of {args: t vector,
+			   prim: Prim.t,
+			   targs: Type.t vector}
 	     | Raise of {exn: t,
-			 filePos: string}
+			 region: Region.t}
 	     | Record of t Record.t
-	     | Var of Var.t
-	    include WRAPPED sharing type node' = node
-		            sharing type obj = t
+	     | Seq of t vector
+	     | Var of (unit -> Var.t) * (unit -> Type.t vector)
 
-	    val andAlso: t * t * Region.t -> t
-	    val casee: t * match * Region.t -> t
-	    val force: t * Region.t -> t
-	    val foreachVar: t * (Var.t -> unit) -> unit
-	    val iff: t * t * t * Region.t -> t
+	    val andAlso: t * t -> t
+	    val casee: {noMatch: noMatch,
+			region: Region.t,
+			rules: (Pat.t * t) vector,
+			test: t} -> t
+	    val dest: t -> node * Type.t
+	    val enterLeave: t * SourceInfo.t -> t
+	    val iff: t * t * t -> t
+	    val falsee: t
 	    (* true if the expression may side-effect. See p 19 of Definition *)
 	    val isExpansive: t -> bool
-	    val lambda: Var.t * t * SourceInfo.t option * Region.t -> t
+	    val lambda: lambda -> t
 	    val layout: t -> Layout.t
-	    val list: t list * Region.t -> t
-	    val orElse: t * t * Region.t -> t
-	    val selector: Record.Field.t * Region.t -> t
-	    val seq: t vector * Region.t -> t
-	    val tuple: t vector * Region.t -> t
-	    val unit: Region.t -> t
-	    val whilee: {test: t, expr: t, region: Region.t} -> t
+	    val make: node * Type.t -> t
+	    val node: t -> node
+	    val orElse: t * t -> t
+	    val truee: t
+	    val tuple: t vector -> t
+	    val ty: t -> Type.t
+	    val unit: t
+	    val var: Var.t * Type.t -> t
+	    val whilee: {expr: t, test: t} -> t
 	 end
 
-      structure Match:
+      structure Lambda:
 	 sig
 	    type t
 
-	    val filePos: t -> string
-	    val new: {rules: (Pat.t * Exp.t) vector,
-		      filePos: string} -> t
-	    val region: t -> Region.t
-	    val rules: t -> (Pat.t * Exp.t) vector
+	    val dest: t -> {arg: Var.t,
+			    argType: Type.t,
+			    body: Exp.t}
+	    val layout: t -> Layout.t
+	    val make: {arg: Var.t,
+		       argType: Type.t,
+		       body: Exp.t} -> t
 	 end
-      where type t = Exp.match
+      sharing type Exp.lambda = Lambda.t
 
       structure Dec:
 	 sig
-	    type t
-	    datatype node =
-	       Datatype of {
-			    tyvars: Tyvar.t vector,
+	    datatype t =
+	       Datatype of {cons: {arg: Type.t option,
+				   con: Con.t} vector,
 			    tycon: Tycon.t,
-			    cons: {
-				   con: Con.t,
-				   arg: Type.t option
-				  } vector
-			   } vector
-	     | Exception of {
-			     con: Con.t,
-			     arg: Type.t option
-			    }
-	     | Fun of {
-		       tyvars: Tyvar.t vector,
-		       decs: {match: Match.t,
-			      profile: SourceInfo.t option,
-			      types: Type.t vector, (* multiple constraints *)
-			      var: Var.t} vector
-		      }
-	     | Overload of {
-			    var: Var.t,
-			    scheme: Scheme.t,
-			    ovlds: Var.t vector
-			   }
-	     | Val of {exp: Exp.t,
-		       filePos: string,
-		       pat: Pat.t,
-		       tyvars: Tyvar.t vector}
-	    include WRAPPED sharing type node' = node
-		            sharing type obj = t
+			    tyvars: Tyvar.t vector} vector
+	     | Exception of {arg: Type.t option,
+			     con: Con.t}
+	     | Fun of {decs: {lambda: Lambda.t,
+			      var: Var.t} vector,
+		       tyvars: unit -> Tyvar.t vector}
+	     | Val of {rvbs: {lambda: Lambda.t,
+			      var: Var.t} vector,
+		       tyvars: unit -> Tyvar.t vector,
+		       vbs: {exp: Exp.t,
+			     pat: Pat.t,
+			     patRegion: Region.t} vector}
 
-	    val isExpansive: t -> bool
 	    val layout: t -> Layout.t
-	    val toAst: t -> Ast.Dec.t
 	 end
       where type t = Exp.dec
 
@@ -158,6 +156,5 @@
 	    datatype t = T of {decs: Dec.t vector}
 
 	    val layout: t -> Layout.t
-	    val layoutStats: t -> Layout.t
 	 end
    end



1.4       +3 -7      mlton/mlton/core-ml/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/sources.cm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- sources.cm	16 Apr 2002 12:10:52 -0000	1.3
+++ sources.cm	9 Oct 2003 18:17:32 -0000	1.4
@@ -8,10 +8,8 @@
 Group
 
 signature CORE_ML
-signature LOOKUP_CONSTANT
 functor CoreML
-functor DeadCode
-functor LookupConstant
+(*functor DeadCode *)
 
 is
 
@@ -20,9 +18,7 @@
 ../control/sources.cm
 ../../lib/mlton/sources.cm
 
+core-ml.fun
 core-ml.sig
-lookup-constant.sig
-lookup-constant.fun
+(*dead-code.fun *)
 dead-code.sig
-dead-code.fun
-core-ml.fun



1.1                  mlton/mlton/defunctorize/defunctorize.fun

Index: defunctorize.fun
===================================================================
functor Defunctorize (S: DEFUNCTORIZE_STRUCTS): DEFUNCTORIZE = 
struct

open S

local
   open CoreML
in
   structure Const = Const
   structure Cdec = Dec
   structure Cexp = Exp
   structure IntSize = IntSize
   structure Clambda = Lambda
   structure Cpat = Pat
   structure Prim = Prim
   structure Record = Record
   structure Ctype = Type
   structure WordSize = WordSize
end

structure IntX = Const.IntX
structure Field = Record.Field

local
   open Xml
in
   structure Xcases = Cases
   structure Con = Con
   structure Xdec = Dec
   structure Xexp = DirectExp
   structure Xlambda = Lambda
   structure Xpat = Pat
   structure XprimExp = PrimExp
   structure Tycon = Tycon
   structure Xtype = Type
   structure Tyvar = Tyvar
   structure Var = Var
   structure XvarExp = VarExp
end

structure Region =
   struct
      open Region

      fun toFilePos r = Option.map (left r, SourcePos.toString)
   end

structure NestedPat = NestedPat (open Xml)
structure MatchCompile =
   MatchCompile (open CoreML
		 structure Type = Xtype
		 structure NestedPat = NestedPat
		 structure Cases =
		    struct
		       type exp = Xexp.t

		       open Xcases
		       type t = exp t
		       val int = Int
		       val word = Word
		       fun con v =
			  Con (Vector.map
			       (v, fn {con, targs, arg, rhs} =>
				(Xpat.T {con = con,
					 targs = targs,
					 arg = arg},
				 rhs)))
		    end
		structure Exp =
		   struct
		      open Xexp
		      val lett = let1
		      val var = monoVar

		      fun detuple {tuple, body} =
			 Xexp.detuple
			 {tuple = tuple,
			  body = fn xts => body (Vector.map
						 (xts, fn (x, t) =>
						  (XvarExp.var x, t)))}
		   end)

structure Xexp =
   struct
      open Xexp
	 
      local
	 fun exn (c: Con.t): Xexp.t =
	    conApp {arg = NONE,
		    con = c,
		    targs = Vector.new0 (),
		    ty = Xtype.exn}
      in
	 val bind = exn Con.bind
	 val match = exn Con.match
      end
   end

fun casee {caseType: Xtype.t,
	   cases: (NestedPat.t * Xexp.t) vector,
	   conTycon,
	   noMatch,
	   region: Region.t,
	   test = (test: Xexp.t, testType: Xtype.t),
	   tyconCons}: Xexp.t =
   let
      fun raiseExn f =
	 let
	    val e = Var.newNoname ()
	 in
	    Vector.concat
	    [cases,
	     Vector.new1 (NestedPat.make (NestedPat.Var e, testType),
			  Xexp.raisee ({exn = f e,
					filePos = Region.toFilePos region},
				       caseType))]
	 end
      val cases =
	 let
	    datatype z = datatype Cexp.noMatch
	 in
	    case noMatch of
	       Impossible => cases
	     | RaiseAgain => raiseExn (fn e => Xexp.monoVar (e, Xtype.exn))
	     | RaiseBind => raiseExn (fn _ => Xexp.bind)
	     | RaiseMatch => raiseExn (fn _ => Xexp.match)
	 end
      fun matchCompile () =		     		     
	 let
	    val (cases, decs) =
	       Vector.mapAndFold
	       (cases, [], fn ((p: NestedPat.t, e: Xexp.t), decs) =>
		let
		   val args = Vector.fromList (NestedPat.varsAndTypes p)
		   val (vars, tys) = Vector.unzip args
		   val func = Var.newNoname ()
		   val arg = Var.newNoname ()
		   val argType = Xtype.tuple tys
		   val funcType = Xtype.arrow (argType, caseType)
		   val dec =
		      Xdec.MonoVal
		      {var = func,
		       ty = funcType,
		       exp =
		       XprimExp.Lambda
		       (Xlambda.make
			{arg = arg,
			 argType = argType,
			 body =
			 Xexp.toExp
			 (Xexp.detupleBind
			  {tuple = Xexp.monoVar (arg, argType),
			   components = vars,
			   body = e})})}
		   fun finish rename =
		      Xexp.app
		      {func = Xexp.monoVar (func, funcType),
		       arg =
		       Xexp.tuple {exps = (Vector.map
					   (args, fn (x, t) =>
					    Xexp.monoVar (rename x, t))),
				   ty = argType},
		       ty = caseType}
		in ((p, finish), dec :: decs)
		end)
	    val testVar = Var.newNoname ()
	 in
	    Xexp.let1
	    {var = testVar,
	     exp = test,
	     body = 
	     Xexp.lett
	     {decs = decs,
	      body = MatchCompile.matchCompile {caseType = caseType,
						cases = cases,
						conTycon = conTycon,
						region = region,
						test = testVar,
						testType = testType,
						tyconCons = tyconCons}}}
	 end
      datatype z = datatype NestedPat.node
      fun lett (x, e) = Xexp.let1 {var = x, exp = test, body = e}
      fun wild e = lett (Var.newNoname (), e)
      fun normal () =
	 if Vector.isEmpty cases
	    then Error.bug "case with no patterns"
	 else
	    let
	       val (p, e) = Vector.sub (cases, 0)
	    in
	       case NestedPat.node p of
		  Wild => wild e
		| Var x => lett (x, e)
		| Tuple ps =>
		     if Vector.forall (ps, NestedPat.isVar)
			then
			   (* It's a flat tuple pattern.
			    * Generate the selects.
			    *)
			   let
			      val t = Var.newNoname ()
			      val tuple = XvarExp.mono t
			      val tys = Xtype.deTuple testType
			      val (_, decs) =
				 Vector.fold2
				 (ps, tys, (0, []),
				  fn (p, ty, (i, decs)) =>
				  case NestedPat.node p of
				     Var x =>
					(i + 1,
					 Xdec.MonoVal
					 {var = x,
					  ty = ty,
					  exp = (XprimExp.Select
						 {tuple = tuple,
						  offset = i})}
					 :: decs)
				   | _ => Error.bug "infer flat tuple")
			   in Xexp.let1 {var = t, exp = test,
					 body = Xexp.lett {decs = decs,
							   body = e}}
			   end
		     else matchCompile ()
				   | _ => matchCompile ()
	    end
				 fun make (ac, default) =
				    Xexp.casee {test = test,
						default = default,
						ty = caseType,
						cases = Xcases.Con (Vector.fromList ac)}
				 fun step (_, (p, e), ac) =
				    case NestedPat.node p of
				       NestedPat.Wild =>
					  Vector.Done
					  (case ac of
					      [] => wild e
					    | _ => make (ac, SOME (e, region)))
				     | _ => Vector.Done (normal ())
				 fun done ac = make (ac, NONE)
   in
      Vector.fold' (cases, 0, [], step, done)
   end

val casee =
   Trace.trace ("Defunctorize.casee",
		Region.layout o #region,
		Xml.Exp.layout o Xexp.toExp)
   casee

fun 'a sortByField (v: (Field.t * 'a) vector): 'a vector =
   Vector.map (QuickSort.sortVector (v, fn ((f, _), (f', _)) =>
				     Field.<= (f, f')),
	       #2)

fun valDec (tyvars: Tyvar.t vector,
	    x: Var.t,
	    e: Xexp.t,
	    et: Xtype.t,
	    e': Xexp.t): Xexp.t =
   Xexp.lett {body = e',
	      decs = [Xdec.PolyVal {exp = Xexp.toExp e,
				    ty = et,
				    tyvars = tyvars,
				    var = x}]}

fun defunctorize (CoreML.Program.T {decs}) =
   let
      val loopTy = Ctype.hom {con = fn (c, ts) => if Tycon.equals (c, Tycon.char)
						     then Xtype.word8
						  else Xtype.con (c, ts),
			      var = Xtype.var}
      val {get = conTycon, set = setConTycon, ...} =
	 Property.getSetOnce (Con.plist,
			      Property.initRaise ("conTycon", Con.layout))
      val {get = tyconCons: Tycon.t -> Con.t vector,
	   set = setTyconCons, ...} =
	 Property.getSetOnce (Tycon.plist,
			      Property.initRaise ("tyconCons", Tycon.layout))
      val setConTycon =
	 Trace.trace2 ("setConTycon", Con.layout, Tycon.layout, Unit.layout)
	 setConTycon
      val datatypes = ref []
      (* Process all the datatypes. *)
      fun loopDec (d: Cdec.t) =
	 let
(*	    datatype z = datatype Cdec.t *)
	    open Cdec
	 in
	    case d of
	       Datatype dbs =>
		  Vector.foreach
		  (dbs, fn {cons, tycon, tyvars} =>
		   let
		      val _ = setTyconCons (tycon, Vector.map (cons, #con))
		      val cons =
			 Vector.map
			 (cons, fn {arg, con} =>
			  (setConTycon (con, tycon)
			   ; {arg = Option.map (arg, loopTy),
			      con = con}))
		      val _ = 
			 if Tycon.equals (tycon, Tycon.reff)
			    then ()
			 else
			    List.push (datatypes, {cons = cons,
						   tycon = tycon,
						   tyvars = tyvars})
		   in
		      ()
		   end)
	     | Exception {con, ...} => setConTycon (con, Tycon.exn)
	     | Fun {decs, ...} => Vector.foreach (decs, loopLambda o #lambda)
	     | Val {rvbs, vbs, ...} =>
		  (Vector.foreach (rvbs, loopLambda o #lambda)
		   ; Vector.foreach (vbs, loopExp o #exp))
	 end
      and loopExp (e: Cexp.t): unit =
	 let
	    datatype z = datatype Cexp.node
	 in
	    case Cexp.node e of
	       App (e, e') => (loopExp e; loopExp e')
	     | Case {rules, test, ...} =>
		  (loopExp test
		   ; Vector.foreach (rules, loopExp o #2))
	     | Con _ => ()
	     | Const _ => ()
	     | EnterLeave (e, _) => loopExp e
	     | Handle {handler, try, ...} => (loopExp handler; loopExp try)
	     | Lambda l => loopLambda l
	     | Let (ds, e) => (Vector.foreach (ds, loopDec); loopExp e)
	     | List es => Vector.foreach (es, loopExp)
	     | PrimApp {args, ...} => Vector.foreach (args, loopExp)
	     | Raise {exn, ...} => loopExp exn
	     | Record r => Record.foreach (r, loopExp)
	     | Seq es => Vector.foreach (es, loopExp)
	     | Var _ => ()
	 end
      and loopLambda (l: Clambda.t): unit =
	 loopExp (#body (Clambda.dest l))
      fun loopPat (p: Cpat.t): NestedPat.t =
	 let
	    val (p, t) = Cpat.dest p
	    val t' = loopTy t
	    datatype z = datatype Cpat.node
	    val p = 
	       case p of
		  Con {arg, con, targs} =>
		     NestedPat.Con {arg = Option.map (arg, loopPat),
				    con = con,
				    targs = Vector.map (targs, loopTy)}
		| Const f => NestedPat.Const (f ())
		| Layered (x, p) => NestedPat.Layered (x, loopPat p)
		| List ps =>
		     let
			val targs = Vector.map (#2 (valOf (Ctype.deConOpt t)),
						loopTy)
		     in
			Vector.foldr
			(ps,
			 NestedPat.Con {arg = NONE,
					con = Con.nill,
					targs = targs},
			 fn (p, np) =>
			 NestedPat.Con {arg = SOME (NestedPat.tuple
						    (Vector.new2
						     (loopPat p,
						      NestedPat.make (np, t')))),
					con = Con.cons,
					targs = targs})
		     end
		| Record r =>
		     NestedPat.Tuple
		     (Vector.map
		      (Ctype.deRecord t, fn (f, t: Ctype.t) =>
		       case Record.peek (r, f) of
			  NONE => NestedPat.make (NestedPat.Wild, loopTy t)
			| SOME p => loopPat p))
		| Tuple ps => NestedPat.Tuple (Vector.map (ps, loopPat))
		| Var x => NestedPat.Var x
		| Wild => NestedPat.Wild
	 in
	    NestedPat.make (p, t')
	 end
      val _ = Vector.foreach (decs, loopDec)
      (* Now, do the actual defunctorization. *)
      fun loopDec (d: Cdec.t, e: Xexp.t, et: Xtype.t): Xexp.t =
	 let
	    fun prefix (d: Xdec.t) =
	       Xexp.lett {decs = [d], body = e}
	    fun processLambdas v =
	       Vector.map
	       (v, fn {lambda, var} =>
		let
		   val {arg, argType, body, bodyType} = loopLambda lambda
		in
		   {lambda = Xlambda.make {arg = arg,
					   argType = argType,
					   body = Xexp.toExp body},
		    ty = Xtype.arrow (argType, bodyType),
		    var = var}
		end)
(* Use open Cdec instead of the following due to an SML/NJ 110.43 bug *)
(*	    datatype z = datatype Cdec.t *)
	    open Cdec
	 in
	    case d of
	       Datatype _ => e
	     | Exception {arg, con} =>
		  prefix (Xdec.Exception {arg = Option.map (arg, loopTy),
					  con = con})
	     | Fun {decs, tyvars} =>
		  prefix (Xdec.Fun {decs = processLambdas decs,
				    tyvars = tyvars ()})
	     | Val {rvbs, tyvars, vbs} =>
	       let
		  val tyvars = tyvars ()
		  val bodyType = et
		  fun patDec (p: NestedPat.t,
			      e: Xexp.t,
			      r: Region.t,
			      body: Xexp.t,
			      bodyType: Xtype.t) =
		     casee {caseType = bodyType,
			    cases = Vector.new1 (p, body),
			    conTycon = conTycon,
			    noMatch = Cexp.RaiseBind,
			    region = r,
			    test = (e, NestedPat.ty p),
			    tyconCons = tyconCons}
		  val e =
		     Vector.foldr
		     (vbs, e, fn ({exp, pat, patRegion}, e) =>
		      let
			 val (exp, expType) = loopExp exp
			 val pat = loopPat pat
			 fun vd (x: Var.t) = valDec (tyvars, x, exp, expType, e)
		      in
			 if Vector.isEmpty tyvars
			    then patDec (pat, exp, patRegion, e, bodyType)
			 else
			    case NestedPat.node pat of
			       NestedPat.Wild => vd (Var.newNoname ())
			     | NestedPat.Var x => vd x
			     | _ =>
				  (* Polymorphic pattern.
				   *  val 'a Foo (y1, y2) = e
				   * Expands to
				   *  val 'a x = e
				   *  val Foo _ = x
				   *  val 'a y1 = case x of Foo (y1', _) => y1'
				   *  val 'a y2 = case x of Foo (_, y2') => y2'
				   *)
				  let
				     val x = Var.newNoname ()
				     val xt = expType
				     val targs = Vector.map (tyvars, Xtype.var)
				     val e =
					List.fold
					(NestedPat.varsAndTypes pat, e,
					 fn ((y, yt), e) =>
					 let
					    val y' = Var.new y
					    val pat =
					       NestedPat.removeOthersReplace
					       (pat, {old = y, new = y'})
					 in
					    valDec
					    (tyvars,
					     y,
					     patDec (pat,
						     Xexp.var {targs = targs,
							       ty = xt,
							       var = x},
						     patRegion,
						     Xexp.monoVar (y', yt),
						     yt),
					     yt,
					     e)
					 end)
				     fun instantiatePat () =
					let
					   val pat = NestedPat.removeVars pat
					   fun con (_, c, ts) = Xtype.con (c, ts)
					   fun var (t, a) =
					      if (Vector.exists
						  (tyvars, fn a' =>
						   Tyvar.equals (a, a')))
						 then Xtype.unit
					      else t
					   val {destroy, hom} =
					      Xtype.makeHom {con = con,
							     var = var}
					   val pat =
					      NestedPat.replaceTypes
					      (pat, hom)
					   val _ = destroy ()
					in
					   pat
					end
				     val e =
					if NestedPat.isRefutable pat
					   then
					       let
						  val targs =
						     Vector.map (tyvars, fn _ =>
								 Xtype.unit)
						  val pat = instantiatePat ()
					       in
						  patDec
						  (pat,
						   Xexp.var
						   {targs = targs,
						    ty = NestedPat.ty pat,
						    var = x},
						   patRegion,
						   e,
						   bodyType)
					       end
					else e
				  in
				     valDec (tyvars, x, exp, expType, e)
				  end
		      end)
	       in
		  if 0 = Vector.length rvbs
		     then e
		  else
		     Xexp.lett {decs = [Xdec.Fun {decs = processLambdas rvbs,
						  tyvars = tyvars}],
				body = e}
	       end
	 end
      and loopDecs (ds: Cdec.t vector, (e: Xexp.t, t: Xtype.t)): Xexp.t =
         Vector.foldr (ds, e, fn (d, e) => loopDec (d, e, t))
      and loopExp (e: Cexp.t): Xexp.t * Xtype.t =
	 let
	    val (n, ty) = Cexp.dest e
	    val ty = loopTy ty
	    fun conApp {arg, con, targs, ty} =
	       if Con.equals (con, Con.reff)
		  then Xexp.primApp {args = Vector.new1 arg,
				     prim = Prim.reff,
				     targs = targs,
				     ty = ty}
	       else Xexp.conApp {arg = SOME arg,
				 con = con,
				 targs = targs,
				 ty = ty}
	    datatype z = datatype Cexp.node
	    val exp =
	       case n of
		  App (e1, e2) =>
		     let
			val (e2, _) = loopExp e2
		     in
			case Cexp.node e1 of
			   Con (con, targs) =>
			      conApp {arg = e2,
				      con = con,
				      targs = Vector.map (targs, loopTy),
				      ty = ty}
			 | _ => 
			      Xexp.app {arg = e2,
					func = #1 (loopExp e1),
					ty = ty}
		     end
		| Case {noMatch, region, rules, test} =>
		     casee {caseType = ty,
			    cases = Vector.map (rules, fn (pat, exp) =>
						(loopPat pat,
						 #1 (loopExp exp))),
			    conTycon = conTycon,
			    noMatch = noMatch,
			    region = region,
			    test = loopExp test,
			    tyconCons = tyconCons}
		| Con (con, targs) =>
		     let
			val targs = Vector.map (targs, loopTy)
		     in
			case Xtype.deArrowOpt ty of
			   NONE =>
			      Xexp.conApp {arg = NONE,
					   con = con,
					   targs = targs,
					   ty = ty}
			 | SOME (argType, bodyType) =>
			      let
				 val arg = Var.newNoname ()
			      in
				 Xexp.lambda
				 {arg = arg,
				  argType = argType,
				  body = (conApp
					  {arg = Xexp.monoVar (arg, argType),
					   con = con,
					   targs = targs,
					   ty = bodyType}),
				  bodyType = bodyType}
			      end
		     end
		| Const f =>
		     let
			val c = f ()
		     in
			if Xtype.equals (ty, Xtype.bool)
			   then
			      (case c of
				  Const.Int i =>
				     if 0 = IntX.toInt i
					then Xexp.falsee ()
				     else Xexp.truee ()
				| _ => Error.bug "strange boolean constant")
			else Xexp.const c
		     end
		| EnterLeave (e, si) =>
		     let
			val (e, t) = loopExp e
		     in
			Xexp.fromExp (Xml.Exp.enterLeave (Xexp.toExp e, t, si),
				      t)
		     end
		| Handle {catch = (x, t), handler, try} =>
		     Xexp.handlee {catch = (x, loopTy t),
				   handler = #1 (loopExp handler),
				   try = #1 (loopExp try),
				   ty = ty}
		| Lambda l => Xexp.lambda (loopLambda l)
		| Let (ds, e) => loopDecs (ds, loopExp e)
		| List es =>
		     let
			val targs = #2 (valOf (Xtype.deConOpt ty))
			val eltTy = Vector.sub (targs, 0)
		     in
			Vector.foldr
			(es,
			 Xexp.conApp {arg = NONE,
				      con = Con.nill,
				      targs = targs,
				      ty = ty},
			 fn (e, l) =>
			 Xexp.conApp
			 {arg = (SOME
				 (Xexp.tuple
				  {exps = Vector.new2 (#1 (loopExp e), l),
				   ty = Xtype.tuple (Vector.new2 (eltTy, ty))})),
			  con = Con.cons,
			  targs = targs,
			  ty = ty})
		     end
		| PrimApp {args, prim, targs} =>
		     let
			val args = Vector.map (args, #1 o loopExp)
			val targs = Vector.map (targs, loopTy)
			fun app prim =
			   Xexp.primApp {args = args,
					 prim = prim,
					 targs = targs,
					 ty = ty}
			fun id () = Vector.sub (args, 0)
			datatype z = datatype Prim.Name.t
			datatype z = datatype WordSize.t
		     in
			case Prim.name prim of
			   C_CS_charArrayToWord8Array => id ()
			 | Char_chr =>
			      app (Prim.intToWord (IntSize.default, W8))
			 | Char_ge => app (Prim.wordGe W8)
			 | Char_gt => app (Prim.wordGt W8)
			 | Char_le => app (Prim.wordLe W8)
			 | Char_lt => app (Prim.wordLt W8)
			 | Char_ord =>
			      app (Prim.wordToInt (W8, IntSize.default))
			 | Char_toWord8 => id ()
			 | String_toWord8Vector => id ()
			 | Word8_toChar => id ()
			 | Word8Vector_toString => id ()
			 | _ => app prim
		     end
		| Raise {exn, region} =>
		     Xexp.raisee ({exn = #1 (loopExp exn),
				   filePos = Region.toFilePos region},
				  ty)
		| Record r =>
		     (* The components of the record have to be evaluated left to 
		      * right as they appeared in the source program, but then
		      * ordered according to sorted field name within the tuple.
		      *)
		     let
			val fes = Record.toVector r
		     in
			Xexp.seq
			(Vector.map (fes, #1 o loopExp o #2), fn es =>
			 Xexp.tuple {exps = (sortByField
					     (Vector.map2
					      (fes, es, fn ((f, _), e) => (f, e)))),
				     ty = ty})
		     end
		| Seq es => Xexp.sequence (Vector.map (es, #1 o loopExp))
		| Var (var, targs) =>
		     Xexp.var {targs = Vector.map (targs (), loopTy),
			       ty = ty,
			       var = var ()}
	 in
	    (exp, ty)
	 end
      and loopLambda (l: Clambda.t) =
	 let
	    val {arg, argType, body} = Clambda.dest l
	    val (body, bodyType) = loopExp body
	 in
	    {arg = arg,
	     argType = loopTy argType,
	     body = body,
	     bodyType = bodyType}
	 end
      val body = loopDecs (decs, (Xexp.unit (), Xtype.unit))
   in
      Xml.Program.T {body = Xexp.toExp body,
		     datatypes = Vector.fromList (!datatypes),
		     overflow = NONE}
   end

end



1.1                  mlton/mlton/defunctorize/defunctorize.sig

Index: defunctorize.sig
===================================================================
signature DEFUNCTORIZE_STRUCTS = 
   sig
      structure CoreML: CORE_ML
      structure Xml: XML
      sharing CoreML.Atoms = Xml.Atoms
   end

signature DEFUNCTORIZE = 
   sig
      include DEFUNCTORIZE_STRUCTS

      val defunctorize: CoreML.Program.t -> Xml.Program.t
   end



1.1                  mlton/mlton/defunctorize/sources.cm

Index: sources.cm
===================================================================
Group

functor Defunctorize

is

../../lib/mlton/sources.cm
../control/sources.cm
../core-ml/sources.cm
../match-compile/sources.cm
../xml/sources.cm

defunctorize.fun
defunctorize.sig



1.4       +3 -6      mlton/mlton/elaborate/decs.fun

Index: decs.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/decs.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- decs.fun	10 Apr 2002 07:02:20 -0000	1.3
+++ decs.fun	9 Oct 2003 18:17:33 -0000	1.4
@@ -10,6 +10,8 @@
 
 open S
 
+structure Dec = CoreML.Dec
+
 type dec = CoreML.Dec.t
 
 open AppendList
@@ -20,16 +22,11 @@
 
 val fromDec = single
 
-fun toAsts ds =
-   Vector.map (toVector ds, CoreML.Dec.toAst)
-
-fun toAst ds = Ast.Dec.makeRegion (Ast.Dec.SeqDec (toAsts ds), Region.bogus)
-
 fun layout ds =
    let
       open Layout
    in
-      align (Vector.toListMap (toAsts ds, Ast.Dec.layout))
+      align (Vector.toListMap (toVector ds, Dec.layout))
    end
 
 end



1.3       +0 -3      mlton/mlton/elaborate/decs.sig

Index: decs.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/decs.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- decs.sig	10 Apr 2002 07:02:20 -0000	1.2
+++ decs.sig	9 Oct 2003 18:17:33 -0000	1.3
@@ -7,9 +7,7 @@
  *)
 signature DECS_STRUCTS =
    sig
-      structure Ast: AST
       structure CoreML: CORE_ML
-      sharing Ast = CoreML.Ast
    end
 
 signature DECS =
@@ -31,7 +29,6 @@
       val layout: t -> Layout.t
       val map: t * (dec -> dec) -> t
       val single: dec -> t
-      val toAst: t -> Ast.Dec.t
       val toList: t -> dec list
       val toVector: t -> dec vector
    end



1.28      +1474 -667 mlton/mlton/elaborate/elaborate-core.fun

Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- elaborate-core.fun	27 Aug 2003 21:13:33 -0000	1.27
+++ elaborate-core.fun	9 Oct 2003 18:17:33 -0000	1.28
@@ -10,13 +10,8 @@
 
 open S
 
-local open Env
-in
-   structure TypeStr = TypeStr
-   structure Vid = Vid
-end
-
-local open Ast
+local
+   open Ast
 in 
    structure Aconst = Const
    structure Adec = Dec
@@ -39,24 +34,47 @@
    structure TypBind = TypBind
 end
 
-local open CoreML
+local
+   open Env
+in
+   structure TypeEnv = TypeEnv
+   structure TypeStr = TypeStr
+   structure Vid = Vid
+end
+
+structure Kind = TypeStr.Kind
+
+local
+   open TypeEnv
+in
+   structure Scheme = InferScheme
+   structure Type = Type
+end
+
+local
+   open CoreML
 in
    structure CFunction = CFunction
    structure Convention	 = CFunction.Convention	
    structure CType = CType
    structure Con = Con
+   structure Const = Const
    structure Cdec = Dec
    structure Cexp = Exp
-   structure Cmatch = Match
-   structure Cpat = Pat
-   structure Cprim = Prim
-   structure Cvar = Var
    structure Ffi = Ffi
-   structure Scheme = Scheme
+   structure IntSize = IntSize
+   structure IntX = IntX
+   structure Lambda = Lambda
+   structure Cpat = Pat
+   structure Prim = Prim
+   structure RealSize = RealSize
+   structure RealX = RealX
    structure SourceInfo = SourceInfo
    structure Tycon = Tycon
-   structure Type = Type
    structure Tyvar = Tyvar
+   structure Var = Var
+   structure WordSize = WordSize
+   structure WordX = WordX
 end
 
 local
@@ -70,6 +88,20 @@
 
 structure Scope = Scope (structure Ast = Ast)
 
+structure Aconst =
+   struct
+      open Aconst
+
+      fun ty (c: t): Type.t =
+	 case node c of
+	    Bool _ => Type.bool
+	  | Char _ => Type.char
+	  | Int _ => Type.unresolvedInt ()
+	  | Real _ => Type.unresolvedReal ()
+	  | String _ => Type.string
+	  | Word _ => Type.unresolvedWord ()
+   end
+
 structure Apat =
    struct
       open Apat
@@ -101,8 +133,8 @@
       fun plusEnv (lookup: t, E: Env.t): t =
 	 fn longtycon =>
 	 case Env.peekLongtycon (E, longtycon) of
-	    SOME typeFcn => typeFcn
-	  | NONE => lookup longtycon
+	    NONE => lookup longtycon
+	  | SOME typeFcn => typeFcn
 
       fun plusTycons (f: t, v) =
 	 if Vector.isEmpty v
@@ -117,139 +149,277 @@
 		      | _ => f t)
    end
 
-(*
- * Replaces all tyvars that have the same name with a single tyvar.
- *)
-fun elaborateType (ty: Atype.t, lookup: Lookup.t): Scheme.t =
+fun newType () = Type.new {canGeneralize = true,
+			   equality = false}
+
+fun elaborateType (ty: Atype.t, lookup: Lookup.t): Type.t =
    let 
-      fun loop (ty: Atype.t, accum: Tyvar.t list): Type.t * Tyvar.t list =
+      fun loop (ty: Atype.t): Type.t =
 	 case Atype.node ty of
 	    Atype.Var a => (* rule 44 *)
-	       let
-		  fun loop tyvars =
-		     case tyvars of
-			[] => (* new type variable, add it to the accum *)
-			   (Type.var a, a :: accum)
-		      | a' :: tyvars =>
-			   if Tyvar.sameName (a, a')
-			      then (Type.var a', accum)
-			   else loop tyvars
-	       in loop accum
-	       end
+	       Type.var a
 	  | Atype.Con (c, ts) => (* rules 46, 47 *)
 	       let
-		  val (ts, accum) = loops (ts, accum)
-		  fun normal () = TypeStr.apply (lookup c, ts)
-	       in (case (Ast.Longtycon.split c, Vector.length ts) of
-		      (([], c), 2) =>
-			 if Ast.Tycon.equals (c, Ast.Tycon.arrow)
-			    then Type.arrow (Vector.sub (ts, 0),
-					     Vector.sub (ts, 1))
-			 else normal ()
-		    | _ => normal (),
-		   accum)
-	       end
-	  | Atype.Record r => (* rules 45, 49 *)
-	       let
-		  val (fs, ts) = SortedRecord.unzip r
-		  val (ts, accum) = loops (ts, accum)
+		  val ts = Vector.map (ts, loop)
+		  fun normal () =
+		     let
+			val s = lookup c
+			val kind = TypeStr.kind s
+			val numArgs = Vector.length ts
+		     in
+			if (case kind of
+			       Kind.Arity n => n = numArgs
+			     | Kind.Nary => true)
+			   then TypeStr.apply (s, ts)
+			else
+			   let
+			      open Layout
+			      val _ = 
+				 Control.error
+				 (Atype.region ty,
+				  seq [str "type constructor ",
+				       Ast.Longtycon.layout c,
+				       str " given ",
+				       Int.layout numArgs,
+				       str " arguments but wants ",
+				       Kind.layout kind],
+				  empty)
+			   in
+			      newType ()
+			   end
+		     end
 	       in
-		  (Type.record (SortedRecord.zip (fs, ts)), accum)
+		  case (Ast.Longtycon.split c, Vector.length ts) of
+		     (([], c), 2) =>
+			if Ast.Tycon.equals (c, Ast.Tycon.arrow)
+			   then Type.arrow (Vector.sub (ts, 0),
+					    Vector.sub (ts, 1))
+			else normal ()
+		   | _ => normal ()
 	       end
-      and loops (ts, ac) = Vector.mapAndFold (ts, ac, loop)
-      val (ty, tyvars) = loop (ty, [])
-   in Scheme.T {tyvars = Vector.fromList tyvars, ty = ty}
+	  | Atype.Record r => (* rules 45, 49 *)
+	       Type.record (SortedRecord.map (r, loop))
+   in
+      loop ty
    end
 
-fun elaborateTypeOpt (ty, lookup) =
-   Option.map (ty, fn ty => Scheme.ty (elaborateType (ty, lookup)))
+fun elaborateTypeOpt (ty: Ast.Type.t option, lookup): Type.t option =
+   Option.map (ty, fn ty => elaborateType (ty, lookup))
 
-(* Returns a scheme, plus the type variables that occured in the ty but
- * not in the tyvars.
- *)
-fun elaborateScheme (tyvars, ty: Atype.t, lookup: Lookup.t)
-  : Scheme.t * Tyvar.t list =
-   let val Scheme.T {tyvars = tyvars', ty} = elaborateType (ty, lookup)
-      (* Replace each tyvar with the corresponding tyvar'.
-       * Keep track of any tyvars' that are left over.
-       *)
-      val (tyvars, tyvars') =
-	 Vector.foldr
-	 (tyvars, ([], Vector.toList tyvars'), fn (a, (tyvars, tyvars')) =>
-	  let
-	     fun loop (tyvars', remaining) =
-		case tyvars' of
-		   [] => (a, remaining)
-		 | a' :: tyvars' =>
-		      if Tyvar.sameName (a, a')
-			 then (a', remaining @ tyvars')
-		      else loop (tyvars', a' :: remaining)
-	     val (a, tyvars') = loop (tyvars', [])
-	  in (a :: tyvars, tyvars')
-	  end)
-   in (Scheme.T {tyvars = Vector.fromList tyvars, ty = ty}, tyvars')
-   end
+val overloads: (unit -> unit) list ref = ref []
+val freeTyvarChecks: (unit -> unit) list ref = ref []
 
-fun elaborateClosedScheme arg: Scheme.t =
+val typeTycon: Type.t -> Tycon.t option =
+   Type.hom {con = fn (c, _) => SOME c,
+	     var = fn _ => NONE}
+   
+fun resolveConst (c: Aconst.t, ty: Type.t): Const.t =
    let
-      val (scheme, tyvars) = elaborateScheme arg
-      val _ =
-	 case tyvars of
-	    [] => ()
-	  | tyvar :: _ =>
-	       Control.error
-	       (Tyvar.region tyvar,
-		let open Layout
-		in seq [str "unbound type variables: ",
-			seq (separate (List.map (tyvars, Tyvar.layout), " "))]
-		end,
-		Layout.empty)
+      fun error m =
+	 Control.error (Aconst.region c,
+			Layout.str (concat [m, ": ", Aconst.toString c]),
+			Layout.empty)
+      val tycon =
+	 case typeTycon ty of
+	    NONE =>
+	       Error.bug (concat ["constant ", Aconst.toString c,
+				  " of strange type ",
+				  Layout.toString (Type.layoutPretty ty)])
+	  | SOME c => c
+      fun choose (all, sizeTycon, name, make) =
+	 case List.peek (all, fn s => Tycon.equals (tycon, sizeTycon s)) of
+	    NONE => Error.bug (concat ["strange ", name, " type: ",
+				       Layout.toString (Type.layout ty)])
+	  | SOME s => make s
    in
-      scheme
+      case Aconst.node c of
+	 Aconst.Bool _ => Error.bug "resolveConst can't handle bools"
+       | Aconst.Char c =>
+	    Const.Word (WordX.make (LargeWord.fromChar c, WordSize.W8))
+       | Aconst.Int i =>
+	    if Tycon.equals (tycon, Tycon.intInf)
+	       then Const.IntInf i
+	    else
+	       choose (IntSize.all, Tycon.int, "int", fn s =>
+		       Const.Int
+		       (IntX.make (i, s)
+			handle Overflow =>
+			   (error (concat [Type.toString ty, " too big"])
+			    ; IntX.zero s)))
+       | Aconst.Real r =>
+	    choose (RealSize.all, Tycon.real, "real", fn s =>
+		    Const.Real (RealX.make (r, s)))
+       | Aconst.String s => Const.string s
+       | Aconst.Word w =>
+	    choose (WordSize.all, Tycon.word, "word", fn s =>
+		    Const.Word
+		    (if w <= LargeWord.toIntInf (WordSize.max s)
+			then WordX.fromLargeInt (w, s)
+		     else (error (concat [Type.toString ty, " too big"])
+			   ; WordX.zero s)))
    end
 
-fun elaborateTypBind (typBind, lookup: Lookup.t)
-   : (Ast.Tycon.t * TypeStr.t) list =
+local
+   open Layout
+in
+   val align = align
+   val empty = empty
+   val seq = seq
+   val str = str
+end
+
+fun unify (t1: Type.t, t2: Type.t,
+	   f: Layout.t * Layout.t -> Region.t * Layout.t * Layout.t): unit =
    let
-      val TypBind.T types = TypBind.node typBind
+      datatype z = datatype Type.unifyResult
    in
-      List.revMap
-      (types, fn {tyvars, tycon, def} =>
-       (tycon, TypeStr.def (elaborateClosedScheme (tyvars, def, lookup))))
+      case Type.unify (t1, t2) of
+	 NotUnifiable z => Control.error (f z)
+       | Unified => ()
    end
 
+fun unifyList (trs: (Type.t * Region.t) vector): Type.t =
+   if 0 = Vector.length trs
+      then Type.list (newType ())
+   else
+      let
+	 val (t, _) = Vector.sub (trs, 0)
+	 val _ =
+	    Vector.foreach
+	    (trs, fn (t', r) =>
+	     unify (t, t', fn (l, l') =>
+		    (r,
+		     str "list elements must be of same type",
+		     align [seq [str "element:  ", l'],
+			    seq [str "previous: ", l]])))
+      in
+	 Type.list t
+      end
+
 val info = Trace.info "elaboratePat"
 
-fun elaboratePat (p: Apat.t, E: Env.t): Cpat.t =
+structure Var =
+   struct
+      open Var
+
+      val fromAst = fromString o Avar.toString
+   end
+
+fun elaboratePat (p: Apat.t, E: Env.t, amInRvb: bool)
+   : Cpat.t * (Avar.t * Var.t * Type.t) vector =
    let
-      fun bind (x: Ast.Var.t): Cvar.t =
+      val xts: (Avar.t * Var.t * Type.t) list ref = ref []
+      fun bindToType (x: Ast.Var.t, t: Type.t): Var.t =
 	 let
-	    val x' = Cvar.fromAst x
-	    val _ = Env.extendVar (E, x, x')
-	 in x'
+	    val x' = Var.fromAst x
+	    val _ = List.push (xts, (x, x', t))
+	    val _ = Env.extendVar (E, x, x', Scheme.fromType t)
+	 in
+	    x'
+	 end
+      fun bind (x: Ast.Var.t): Var.t * Type.t =
+	 let
+	    val t = newType ()
+	 in
+	    (bindToType (x, t), t)
 	 end
       fun loop arg: Cpat.t =
 	 Trace.traceInfo' (info, Apat.layout, Cpat.layout)
 	 (fn p: Apat.t =>
 	  let
 	     val region = Apat.region p
-	     fun doit n = Cpat.makeRegion (n, region)
+	     fun error (e1, e2) =
+		Control.error (region, e1, e2)
+	     fun unifyPatternConstraint (p, c) =
+		unify
+		(p, c, fn (l1, l2) =>
+		 (region,
+		  str "pattern and constraint don't agree",
+		  align [seq [str "pattern:    ", l1],
+			 seq [str "constraint: ", l2]]))
 	  in
 	     case Apat.node p of
-		Apat.Wild => doit Cpat.Wild
-	      | Apat.Var {name = x, ...} =>
-		   (case Env.peekLongcon (E, Ast.Longvid.toLongcon x) of
-		       SOME c => doit (Cpat.Con {con = c, arg = NONE})
-		     | NONE =>
-			  (case Ast.Longvid.split x of
-			      ([], x) =>
-				 doit (Cpat.Var (bind (Ast.Vid.toVar x)))
-			    | _ => Error.bug (concat ["longid in var pat: ",
-						      Ast.Longvid.toString x])))
-	      | Apat.Const c => doit (Cpat.Const c)
-	      | Apat.Tuple ps =>
-		   loopsContV (ps, fn ps => Cpat.tuple (ps, region))
-	      | Apat.Record {items, flexible} =>
+		Apat.App (c, p) =>
+		   let
+		      val (con, s) = Env.lookupLongcon (E, c)
+		      val {args, instance} = Scheme.instantiate s
+		      val args = args ()
+		      val p = loop p
+		      val res =
+			 case Type.deArrowOpt instance of
+			    NONE =>
+			       let
+				  val _ =
+				     error
+				     (seq [str "constant constructor applied to argument in pattern: ",
+					   Ast.Longcon.layout c],
+				      empty)
+			       in
+				  newType ()
+			       end
+			  | SOME (u1, u2) =>
+			       let
+				  val _ =
+				     unify
+				     (Cpat.ty p, u1, fn (l, l') =>
+				      (region,
+				       str "constructor and argument don't agree in pattern",
+				       align
+				       [seq [str "constructor expects: ", l],
+					seq [str "but got:             ", l']]))
+			       in
+				  u2
+			       end
+		   in
+		      Cpat.make (Cpat.Con {arg = SOME p,
+					   con = con,
+					   targs = args},
+				 res)
+		   end
+	      | Apat.Const c =>
+		   (case Aconst.node c of
+		       Aconst.Bool b => if b then Cpat.truee else Cpat.falsee
+		     | _ => 
+			  let
+			     val ty = Aconst.ty c
+			     fun resolve () = resolveConst (c, ty)
+			     val _ = List.push (overloads, fn () =>
+						(resolve (); ()))
+			  in
+			     Cpat.make (Cpat.Const resolve, ty)
+			  end)
+	      | Apat.Constraint (p, t) =>
+		   let
+		      val p = loop p
+		      val _ =
+			 unifyPatternConstraint
+			 (Cpat.ty p, elaborateType (t, Lookup.fromEnv E))
+		   in
+		      p
+		   end
+	      | Apat.FlatApp items => loop (Parse.parsePat (items, E))
+	      | Apat.Layered {var = x, constraint, pat, ...} =>
+		   let
+		      val t =
+			 case constraint of
+			    NONE => newType ()
+			  | SOME t => elaborateType (t, Lookup.fromEnv E)
+		      val x = bindToType (x, t)
+		      val pat = loop pat
+		      val _ = unifyPatternConstraint (t, Cpat.ty pat)
+		   in
+		      Cpat.make (Cpat.Layered (x, pat), t)
+		   end
+	      | Apat.List ps =>
+		   let
+		      val ps' = Vector.map (ps, loop)
+		   in
+		      Cpat.make (Cpat.List ps',
+				 unifyList
+				 (Vector.map2 (ps, ps', fn (p, p') =>
+					       (Cpat.ty p', Apat.region p))))
+		   end
+	      | Apat.Record {flexible, items} =>
 		   (* rules 36, 38, 39 and Appendix A, p.57 *)
 		   let
 		      val (fs, ps) =
@@ -275,48 +445,85 @@
 					NONE => p
 				      | SOME ty => Apat.constraint (p, ty)
 				  end)))
+		      val ps = Vector.map (ps, loop)
+		      val r = SortedRecord.zip (fs, Vector.map (ps, Cpat.ty))
+		      val ty =
+			 if flexible
+			    then
+			       let
+				  val (t, isResolved) = Type.flexRecord r
+				  fun resolve () =
+				     if isResolved ()
+					then ()
+				     else
+					Control.error
+					(region,
+					 str "unresolved ... in flexible record pattern",
+					 Layout.empty)
+				  val _ = List.push (overloads, resolve)
+			       in
+				  t
+			       end
+			 else
+			    Type.record r
 		   in
-		      loopsContV
-		      (ps, fn ps =>		   
-		       Cpat.record
-		       {flexible = flexible,
-			record = Record.fromVector (Vector.zip (fs, ps)),
-			region = region})
+		      Cpat.make
+		      (Cpat.Record (Record.fromVector (Vector.zip (fs, ps))),
+		       ty)
 		   end
-	      | Apat.List ps => loopsCont (ps, fn ps => Cpat.list (ps, region))
-	      | Apat.FlatApp items => loop (Parse.parsePat (items, E))
-	      | Apat.App (c, p) =>
-		   doit (Cpat.Con {con = Env.lookupLongcon (E, c),
-				   arg = SOME (loop p)})
-	      | Apat.Constraint (p, t) =>
-		   doit (Cpat.Constraint
-			 (loop p,
-			  Scheme.ty (elaborateType (t, Lookup.fromEnv E))))
-	      | Apat.Layered {var = x, constraint, pat, ...} =>
-		   doit (Cpat.Layered
-			 (bind x,
-			  loop (case constraint of
-				   NONE => pat
-				 | SOME t => Apat.constraint (pat, t))))
+	      | Apat.Tuple ps =>
+		   let
+		      val ps = Vector.map (ps, loop)
+		   in
+		      Cpat.make (Cpat.Tuple ps,
+				 Type.tuple (Vector.map (ps, Cpat.ty)))
+		   end
+	      | Apat.Var {name, ...} =>
+		   let
+		      val (strids, x) = Ast.Longvid.split name
+		      fun var () =
+			 let
+			    val (x, t) = bind (Ast.Vid.toVar x)
+			 in
+			    Cpat.make (Cpat.Var x, t)
+			 end
+
+		   in
+		      if amInRvb andalso List.isEmpty strids
+			 then var ()
+		      else
+			 (case Env.peekLongcon (E, Ast.Longvid.toLongcon name) of
+			     NONE =>
+				if List.isEmpty strids
+				   then var ()
+				else
+				   let
+				      val _ = 
+					 Control.error
+					 (region,
+					  seq [str "longid in var pat: ",
+					       Ast.Longvid.layout name],
+					  empty)
+				   in
+				      Cpat.make (Cpat.Wild, newType ())
+				   end
+			   | SOME (c, s) =>
+				let
+				   val {args, instance} = Scheme.instantiate s
+				in
+				   Cpat.make
+				   (Cpat.Con {arg = NONE, con = c, targs = args ()},
+				    instance)
+				end)
+		   end
+	      | Apat.Wild =>
+		   Cpat.make (Cpat.Wild, newType ())
 	  end) arg
-      and loopsCont (ps: Apat.t list, cont: Cpat.t list -> Cpat.t): Cpat.t =
-	 cont (elaboratePats (ps, E))
-      and loopsContV (ps: Apat.t vector, cont: Cpat.t vector -> Cpat.t): Cpat.t =
-	 cont (elaboratePatsV (ps, E))
-   in loop p
+      val p = loop p
+   in
+      (p, Vector.fromList (!xts))
    end
 
-and elaboratePats (ps: Apat.t list, E): Cpat.t list =
-   List.map (ps, fn p => elaboratePat (p, E))
-
-and elaboratePatsV (ps: Apat.t vector, E): Cpat.t vector =
-   Vector.map (ps, fn p => elaboratePat (p, E))
-
-fun constrain (e, tyOpt, r) =
-   case tyOpt of
-      NONE => e
-    | SOME ty => Cexp.makeRegion (Cexp.Constraint (e, ty), r)
-  
 (*---------------------------------------------------*)
 (*                   Declarations                    *)
 (*---------------------------------------------------*)
@@ -334,55 +541,62 @@
 structure CType =
    struct
       open CoreML.CType
-	       
+
       fun sized (all: 'a list,
 		 toString: 'a -> string,
 		 prefix: string,
 		 make: 'a -> t,
-		 makeType: 'a -> Type.t) =
+		 makeType: 'a -> 'b) =
 	 List.map (all, fn a =>
 		   (make a, concat [prefix, toString a], makeType a))
-      val nullary =
-	 [(bool, "Bool", Type.bool),
-	  (char, "Char", Type.con (Tycon.char, Vector.new0 ())),
-	  (pointer, "Pointer", Type.pointer),
-	  (pointer, "Pointer", Type.preThread),
-	  (pointer, "Pointer", Type.thread)]
-	 @ sized (IntSize.all, IntSize.toString, "Int", Int, Type.int)
-	 @ sized (RealSize.all, RealSize.toString, "Real", Real, Type.real)
-	 @ sized (WordSize.all, WordSize.toString, "Word", Word, Type.word)
 
-      val unary = [Tycon.array, Tycon.reff, Tycon.vector]
+      val nullary: (t * string * Tycon.t) list =
+	 [(bool, "Bool", Tycon.bool),
+	  (char, "Char", Tycon.char),
+	  (pointer, "Pointer", Tycon.pointer),
+	  (pointer, "Pointer", Tycon.preThread),
+	  (pointer, "Pointer", Tycon.thread)]
+	 @ sized (IntSize.all, IntSize.toString, "Int", Int, Tycon.int)
+	 @ sized (RealSize.all, RealSize.toString, "Real", Real, Tycon.real)
+	 @ sized (WordSize.all, WordSize.toString, "Word", Word, Tycon.word)
+
+      val unary: Tycon.t list =
+	 [Tycon.array, Tycon.reff, Tycon.vector]
 
       fun fromType (t: Type.t): (t * string) option =
-	 case List.peek (nullary, fn (_, _, t') => Type.equals (t, t')) of
-	    NONE =>
-	       (case Type.deconOpt t of
-		   NONE => NONE
-		 | SOME (tycon, ts) =>
-		      if List.exists (unary, fn tycon' =>
-				      Tycon.equals (tycon, tycon'))
-			 andalso 1 = Vector.length ts
-			 andalso isSome (fromType (Vector.sub (ts, 0)))
-			 then SOME (Pointer, "Pointer")
-		      else NONE)
-	  | SOME (t, s, _) => SOME (t, s)
+	 case Type.deConOpt t of
+	    NONE => NONE
+	  | SOME (c, ts) =>
+	       case List.peek (nullary, fn (_, _, c') => Tycon.equals (c, c')) of
+		  NONE =>
+		     if List.exists (unary, fn c' => Tycon.equals (c, c'))
+			andalso 1 = Vector.length ts
+			andalso isSome (fromType (Vector.sub (ts, 0)))
+			then SOME (Pointer, "Pointer")
+		     else NONE
+		| SOME (t, s, _) => SOME (t, s)
+
+      val fromType =
+	 Trace.trace ("Ctype.fromType",
+		      Type.layoutPretty,
+		      Option.layout (Layout.tuple2 (layout, String.layout)))
+	 fromType
 
       fun parse (ty: Type.t)
 	 : ((t * string) vector * (t * string) option) option =
-	 case Type.dearrowOpt ty of
+	 case Type.deArrowOpt ty of
 	    NONE => NONE
 	  | SOME (t1, t2) =>
 	       let
 		  fun finish (ts: (t * string) vector) =
 		     case fromType t2 of
 			NONE =>
-			   if Type.equals (t2, Type.unit)
+			   if Type.isUnit t2
 			      then SOME (ts, NONE)
 			   else NONE
 		      | SOME t => SOME (ts, SOME t)
 	       in
-		  case Type.detupleOpt t1 of 
+		  case Type.deTupleOpt t1 of 
 		     NONE =>
 			(case fromType t1 of
 			    NONE => NONE
@@ -413,36 +627,34 @@
 fun import {attributes: Attribute.t list,
 	    name: string,
 	    ty: Type.t,
-	    region: Region.t}: Cprim.t =
+	    region: Region.t}: Prim.t =
    let
       fun error l = Control.error (region, l, Layout.empty)
       fun invalidAttributes () =
-	 error (let
-		   open Layout
-		in
-		   seq [str "invalid attributes for import: ",
-			List.layout Attribute.layout attributes]
-		end)
+	 error (seq [str "invalid attributes for import: ",
+		     List.layout Attribute.layout attributes])
    in
       case CType.parse ty of
 	 NONE =>
 	    (case CType.fromType ty of
 		NONE => 
-		   (error (let
-			      open Layout
-			   in
-			      seq [str "invalid type for import: ",
-				   Type.layout ty]
-			   end)
-		    ; Cprim.bogus)
+		   let
+		      val _ =
+			 Control.error
+			 (region,
+			  str "invalid type for import:",
+			  Type.layoutPretty ty)
+		   in
+		      Prim.bogus
+		   end
 	      | SOME (t, _) =>
 		   case attributes of
-		      [] => Cprim.ffiSymbol {name = name, ty = t}
+		      [] => Prim.ffiSymbol {name = name, ty = t}
 		    | _ => 
 			 let
 			    val _ = invalidAttributes ()
 			 in
-			    Cprim.bogus
+			    Prim.bogus
 			 end)
        | SOME (args, result) =>
 	    let
@@ -456,14 +668,14 @@
 			       bytesNeeded = NONE,
 			       convention = convention,
 			       ensuresBytesFree = false,
-			       modifiesFrontier = true (* callsFromC *),
-			       modifiesStackTop = true (* callsFromC *),
-			       mayGC = true (* callsFromC *),
+			       modifiesFrontier = true,
+			       modifiesStackTop = true,
+			       mayGC = true,
 			       maySwitchThreads = false,
 			       name = name,
 			       return = Option.map (result, #1)}
 	    in
-	       Cprim.ffi (func, Scheme.fromType ty)
+	       Prim.ffi func
 	    end
    end
 
@@ -471,12 +683,8 @@
    let
       fun error l = Control.error (region, l, Layout.empty)
       fun invalidAttributes () =
-	 error (let
-		   open Layout
-		in
-		   seq [str "invalid attributes for export: ",
-			List.layout Attribute.layout attributes]
-		end)
+	 error (seq [str "invalid attributes for export: ",
+		     List.layout Attribute.layout attributes])
       val convention =
 	 case parseAttributes attributes of
 	    NONE => (invalidAttributes ()
@@ -487,12 +695,8 @@
 	    NONE =>
 	       (Control.error
 		(region,
-		 let
-		    open Layout
-		 in
-		    seq [str "invalid type for exported function: ",
-			 Type.layout ty]
-		 end,
+		 seq [str "invalid type for exported function: ",
+		      Type.layout ty],
 		 Layout.empty)
 		; (0, Vector.new0 (), NONE))
 	  | SOME (us, t) =>
@@ -505,7 +709,6 @@
 		  (id, us, t)
 	       end
       open Ast
-      val filePos = "<export>"
       fun id name =
 	 Aexp.longvid (Longvid.short (Vid.fromString (name, region)))
       fun int (i: int): Aexp.t =
@@ -513,306 +716,538 @@
       val f = Var.fromString ("f", region)
    in
       Exp.fnn
-      (Match.T
-       {filePos = filePos,
-	rules =
-	Vector.new1
-	(Pat.var f,
-	 Exp.app
-	 (id "register",
-	  Exp.tuple
-	  (Vector.new2
-	   (int exportId,
-	    Exp.fnn
-	    (Match.T
-	     {filePos = filePos,
-	      rules =
-	      Vector.new1
-	      (Pat.tuple (Vector.new0 ()),
-	       let
-		  val map = CType.memo (fn _ => Counter.new 0)
-		  val varCounter = Counter.new 0
-		  val (args, decs) =
-		     Vector.unzip
-		     (Vector.map
-		      (args, fn (u, name) =>
-		       let
-			  val x =
-			     Var.fromString
-			     (concat ["x",
-				      Int.toString (Counter.next varCounter)],
-			      region)
-			  val dec =
-			     Dec.vall (Vector.new0 (),
-				       x,
-				       Exp.app (id (concat ["get", name]),
-						int (Counter.next (map u))))
-		       in
-			  (x, dec)
-		       end))
-		  val resVar = Var.fromString ("res", region)
-		  fun newVar () = Var.fromString ("none", region)
-	       in
-		  Exp.lett
-		  (Vector.concat
-		   [decs,
-		    Vector.map 
-		    (Vector.new4
-		     ((newVar (), Exp.app (id "atomicEnd", Exp.unit)),
-		      (resVar, Exp.app (Exp.var f,
-					Exp.tuple (Vector.map (args, Exp.var)))),
-		      (newVar (), Exp.app (id "atomicBegin", Exp.unit)),
-		      (newVar (),
-		       (case res of
-			   NONE => Exp.unit
-			 | SOME (t, name) => 
-			      Exp.app (id (concat ["set", name]),
-				       Exp.var resVar)))),
-		     fn (x, e) => Dec.vall (Vector.new0 (), x, e))],
-		   Exp.tuple (Vector.new0 ()))
-	       end)})))))})
+      (Vector.new1
+       (Pat.var f,
+	Exp.app
+	(id "register",
+	 Exp.tuple
+	 (Vector.new2
+	  (int exportId,
+	   Exp.fnn
+	   (Vector.new1
+	    (Pat.tuple (Vector.new0 ()),
+	     let
+		val map = CType.memo (fn _ => Counter.new 0)
+		val varCounter = Counter.new 0
+		val (args, decs) =
+		   Vector.unzip
+		   (Vector.map
+		    (args, fn (u, name) =>
+		     let
+			val x =
+			   Var.fromString
+			   (concat ["x",
+				    Int.toString (Counter.next varCounter)],
+			    region)
+			val dec =
+			   Dec.vall (Vector.new0 (),
+				     x,
+				     Exp.app (id (concat ["get", name]),
+					      int (Counter.next (map u))))
+		     in
+			(x, dec)
+		     end))
+		val resVar = Var.fromString ("res", region)
+		fun newVar () = Var.fromString ("none", region)
+	     in
+		Exp.lett
+		(Vector.concat
+		 [decs,
+		  Vector.map 
+		  (Vector.new4
+		   ((newVar (), Exp.app (id "atomicEnd", Exp.unit)),
+		    (resVar, Exp.app (Exp.var f,
+				      Exp.tuple (Vector.map (args, Exp.var)))),
+		    (newVar (), Exp.app (id "atomicBegin", Exp.unit)),
+		    (newVar (),
+		     (case res of
+			 NONE => Exp.unit
+		       | SOME (t, name) => 
+			    Exp.app (id (concat ["set", name]),
+				     Exp.var resVar)))),
+		   fn (x, e) => Dec.vall (Vector.new0 (), x, e))],
+		 Exp.tuple (Vector.new0 ()))
+	     end)))))))
    end
-   
-fun elaborateDec (d, nest, E) =
+
+structure Aexp =
+   struct
+      open Aexp
+
+      fun selector (f: Field.t, r: Region.t): t =
+	 let
+	    val x = Avar.fromString ("x", r)
+	 in
+	    fnn (Vector.new1
+		 (Apat.makeRegion
+		  (Apat.Record {flexible = true,
+				items = (Vector.new1
+					 (Apat.Item.Field (f, Apat.var x)))},
+		   r),
+		  var x))
+	 end
+   end
+
+structure Con =
+   struct
+      open Con
+
+      val fromAst = fromString o Ast.Con.toString
+   end
+
+fun elaborateDec (d, {env = E,
+		      lookupConstant: string * ConstType.t -> CoreML.Const.t,
+		      nest}) =
    let
-      fun elabType t = elaborateType (t, Lookup.fromEnv E)
+      val {get = recursiveTargs: Var.t -> (unit -> Type.t vector) option ref,
+	   ...} =
+	 Property.get (Var.plist, Property.initFun (fn _ => ref NONE))
+      fun recursiveFun () =
+	 let
+	    val boundRef: (unit -> Tyvar.t vector) option ref = ref NONE
+	    val targs =
+	       Promise.lazy
+	       (fn () =>
+		case !boundRef of
+		   NONE => Error.bug "boundRef not set"
+		 | SOME f => Vector.map (f (), Type.var))
+	    fun markFunc func = recursiveTargs func := SOME targs
+	    fun unmarkFunc func = recursiveTargs func := NONE
+	    fun setBound b = boundRef := SOME b
+	 in
+	    {markFunc = markFunc,
+	     setBound = setBound,
+	     unmarkFunc = unmarkFunc}
+	 end  
+      fun elabType (t: Atype.t): Type.t =
+	 elaborateType (t, Lookup.fromEnv E)
       fun elabTypeOpt t = elaborateTypeOpt (t, Lookup.fromEnv E)
-      fun elabDatBind datBind =
+      fun elabTypBind (typBind: TypBind.t) =
+	 let
+	    val lookup = Lookup.fromEnv E
+	    val TypBind.T types = TypBind.node typBind
+	    val strs =
+	       List.map
+	       (types, fn {def, tyvars, ...} =>
+		TypeStr.def (Scheme.make {canGeneralize = true,
+					  ty = elabType def,
+					  tyvars = tyvars},
+			     Kind.Arity (Vector.length tyvars)))
+	 in
+	    List.foreach2
+	    (types, strs, fn ({tycon, ...}, str) =>
+	     Env.extendTycon (E, tycon, str))
+	 end
+      fun elabDatBind (datBind: DatBind.t, nest: string list)
+	 : Decs.t * {tycon: Ast.Tycon.t,
+		     typeStr: TypeStr.t} vector =
 	 (* rules 28, 29, 81, 82 *)
 	 let
 	    val region = DatBind.region datBind
 	    val lookup = Lookup.fromEnv E
 	    val DatBind.T {datatypes, withtypes} = DatBind.node datBind
-	    (* Build enough of an env so that that the withtypes
-	     * and the constructor argument types can be evaluated.
+	    (* Build enough of an env so that that the withtypes and the
+	     * constructor argument types can be elaborated.
 	     *)
-	    val (tycons, datatypes) =
+	    val tycons =
+	       Vector.map
+	       (datatypes, fn {cons, tycon = name, tyvars} =>
+		let
+		   val tycon =
+		      Tycon.fromString
+		      (concat (List.separate
+			       (rev (Ast.Tycon.toString name :: nest),
+				".")))
+		   val _ =
+		      Env.extendTycon
+		      (E, name,
+		       TypeStr.tycon (tycon, Kind.Arity (Vector.length tyvars)))
+		in
+		   tycon
+		end)
+	    val _ = elabTypBind withtypes
+	    val (dbs, strs) =
 	       Vector.unzip
-	       (Vector.map
-		(datatypes, fn {tyvars, tycon = name, cons} =>
+	       (Vector.map2
+		(tycons, datatypes,
+		 fn (tycon, {cons, tycon = astTycon, tyvars, ...}) =>
 		 let
-		    val tycon = Tycon.fromAst name
-		 in
-		    ((name, TypeStr.tycon tycon),
-		     {name = name, tycon = tycon, tyvars = tyvars, cons = cons})
-		 end))
-	    val lookup = Lookup.plusTycons (lookup, tycons)
-	    (* Elaborate the withtypes. *)
-	    val tycons' = Vector.fromList (elaborateTypBind (withtypes, lookup))
-	    val lookup =
-	       Lookup.plusTycons (lookup, Vector.concat [tycons', tycons])
-	    (* Elaborate the datatypes, this time including the constructors. *)
-	    val (cons, tycons, datatypes) =
-	       Vector.unzip3
-	       (Vector.map
-		(datatypes, fn {name, tyvars, tycon, cons} =>
-		 let
-		    val resultType =
-		       Atype.con (name, Vector.map (tyvars, Atype.var))
+		    val resultType: Type.t =
+		       Type.con (tycon, Vector.map (tyvars, Type.var))
 		    val (cons, datatypeCons) =
 		       Vector.unzip
 		       (Vector.map
 			(cons, fn (name, arg) =>
 			 let
 			    val con = Con.fromAst name
-			 in ({name = name, con = con},
-			     {con = con,
-			      arg = Option.map (arg, fn t =>
-						Scheme.ty
-						(elaborateType (t, lookup)))})
+			    val (arg, ty) =
+			       case arg of
+				  NONE => (NONE, resultType)
+				| SOME t =>
+				     let
+					val t = elabType t
+				     in
+					(SOME t, Type.arrow (t, resultType))
+				     end
+			    val scheme =
+			       Scheme.make {canGeneralize = true,
+					    ty = ty,
+					    tyvars = tyvars}
+			    val _ = Env.extendCon (E, name, con, scheme)
+			 in
+			    ({con = con, name = name, scheme = scheme},
+			     {arg = arg, con = con})
 			 end))
-		 in (cons,
-		     (name, TypeStr.data (tycon, cons)),
-		     {tyvars = tyvars,
+		    val typeStr =
+		       TypeStr.data (tycon,
+				     Kind.Arity (Vector.length tyvars),
+				     cons)
+		    val _ = Env.extendTycon (E, astTycon, typeStr)
+		 in
+		    ({cons = datatypeCons,
 		      tycon = tycon,
-		      cons = datatypeCons})
+		      tyvars = tyvars},
+		     {tycon = astTycon,
+		      typeStr = typeStr})
 		 end))
-	 in {cons = Vector.concatV cons,
-	     tycons = Vector.concat [tycons, tycons'],
-	     decs = Decs.single (Cdec.makeRegion (Cdec.Datatype datatypes,
-						  region))}
+	 in
+	    (Decs.single (Cdec.Datatype dbs), strs)
 	 end
-      fun elabDec arg =
-	 Trace.traceInfo (info,
-			  Layout.tuple2 (Ast.Dec.layout, Nest.layout),
-			  Layout.ignore, Trace.assertTrue)
-	 (fn (d, nest) =>
+      fun elabDec arg : Decs.t =
+	 Trace.traceInfo
+	 (info,
+	  Layout.tuple3 (Ast.Dec.layout, Nest.layout, Bool.layout),
+	  Layout.ignore, Trace.assertTrue)
+	 (fn (d, nest, isTop) =>
 	  let
 	     val region = Adec.region d
-	     fun doit n = Cexp.makeRegion (n, region)
-	     val elabDec' = elabDec
-	     fun elabDec (d: Adec.t) = elabDec' (d, nest)
+	     fun checkSchemes (v: (Var.t * Scheme.t) vector): unit =
+		if isTop
+		   then
+		      List.push
+		      (freeTyvarChecks,
+		       fn () =>
+		       Vector.foreach2
+		       (v, Scheme.haveFrees (Vector.map (v, #2)),
+			fn ((x, s), b) =>
+			if b
+			   then
+			      let
+				 open Layout
+			      in
+				 Control.error
+				 (region,
+				  seq [str "unable to infer type for ",
+				       Var.layout x],
+				  seq [str "type: ", Scheme.layoutPretty s])
+			      end
+			else ()))
+		else ()
+	     val elabDec = fn (d, isTop) => elabDec (d, nest, isTop)
 	  in
 	     case Adec.node d of
 		Adec.Abstype {datBind, body} => (* rule 19 and p.57 *)
 		   let
-		      val {cons, decs, tycons} = elabDatBind datBind
-		      val (_, decs') =
+		      val ((decs, strs), decs') =
 			 Env.localCore
 			 (E,
-			  fn () =>
-			  (Vector.foreach (cons, fn {name, con} =>
-					   Env.extendCon (E, name, con))
-			   ; Vector.foreach (tycons, fn (t, s) =>
-					     Env.extendTycon (E, t, s))),
-			  fn () => elabDec body)
+			  fn () => elabDatBind (datBind, nest),
+			  fn z => (z, elabDec (body, isTop)))
 		      val _ =
-			 Vector.foreach (tycons, fn (t, s) =>
-					 Env.extendTycon (E, t, TypeStr.abs s))
+			 Vector.foreach
+			 (strs, fn {tycon, typeStr} =>
+			  Env.extendTycon (E, tycon, TypeStr.abs typeStr))
 		   in
 		      Decs.append (decs, decs')
 		   end
 	      | Adec.Datatype rhs =>
+		   (case DatatypeRhs.node rhs of
+		       DatatypeRhs.DatBind datBind => (* rule 17 *)
+			  #1 (elabDatBind (datBind, nest))
+		     | DatatypeRhs.Repl {lhs, rhs} => (* rule 18 *)
+			  let
+			     val tyStr = Env.lookupLongtycon (E, rhs)
+			     val _ = Env.extendTycon (E, lhs, tyStr)
+			     val _ =
+				Vector.foreach
+				(TypeStr.cons tyStr, fn {con, name, scheme} =>
+				 Env.extendCon (E, name, con, scheme))
+			  in
+			     Decs.empty
+			  end)
+	      | Adec.Exception ebs =>
 		   let
-		      val {cons, decs, tycons} =
-			 case DatatypeRhs.node rhs of
-			    DatatypeRhs.DatBind datBind => (* rule 17 *)
-			       elabDatBind datBind
-			  | DatatypeRhs.Repl {lhs, rhs} => (* rule 18 *)
-			       let
-				  val tyStr = Env.lookupLongtycon (E, rhs)
-			       in
-				  {cons = TypeStr.cons tyStr,
-				   decs = Decs.empty,
-				   tycons = Vector.new1 (lhs, tyStr)}
-			       end
-		      val _ = Vector.foreach (cons, fn {name, con} =>
-					      Env.extendCon (E, name, con))
-		      val _ = Vector.foreach (tycons, fn (t, s) =>
-					      Env.extendTycon (E, t, s))
+		      val decs =
+			 Vector.fold
+			 (ebs, Decs.empty, fn ((exn, rhs), decs) =>
+			  let
+			     val (decs, exn', scheme) =
+				case EbRhs.node rhs of
+				   EbRhs.Def c =>
+				      let
+					 val (c, s) = Env.lookupLongcon (E, c)
+				      in
+					 (decs, c, s)
+				      end
+				 | EbRhs.Gen arg =>
+				      let
+					 val exn' = Con.fromAst exn
+					 val (arg, ty) =
+					    case arg of
+					       NONE => (NONE, Type.exn)
+					     | SOME t =>
+						  let
+						     val t = elabType t
+						  in
+						     (SOME t,
+						      Type.arrow (t, Type.exn))
+						  end
+					 val scheme = Scheme.fromType ty
+				      in
+					 (Decs.add (decs,
+						    Cdec.Exception {arg = arg,
+								    con = exn'}),
+					  exn',
+					  scheme)
+				      end
+			     val _ = Env.extendExn (E, exn, exn', scheme)
+			  in
+			     decs
+			  end)
 		   in
 		      decs
 		   end
-	      | Adec.Exception ebs =>
-		   Vector.fold
-		   (ebs, Decs.empty, fn ((exn, rhs), decs) =>
-		    let
-		       val (decs, exn') =
-			  case EbRhs.node rhs of
-			     EbRhs.Def c => (decs, Env.lookupLongcon (E, c))
-			   | EbRhs.Gen to =>
-				let val exn' = Con.fromAst exn
-				in (Decs.add
-				    (decs,
-				     Cdec.makeRegion
-				     (Cdec.Exception {con = exn',
-						      arg = elabTypeOpt to},
-				      EbRhs.region rhs)),
-				    exn')
-				end
-		       val _ = Env.extendExn (E, exn, exn')
-		    in decs
-		    end)
 	      | Adec.Fix {ops, fixity} =>
 		   (Vector.foreach (ops, fn op' =>
 				    Env.extendFix (E, op', fixity))
 		    ; Decs.empty)
 	      | Adec.Fun (tyvars, fbs) =>
 		   let
-		      val clausess =
+		      val fbs =
 			 Vector.map
-			 (fbs, fn {clauses, filePos} =>
-			  {filePos = filePos,
-			   clauses = 
-			   Vector.map
-			   (clauses, fn {pats, resultType, body} =>
-			    let
-			       val {func, args} = Parse.parseClause (pats, E)
-			    in
-			       {func = func,
-				args = args,
-				resultType = resultType,
-				body = body}
-			    end)})
-		      val funcs =
-			 Vector.map (clausess, fn {clauses, ...} =>
-				     if Vector.isEmpty clauses
-					then Error.bug "no clauses in fundec"
-				     else #func (Vector.sub (clauses, 0)))
-		      val newFuncs = Vector.map (funcs, Cvar.fromAst)
-		      val _ =
-			 Vector.foreach2 (funcs, newFuncs, fn (name, var) =>
-					  Env.extendVar (E, name, var))
-		      val decs =
-			 Vector.map2
-			 (clausess, newFuncs, fn ({clauses, filePos}, newFunc) =>
+			 (fbs, fn clauses =>
+			  Vector.map
+			  (clauses, fn {body, pats, resultType} =>
+			   let
+			      val {args, func} = Parse.parseClause (pats, E)
+			   in
+			      {args = args,
+			       body = body,
+			       func = func,
+			       resultType = resultType}
+			   end))
+		      val close = TypeEnv.close (tyvars, region)
+		      val {markFunc, setBound, unmarkFunc} = recursiveFun ()
+		      val fbs =
+			 Vector.map
+			 (fbs, fn clauses =>
 			  if Vector.isEmpty clauses
-			     then Error.bug "empty clauses in fundec"
+			     then Error.bug "no clauses in fundec"
 			  else
 			     let
-				val {func, args, ...} = Vector.sub (clauses, 0)
-				val nest = Avar.toString func :: nest
-				val profile =
-				   SourceInfo.function
-				   {name = nest,
-				    region = Avar.region func}
-				val numVars = Vector.length args
-				val match =
-				   let
-				      val rs =
-					 Vector.map
-					 (clauses,
-					  fn {args, resultType, body, ...} =>
-					  let
-					     val (pats, body) =
-						Env.scope
-						(E, fn () =>
-						 (elaboratePatsV (args, E),
-						  elabExp' (body, nest)))
-					  in (Cpat.tuple (pats, region),
-					      constrain (body,
-							 elabTypeOpt resultType,
-							 region))
-					  end)
-				      fun make (i, xs) =
-					 if i = 0
-					    then
-					       Cexp.casee
-					       (Cexp.tuple
-						(Vector.rev
-						 (Vector.fromListMap
-						  (xs, fn x =>
-						   doit (Cexp.Var x))),
-						 region),
-						Cmatch.new {filePos = filePos,
-							    rules = rs},
-						region)
-					 else 
-					    let
-					       val x = Cvar.newNoname ()
-					    in
-					       Cexp.lambda
-					       (x,
-						make (i - 1, x :: xs),
-						if i = 1
-						   then SOME profile
-						else NONE,
-						region)
-					    end
-				   in if numVars = 1
-					 then Cmatch.new {filePos = filePos,
-							  rules = rs}
-				      else (case Cexp.node (make (numVars, [])) of
-					       Cexp.Fn {match = m, ...} => m
-					     | _ => Error.bug "elabFbs")
-				   end
+				val {args, func, ...} = Vector.sub (clauses, 0)
+				val numArgs = Vector.length args
+				val _ =
+				   Vector.foreach
+				   (clauses, fn {args, ...} =>
+				    if numArgs = Vector.length args
+				       then ()
+				    else
+				       Control.error
+				       (region,
+					seq [str "clauses don't all have the same number of patterns"],
+					empty))
+				val _ =
+				   Vector.foreach
+				   (clauses, fn {func = func', ...} =>
+				    if Ast.Var.equals (func, func')
+				       then ()
+				    else
+				       Control.error
+				       (region,
+					seq [str "clauses don't all have same function name"],
+					seq [Avar.layout func,
+					     str ", ", Avar.layout func']))
+				val var = Var.fromAst func
+				val ty = newType ()
+				val _ = Env.extendVar (E, func, var,
+						       Scheme.fromType ty)
+				val _ = markFunc var
 			     in
-				{match = match,
-				 profile = if numVars = 1
-					      then SOME profile
-					   else NONE,
-				 types = Vector.new0 (),
-				 var = newFunc}
+				{clauses = clauses,
+				 func = func,
+				 ty = ty,
+				 var = var}
 			     end)
+		      val decs =
+			 Vector.map
+			 (fbs, fn {clauses,
+				   func: Avar.t,
+				   ty: Type.t,
+				   var: Var.t} =>
+			  let
+			     val nest = Avar.toString func :: nest
+			     val sourceInfo =
+				SourceInfo.function {name = nest,
+						     region = Avar.region func}
+			     val rs =
+				Vector.map
+				(clauses, fn {args: Apat.t vector,
+					      body: Aexp.t,
+					      resultType: Atype.t option, ...} =>
+				 Env.scope
+				 (E, fn () =>
+				  let
+				     val pats =
+					Vector.map
+					(args, fn p =>
+					 {pat = #1 (elaboratePat (p, E, false)),
+					  region = Apat.region p})
+				     val bodyRegion = Aexp.region body
+				     val body = elabExp (body, nest)
+				     val _ =
+					Option.app
+					(resultType, fn t =>
+					 unify
+					 (elabType t, Cexp.ty body,
+					  fn (l1, l2) =>
+					  (Atype.region t,
+					   str "function result type does not agree with expression",
+					   align
+					   [seq [str "result type:", l1],
+					    seq [str "expression: ", l2]])))
+				  in
+				     {body = body,
+				      bodyRegion = bodyRegion,
+				      pats = pats}
+				  end))
+			     val numArgs =
+				Vector.length (#pats (Vector.sub (rs, 0)))
+			     val argTypes =
+				Vector.tabulate
+				(numArgs, fn i =>
+				 let
+				    val t =
+				       Cpat.ty
+				       (#pat (Vector.sub
+					      (#pats (Vector.sub (rs, 0)),
+					       i)))
+				    val _ =
+				       Vector.foreach
+				       (rs, fn {pats, ...} =>
+					let
+					   val {pat, region} =
+					      Vector.sub (pats, i)
+					in
+					   unify
+					   (t, Cpat.ty pat, fn (l1, l2) =>
+					    (region,
+					     str "function argument patterns must be of same type",
+					     align [seq [str "pattern:  ", l2],
+						    seq [str "previous: ", l1]]))
+					end)
+				 in
+				    t
+				 end)
+			     val bodyType =
+				let
+				   val t = Cexp.ty (#body (Vector.sub (rs, 0)))
+				   val _ =
+				      Vector.foreach
+				      (rs, fn {body, bodyRegion, ...} =>
+				       unify
+				       (t, Cexp.ty body, fn (l1, l2) =>
+					(bodyRegion,
+					 str "function results must be of same type",
+					 align [seq [str "result:   ", l2],
+						seq [str "previous: ", l1]])))
+				in
+				   t
+				end
+			     val xs =
+				Vector.tabulate (numArgs, fn _ =>
+						 Var.newNoname ())
+			     fun make (i: int): Cexp.t =
+				if i = Vector.length xs
+				   then
+				      let
+					 val e =
+					    Cexp.casee
+					    {noMatch = Cexp.RaiseMatch,
+					     region = Region.bogus,
+					     rules =
+					     Vector.map
+					     (rs, fn {body, pats, ...} =>
+					      let
+						 val pats =
+						    Vector.map (pats, #pat)
+					      in
+						 (Cpat.make
+						  (Cpat.Tuple pats,
+						   Type.tuple
+						   (Vector.map (pats, Cpat.ty))),
+						  body)
+					      end),
+					     test = 
+					     Cexp.tuple
+					     (Vector.map2
+					      (xs, argTypes, Cexp.var))}
+				      in
+					 Cexp.enterLeave (e, sourceInfo)
+				      end
+				else
+				   let
+				      val body = make (i + 1)
+				      val argType = Vector.sub (argTypes, i)
+				   in
+				      Cexp.make
+				      (Cexp.Lambda
+				       (Lambda.make
+					{arg = Vector.sub (xs, i),
+					 argType = argType,
+					 body = body}),
+				       Type.arrow (argType, Cexp.ty body))
+				   end
+			     val lambda = make 0
+			     val _ =
+				unify
+				(Cexp.ty lambda, ty, fn (l1, l2) =>
+				 (Avar.region func,
+				  str "function type does not match recursive uses",
+				  align [seq [str "function type:  ", l1],
+					 seq [str "recursive uses: ", l2]]))
+			     val lambda =
+				case Cexp.node lambda of
+				   Cexp.Lambda l => l
+				 | _ => Error.bug "not a lambda"
+			  in
+			     {lambda = lambda,
+			      ty = ty,
+			      var = var}
+			  end)
+		      val {bound, schemes} = close (Vector.map (decs, #ty))
+		      val _ = checkSchemes (Vector.zip
+					    (Vector.map (decs, #var),
+					     schemes))
+		      val _ = setBound bound
+		      val _ =
+			 Vector.foreach3
+			 (fbs, decs, schemes,
+			  fn ({func, ...}, {var, ...}, scheme) =>
+			  (Env.extendVar (E, func, var, scheme)
+			   ; unmarkFunc var))
+		      val decs =
+			 Vector.map (decs, fn {lambda, var, ...} =>
+				     {lambda = lambda, var = var})
 		   in
-		      Decs.single (Cdec.makeRegion (Cdec.Fun {tyvars = tyvars,
-							      decs = decs},
-						    region))
+		      Decs.single (Cdec.Fun {decs = decs,
+					     tyvars = bound})
 		   end
 	      | Adec.Local (d, d') =>
-		   Decs.append (Env.localCore (E,
-					       fn () => elabDec d,
-					       fn () => elabDec d'))
+		   Env.localCore
+		   (E,
+		    fn () => elabDec (d, false),
+		    fn decs => Decs.append (decs, elabDec (d', isTop)))
 	      | Adec.Open paths =>
 		   let
 		      (* The following code is careful to first lookup all of the
@@ -827,265 +1262,637 @@
 		   in
 		      Decs.empty
 		   end
-	      | Adec.Overload (x, t, xs) =>
+	      | Adec.Overload (x, tyvars, ty, xs) =>
 		   let
-		      val x' = Cvar.fromAst x
-		      val scheme = elabType t
-		      (* Elaborate the overloads before extending the var in
-		       * case x appears in the xs.
+		      (* Lookup the overloads before extending the var in case
+		       * x appears in the xs.
 		       *)
 		      val ovlds =
 			 Vector.map (xs, fn x => Env.lookupLongvar (E, x))
-		      val _ = Env.extendVar (E, x, x')
+		      val _ =
+			 Env.extendOverload
+			 (E, x, 
+			  Vector.map (ovlds, fn (x, s) => (x, Scheme.ty s)),
+			  Scheme.make {canGeneralize = false,
+				       tyvars = tyvars,
+				       ty = elabType ty})
 		   in
-		      Decs.single (Cdec.makeRegion
-				   (Cdec.Overload {var = x',
-						   scheme = scheme,
-						   ovlds = ovlds},
-				    region))
+		      Decs.empty
 		   end
 	      | Adec.SeqDec ds =>
 		   Vector.fold (ds, Decs.empty, fn (d, decs) =>
-				Decs.append (decs, elabDec d))
+				Decs.append (decs, elabDec (d, isTop)))
 	      | Adec.Type typBind =>
-		   (List.foreach
-		    (elaborateTypBind (typBind, Lookup.fromEnv E),
-		     fn (tyc, str) => Env.extendTycon (E, tyc, str))
+		   (elabTypBind typBind
 		    ; Decs.empty)
-	      | Adec.Val {tyvars, vbs, rvbs} =>
+	      | Adec.Val {tyvars, rvbs, vbs} =>
 		   let
-		      val hasCon: string option ref = ref NONE
-		      fun checkName (name: Ast.Longvid.t): unit =
-			 case !hasCon of
-			    SOME _ => ()
-			  | NONE =>
-			       if isSome (Env.peekLongcon
-					  (E, Ast.Longvid.toLongcon name))
-				  then hasCon := SOME (Region.toString
-						       (Ast.Longvid.region name))
-			       else ()
-		      (* Must do all the es and rvbs pefore the ps because of
+		      val close = TypeEnv.close (tyvars, region)
+		      (* Must do all the es and rvbs before the ps because of
 		       * scoping rules.
 		       *)
-		      val es =
-			 Vector.map (vbs, fn {pat, exp, ...} =>
-				     elabExp'
-				     (exp,
-				      case Apat.getName pat of
-					 NONE => "<anon>" :: nest
-				       | SOME s => s :: nest))
-		      fun varsAndTypes (p: Apat.t, vars, types)
-			 : Avar.t list * Atype.t list =
-			 let
-			    fun error () =
-			       Error.bug
-			       (concat ["strange rec pattern: ",
-					Layout.toString (Apat.layout p)])
-			    datatype z = datatype Apat.node
-			 in
-			    case Apat.node p of
-			       Wild => (vars, types)
-			     | Var {name, ...} =>
-				  (checkName name
-				   ; (case Ast.Longvid.split name of
-					 ([], x) =>
-					    (Ast.Vid.toVar x :: vars, types)
-				       | _ => Error.bug "longid in val rec pattern"))
-			     | Constraint (p, t) =>
-				  varsAndTypes (p, vars, t :: types)
-			     | FlatApp ps =>
-				  if 1 = Vector.length ps
-				     then varsAndTypes (Vector.sub (ps, 0),
-							vars, types)
-				  else error ()
-			     | Apat.Layered {var, constraint, pat, ...} =>
-				  varsAndTypes (pat, var :: vars,
-						case constraint of
-						   NONE => types
-						 | SOME t => t :: types)
-			     | _ => error ()
-			 end
-		      val varsAndTypes =
-			 Trace.trace ("varsAndTypes",
-				      Apat.layout o #1,
-				      Layout.tuple2 (List.layout Avar.layout,
-						     List.layout Atype.layout))
-			 varsAndTypes
-		      val vts =
+		      val vbs =
 			 Vector.map
-			 (rvbs, fn {pat, ...} =>
+			 (vbs, fn {exp, pat, ...} =>
+			  {exp = elabExp (exp,
+					  case Apat.getName pat of
+					     NONE => "anon" :: nest
+					   | SOME s => s :: nest),
+			   expRegion = Aexp.region exp,
+			   pat = pat,
+			   patRegion = Apat.region pat})
+		      val close =
+			 case Vector.peek (vbs, Cexp.isExpansive o #exp) of
+			    NONE => close
+			  | SOME {expRegion, ...} => 
+			       let
+				  val _ =
+				     if Vector.isEmpty tyvars
+					then ()
+				     else
+					Control.error
+					(expRegion,
+					 str "value restriction prevents generalization",
+					 empty)
+			       in
+				  fn tys => {bound = fn () => Vector.new0 (),
+					     schemes =
+					     Vector.map (tys, Scheme.fromType)}
+			       end
+		      val {markFunc, setBound, unmarkFunc} = recursiveFun ()
+		      val rvbs =
+			 Vector.map
+			 (rvbs, fn {pat, match} =>
 			  let
-			     val (vars, types) = varsAndTypes (pat, [], [])
-			     val (nest, var) =
-				case vars of
-				   [] => ("<anon>" :: nest, Cvar.newNoname ())
-				 | x :: _ =>
-				      let
-					 val x' = Cvar.fromAst x
-					 val _ =
-					    List.foreach
-					    (vars, fn y =>
-					     Env.extendVar (E, y, x'))
-				      in
-					 (Avar.toString x :: nest, x')
-				      end
+			     val region = Apat.region pat
+			     val (pat, bound) = elaboratePat (pat, E, true)
+			     val (nest, var, ty) =
+				if 0 = Vector.length bound
+				   then ("<anon>" :: nest,
+					 Var.newNoname (),
+					 newType ())
+				else
+				   let
+				      val (x, x', t) = Vector.sub (bound, 0)
+				   in
+				      (Avar.toString x :: nest, x', t)
+				   end
+			     val _ = markFunc var
+			     val scheme = Scheme.fromType ty
+			     val bound =
+				Vector.map
+				(bound, fn (x, _, _) =>
+				 (Env.extendVar (E, x, var, scheme)
+				  ; (x, var, ty)))
 			  in
-			     {nest = nest,
-			      types = (Vector.fromListMap
-				       (types, Scheme.ty o elabType)),
+			     {bound = bound,
+			      match = match,
+			      nest = nest,
+			      pat = pat,
+			      region = region,
 			      var = var}
 			  end)
+		      val boundVars =
+			 Vector.concatV (Vector.map (rvbs, #bound))
 		      val rvbs =
-			 Vector.map2
-			 (rvbs, vts,
-			  fn ({pat, match, ...}, {nest, types, var}) =>
-			  {match = elabMatch (match, nest),
-			   profile = SOME (SourceInfo.function
-					   {name = nest,
-					    region = Apat.region pat}),
-			   types = types,
-			   var = var})
-		      val ps = Vector.map (vbs, fn {pat, filePos, ...} =>
-					   {pat = elaboratePat (pat, E),
-					    filePos = filePos,
-					    region = Apat.region pat})
+			 Vector.map
+			 (rvbs, fn {bound, match, nest, pat, region, var, ...} =>
+			  let
+			     val {argType, region, resultType, rules} =
+				elabMatch (match, nest)
+			     val _ =
+				unify
+				(Cpat.ty pat,
+				 Type.arrow (argType, resultType),
+				 fn (l1, l2) =>
+				 (region,
+				  str "pattern does not match function type",
+				  align [seq [str "pattern:    ", l1],
+					 seq [str "function type: ", l2]]))
+			     val arg = Var.newNoname ()
+			     val body =
+				Cexp.enterLeave
+				(Cexp.casee {noMatch = Cexp.RaiseMatch,
+					     region = region,
+					     rules = rules,
+					     test = Cexp.var (arg, argType)},
+				 SourceInfo.function {name = nest,
+						      region = region})
+			     val lambda =
+				Lambda.make {arg = arg,
+					     argType = argType,
+					     body = body}
+			  in
+			     {bound = bound,
+			      lambda = lambda,
+			      var = var}
+			  end)
+		      val rvbs =
+			 Vector.map
+			 (rvbs, fn {bound, lambda, var} =>
+			  (Vector.foreach (bound, unmarkFunc o #2)
+			   ; {lambda = lambda,
+			      var = var}))
+		      val vbs =
+			 Vector.map
+			 (vbs, fn {exp = e, expRegion, pat, patRegion, ...} =>
+			  let
+			     val (p, bound) = elaboratePat (pat, E, false)
+			     val _ =
+				unify
+				(Cpat.ty p, Cexp.ty e, fn (p, e) =>
+				 (Apat.region pat,
+				  str "pattern and expression don't agree",
+				  align [seq [str "pattern:    ", p],
+					 seq [str "expression: ", e]]))
+			  in
+			     {bound = bound,
+			      exp = e,
+			      expRegion = expRegion,
+			      pat = p,
+			      patRegion = patRegion}
+			  end)
+		      val boundVars =
+			 Vector.concat
+			 [boundVars, Vector.concatV (Vector.map (vbs, #bound))]
+		      val {bound, schemes} =
+			 close (Vector.map (boundVars, #3))
+		      val _ = checkSchemes (Vector.zip
+					    (Vector.map (boundVars, #2),
+					     schemes))
+		      val _ = setBound bound
+		      val _ =
+			 Vector.foreach2
+			 (boundVars, schemes, fn ((x, x', _), scheme) =>
+			  Env.extendVar (E, x, x', scheme))
 		      val vbs =
-			 Vector.map2 (ps, es, fn ({pat, filePos, region}, e) =>
-				      Cdec.makeRegion
-				      (Cdec.Val {pat = pat,
-						 filePos = filePos,
-						 tyvars = tyvars,
-						 exp = e},
-				       region))
-		   in Decs.appends
-		      [Decs.fromVector vbs,
-		       Decs.single (Cdec.makeRegion
-				    (Cdec.Fun {tyvars = tyvars,
-					       decs = rvbs},
-				     region)),
-		       (* Hack to implement rule 126, which requires Bind to be
-			* raised if any of the rvbs contains a constructor in a
-			* pattern.  This, despite the fact that rule 26 allows
-			* identifier status to be overridden for the purposes of
-			* type checking.
-			*)
-		       case !hasCon of
-			  NONE => Decs.empty
-			| SOME filePos => 
-			     Decs.single
-			     (Cdec.makeRegion
-			      (Cdec.Val
-			       {exp = doit (Cexp.Raise
-					    {exn = doit (Cexp.Con Con.bind),
-					     filePos = filePos}),
-				filePos = "",
-				pat = Cpat.makeRegion (Cpat.Wild, region),
-				tyvars = Vector.new0 ()},
-			       region))]
+			 Vector.map (vbs, fn {exp, pat, patRegion, ...} =>
+				     {exp = exp,
+				      pat = pat,
+				      patRegion = patRegion})
+		   in
+		      Decs.single (Cdec.Val {rvbs = rvbs,
+					     tyvars = bound,
+					     vbs = vbs})
 		   end
 	  end) arg
-      and elabExp' (arg: Aexp.t * Nest.t): Cexp.t =
+      and elabExp (arg: Aexp.t * Nest.t): Cexp.t =
 	 Trace.traceInfo (elabExpInfo,
 			  Layout.tuple2 (Aexp.layout, Nest.layout),
-			  Cexp.layout,
+			  Layout.ignore,
 			  Trace.assertTrue)
 	 (fn (e: Aexp.t, nest) =>
 	  let
 	     val region = Aexp.region e
-	     fun doit n = Cexp.makeRegion (n, region)
-	     fun elabExp e = elabExp' (e, nest)
+	     fun constant (c: Aconst.t) =
+		case Aconst.node c of
+		   Aconst.Bool b => if b then Cexp.truee else Cexp.falsee
+		 | _ => 
+		      let
+			 val ty = Aconst.ty c
+			 fun resolve () = resolveConst (c, ty)
+			 val _ = List.push (overloads, fn () => (resolve (); ()))
+		      in
+			 Cexp.make (Cexp.Const resolve, ty)
+		      end
+	     fun elab e = elabExp (e, nest)
 	  in
 	     case Aexp.node e of
 		Aexp.Andalso (e, e') =>
-		   Cexp.andAlso (elabExp e, elabExp e', region)
+		   let
+		      val ce = elab e
+		      val ce' = elab e'
+		      fun doit (ce, br) =
+			 unify
+			 (Cexp.ty ce, Type.bool,
+			  fn (l, _) =>
+			  (Aexp.region e,
+			   str (concat
+				[br, " branch of andalso must be of type bool"]),
+			   seq [str (concat [br, " branch: "]), l]))
+		      val _ = doit (ce, "left")
+		      val _ = doit (ce', "right")
+		   in
+		      Cexp.andAlso (ce, ce')
+		   end
 	      | Aexp.App (e1, e2) =>
-		   doit (Cexp.App (elabExp e1, elabExp e2))
+		   let
+		      val e1 = elab e1
+		      val e2 = elab e2
+		      val argType = newType ()
+		      val resultType = newType ()
+		      val _ =
+			 unify (Cexp.ty e1, Type.arrow (argType, resultType),
+				fn (l, _) =>
+				(region,
+				 str "attempt to apply non-function",
+				 seq [str "function: ", l]))
+		      val _ =
+			 unify
+			 (argType, Cexp.ty e2, fn (l1, l2) =>
+			  (region,
+			   str "function applied to incorrect arguments",
+			   align [seq [str "expects: ", l2],
+				  seq [str "but got: ", l1]]))
+		   in
+		      Cexp.make (Cexp.App (e1, e2), resultType)
+		   end
 	      | Aexp.Case (e, m) =>
-		   Cexp.casee (elabExp e, elabMatch (m, nest), region)
-	      | Aexp.Const c => doit (Cexp.Const c)
-	      | Aexp.Constraint (e, t) =>
-		   doit (Cexp.Constraint (elabExp e,
-					  Scheme.ty (elabType t)))
-	      | Aexp.FlatApp items => elabExp (Parse.parseExp (items, E))
+		   let
+		      val e = elab e
+		      val {argType, region, resultType, rules} =
+			 elabMatch (m, nest)
+		      val _ =
+			 unify
+			 (Cexp.ty e, argType, fn (l1, l2) =>
+			  (region,
+			   str "case object and rules disagree",
+			   align [seq [str "object: ", l1],
+				  seq [str "rules:  ", l2]]))
+		   in
+		      Cexp.casee {noMatch = Cexp.RaiseMatch,
+				  region = region,
+				  rules = rules,
+				  test = e}
+		   end
+	      | Aexp.Const c => constant c
+	      | Aexp.Constraint (e, t') =>
+		   let
+		      val e = elab e
+		      val _ =
+			 unify
+			 (Cexp.ty e, elabType t', fn (l1, l2) =>
+			  (region,
+			   str "expression and constraint mismatch",
+			   align [seq [str "expression: ", l1],
+				  seq [str "constraint: ", l2]]))
+		   in
+		      e
+		   end
+	      | Aexp.FlatApp items => elab (Parse.parseExp (items, E))
 	      | Aexp.Fn m =>
-		   doit
-		   (Cexp.Fn
-		    {match = elabMatch (m, nest),
-		     profile = SOME (SourceInfo.function {name = nest,
-							  region = region})})
+		   let
+		      val {arg, argType, body} =
+			 elabMatchFn (m, nest, Cexp.RaiseMatch)
+		      val body =
+			 Cexp.enterLeave
+			 (body, SourceInfo.function {name = nest,
+						     region = region})
+		   in
+		      Cexp.make (Cexp.Lambda (Lambda.make {arg = arg,
+							   argType = argType,
+							   body = body}),
+				 Type.arrow (argType, Cexp.ty body))
+		   end
 	      | Aexp.Handle (try, match) =>
-		   doit (Cexp.Handle (elabExp try, elabMatch (match, nest)))
+		   let
+		      val try = elab try
+		      val {arg, argType, body} =
+			 elabMatchFn (match, nest, Cexp.RaiseAgain)
+		      val _ =
+			 unify
+			 (Cexp.ty try, Cexp.ty body, fn (l1, l2) =>
+			  (region,
+			   str "expression and handler don't agree",
+			   align [seq [str "expression: ", l1],
+				  seq [str "handler: ", l2]]))
+		      val _ =
+			 unify
+			 (argType, Type.exn, fn (l1, _) =>
+			  (Amatch.region match,
+			   seq [str "handler must handle exn: ", l1],
+			   empty))
+		   in
+		      Cexp.make (Cexp.Handle {catch = (arg, Type.exn),
+					      handler = body, 
+					      try = try},
+				 Cexp.ty try)
+		   end
 	      | Aexp.If (a, b, c) =>
-		   Cexp.iff (elabExp a, elabExp b, elabExp c, region)
+		   let
+		      val a' = elab a
+		      val b' = elab b
+		      val c' = elab c
+		      val _ =
+			 unify
+			 (Cexp.ty a', Type.bool, fn (l1, _) =>
+			  (Aexp.region a,
+			   str "if test must be of type bool",
+			   seq [str "test: ", l1]))
+		      val _ =
+			 unify
+			 (Cexp.ty b', Cexp.ty c', fn (l1, l2) =>
+			  (region,
+			   str "then and else branches disagree",
+			   align [seq [str "then: ", l1],
+				  seq [str "else: ", l2]]))
+		   in
+		      Cexp.iff (a', b', c')
+		   end
 	      | Aexp.Let (d, e) =>
 		   Env.scope
 		   (E, fn () =>
-		    doit (Cexp.Let (Decs.toVector (elabDec (d, nest)),
-				    elabExp e)))
-	      | Aexp.List es => Cexp.list (List.map (es, elabExp), region)
+		    let
+		       val d = Decs.toVector (elabDec (d, nest, false))
+		       val e = elab e
+		    in
+		       Cexp.make (Cexp.Let (d, e), Cexp.ty e)
+		    end)
+	      | Aexp.List es =>
+		   let
+		      val es' = Vector.map (es, elab)
+		   in
+		      Cexp.make (Cexp.List es',
+				 unifyList
+				 (Vector.map2 (es, es', fn (e, e') =>
+					       (Cexp.ty e', Aexp.region e))))
+		   end
 	      | Aexp.Orelse (e, e') =>
-		   Cexp.orElse (elabExp e, elabExp e', region)
+		   let
+		      val ce = elab e
+		      val ce' = elab e'
+		      fun doit (ce, br) =
+			 unify
+			 (Cexp.ty ce, Type.bool,
+			  fn (l, _) =>
+			  (Aexp.region e,
+			   str (concat
+				[br, " branch of orelse must be of type bool"]),
+			   seq [str (concat [br, " branch: "]), l]))
+		      val _ = doit (ce, "left")
+		      val _ = doit (ce', "right")
+		   in
+		      Cexp.orElse (ce, ce')
+		   end
 	      | Aexp.Prim {kind, name, ty} =>
 		   let
 		      val ty = elabType ty
+		      fun primApp {args, prim, result: Type.t} =
+			 let
+			    val targs =
+			       Prim.extractTargs
+			       {args = Vector.map (args, Cexp.ty),
+				deArray = Type.deArray,
+				deArrow = Type.deArrow,
+				deRef = Type.deRef,
+				deVector = Type.deVector,
+				deWeak = Type.deWeak,
+				prim = prim,
+				result = result}
+			 in
+			    Cexp.make (Cexp.PrimApp {args = args,
+						     prim = prim,
+						     targs = targs},
+				       result)
+			 end
+		      fun eta (p: Prim.t): Cexp.t =
+			 case Type.deArrowOpt ty of
+			    NONE => primApp {args = Vector.new0 (),
+					     prim = p,
+					     result = ty}
+			  | SOME (argType, bodyType) =>
+			       let
+				  val arg = Var.newNoname ()
+				  fun app args =
+				     primApp {args = args,
+					      prim = p,
+					      result = bodyType}
+				  val body =
+				     case Type.deTupleOpt argType of
+					NONE =>
+					   app (Vector.new1
+						(Cexp.var (arg, argType)))
+				      | SOME ts =>
+					   let
+					      val vars =
+						 Vector.map
+						 (ts, fn t =>
+						  (Var.newNoname (), t))
+					   in
+					      Cexp.casee
+					      {noMatch = Cexp.Impossible,
+					       region = Region.bogus,
+					       rules =
+					       Vector.new1
+					       (Cpat.tuple
+						(Vector.map (vars, Cpat.var)),
+						app (Vector.map
+						     (vars, Cexp.var))),
+					       test = Cexp.var (arg, argType)}
+					   end
+			       in
+				  Cexp.lambda (Lambda.make {arg = arg,
+							    argType = argType,
+							    body = body})
+			       end
+		      fun lookConst (name: string) =
+			 case Type.deConOpt ty of
+			    NONE => Error.bug "strange constant"
+			  | SOME (c, ts) =>
+			       let
+				  val ct =
+				     if Tycon.equals (c, Tycon.bool)
+					then ConstType.Bool
+				     else if Tycon.isIntX c
+					then ConstType.Int
+				     else if Tycon.isRealX c
+					then ConstType.Real
+				     else if Tycon.isWordX c
+					then ConstType.Word
+				     else if Tycon.equals (c, Tycon.vector)
+					     andalso 1 = Vector.length ts
+					     andalso
+					     (case (Type.deConOpt
+						    (Vector.sub (ts, 0))) of
+						 NONE => false
+					       | SOME (c, _) => 
+						    Tycon.equals
+						    (c, Tycon.char))
+					then ConstType.String
+				     else Error.bug "strange const type"
+				  fun finish () = lookupConstant (name, ct)
+			       in
+				  Cexp.make (Cexp.Const finish, ty)
+			       end
 		      datatype z = datatype Ast.PrimKind.t
-		      val simple = doit o Cexp.Prim
 		   in
 		      case kind of
-			 BuildConst => simple (Cprim.buildConstant (name, ty))
-		       | Const => simple (Cprim.constant (name, ty))
+			 BuildConst => lookConst name
+		       | Const =>  lookConst name
 		       | Export attributes =>
-			    let
-			       val ty = Scheme.ty ty
-			    in
-			       doit
-			       (Cexp.Constraint
-				(Env.scope
-				 (E, fn () =>
-				  (Env.openStructure (E,
-						      valOf (!Env.Structure.ffi))
-				   ; elabExp' (export {attributes = attributes,
-						       name = name,
-						       region = region,
-						       ty = ty},
-					       nest))),
-				 Type.arrow (ty, Type.unit)))
-			    end
+			    Env.scope
+			    (E, fn () =>
+			     (Env.openStructure (E,
+						 valOf (!Env.Structure.ffi))
+			      ; elabExp (export {attributes = attributes,
+						 name = name,
+						 region = region,
+						 ty = ty},
+					 nest)))
 		       | Import attributes =>
-			    simple (import {attributes = attributes,
-					    name = name,
-					    region = region,
-					    ty = Scheme.ty ty})
-		       | Prim => simple (Cprim.new (name, ty))
+			    eta (import {attributes = attributes,
+					 name = name,
+					 region = region,
+					 ty = ty})
+		       | Prim => eta (Prim.new name)
+		   end
+	      | Aexp.Raise exn =>
+		   let
+		      val region = Aexp.region exn
+		      val exn = elab exn
+		      val _ =
+			 unify
+			 (Cexp.ty exn, Type.exn, fn (l1, _) =>
+			  (region,
+			   str "raise must get an exception",
+			   seq [str "expression: ", l1]))
+		      val resultType = newType ()
+		   in
+		      Cexp.make (Cexp.Raise {exn = exn, region = region},
+				 resultType)
 		   end
-	      | Aexp.Raise {exn, filePos} =>
-		   doit (Cexp.Raise {exn = elabExp exn, filePos = filePos})
 	      | Aexp.Record r =>
-		   doit (Cexp.Record (Record.map (r, elabExp)))
-	      | Aexp.Selector f =>
-		   Cexp.selector (f, region)
+		   let
+		      val r = Record.map (r, elab)
+		      val ty =
+			 Type.record
+			 (SortedRecord.fromVector
+			  (Record.toVector (Record.map (r, Cexp.ty))))
+		   in
+		      Cexp.make (Cexp.Record r, ty)
+		   end
+	      | Aexp.Selector f => elab (Aexp.selector (f, region))
 	      | Aexp.Seq es =>
-		   Cexp.seq (Vector.map (es, elabExp), region)
+		   let
+		      val es = Vector.map (es, elab)
+		   (* Could put warning here for expressions before a ; that
+		    * don't return unit.
+		    *)
+		   in
+		      Cexp.make (Cexp.Seq es, Cexp.ty (Vector.last es))
+		   end
 	      | Aexp.Var {name = id, ...} =>
-		   doit (case Env.lookupLongvid (E, id) of
-			    Vid.Var x => Cexp.Var x
-			  | Vid.ConAsVar c => Cexp.Con c
-			  | Vid.Con c => Cexp.Con c
-			  | Vid.Exn c => Cexp.Con c
-			  | Vid.Prim p => Cexp.Prim p)
-	      | Aexp.While {test, expr} =>
-		   Cexp.whilee {test = elabExp test,
-				expr = elabExp expr,
-				region = region}
+		   let
+		      val (vid, scheme) = Env.lookupLongvid (E, id)
+		      val {args, instance} = Scheme.instantiate scheme
+		      fun con c = Cexp.Con (c, args ())
+		      val e =
+			 case vid of
+			    Vid.ConAsVar c => con c
+			  | Vid.Con c => con c
+			  | Vid.Exn c => con c
+			  | Vid.Overload yts =>
+			       let
+				  val resolve =
+				     Promise.lazy
+				     (fn () =>
+				      case (Vector.peek
+					    (yts, fn (_, t) =>
+					     Type.canUnify (instance, t))) of
+					 NONE =>
+					    let
+					       val _ =
+						  Control.error
+						  (region,
+						   seq [str "impossible use of overloaded var: ",
+							str (Longvid.toString id)],
+						   Type.layoutPretty instance)
+					    in
+					       Var.newNoname ()
+					    end
+				       | SOME (y, t) =>  
+					    (unify (instance, t, fn _ =>
+						    Error.bug "overload unify")
+					     ; y))
+				  val _ = 
+				     List.push (overloads, fn () =>
+						(resolve (); ()))
+			       in
+				  Cexp.Var (resolve, fn () => Vector.new0 ())
+			       end
+			  | Vid.Var x =>
+			       Cexp.Var (fn () => x,
+					 case ! (recursiveTargs x) of
+					    NONE => args
+					  | SOME f => f)
+		   in
+		      Cexp.make (e, instance)
+		   end
+	      | Aexp.While {expr, test} =>
+		   let
+		      val test' = elab test
+		      val _ =
+			 unify
+			 (Cexp.ty test', Type.bool, fn (l1, _) =>
+			  (Aexp.region test,
+			   str "while-test must be of type bool",
+			   seq [str "test: ", l1]))
+		      (* Could put warning here if the expr is not of type unit.
+		       *)
+		      val expr = elab expr
+		   in
+		      Cexp.whilee {expr = expr, test = test'}
+		   end
 	  end) arg
-      and elabMatch (Amatch.T {filePos, rules}, nest: Nest.t) =
-	 Cmatch.new {filePos = filePos,
-		     rules = 
-		     Vector.map (rules, fn (pat, exp) =>
-				 Env.scope (E, fn () => (elaboratePat (pat, E),
-							 elabExp' (exp, nest))))}
+      and elabMatchFn (m: Amatch.t, nest, noMatch) =
+	 let
+	    val arg = Var.newNoname ()
+	    val {argType, region, resultType, rules} = elabMatch (m, nest)
+	    val body =
+	       Cexp.casee {noMatch = noMatch,
+			   region = region,
+			   rules = rules,
+			   test = Cexp.var (arg, argType)}
+	 in
+	   {arg = arg,
+	    argType = argType,
+	    body = body}
+	 end
+      and elabMatch (m: Amatch.t, nest: Nest.t) =
+	 let
+	    val region = Amatch.region m
+	    val Amatch.T rules = Amatch.node m
+	    val argType = newType ()
+	    val resultType = newType ()
+	    val rules =
+	       Vector.map
+	       (rules, fn (pat, exp) =>
+		Env.scope
+		(E, fn () =>
+		 let
+		    val (p, xts) = elaboratePat (pat, E, false)
+		    val _ =
+		       unify
+		       (Cpat.ty p, argType, fn (l1, l2) =>
+			(Apat.region pat,
+			 str "rule patterns not of same type",
+			 align [seq [str "this rule: ", l1],
+				seq [str "previous:  ", l2]]))
+		    val e = elabExp (exp, nest)
+		    val _ =
+		       unify
+		       (Cexp.ty e, resultType, fn (l1, l2) =>
+			(Aexp.region exp,
+			 str "cases not of same type",
+			 align [seq [str "this case:      ", l1],
+				seq [str "previous cases: ", l2]]))
+		 in
+		    (p, e)
+		 end))
+	 in
+	    {argType = argType,
+	     region = region,
+	     resultType = resultType,
+	     rules = rules}
+	 end
+      val ds = elabDec (Scope.scope d, nest, true)
+      val _ = List.foreach (!overloads, fn p => (p (); ()))
+      val _ = overloads := []
+      val _ = List.foreach (!freeTyvarChecks, fn p => p ())
+      val _ = freeTyvarChecks := []
+      val _ = TypeEnv.closeTop (Adec.region d)
    in
-      elabDec (Scope.scope d, nest)
+      ds
    end
 
 end



1.5       +8 -2      mlton/mlton/elaborate/elaborate-core.sig

Index: elaborate-core.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- elaborate-core.sig	24 Jun 2003 20:14:22 -0000	1.4
+++ elaborate-core.sig	9 Oct 2003 18:17:33 -0000	1.5
@@ -11,10 +11,12 @@
 signature ELABORATE_CORE_STRUCTS = 
    sig
       structure Ast: AST
+      structure ConstType: CONST_TYPE
       structure CoreML: CORE_ML
       structure Decs: DECS
       structure Env: ELABORATE_ENV
-      sharing Ast = CoreML.Ast
+      sharing Ast = Env.Ast
+      sharing Ast.Tyvar = CoreML.Tyvar
       sharing CoreML = Decs.CoreML = Env.CoreML
    end
 
@@ -23,5 +25,9 @@
       include ELABORATE_CORE_STRUCTS
 
       (* Elaborate dec in env, returning Core ML decs. *)
-      val elaborateDec: Ast.Dec.t * string list * Env.t -> Decs.t
+      val elaborateDec:
+	 Ast.Dec.t * {env: Env.t,
+		      lookupConstant: string * ConstType.t -> CoreML.Const.t,
+		      nest: string list}
+	 -> Decs.t
    end



1.12      +154 -101  mlton/mlton/elaborate/elaborate-env.fun

Index: elaborate-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- elaborate-env.fun	26 Jun 2003 19:17:30 -0000	1.11
+++ elaborate-env.fun	9 Oct 2003 18:17:33 -0000	1.12
@@ -10,8 +10,10 @@
 
 open S
 
-local open Ast
-in structure Fixity = Fixity
+local
+   open Ast
+in
+   structure Fixity = Fixity
    structure Strid = Strid
    structure Longcon = Longcon
    structure Longvid = Longvid
@@ -19,104 +21,145 @@
    structure Longtycon = Longtycon
 end
 
-local open CoreML
-in structure Con = Con
+local
+   open CoreML
+in
+   structure Con = Con
    structure Var = Var
    structure Prim = Prim
    structure Record = Record
-   structure Scheme = Scheme
    structure Srecord = SortedRecord
    structure Tycon = Tycon
-   structure Type = Type
    structure Tyvar = Tyvar
    structure Var = Var
 end
 
-structure Scope = UniqueId ()
+local
+   open TypeEnv
+in
+   structure Scheme = InferScheme
+   structure Type = Type
+end
+
+structure Decs = Decs (structure CoreML = CoreML)
 
+structure Scheme =
+   struct
+      open Scheme
+	 
+      val bogus = fromType (Type.var (Tyvar.newNoname {equality = false}))
+   end
+
+structure TypeScheme = Scheme
+
+structure Scope = UniqueId ()
+   
 structure TypeStr =
    struct
-      datatype t =
-	 Datatype of {cons: {name: Ast.Con.t,
-			     con: Con.t} vector,
+      structure Kind = CoreML.Tycon.Kind
+
+      datatype node =
+	 Datatype of {cons: {con: Con.t,
+			     name: Ast.Con.t,
+			     scheme: Scheme.t} vector,
 		      tycon: Tycon.t}
        | Scheme of Scheme.t
        | Tycon of Tycon.t
 
+      datatype t = T of {kind: Kind.t,
+			 node: node}
+
+      local
+	 fun make f (T r) = f r
+      in
+	 val kind = make #kind
+	 val node = make #node
+      end
+
       val bogus =
-	 Scheme (Scheme.T
-		 {tyvars = Vector.new0 (),
-		  ty = Type.Var (Ast.Tyvar.newNoname {equality = false})})
+	 T {kind = Kind.Arity 0,
+	    node = Scheme Scheme.bogus}
 
       fun abs t =
-	 case t of
-	    Datatype {tycon, ...} => Tycon tycon
+	 case node t of
+	    Datatype {tycon, ...} => T {kind = kind t,
+					node = Tycon tycon}
 	  | _ => t
 
-      fun apply (t, tys) =
-	 case t of
+      fun apply (t: t, tys: Type.t vector): Type.t =
+	 case node t of
 	    Datatype {tycon, ...} => Type.con (tycon, tys)
 	  | Scheme s => Scheme.apply (s, tys)
 	  | Tycon t => Type.con (t, tys)
 
       fun cons t =
-	 case t of
+	 case node t of
 	    Datatype {cons, ...} => cons
 	  | _ => Vector.new0 ()
 
-      fun data (tycon, cons) = Datatype {tycon = tycon, cons = cons}
+      fun data (tycon, kind, cons) =
+	 T {kind = kind,
+	    node = Datatype {tycon = tycon, cons = cons}}
 
-      val def = Scheme
+      fun def (s, kind) = T {kind = kind,
+			     node = Scheme s}
 
-      val tycon = Tycon
+      fun tycon (c, kind) = T {kind = kind,
+			       node = Tycon c}
 
       fun layout t =
-	 let open Layout
-	 in case t of
-	    Datatype {tycon, cons} =>
-	       seq [str "Datatype ",
-		    record [("tycon", Tycon.layout tycon),
-			    ("cons", (Vector.layout (fn {name, con} =>
-						     tuple [Ast.Con.layout name,
-							    Con.layout con])
-				      cons))]]
-	  | Scheme s => Scheme.layout s
-	  | Tycon t => seq [str "Tycon ", Tycon.layout t]
+	 let
+	    open Layout
+	 in
+	    case node t of
+	       Datatype {tycon, cons} =>
+		  seq [str "Datatype ",
+		       record [("tycon", Tycon.layout tycon),
+			       ("cons", (Vector.layout
+					 (fn {con, name, scheme} =>
+					  tuple [Ast.Con.layout name,
+						 Con.layout con,
+						 str ": ",
+						 Scheme.layout scheme])
+					 cons))]]
+	     | Scheme s => Scheme.layout s
+	     | Tycon t => seq [str "Tycon ", Tycon.layout t]
 	 end
    end
 
 structure Vid =
    struct
-      open CoreML
-	 
       datatype t =
-	 Var of Var.t
-       | Con of Con.t
-       | ConAsVar of CoreML.Con.t
+	 Con of Con.t
+       | ConAsVar of Con.t
        | Exn of Con.t
-       | Prim of Prim.t
+       | Overload of (Var.t * Type.t) vector
+       | Var of Var.t
 
       val statusString =
-	 fn Var _ => "var"
-	  | Prim _ => "var"
+	 fn Con _ => "con"
 	  | ConAsVar _ => "var"
-	  | Con _ => "con"
 	  | Exn _ => "exn"
+	  | Overload _ => "var"
+	  | Var _ => "var"
 
       val bogus = Var Var.bogus
 
       fun layout vid =
-	 let open Layout
+	 let
+	    open Layout
 	    val (name, l) =
 	       case vid of
-		  Var v => ("Var", Var.layout v)
-		| Con c => ("Con", Con.layout c)
+		  Con c => ("Con", Con.layout c)
 		| ConAsVar c => ("ConAsVar", Con.layout c)
 		| Exn c => ("Exn", Con.layout c)
-		| Prim p => ("Prim", Prim.layout p)
-	 in if false
-	       then l
-	    else paren (seq [str name, str " ", l])
+		| Overload xts =>
+		     ("Overload",
+		      Vector.layout (Layout.tuple2 (Var.layout, Type.layout))
+		      xts)
+		| Var v => ("Var", Var.layout v)
+	 in
+	    paren (seq [str name, str " ", l])
 	 end
 
       val deVar =
@@ -127,10 +170,6 @@
 	 fn Con c => SOME c
 	  | Exn c => SOME c
 	  | _ => NONE
-
-      val dePrim =
-	 fn Prim p => SOME p
-	  | _ => NONE
 	  
       fun output (r, out) = Layout.output (layout r, out)
    end
@@ -307,7 +346,7 @@
       datatype t = T of {shapeId: ShapeId.t option,
 			 strs: (Ast.Strid.t, t) Info.t,
 			 types: (Ast.Tycon.t, TypeStr.t) Info.t,
-			 vals: (Ast.Vid.t, Vid.t) Info.t}
+			 vals: (Ast.Vid.t, Vid.t * Scheme.t) Info.t}
 
       fun layoutUsed (T {strs, types, vals, ...}) =
 	 let
@@ -327,25 +366,26 @@
 			 align [seq [str "structure ", Ast.Strid.layout d],
 				indent (layoutUsed r, 3)])]
 	 end
+
       fun layout (T {strs, vals, types, ...}) =
 	 Layout.record
 	 [("types", Info.layout (Ast.Tycon.layout, TypeStr.layout) types),
-	  ("vals", Info.layout (Ast.Vid.layout, Vid.layout) vals),
+	  ("vals",
+	   Info.layout (Ast.Vid.layout,
+			Layout.tuple2 (Vid.layout, Scheme.layout))
+	   vals),
 	  ("strs", Info.layout (Ast.Strid.layout, layout) strs)]
 
       local
 	 open Layout
       in
 	 fun layoutTypeSpec (d, _) = seq [str "type ", Ast.Tycon.layout d]
-	 fun layoutValSpec (d, r) =
-	    seq [str (case r of
-			 Vid.Var _ => "val"
-		       | Vid.Con _ => "con"
-		       | Vid.ConAsVar _ => "val"
-		       | Vid.Exn _ => "exn"
-		       | Vid.Prim _ => "val"),
+	 fun layoutValSpec (d, (vid, scheme)) =
+	    seq [str (Vid.statusString vid),
 		 str " ",
-		 Ast.Vid.layout d]
+		 Ast.Vid.layout d,
+		 str ": ",
+		 Scheme.layoutPretty scheme]
 	 fun layoutStrSpec (d, r) =
 	    seq [str "structure ", Ast.Strid.layout d, str ": ",
 		 layoutPretty r]
@@ -385,16 +425,11 @@
       fun peekTycon z = Option.map (peekTycon' z, #range)
       fun peekVid z = Option.map (peekVid' z, #range)
 
-      val peekVid =
-	 Trace.trace2 ("peekVid",
-		       layout, Ast.Vid.layout, Option.layout Vid.layout)
-	 peekVid
-	 
       local
 	 fun make (from, de) (S, x) =
 	    case peekVid (S, from x) of
 	       NONE => NONE
-	     | SOME vid => de vid
+	     | SOME (vid, s) => Option.map (de vid, fn z => (z, s))
       in
 	 val peekCon = make (Ast.Vid.fromCon, Vid.deCon)
 	 val peekVar = make (Ast.Vid.fromVar, Vid.deVar)
@@ -470,11 +505,11 @@
 				     (Longtycon.long (rev strids, name)))
 			       | SOME {range = typeStr', values, ...} =>
 				    let
-				       datatype z = datatype TypeStr.t
+				       datatype z = datatype TypeStr.node
 				       val typeStr'' =
 					  case typeStr of
 					     Interface.TypeStr.Datatype {cons} =>
-						(case typeStr' of
+						(case TypeStr.node typeStr' of
 						    Datatype _ => typeStr'
 						  | _ =>
 						       (Control.error
@@ -487,9 +522,11 @@
 					   | Interface.TypeStr.Tycon =>
 						let
 						   datatype z = datatype TypeStr.t
-						in case typeStr' of
+						in case TypeStr.node typeStr' of
 						   Datatype {tycon, ...} =>
-						      Tycon tycon
+						      TypeStr.T
+						      {kind = TypeStr.kind typeStr',
+						       node = Tycon tycon}
 						 | _ => typeStr'
 						end
 				    in List.push (types,
@@ -503,7 +540,7 @@
 				    error (Longvid.className,
 					   Longvid.layout (Longvid.long
 							   (rev strids, name)))
-			       | SOME {range = vid, values, ...} =>
+			       | SOME {range = (vid, s), values, ...} =>
 				    let
 				       val vid =
 					  case (vid, status) of
@@ -531,9 +568,10 @@
 						    " in signature "]),
 						  Layout.empty)
 						 ; vid)
-				    in List.push (vals,
+				    in
+				       List.push (vals,
 						  {isUsed = ref false,
-						   range = vid,
+						   range = (vid, s),
 						   values = values})
 				    end
 			   val _ =
@@ -699,7 +737,7 @@
 		   sigs: (Ast.Sigid.t, Interface.t) NameSpace.t,
 		   strs: (Ast.Strid.t, Structure.t) NameSpace.t,
 		   types: (Ast.Tycon.t, TypeStr.t) NameSpace.t,
-		   vals: (Ast.Vid.t, Vid.t) NameSpace.t}
+		   vals: (Ast.Vid.t, Vid.t * Scheme.t) NameSpace.t}
 
 fun clean (T {fcts, fixs, sigs, strs, types, vals, ...}): unit =
    let
@@ -738,7 +776,8 @@
 fun layout (T {strs, types, vals, ...}) =
    Layout.tuple
    [NameSpace.layout (Ast.Tycon.layout, TypeStr.layout) types,
-    NameSpace.layout (Ast.Vid.layout, Vid.layout) vals,
+    NameSpace.layout (Ast.Vid.layout,
+		      Layout.tuple2 (Vid.layout, Scheme.layout)) vals,
     NameSpace.layout (Ast.Strid.layout, Structure.layout) strs]
 
 fun layoutPretty (T {fcts, sigs, strs, types, vals, ...}) =
@@ -855,7 +894,8 @@
       val strs = doit (strs, Ast.Strid.layout)
       val types = doit (types, Ast.Tycon.layout)
       val vals = doit (vals, Ast.Vid.layout)
-   in fn th =>
+   in
+      fn th =>
       let
 	 val s0 = Scope.new ()
 	 val fcts = fcts s0
@@ -869,7 +909,8 @@
 	 val res = th ()
 	 val _ = currentScope := s1
 	 val _ = (fcts (); fixs (); sigs (); strs (); types (); vals ())
-      in res
+      in
+	 res
       end
    end
       
@@ -891,14 +932,13 @@
       val apply =
 	 Trace.trace ("functorApply",
 		      Structure.layout o #1,
-		      Layout.tuple2 (Decs.layout, Structure.layout))
+		      Layout.tuple2 (Layout.ignore, Structure.layout))
 	 apply
       fun sizeMessage () = layoutSize apply
    in
       FunctorClosure.T {apply = apply,
 			sizeMessage = sizeMessage}
    end
-   
 
 (* ------------------------------------------------- *)
 (*                       peek                        *)
@@ -920,13 +960,13 @@
    fun peekVar (E, x) =
       case peekVid (E, Ast.Vid.fromVar x) of
 	 NONE => NONE
-       | SOME vid => Vid.deVar vid
+       | SOME (vid, s) => Option.map (Vid.deVar vid, fn x => (x, s))
 end
 
-fun peekCon (E: t, c: Ast.Con.t): CoreML.Con.t option =
+fun peekCon (E: t, c: Ast.Con.t): (Con.t * Scheme.t) option =
    case peekVid (E, Ast.Vid.fromCon c) of
       NONE => NONE
-    | SOME vid => Vid.deCon vid
+    | SOME (vid, s) => Option.map (Vid.deCon vid, fn c => (c, s))
 
 local
    fun make (split, peek, strPeek) (E, x) =
@@ -944,13 +984,20 @@
 		      | SOME S => strPeek (S, x)
       end
 in
-   val peekLongstrid = make (Ast.Longstrid.split, peekStrid, Structure.peekStrid)
-   val peekLongtycon = make (Ast.Longtycon.split, peekTycon, Structure.peekTycon)
+   val peekLongstrid =
+      make (Ast.Longstrid.split, peekStrid, Structure.peekStrid)
+   val peekLongtycon =
+      make (Ast.Longtycon.split, peekTycon, Structure.peekTycon)
    val peekLongvar = make (Ast.Longvar.split, peekVar, Structure.peekVar)
    val peekLongvid = make (Ast.Longvid.split, peekVid, Structure.peekVid)
    val peekLongcon = make (Ast.Longcon.split, peekCon, Structure.peekCon)
 end
 
+val peekLongcon =
+   Trace.trace2 ("peekLongcon", Layout.ignore, Ast.Longcon.layout,
+		 Option.layout (Layout.tuple2
+				(CoreML.Con.layout, TypeScheme.layout)))
+   peekLongcon
 (* ------------------------------------------------- *)
 (*                      lookup                       *)
 (* ------------------------------------------------- *)
@@ -964,13 +1011,16 @@
        | NONE => (unbound x; bogus)
 in
    val lookupFctid = make (peekFctid, FunctorClosure.bogus, Ast.Fctid.unbound)
-   val lookupLongcon = make (peekLongcon, Con.bogus, Ast.Longcon.unbound)
+   val lookupLongcon =
+      make (peekLongcon, (Con.bogus, Scheme.bogus), Ast.Longcon.unbound)
    val lookupLongstrid =
       make (peekLongstrid, Structure.bogus, Ast.Longstrid.unbound)
    val lookupLongtycon =
       make (peekLongtycon, TypeStr.bogus, Ast.Longtycon.unbound)
-   val lookupLongvid = make (peekLongvid, Vid.bogus, Ast.Longvid.unbound)
-   val lookupLongvar = make (peekLongvar, Var.bogus, Ast.Longvar.unbound)
+   val lookupLongvid =
+      make (peekLongvid, (Vid.bogus, Scheme.bogus), Ast.Longvid.unbound)
+   val lookupLongvar =
+      make (peekLongvar, (Var.bogus, Scheme.bogus), Ast.Longvar.unbound)
    val lookupSigid = make (peekSigid, Interface.bogus, Ast.Sigid.unbound)
 end
 
@@ -1008,17 +1058,22 @@
 		 Unit.layout)
    extendTycon
 
-fun extendCon (E, c, c') =
-   extendVals (E, Ast.Vid.fromCon c, Vid.Con c')
+fun extendCon (E, c, c', s) =
+   extendVals (E, Ast.Vid.fromCon c, (Vid.Con c', s))
 	       
-fun extendExn (E, c, c') =
-   extendVals (E, Ast.Vid.fromCon c, Vid.Exn c')
+fun extendExn (E, c, c', s) =
+   extendVals (E, Ast.Vid.fromCon c, (Vid.Exn c', s))
 	       
-fun extendVar (E, x, x') =
-   extendVals (E, Ast.Vid.fromVar x, Vid.Var x')
+fun extendVar (E, x, x', s) =
+   extendVals (E, Ast.Vid.fromVar x, (Vid.Var x', s))
+
+fun extendOverload (E, x, yts, s) =
+   extendVals (E, Ast.Vid.fromVar x, (Vid.Overload yts, s))
 
 val extendVar =
-   Trace.trace3 ("extendVar", layout, Ast.Var.layout, Var.layout, Unit.layout)
+   Trace.trace4
+   ("extendVar", Layout.ignore, Ast.Var.layout, Var.layout, Scheme.layoutPretty,
+    Unit.layout)
    extendVar
 
 (* ------------------------------------------------- *)   
@@ -1098,10 +1153,11 @@
 	 val types = types ()
 	 val vals = vals ()
 	 val _ = currentScope := Scope.new ()
-	 val a2 = f2 ()
+	 val a2 = f2 a1
 	 val _ = (fixs (); strs (); types (); vals ())
 	 val _ = currentScope := s0
-      in (a1, a2)
+      in
+	 a2
       end
 
    (* Can't eliminate the use of strs in localCore, because openn still modifies
@@ -1337,7 +1393,4 @@
     types = NameSpace.new let open Ast.Tycon in (equals, hash) end,
     vals = NameSpace.new let open Ast.Vid in (equals, hash) end}
    
-fun addEquals E =
-   extendVals (E, Ast.Vid.fromString ("=", Region.bogus), Vid.Prim Prim.equal)
- 
 end



1.7       +48 -30    mlton/mlton/elaborate/elaborate-env.sig

Index: elaborate-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- elaborate-env.sig	26 Jun 2003 19:17:30 -0000	1.6
+++ elaborate-env.sig	9 Oct 2003 18:17:33 -0000	1.7
@@ -12,45 +12,62 @@
    sig
       structure Ast: AST
       structure CoreML: CORE_ML
-      structure Decs: DECS
-      sharing Ast = CoreML.Ast = Decs.Ast
-      sharing CoreML = Decs.CoreML
+      structure TypeEnv: TYPE_ENV
+      sharing Ast.Record = CoreML.Record
+      sharing Ast.SortedRecord = CoreML.SortedRecord
+      sharing CoreML.Atoms = TypeEnv.Atoms
+      sharing CoreML.Type = TypeEnv.Type
    end
 
 signature ELABORATE_ENV =
    sig
       include ELABORATE_ENV_STRUCTS
 
+      structure Decs: DECS
+      sharing CoreML = Decs.CoreML
+
+      structure Type:
+	 sig
+	    type t
+	 end
+      sharing type Type.t = TypeEnv.Type.t
+      structure TypeScheme:
+	 sig
+	    type t
+	 end
+      sharing type TypeScheme.t = TypeEnv.InferScheme.t
       (* The value of a vid.  This is used to distinguish between vids whose
        * status cannot be determined at parse time.
        *)
       structure Vid:
 	 sig
 	    datatype t =
-	       Var of CoreML.Var.t
-	     | ConAsVar of CoreML.Con.t (* a constructor, but it has status
-					 * of a variable.
-					 *)
-	     | Con of CoreML.Con.t
+	       Con of CoreML.Con.t
+	     | ConAsVar of CoreML.Con.t
 	     | Exn of CoreML.Con.t
-	     | Prim of CoreML.Prim.t
+	     | Overload of (CoreML.Var.t * TypeEnv.Type.t) vector
+	     | Var of CoreML.Var.t
 
-	    val deVar: t -> CoreML.Var.t option
-	    val deCon: t -> CoreML.Con.t option
 	    val layout: t -> Layout.t
 	 end
       structure TypeStr:
 	 sig
+	    structure Kind: TYCON_KIND
 	    type t
 
 	    val abs: t -> t
-	    val apply: t * CoreML.Type.t vector -> CoreML.Type.t
-	    val cons: t -> {name: Ast.Con.t,
-			    con: CoreML.Con.t} vector
-	    val data: CoreML.Tycon.t * {name: Ast.Con.t,
-					con: CoreML.Con.t} vector -> t
-	    val def: CoreML.Scheme.t -> t
-	    val tycon: CoreML.Tycon.t -> t
+	    val apply: t * TypeEnv.Type.t vector -> TypeEnv.Type.t
+	    val cons: t -> {con: CoreML.Con.t,
+			    name: Ast.Con.t,
+			    scheme: TypeScheme.t} vector
+	    val data:
+	       CoreML.Tycon.t * Kind.t
+	       * {con: CoreML.Con.t,
+		  name: Ast.Con.t,
+		  scheme: TypeScheme.t} vector -> t
+	    val def: TypeScheme.t * Kind.t -> t
+	    val kind: t -> Kind.t
+	    val tycon: CoreML.Tycon.t * Kind.t -> t
 	 end
       structure Interface:
 	 sig
@@ -89,46 +106,47 @@
 	    type t
 
 	    val apply:
-	       t * Structure.t * string list * Region.t
-	       -> Decs.t * Structure.t
+	       t * Structure.t * string list * Region.t -> Decs.t * Structure.t
 	 end
 
       type t
 
-      val addEquals: t -> unit
       (* Remove unnecessary entries. *)
       val clean: t -> unit
       val empty: unit -> t
-      val extendCon: t * Ast.Con.t * CoreML.Con.t -> unit
-      val extendExn: t * Ast.Con.t * CoreML.Con.t -> unit
+      val extendCon: t * Ast.Con.t * CoreML.Con.t * TypeScheme.t -> unit
+      val extendExn: t * Ast.Con.t * CoreML.Con.t * TypeScheme.t -> unit
       val extendFctid: t * Ast.Fctid.t * FunctorClosure.t -> unit
       val extendFix: t * Ast.Vid.t * Ast.Fixity.t -> unit
       val extendSigid: t * Ast.Sigid.t * Interface.t -> unit
       val extendStrid: t * Ast.Strid.t * Structure.t -> unit
       val extendTycon: t * Ast.Tycon.t * TypeStr.t -> unit
-      val extendVar: t * Ast.Var.t * CoreML.Var.t -> unit
+      val extendVar: t * Ast.Var.t * CoreML.Var.t * TypeScheme.t -> unit
+      val extendOverload:
+	 t * Ast.Var.t * (CoreML.Var.t * TypeEnv.Type.t) vector * TypeScheme.t
+	 -> unit
       val functorClosure:
 	 t * Interface.t * (Structure.t * string list -> Decs.t * Structure.t)
 	 -> FunctorClosure.t
       val layout: t -> Layout.t
       val layoutPretty: t -> Layout.t
       val layoutUsed: t -> Layout.t
-      val localCore: t * (unit -> 'a) * (unit -> 'b) -> 'a * 'b
-      val localModule: t * (unit -> 'a) * (unit -> 'b) -> 'a * 'b
+      val localCore: t * (unit -> 'a) * ('a -> 'b) -> 'b
+      val localModule: t * (unit -> 'a) * ('a -> 'b) -> 'b
       val localTop: t * (unit -> 'a) -> ('a * ((unit -> 'b) -> 'b))
       val lookupFctid: t * Ast.Fctid.t -> FunctorClosure.t
-      val lookupLongcon: t * Ast.Longcon.t -> CoreML.Con.t
+      val lookupLongcon: t * Ast.Longcon.t -> CoreML.Con.t * TypeScheme.t
       val lookupLongstrid: t * Ast.Longstrid.t -> Structure.t
       val lookupLongtycon: t * Ast.Longtycon.t -> TypeStr.t
-      val lookupLongvar: t * Ast.Longvar.t -> CoreML.Var.t
-      val lookupLongvid: t * Ast.Longvid.t -> Vid.t
+      val lookupLongvar: t * Ast.Longvar.t -> CoreML.Var.t * TypeScheme.t
+      val lookupLongvid: t * Ast.Longvid.t -> Vid.t * TypeScheme.t
       val lookupSigid: t * Ast.Sigid.t -> Interface.t
       val makeInterfaceMaker: t -> InterfaceMaker.t
       val makeStructure: t * (unit -> 'a) -> 'a * Structure.t
       (* openStructure (E, S) opens S in the environment E. *) 
       val openStructure: t * Structure.t -> unit
       val peekFix: t * Ast.Vid.t -> Ast.Fixity.t option
-      val peekLongcon: t * Ast.Longcon.t -> CoreML.Con.t option
+      val peekLongcon: t * Ast.Longcon.t -> (CoreML.Con.t * TypeScheme.t) option
       val peekLongtycon: t * Ast.Longtycon.t -> TypeStr.t option
       (* scope f evaluates f () in a new scope so that extensions that occur
        * during f () are forgotten afterwards.



1.6       +35 -13    mlton/mlton/elaborate/elaborate.fun

Index: elaborate.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- elaborate.fun	26 Feb 2003 00:17:36 -0000	1.5
+++ elaborate.fun	9 Oct 2003 18:17:33 -0000	1.6
@@ -10,10 +10,13 @@
 
 open S
 
-local open Ast
-in structure FctArg = FctArg
+local
+   open Ast
+in
+   structure FctArg = FctArg
    structure Longstrid = Longstrid
    structure Topdec = Topdec
+
    structure SigConst = SigConst
    structure Sigexp = Sigexp
    structure Strdec = Strdec
@@ -21,19 +24,18 @@
    structure Strexp = Strexp
 end
 
-local open CoreML
-in structure Con = Con
+local
+   open CoreML
+in
+   structure Con = Con
    structure Prim = Prim
-   structure Scheme = Scheme
    structure Tycon = Tycon
    structure Type = Type
 end
 
-structure Decs = Decs (structure Ast = Ast
-		       structure CoreML = CoreML)
 structure Env = ElaborateEnv (structure Ast = Ast
 			      structure CoreML = CoreML
-			      structure Decs = Decs)
+			      structure TypeEnv = TypeEnv)
 
 local
    open Env
@@ -49,7 +51,20 @@
 					     structure Env = Env
 					     structure Interface = Interface)
 
+structure ConstType =
+   struct
+      datatype t = Bool | Int | Real | String | Word
+
+      val toString =
+	 fn Bool => "Bool"
+	  | Int => "Int"
+	  | Real => "Real"
+	  | String => "String"
+	  | Word => "Word"
+   end
+
 structure ElaborateCore = ElaborateCore (structure Ast = Ast
+					 structure ConstType = ConstType
 					 structure CoreML = CoreML
 					 structure Decs = Decs
 					 structure Env = Env)
@@ -57,8 +72,11 @@
 val info = Trace.info "elaborateStrdec"
 val info' = Trace.info "elaborateTopdec"
 	  
-fun elaborateProgram (Ast.Program.T decs, E: Env.t) =
+fun elaborateProgram (program,
+		      E: Env.t,
+		      lookupConstant) =
    let
+      val Ast.Program.T decs = Ast.Program.coalesce program 
       fun elabSigexp s = ElaborateSigexp.elaborateSigexp (s, E)
       fun elabSigexpConstraint (cons: SigConst.t, S: Structure.t): Structure.t =
 	 let
@@ -81,15 +99,19 @@
 			   Layout.ignore)
 	 (fn (d: Strdec.t, nest: string list) =>
 	  let
+	     val d = Strdec.coalesce d
 	     val elabStrdec = fn d => elabStrdec (d, nest)
 	  in
 	     case Strdec.node d of
 		Strdec.Core d => (* rule 56 *)
-		   ElaborateCore.elaborateDec (d, nest, E)
+		   ElaborateCore.elaborateDec
+		   (d, {env = E,
+			lookupConstant = lookupConstant,
+			nest = nest})
 	      | Strdec.Local (d, d') => (* rule 58 *)
-		   Decs.append (Env.localModule (E,
-						 fn () => elabStrdec d,
-						 fn () => elabStrdec d'))
+		   Env.localModule (E,
+				    fn () => elabStrdec d,
+				    fn d => Decs.append (d, elabStrdec d'))
 	      | Strdec.Seq ds => (* rule 60 *)
 		   List.fold
 		   (ds, Decs.empty, fn (d, decs) =>



1.3       +12 -3     mlton/mlton/elaborate/elaborate.sig

Index: elaborate.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- elaborate.sig	10 Apr 2002 07:02:20 -0000	1.2
+++ elaborate.sig	9 Oct 2003 18:17:33 -0000	1.3
@@ -12,14 +12,23 @@
    sig
       structure Ast: AST
       structure CoreML: CORE_ML
-      sharing Ast = CoreML.Ast
+      structure TypeEnv: TYPE_ENV
+      sharing Ast.Record = CoreML.Record
+      sharing Ast.SortedRecord = CoreML.SortedRecord
+      sharing Ast.Tyvar = CoreML.Tyvar
+      sharing CoreML.Atoms = TypeEnv.Atoms
+      sharing CoreML.Type = TypeEnv.Type
    end
 
 signature ELABORATE = 
    sig
       include ELABORATE_STRUCTS
+
+      structure ConstType: CONST_TYPE
       structure Decs: DECS
       structure Env: ELABORATE_ENV
-	 
-      val elaborateProgram: Ast.Program.t * Env.t -> Decs.t
+
+      val elaborateProgram:
+	 Ast.Program.t * Env.t * (string * ConstType.t -> CoreML.Const.t)
+	 -> Decs.t
    end



1.2       +18 -22    mlton/mlton/elaborate/scope.fun

Index: scope.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/scope.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- scope.fun	21 Jul 2003 21:53:50 -0000	1.1
+++ scope.fun	9 Oct 2003 18:17:33 -0000	1.2
@@ -177,8 +177,7 @@
 				      fixop = fixop,
 				      pat = pat,
 				      var = var})
-		   | List ps => do1 (loops (Vector.fromList ps, loop),
-				     fn ps => List (Vector.toList ps))
+		   | List ps => do1 (loops (ps, loop), List)
 		   | Record {flexible, items} =>
 			let
 			   val (items, u) =
@@ -298,7 +297,7 @@
 		  let
 		     val (down, finish) = bind' (down, tyvars)
 		     val (decs, u) =
-			loops (decs, fn {clauses, filePos} =>
+			loops (decs, fn clauses =>
 			       let
 				  val (clauses, u) =
 				     loops
@@ -317,9 +316,7 @@
 					  combineUp (u, combineUp (u', u'')))
 				      end)
 				 in
-				    ({clauses = clauses,
-				      filePos = filePos},
-				     u)
+				    (clauses, u)
 				 end)
 		     val (tyvars, u) = finish u
 		  in
@@ -328,7 +325,14 @@
 	     | Local (d, d') =>
 		  do2 (loopDec (d, down), loopDec (d', down), Local)
 	     | Open _ => empty ()
-	     | Overload _ => empty ()
+	     | Overload (x, tyvars, ty, ys) =>
+		  let
+		     val (down, finish) = bind' (down, tyvars)
+		     val (ty, up) = loopTy (ty, down)
+		     val (tyvars, up) = finish up
+		  in
+		     (doit (Overload (x, tyvars, ty, ys)), up)
+		  end
 	     | SeqDec ds => doVec (ds, SeqDec)
 	     | Type tb => do1 (loopTypBind (tb, down), Type)
 	     | Val {rvbs, tyvars, vbs} =>
@@ -345,13 +349,12 @@
 				   combineUp (u, u'))
 			       end)
 		     val (vbs, u') =
-			loops (vbs, fn {exp, filePos, pat} =>
+			loops (vbs, fn {exp, pat} =>
 			       let
 				  val (exp, u) = loopExp (exp, down)
 				  val (pat, u') = loopPat (pat, down)
 			       in
 				  ({exp = exp,
-				    filePos = filePos,
 				    pat = pat},
 				   combineUp (u, u'))
 			       end)
@@ -385,13 +388,6 @@
 		     in
 			(doit (f es), u)
 		     end
-		  fun doList (es: Exp.t list, f: Exp.t list -> Exp.node)
-		     : Exp.t * 'up =
-		     let
-			val (es, u) = loops (Vector.fromList es, loop)
-		     in
-			(doit (f (Vector.toList es)), u)
-		     end
 	       in
 		  case Exp.node e of
 		     Andalso (e1, e2) => do2 (loop e1, loop e2, Andalso)
@@ -404,16 +400,14 @@
 		   | Handle (e, m) => do2 (loop e, loopMatch m, Handle)
 		   | If (e1, e2, e3) => do3 (loop e1, loop e2, loop e3, If)
 		   | Let (dec, e) => do2 (loopDec (dec, d), loop e, Let)
-		   | List ts => doList (ts, List)
+		   | List ts => doVec (ts, List)
 		   | Orelse (e1, e2) => do2 (loop e1, loop e2, Orelse)
 		   | Prim {kind, name, ty} =>
 			do1 (loopTy (ty, d), fn ty =>
 			     Prim {kind = kind,
 				   name = name,
 				   ty = ty})
-		   | Raise {exn, filePos} =>
-			do1 (loop exn,
-			     fn exn => Raise {exn = exn, filePos = filePos})
+		   | Raise exn => do1 (loop exn, Raise)
 		   | Record r =>
 			let
 			   val (r, u) = Record.change (r, fn es =>
@@ -431,8 +425,9 @@
 	 in
 	    loop e
 	 end
-      and loopMatch (Match.T {filePos, rules}, d) =
+      and loopMatch (m, d) =
 	 let
+	    val (Match.T rules, region) = Match.dest m
 	    val (rules, u) =
 	       loops (rules, fn (p, e) =>
 		      let
@@ -442,7 +437,8 @@
 			 ((p, e), combineUp (u, u'))
 		      end)
 	 in
-	    (Match.T {filePos = filePos, rules = rules}, u)
+	    (Match.makeRegion (Match.T rules, region),
+	     u)
 	 end
    in
       loopDec (d, initDown)



1.4       +6 -2      mlton/mlton/elaborate/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/sources.cm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- sources.cm	21 Jul 2003 21:53:50 -0000	1.3
+++ sources.cm	9 Oct 2003 18:17:33 -0000	1.4
@@ -7,9 +7,11 @@
  *)
 Group
 
+signature CONST_TYPE
 signature ELABORATE
 functor Elaborate
-   
+functor TypeEnv
+
 is
 
 ../ast/sources.cm
@@ -18,7 +20,7 @@
 ../core-ml/sources.cm
 ../../lib/mlton/sources.cm
 
-
+const-type.sig
 decs.fun
 decs.sig
 elaborate-core.fun
@@ -33,3 +35,5 @@
 precedence-parse.sig
 scope.fun
 scope.sig
+type-env.fun
+type-env.sig



1.1                  mlton/mlton/elaborate/const-type.sig

Index: const-type.sig
===================================================================
signature CONST_TYPE =
   sig
      datatype t = Bool | Int | Real | String | Word

      val toString: t -> string
   end



1.1                  mlton/mlton/elaborate/type-env.fun

Index: type-env.fun
===================================================================
(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 * Copyright (C) 1997-1999 NEC Research Institute.
 *
 * MLton is released under the GNU General Public License (GPL).
 * Please see the file MLton-LICENSE for license information.
 *)
functor TypeEnv (S: TYPE_ENV_STRUCTS): TYPE_ENV =
struct

open S

structure Field = Record.Field
structure Srecord = SortedRecord
structure Set = DisjointSet

(*
 * Keep a clock so that when we need to generalize a type we can tell which
 * unknowns were created in the expression being generalized.
 *
 * Keep track of all unknowns and the time allocated. 
 *
 * Unify should always keep the older unknown.
 *
 * If they are unknowns since the clock, they may be generalized.
 *
 * For type variables, keep track of the time that they need to be generalized
 * at.  If they are ever unified with an unknown of an earlier time, then
 * they can't be generalized.
 *)
structure Time:>
   sig
      type t

      val <= : t * t -> bool
      val equals: t * t -> bool
      val min: t * t -> t
      val layout: t -> Layout.t
      val now: unit -> t
      val tick: unit -> t
   end =
   struct
      type t = int

      val equals = op =
	 
      val min = Int.min

      val op <= = Int.<=

      val layout = Int.layout

      val clock: t ref = ref 0

      fun now () = !clock

      fun tick () = (clock := 1 + !clock
		     ; !clock)
   end
   
structure Unknown =
   struct
      datatype t = T of {canGeneralize: bool,
			 equality: bool,
			 id: int,
			 time: Time.t ref}

      local
	 fun make f (T r) = f r
      in
	 val time = ! o (make #time)
      end

      fun layout (T {canGeneralize, id, time, ...}) =
	 let
	    open Layout
	 in
	    seq [str "Unknown ",
		 record [("canGeneralize", Bool.layout canGeneralize),
			 ("id", Int.layout id),
			 ("time", Time.layout (!time))]]
	 end

      fun minTime (u as T {time, ...}, t) =
	 if Time.<= (!time, t)
	    then ()
	 else time := t

      fun layoutPretty (T {id, ...}) =
	 let
	    open Layout
	 in
	    seq [str "'a", Int.layout id]
	 end

      val toString = Layout.toString o layoutPretty
      
      local
	 val r: int ref = ref 0
      in
	 fun newId () = (Int.inc r; !r)
      end

      fun new {canGeneralize, equality} =
	 T {canGeneralize = canGeneralize,
	    equality = equality,
	    id = newId (),
	    time = ref (Time.now ())}

      fun join (T r, T r'): t =
	 T {canGeneralize = #canGeneralize r andalso #canGeneralize r',
	    equality = #equality r andalso #equality r',
	    id = newId (),
	    time = ref (Time.min (! (#time r), ! (#time r')))}
   end

(* Flexible record spine, i.e. a possibly extensible list of fields. *)
structure Spine:
   sig
      type t

      val canAddFields: t -> bool
      val empty: unit -> t
      val equals: t * t -> bool
      val fields: t -> Field.t list
      (* ensureField checks if field is there.  If it is not, then ensureField
       * will add it unless no more fields are allowed in the spine.
       * It returns true iff it succeeds.
       *)
      val ensureField: t * Field.t -> bool
      val foldOverNew: t * (Field.t * 'a) list * 'b * (Field.t * 'b -> 'b) -> 'b
      val layout: t -> Layout.t
      val new: Field.t list -> t
      val noMoreFields: t -> unit
      (* Unify returns the fields that are in each spine but not in the other.
       *)
      val unify: t * t -> unit
   end =
   struct
      datatype t = T of {fields: Field.t list ref,
			 more: bool ref} Set.t

      fun new fields = T (Set.singleton {fields = ref fields,
					 more = ref true})

      fun equals (T s, T s') = Set.equals (s, s')

      fun empty () = new []

      fun layout (T s) =
	 let
	    val {fields, more} = Set.value s
	 in
	    Layout.record [("fields", List.layout Field.layout (!fields)),
			   ("more", Bool.layout (!more))]
	 end

      fun canAddFields (T s) = ! (#more (Set.value s))
      fun fields (T s) = ! (#fields (Set.value s))

      fun ensureFieldValue ({fields, more}, f) =
	 List.contains (!fields, f, Field.equals)
	 orelse (!more andalso (List.push (fields, f); true))

      fun ensureField (T s, f) = ensureFieldValue (Set.value s, f)

      fun noMoreFields (T s) = #more (Set.value s) := false

      fun unify (T s, T s') =
	 let
	    val {fields = fs, more = m} = Set.value s
	    val {more = m', ...} = Set.value s'
	    val _ = Set.union (s, s')
	    val _ = Set.setValue (s, {fields = fs, more = ref (!m andalso !m')})
	 in
	    ()
	 end

      fun foldOverNew (spine: t, fs, ac, g) =
	 List.fold
	 (fields spine, ac, fn (f, ac) =>
	  if List.exists (fs, fn (f', _) => Field.equals (f, f'))
	     then ac
	  else g (f, ac))
   end

val {get = tyvarTime: Tyvar.t -> Time.t ref, ...} =
   Property.get (Tyvar.plist, Property.initFun (fn _ => ref (Time.now ())))

structure Type =
   struct
      (* Tuples of length <> 1 are always represented as records.
       * There will never be tuples of length one.
       *)
      datatype t = T of {ty: ty,
			 plist: PropertyList.t} Set.t
      and ty =
	 Con of Tycon.t * t vector
	| FlexRecord of {fields: fields,
			 spine: Spine.t,
			 time: Time.t ref}
	(* GenFlexRecord only appears in type schemes.
	 * It will never be unified.
	 * The fields that are filled in after generalization are stored in
	 * extra.
	 *)
	| GenFlexRecord of genFlexRecord
	| Int (* an unresolved int type *)
	| Real (* an unresolved real type *)
	| Record of t Srecord.t
	| Unknown of Unknown.t
	| Var of Tyvar.t
	| Word (* an unresolved word type *)
      withtype fields = (Field.t * t) list
      and genFlexRecord =
	 {extra: unit -> {field: Field.t,
			  tyvar: Tyvar.t} list,
	  fields: (Field.t * t) list,
	  spine: Spine.t}
 
      val freeFlexes: t list ref = ref []
      val freeUnknowns: t list ref = ref []

      local
	 fun make f (T s) = f (Set.value s)
      in
	 val toType: t -> ty = make #ty
	 val plist: t -> PropertyList.t = make #plist
      end

      local
	 open Layout
      in
	 fun layoutFields fs =
	    List.layout (Layout.tuple2 (Field.layout, layout)) fs
	 and layout ty =
	    case toType ty of
	       Con (c, ts) =>
		  paren (align [seq [str "Con ", Tycon.layout c],
				Vector.layout layout ts])
	     | FlexRecord {fields, spine, time} =>
		  seq [str "Flex ",
		       record [("fields", layoutFields fields),
			       ("spine", Spine.layout spine),
			       ("time", Time.layout (!time))]]
	     | GenFlexRecord {fields, spine, ...} =>
		  seq [str "GenFlex ",
		       record [("fields", layoutFields fields),
			       ("spine", Spine.layout spine)]]
	     | Int => str "Int"
	     | Real => str "Real"
	     | Record r => Srecord.layout {record = r,
					   separator = ": ",
					   extra = "",
					   layoutTuple = Vector.layout layout,
					   layoutElt = layout}
	     | Unknown u => Unknown.layout u
	     | Var a => paren (seq [str "Var ", Tyvar.layout a])
	     | Word => str "Word"
      end

      val toString = Layout.toString o layout

      fun union (T s, T s') = Set.union (s, s')

      fun set (T s, v) = Set.setValue (s, v)
	 
      fun makeHom {con, flexRecord, genFlexRecord, int, real,
		   record, recursive, unknown, var, word} =
	 let
	    datatype status = Processing | Seen | Unseen
	    val {destroy = destroyStatus, get = status, ...} =
	       Property.destGet (plist, Property.initFun (fn _ => ref Unseen))
	    val {get, destroy = destroyProp} =
	       Property.destGet
	       (plist,
		Property.initRec
		(fn (t, get) =>
		 let
		    val r = status t
		 in
		    case !r of
		       Seen => Error.bug "impossible"
		     | Processing => recursive t
		     | Unseen =>
			  let
			     val _ = r := Processing
			     fun loopFields fields =
				List.revMap (fields, fn (f, t) => (f, get t))
			     val res = 
				case toType t of
				   Con (c, ts) =>
				      con (t, c, Vector.map (ts, get))
				 | Int => int t
				 | FlexRecord {fields, spine, time} =>
				      flexRecord (t, {fields = loopFields fields,
						      spine = spine,
						      time = time})
				 | GenFlexRecord {extra, fields, spine} =>
				      genFlexRecord
				      (t, {extra = extra,
					   fields = loopFields fields,
					   spine = spine})
				 | Real => real t
				 | Record r => record (t, Srecord.map (r, get))
				 | Unknown u => unknown (t, u)
				 | Var a => var (t, a)
				 | Word => word t
			     val _ = r := Seen
			  in
			     res
			  end
		 end))
	    fun destroy () =
	       (destroyStatus ()
		; destroyProp ())
	 in
	    {hom = get, destroy = destroy}
	 end

      fun hom (ty, z) =
	 let
	    val {hom, destroy} = makeHom z
	 in
	    hom ty before destroy ()
	 end

      fun layoutPretty (t: t): Layout.t =
	 let
	    open Layout
	    fun recordType (l: (Layout.t * (bool * Layout.t)) list)
	       : bool * Layout.t =
	       (false,
		seq [str "{",
		     mayAlign (separateRight
			       (List.map (l, fn (f, (_, t)) =>
					  seq [f, str ": ", t]),
				",")),
		     str "}"])
	    fun maybeParen (b, t) = if b then paren t else t
	    fun con (_, c, ts) =
	       let
		  val c' = str (Tycon.originalName c)
		  fun t n = maybeParen (Vector.sub (ts, n))
	       in
		  case Vector.length ts of
		     0 => (false, c')
		   | 1 => (false, seq [t 0, str " ", c'])
		   | _ => 
			if Tycon.equals (c, Tycon.arrow)
			   then (true, mayAlign [t 0, seq [str "-> ", t 1]])
			else (true, seq [Vector.layout #2 ts,
					 str " ", c'])
	       end
	    fun int _ = (false, str "int")
	    fun flexRecord (_, {fields, spine, time}) =
	       recordType
	       (List.fold
		(fields,
		 Spine.foldOverNew (spine, fields, [], fn (f, ac) =>
				    (Field.layout f, (false, str "unit"))
				    :: ac),
		 fn ((f, t), ac) => (Field.layout f, t) :: ac))
	    fun genFlexRecord (_, {extra, fields, spine}) =
	       recordType
	       (List.fold
		(fields,
		 List.revMap (extra (), fn {field, tyvar} =>
			      (Field.layout field, (false, Tyvar.layout tyvar))),
		 fn ((f, t), ac) =>
		 (Field.layout f, t) :: ac))
	    fun real _ = (false, str "real")
	    fun record (_, r) =
	       (false,
		Srecord.layout
		{record = r,
		 separator = ": ",
		 extra = "",
		 layoutTuple = (fn ts =>
				if 0 = Vector.length ts
				   then str "unit"
				else
				   paren (seq (separate (Vector.toListMap
							 (ts, maybeParen),
							 " * ")))),
		 layoutElt = #2})
	    fun recursive _ = (false, str "<recur>")
	    fun unknown (_, u) = (false, str "???")
	    fun var (_, a) = (false, Tyvar.layout a)
	    fun word _ = (false, str "word")
	 in
	    #2 (hom (t, {con = con,
			 flexRecord = flexRecord,
			 genFlexRecord = genFlexRecord,
			 int = int,
			 real = real,
			 record = record,
			 recursive = recursive,
			 unknown = unknown,
			 var = var,
			 word = word}))
	 end

      fun deConOpt t =
	 case toType t of
	    Con x => SOME x
	  | _ => NONE

      fun newTy (ty: ty): t =
	 T (Set.singleton {ty = ty,
			   plist = PropertyList.new ()})

      fun new z =
	 let
	    val t = newTy (Unknown (Unknown.new z))
	    val _ = List.push (freeUnknowns, t)
	 in
	    t
	 end

      fun flexRecord record =
	 let
	    val v = Srecord.toVector record
	    val spine = Spine.new (Vector.toListMap (v, #1))
	    fun isResolved (): bool = not (Spine.canAddFields spine)
	    val t =
	       newTy (FlexRecord {fields = Vector.toList v,
				  spine = spine,
				  time = ref (Time.now ())})
	    val _ = List.push (freeFlexes, t)
	 in
	    (t, isResolved)
	 end
	 
      val record = newTy o Record

      fun tuple ts =
	 if 1 = Vector.length ts
	    then Vector.sub (ts, 0)
	 else newTy (Record (Srecord.tuple ts))

      fun con (tycon, ts) =
	 if Tycon.equals (tycon, Tycon.tuple) then tuple ts
	 else newTy (Con (tycon, ts))

      val char = con (Tycon.char, Vector.new0 ())
      val string = con (Tycon.vector, Vector.new1 char)

      val var = newTy o Var
   end

structure Ops = TypeOps (structure IntSize = IntSize
			 structure Tycon = Tycon
			 structure WordSize = WordSize
			 open Type)

local
   open Layout
in
   val unusual =
      [(Tycon.arrow, "(_ -> _)")]
   fun layoutTycon (c: Tycon.t, arity: int): Layout.t =
      case List.peek (unusual, fn (c', _) => Tycon.equals (c, c')) of
	 NONE => if arity = 0
		    then Tycon.layout c
		 else seq [str "_ ", Tycon.layout c]
       | SOME (_, s) => str s
   val dontCare = str "_"
   fun layoutRecord (ds: (Field.t * Layout.t) list) =
      seq [str "{",
	   seq (separate
		(List.map
		 (QuickSort.sortList (ds, fn ((f, _), (f', _)) =>
				      Field.<= (f, f')),
		  fn (f, l) => seq [Field.layout f, str " = ", l]),
		 ", ")),
	   str ", ...}"]
   fun layoutTuple (ls: Layout.t vector) =
      paren (seq (separate (Vector.toList ls, " * ")))
   fun layoutTopLevel t =
      let
	 datatype z = datatype Type.ty
      in
	 case t of
	    Con (c, ts) => layoutTycon (c, Vector.length ts)
	  | FlexRecord _ => str "{_}"
	  | GenFlexRecord _ => str "{_}"
	  | Int => str "int"
	  | Real => str "real"
	  | Record r =>
	       (case Srecord.detupleOpt r of
		   NONE => str "{_}"
		 | SOME ts => layoutTuple (Vector.map (ts, fn _ => dontCare)))
	  | Unknown _ => Error.bug "layoutTopLevel Unknown"
	  | Var a => Tyvar.layout a
	  | Word => str "word"
      end
end
   
structure Type =
   struct
      (* Order is important, since want specialized definitions in Type to
       * override general definitions in Ops.
       *)
      open Ops Type

      val char = con (Tycon.char, Vector.new0 ())
	 
      val unit = tuple (Vector.new0 ())

      fun isUnit t =
	 case toType t of
	    Record r =>
	       (case Srecord.detupleOpt r of
		   NONE => false
		 | SOME v => 0 = Vector.length v)
	  | _ => false

      val equals: t * t -> bool = fn (T s, T s') => Set.equals (s, s')

      local
	 fun make ty () = newTy ty
      in
	 val unresolvedInt = make Int
	 val unresolvedReal = make Real
	 val unresolvedWord = make Word
      end
   
      val traceCanUnify =
	 Trace.trace2 ("canUnify", layout, layout, Bool.layout)

      fun canUnify arg = 
	 traceCanUnify
	 (fn (t, t') =>
	  case (toType t, toType t') of
	     (Unknown _,  _) => true
	   | (_, Unknown _) => true
	   | (Con (c, ts), t') => conAnd (c, ts, t')
	   | (t', Con (c, ts)) => conAnd (c, ts, t')
	   | (Int, Int) => true
	   | (Real, Real) => true
	   | (Record r, Record r') =>
		let
		   val fs = Srecord.toVector r
		   val fs' = Srecord.toVector r'
		in Vector.length fs = Vector.length fs'
		   andalso Vector.forall2 (fs, fs', fn ((f, t), (f', t')) =>
					   Field.equals (f, f')
					   andalso canUnify (t, t'))
		end
	   | (Var a, Var a') => Tyvar.equals (a, a')
	   | (Word, Word) => true
	   | _ => false) arg
      and conAnd (c, ts, t') =
	 case t' of
	    Con (c', ts') =>
	       Tycon.equals (c, c')
	       andalso Vector.forall2 (ts, ts', canUnify)
	  | Int => 0 = Vector.length ts andalso Tycon.isIntX c
	  | Real => 0 = Vector.length ts andalso Tycon.isRealX c
	  | Word => 0 = Vector.length ts andalso Tycon.isWordX c
	  | _ => false

      fun minTime (t, time) =
	 let
	    fun doit r = r := Time.min (!r, time)
	    fun var (_, a) = doit (tyvarTime a)
	    val {destroy, hom} =
	       makeHom
	       {con = fn _ => (),
		flexRecord = fn (_, {time = r, ...}) => doit r,
		genFlexRecord = fn _ => (),
		int = fn _ => (),
		real = fn _ => (),
		record = fn _ => (),
		recursive = fn _ => (),
		unknown = fn (_, u) => Unknown.minTime (u, time),
		var = var,
		word = fn _ => ()}
	    val _ = hom t
	    val _ = destroy ()
	 in
	    ()
	 end

      structure UnifyResult =
	 struct
	    datatype t =
	       NotUnifiable of Layout.t * Layout.t
	     | Unified

	    val layout =
	       let
		  open Layout
	       in
		  fn NotUnifiable _ => str "NotUnifiable"
		   | Unified => str "Unified"
	       end
	 end

      datatype unifyResult = datatype UnifyResult.t
	 
      val traceUnify = Trace.trace2 ("unify", layout, layout, UnifyResult.layout)

      fun unify (t, t'): unifyResult =
	 let
	    fun unify arg =
	       traceUnify
	       (fn (outer as T s, outer' as T s') =>
		if Set.equals (s, s')
		   then Unified
		else
		   let
		      fun notUnifiable (l, l') =
			 (NotUnifiable (l, l'),
			  Unknown (Unknown.new {canGeneralize = true,
						equality = true}))
		      fun oneFlex ({fields, spine, time}, r, outer) =
			 let
			    val _ = minTime (outer, !time)
			    val differences =
			       List.fold
			       (fields, ([], []), fn ((f, t), (ac, ac')) =>
				case Srecord.peek (r, f) of
				   NONE => ((f, dontCare) :: ac, ac')
				 | SOME t' =>
				      case unify (t, t') of
					 NotUnifiable (l, l') =>
					    ((f, l) :: ac, (f, l') :: ac')
				       | Unified => (ac, ac'))
			    val differences =
			       List.fold
			       (Spine.fields spine, differences,
				fn (f, (ac, ac')) =>
				case Srecord.peek (r, f) of
				   NONE => ((f, dontCare) :: ac, ac')
				 | SOME _ => (ac, ac'))
			    val differences =
			       Srecord.foldi
			       (r, differences, fn (f, t, (ac, ac')) =>
				let
				   val ac' =
				      if Spine.ensureField (spine, f)
					 then ac'
				      else (f, dontCare) :: ac'
				in
				   case List.peek (fields, fn (f', _) =>
						   Field.equals (f, f')) of
				      NONE => (ac, ac')
				    | SOME (_, t') =>
					 case unify (t, t') of
					    NotUnifiable (l, l') =>
					       ((f, l') :: ac, (f, l) :: ac')
					  | Unified => (ac, ac')
				end)
			    val _ = Spine.noMoreFields spine
			 in
			    case differences of
			       ([], []) => (Unified, Record r)
			     | (ds, ds') =>
				  notUnifiable (layoutRecord ds,
						layoutRecord ds')
			 end
		      fun genFlexError () =
			 Error.bug "GenFlexRecord seen in unify"
		      val {ty = t, plist} = Set.value s
		      val {ty = t', ...} = Set.value s'
		      fun not () =
			 notUnifiable (layoutTopLevel t, layoutTopLevel t')
		      fun conAnd (c, ts, t, t') =
			 let
			    fun lay () = layoutTycon (c, Vector.length ts)
			 in
			    case t of
			       Con (c', ts') =>
				  if Tycon.equals (c, c')
				     then
					if Vector.length ts <> Vector.length ts'
					   then
					      let
						 fun lay ts =
						    Layout.seq
						    [Layout.str
						     (concat ["<",
							      Int.toString
							      (Vector.length ts),
							      " args> "]),
						     Tycon.layout c]
					      in
						 notUnifiable (lay ts, lay ts')
					      end
					else
					   let
					      val us =
						 Vector.map2 (ts, ts', unify)
					   in
					      if Vector.forall
						 (us,
						  fn Unified => true
						   | _ => false)
						 then (Unified, t)
					      else
						 let
						    val (ls, ls') =
						       Vector.unzip
						       (Vector.map
							(us,
							 fn Unified =>
							    (dontCare,
							     dontCare)
							  | NotUnifiable (l, l') =>
							       (l, l')))
						    fun lay ls =
						       let
							  open Layout
						       in
							  if Tycon.equals (c, Tycon.arrow)
							     then
								paren
								(seq [Vector.sub (ls, 0),
								      str " -> ",
								      Vector.sub (ls, 1)])
							  else
							     seq
							     [tuple
							      (Vector.toList ls),
							      str " ",
							      Tycon.layout c]
						       end
						 in
						    notUnifiable (lay ls,
								  lay ls')
						 end
					   end
				  else not ()
			     | Int =>
				  if Tycon.isIntX c andalso Vector.isEmpty ts
				     then (Unified, t')
				  else not ()
			     | Real =>
				  if Tycon.isRealX c andalso Vector.isEmpty ts
				     then (Unified, t')
				  else not ()
			     | Word =>
				  if Tycon.isWordX c andalso Vector.isEmpty ts
				     then (Unified, t')
				  else not ()
			     | _ => not ()
			 end
		      fun oneUnknown (u, t, outer) =
			 let
			    val _ = minTime (outer, Unknown.time u)
			 in
			    (Unified, t)
			 end
		      fun swap (res, t) =
			 case res of
			    NotUnifiable (l, l') => (NotUnifiable (l', l), t)
			  | Unified => (Unified, t)
		      val (res, t) =
			 case (t, t') of
			    (Unknown r, Unknown r') =>
			       (Unified, Unknown (Unknown.join (r, r')))
			  | (_, Unknown u) => oneUnknown (u, t, outer)
			  | (Unknown u, _) => oneUnknown (u, t', outer')
			  | (Con (c, ts), _) => conAnd (c, ts, t', t)
			  | (_, Con (c, ts)) => swap (conAnd (c, ts, t, t'))
			  | (FlexRecord f, Record r) => oneFlex (f, r, outer')
			  | (Record r, FlexRecord f) =>
			       swap (oneFlex (f, r, outer))
			  | (FlexRecord {fields = fields, spine = s, time = t},
			     FlexRecord {fields = fields', spine = s',
					 time = t', ...}) =>
			       let
				  fun subsetSpine (fields, spine, spine') =
				     List.fold
				     (Spine.fields spine, [], fn (f, ac) =>
				      if List.exists (fields, fn (f', _) =>
						      Field.equals (f, f'))
					 orelse Spine.ensureField (spine', f)
					 then ac
				      else (f, dontCare) :: ac)
				  val ac = subsetSpine (fields, s, s')
				  val ac' = subsetSpine (fields', s', s)
				  fun subset (fields, fields', spine', ac, ac') =
				     List.fold
				     (fields, (ac, ac'),
				      fn ((f, t), (ac, ac')) =>
				      case List.peek (fields', fn (f', _) =>
						      Field.equals (f, f')) of
					 NONE =>
					    if Spine.ensureField (spine', f)
					       then (ac, ac')
					    else ((f, dontCare) :: ac, ac')
				       | SOME (_, t') =>
					    case unify (t, t') of
					       NotUnifiable (l, l') =>
						  ((f, l) :: ac, (f, l) :: ac')
					     | Unified => (ac, ac'))
				  val (ac, ac') =
				     subset (fields, fields', s', ac, ac')
				  val (ac, ac') =
				     subset (fields', fields, s, [], [])
				  val _ = Spine.unify (s, s')
				  val fields =
				     List.fold
				     (fields, fields', fn ((f, t), ac) =>
				      if List.exists (fields', fn (f', _) =>
						      Field.equals (f, f'))
					 then ac
				      else (f, t) :: ac)
			       in
				  case (ac, ac') of
				     ([], []) =>
					(Unified,
					 FlexRecord
					 {fields = fields,
					  spine = s,
					  time = ref (Time.min (!t, !t'))})
				   | _ =>
					notUnifiable (layoutRecord ac,
						      layoutRecord ac')
			       end
			  | (GenFlexRecord _, _) => genFlexError ()
			  | (_, GenFlexRecord _) => genFlexError ()
			  | (Int, Int) => (Unified, Int)
			  | (Real, Real) => (Unified, Real)
			  | (Record r, Record r') =>
			       (case (Srecord.detupleOpt r,
				      Srecord.detupleOpt r') of
				   (NONE, NONE) =>
				      let
					 fun diffs (r, r', ac, ac') =
					    Vector.fold
					    (Srecord.toVector r, (ac, ac'),
					     fn ((f, t), (ac, ac')) =>
					     case Srecord.peek (r', f) of
						NONE =>
						   ((f, dontCare) :: ac, ac')
					      | SOME t' =>
						   case unify (t, t') of
						      NotUnifiable (l, l') =>
							 ((f, l) :: ac,
							  (f, l') :: ac')
						    | Unified => (ac, ac'))
					 val (ac, ac') = diffs (r, r', [], [])
					 val (ac', ac) = diffs (r', r, ac', ac)
				      in
					 case (ac, ac') of
					    ([], []) =>
					       (Unified, Record r)
					  | _ =>
					       notUnifiable (layoutRecord ac,
							     layoutRecord ac')
				      end
				 | (SOME ts, SOME ts') =>
				      if Vector.length ts = Vector.length ts'
					 then
					    let
					       val us =
						  Vector.map2 (ts, ts', unify)
					    in
					       if Vector.forall
						  (us,
						   fn Unified => true
						    | _ => false)
						  then (Unified, Record r)
					       else
						  let
						     val (ls, ls') =
							Vector.unzip
							(Vector.map
							 (us,
							  fn Unified =>
							        (dontCare,
								 dontCare)
							   | NotUnifiable (l, l') =>
								(l, l')))
						  in
						     notUnifiable
						     (layoutTuple ls,
						      layoutTuple ls')
						  end
					    end
				      else not ()
				 | _ => not ())
			  | (Var a, Var a') =>
			       if Tyvar.equals (a, a')
				  then (Unified, t)
			       else not ()
			  | (Word, Word) => (Unified, Word)
			  | _ => not ()
		      val _ = Set.union (s, s')
		      val _ = Set.setValue (s, {ty = t, plist = plist})
		   in
		      res
		   end) arg
	 in
	    unify (t, t')
	 end

      val word8 = word WordSize.W8
	 
      fun 'a simpleHom {con: t * Tycon.t * 'a vector -> 'a,
			record: t * (Field.t * 'a) vector -> 'a,
			var: t * Tyvar.t -> 'a} =
	 let
	    val con =
	       fn (t, c, ts) =>
	       if Tycon.equals (c, Tycon.char)
		  then con (word8, Tycon.word WordSize.W8, Vector.new0 ())
	       else con (t, c, ts)
	    val unit = con (unit, Tycon.tuple, Vector.new0 ())
	    val unknown = unit
	    fun sortFields (fields: (Field.t * 'a) list) =
	       Array.toVector
	       (QuickSort.sortArray
		(Array.fromList fields, fn ((f, _), (f', _)) =>
		 Field.<= (f, f')))
	    fun unsorted (t, fields: (Field.t *  'a) list) =
	       let
		  val v = sortFields fields
	       in
		  record (t, v)
	       end
	    fun genFlexRecord (t, {extra, fields, spine}) =
	       unsorted (t,
			 List.fold
			 (extra (), fields, fn ({field, tyvar}, ac) =>
			  (field, var (Type.var tyvar, tyvar)) :: ac))
	    fun flexRecord (t, {fields, spine, time}) =
	       if Spine.canAddFields spine
		  then Error.bug "Type.hom flexRecord"
	       else unsorted (t,
			      Spine.foldOverNew
			      (spine, fields, fields, fn (f, ac) =>
			       (f, unit) :: ac))
	    fun recursive t = Error.bug "Type.hom recursive"
	    val int =
	       con (int IntSize.default, Tycon.defaultInt, Vector.new0 ())
	    val real =
	       con (real RealSize.default, Tycon.defaultReal, Vector.new0 ())
	    val word =
	       con (word WordSize.default, Tycon.defaultWord, Vector.new0 ())
	    val {hom: t -> 'a, ...} =
	       makeHom {con = con,
			int = fn _ => int,
			flexRecord = flexRecord,
			genFlexRecord = genFlexRecord,
			real = fn _ => real,
			record = fn (t, r) => record (t, Srecord.toVector r),
			recursive = recursive,
			unknown = fn _ => unknown,
			var = var,
			word = fn _ => word}
	 in
	    hom
	 end
   end

structure InferScheme =
   struct
      datatype t =
	 General of {bound: unit -> Tyvar.t vector,
		     canGeneralize: bool,
		     flexes: Type.genFlexRecord list,
		     tyvars: Tyvar.t vector,
		     ty: Type.t}
       | Type of Type.t
      
      fun layout s =
	 case s of
	    Type t => Type.layout t
	  | General {canGeneralize, tyvars, ty, ...} =>
	       Layout.record [("canGeneralize", Bool.layout canGeneralize),
			      ("tyvars", Vector.layout Tyvar.layout tyvars),
			      ("ty", Type.layout ty)]

      fun layoutPretty s =
	 case s of
	    Type t => Type.layoutPretty t
	  | General {ty, ...} => Type.layoutPretty ty

      val tyvars =
	 fn General {tyvars, ...} => tyvars
	  | Type _ => Vector.new0 ()
	 
      val bound =
	 fn General {bound, ...} => bound ()
	  | Type _ => Vector.new0 ()

      val bound =
	 Trace.trace ("Scheme.bound", layout, Vector.layout Tyvar.layout)
	 bound

      val ty =
	 fn General {ty, ...} => ty
	  | Type ty => ty

      fun make {canGeneralize, tyvars, ty} =
	 if 0 = Vector.length tyvars
	    then Type ty
	 else General {bound = fn () => tyvars,
		       canGeneralize = canGeneralize,
		       flexes = [],
		       tyvars = tyvars,
		       ty = ty}

      val fromType = Type

      fun instantiate (t: t, subst) =
	 case t of
	    Type ty => {args = fn () => Vector.new0 (),
			instance = ty}
	  | General {canGeneralize, flexes, tyvars, ty, ...} =>
	       let
		  open Type
		  val {destroy = destroyTyvarInst,
		       get = tyvarInst: Tyvar.t -> Type.t option,
		       set = setTyvarInst} =
		     Property.destGetSetOnce (Tyvar.plist,
					      Property.initConst NONE)
		  val types =
		     Vector.mapi
		     (tyvars, fn (i, a) =>
		      let
			 val t = subst {canGeneralize = canGeneralize,
					equality = Tyvar.isEquality a,
					index = i}
			 val _ = setTyvarInst (a, SOME t)
		      in
			 t
		      end)
		  type z = {isNew: bool, ty: Type.t}
		  fun isNew {isNew = b, ty} = b
		  fun keep ty = {isNew = false, ty = ty}
		  fun con (ty, c, zs) =
		     if Vector.exists (zs, isNew)
			then {isNew = true,
			      ty = newTy (Con (c, Vector.map (zs, #ty)))}
		     else keep ty
		  val flexInsts = ref []
		  fun genFlexRecord (t, {extra, fields, spine}) =
		     let
			val fields = List.revMap (fields, fn (f, t: z) =>
						  (f, #ty t))
			val flex = newTy (FlexRecord {fields = fields,
						      spine = spine,
						      time = ref (Time.now ())})
			val _ = List.push (flexInsts, {spine = spine,
						       flex = flex})
		     in
			{isNew = true,
			 ty = flex}
		     end
		  fun record (t, r) =
		     if Srecord.exists (r, isNew)
			then {isNew = true,
			      ty = newTy (Record (Srecord.map (r, #ty)))}
		     else keep t
		  fun recursive t =
		     if true
			then Error.bug "instantiating recursive type"
		     else
			{isNew = true,
			 ty = new {canGeneralize = true,
				   equality = true}}
		  fun var (ty, a) =
		     case tyvarInst a of
			NONE => {isNew = false, ty = ty}
		      | SOME ty => {isNew = true, ty = ty}
		  val {ty: Type.t, ...} =
		     Type.hom (ty, {con = con,
				    int = keep,
				    flexRecord = keep o #1,
				    genFlexRecord = genFlexRecord,
				    real = keep,
				    record = record,
				    recursive = recursive,
				    unknown = keep o #1,
				    var = var,
				    word = keep})
		  val _ = destroyTyvarInst ()
		  val flexInsts = !flexInsts
		  fun args (): Type.t vector =
		     Vector.fromList
		     (List.fold
		      (flexes, Vector.toList types,
		       fn ({fields, spine, ...}, ac) =>
		       let
			  val flex =
			     case List.peek (flexInsts,
					     fn {spine = spine', ...} =>
					     Spine.equals (spine, spine')) of
				NONE => Error.bug "missing flexInst"
			      | SOME {flex, ...} => flex
			  fun peekFields (fields, f) =
			     Option.map
			     (List.peek (fields, fn (f', _) =>
					 Field.equals (f, f')),
			      #2)
			  val peek =
			     case Type.toType flex of
				FlexRecord {fields, ...} =>
				   (fn f => peekFields (fields, f))
			      | GenFlexRecord {extra, fields, ...} =>
				   (fn f =>
				    case peekFields (fields, f) of
				       NONE =>
					  Option.map
					  (List.peek
					   (extra (), fn {field, ...} =>
					    Field.equals (f, field)),
					   Type.var o #tyvar)
				     | SOME t => SOME t)
			      | Record r => (fn f => Srecord.peek (r, f))
			      | _ => Error.bug "strange flexInst"
		       in
			  Spine.foldOverNew
			  (spine, fields, ac, fn (f, ac) =>
			   (case peek f of
			       NONE => Type.unit
			     | SOME t => t) :: ac)
		       end))
	       in
		  {args = args,
		   instance = ty}
	       end

      fun apply (s, ts) =
	 #instance (instantiate (s, fn {index, ...} => Vector.sub (ts, index)))
	    			    
      val instantiate =
	 fn s =>
	 instantiate (s, fn {canGeneralize, equality, ...} =>
		      Type.new {canGeneralize = canGeneralize,
				equality = equality})
				
      val instantiate =
	 Trace.trace ("Scheme.instantiate", layout, Type.layout o #instance)
	 instantiate
	 
      fun haveFrees (v: t vector): bool vector =
	 let
	    exception Yes
	    val {destroy, hom} =
	       Type.makeHom {con = fn _ => (),
			     flexRecord = fn _ => (),
			     genFlexRecord = fn _ => (),
			     int = fn _ => (),
			     real = fn _ => (),
			     record = fn _ => (),
			     recursive = fn _ => (),
			     unknown = fn _ => raise Yes,
			     var = fn _ => (),
			     word = fn _ => ()}
	    val res =
	       Vector.map (v, fn s =>
			   let
			      val _ =
				 case s of
				    General {ty, ...} => hom ty
				  | Type ty => hom ty
			   in
			      false
			   end handle Yes => true)
	    val _ = destroy ()
	 in
	    res
	 end
   end

fun close (ensure: Tyvar.t vector, region)
   : Type.t vector -> {bound: unit -> Tyvar.t vector,
		       schemes: InferScheme.t vector} =
   let
      val genTime = Time.tick ()
      val _ = Vector.foreach (ensure, fn a => (tyvarTime a; ()))
   in
      fn tys =>
      let
	 val unable =
	    Vector.keepAll (ensure, fn a =>
			    not (Time.<= (genTime, !(tyvarTime a))))
	 val _ = 
	    if Vector.length unable > 0
	       then
		  let
		     open Layout
		  in
		     Control.error
		     (region,
		      seq [str "unable to generalize ",
			   seq (List.separate (Vector.toListMap (unable,
								 Tyvar.layout),
					       str ", "))],
		      empty)
		  end
	    else ()
	 (* Convert all the unknown types bound at this level into tyvars. *)
	 val (tyvars, ac) =
	    List.fold
	    (!Type.freeUnknowns, (Vector.toList ensure, []),
	     fn (t, (tyvars, ac)) =>
	     case Type.toType t of
		Type.Unknown (Unknown.T {canGeneralize, equality, time, ...}) =>
		   if canGeneralize andalso Time.<= (genTime, !time)
		      then
			 let
			    val a = Tyvar.newNoname {equality = equality}
			    val _ = Type.set (t, {ty = Type.Var a,
						  plist = PropertyList.new ()})
			 in
			    (a :: tyvars, ac)
			 end
		   else (tyvars, t :: ac)
	      | _ => (tyvars, ac))
	 val _ = Type.freeUnknowns := ac
	 (* Convert all the FlexRecords bound at this level into GenFlexRecords.
	  *)
	 val (flexes, ac) =
	    List.fold
	    (!Type.freeFlexes, ([], []), fn (t as Type.T s, (flexes, ac)) =>
	     let
		val {ty, plist} = Set.value s
	     in
		case ty of
		   Type.FlexRecord {fields, spine, time, ...} =>
		      if Time.<= (genTime, !time)
			 then
			    let
			       val extra =
				  Promise.lazy
				  (fn () =>
				   Spine.foldOverNew
				   (spine, fields, [], fn (f, ac) =>
				    {field = f,
				     tyvar = Tyvar.newNoname {equality = false}}
				    :: ac))
			       val gfr = {extra = extra,
					  fields = fields,
					  spine = spine}
			       val _ = 
				  Set.setValue
				  (s, {plist = plist,
				       ty = Type.GenFlexRecord gfr})
			    in
			       (gfr :: flexes, ac)
			    end
		      else (flexes, t :: ac)
                  | _ => (flexes, ac)
	     end)
	 val _ = Type.freeFlexes := ac
	 (* For all fields that were added to the generalized flex records, add
	  * a type variable.
	  *)
	 fun bound () =
	    Vector.fromList
	    (List.fold
	     (flexes, tyvars, fn ({extra, fields, spine}, ac) =>
	      let
		 val extra = extra ()
	      in
		 Spine.foldOverNew
		 (spine, fields, ac, fn (f, ac) =>
		  case List.peek (extra, fn {field, ...} =>
				  Field.equals (f, field)) of
		     NONE => Error.bug "GenFlex missing field"
		   | SOME {tyvar, ...} => tyvar :: ac)
	      end))
	 val schemes =
	    Vector.map
	    (tys, fn ty =>
	     InferScheme.General {bound = bound,
				  canGeneralize = true,
				  flexes = flexes,
				  tyvars = Vector.fromList tyvars,
				  ty = ty})
      in
	 {bound = bound,
	  schemes = schemes}
      end
   end

fun closeTop (r: Region.t): unit =
   let
      val _ =
	 List.foreach
	 (!Type.freeUnknowns, fn t =>
	  case Type.toType t of
	     Type.Unknown _ => (Type.unify (t, Type.unit)
				; ())
	   | _ => ())
      val _ = Type.freeUnknowns := []
      val _ = List.foreach (!Type.freeFlexes, fn t =>
			    case Type.toType t of
 			       Type.FlexRecord _ => Error.bug "free flex\n"
			     | _ => ())
      val _ = Type.freeFlexes := []
   in
      ()
   end

structure Type =
   struct
      open Type

      fun homConVar {con, var} =
	 let
	    fun tuple (t, ts) =
	       if 1 = Vector.length ts
		  then Vector.sub (ts, 0)
	       else con (t, Tycon.tuple, ts)
	 in
	    simpleHom {con = con,
		       record = fn (t, fs) => tuple (t, Vector.map (fs, #2)),
		       var = var}
	 end

      fun hom {con, var} =
	 homConVar {con = fn (_, c, ts) => con (c, ts),
		    var = fn (_, a) => var a}
	 
      fun deRecord t =
	 let
	    val hom =
	       simpleHom
	       {con = fn (t, _, _) => (t, NONE),
		record = fn (t, fs) => (t,
					SOME (Vector.map (fs, fn (f, (t, _)) =>
							  (f, t)))),
		var = fn (t, _) => (t, NONE)}
	 in
	    case #2 (hom t) of
	       NONE => Error.bug "Type.deRecord"
	     | SOME fs => fs
	 end

      fun deTupleOpt t =
	 let
	    val hom =
	       homConVar
	       {con = fn (t, c, ts) => (t,
					if Tycon.equals (c, Tycon.tuple)
					   then SOME (Vector.map (ts, #1))
					else NONE),
                var = fn (t, _) => (t, NONE)}
	 in
	    #2 (hom t)
	 end

      val deTupleOpt =
	 Trace.trace ("Type.deTupleOpt", layout,
		      Option.layout (Vector.layout layout))
	 deTupleOpt

      val deTuple = valOf o deTupleOpt
   end
end



1.1                  mlton/mlton/elaborate/type-env.sig

Index: type-env.sig
===================================================================
(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 * Copyright (C) 1997-1999 NEC Research Institute.
 *
 * MLton is released under the GNU General Public License (GPL).
 * Please see the file MLton-LICENSE for license information.
 *)
type int = Int.t
   
signature TYPE_ENV_STRUCTS = 
   sig
      include ATOMS
   end

signature TYPE_ENV = 
   sig
      include TYPE_ENV_STRUCTS
      structure Type:
	 sig
	    include TYPE_OPS

            (* can two types be unified?  not side-effecting. *)
            val canUnify: t * t -> bool
	    val char: t
	    val deRecord: t -> (Record.Field.t * t) vector
	    val flexRecord: t SortedRecord.t -> t * (unit -> bool)
	    val hom: {con: Tycon.t * 'a vector -> 'a,
		      var: Tyvar.t -> 'a} -> t -> 'a
	    val isUnit: t -> bool
	    val layout: t -> Layout.t
	    val layoutPretty: t -> Layout.t
	    val new: {canGeneralize: bool, equality: bool} -> t
	    val record: t SortedRecord.t -> t
	    val string: t
	    val toString: t -> string
	    (* make two types identical (recursively).  side-effecting. *)
	    datatype unifyResult =
	       NotUnifiable of Layout.t * Layout.t
	     | Unified
	    val unify: t * t -> unifyResult
	    val unresolvedInt: unit -> t
	    val unresolvedReal: unit -> t
	    val unresolvedWord: unit -> t
	    val var: Tyvar.t -> t
	 end
      sharing type Type.intSize = IntSize.t
      sharing type Type.realSize = RealSize.t
      sharing type Type.wordSize = WordSize.t
      sharing type Type.tycon = Tycon.t
      structure InferScheme:
	 sig
	    type t

	    val apply: t * Type.t vector -> Type.t
	    val fromType: Type.t -> t
	    val haveFrees: t vector -> bool vector
	    val instantiate: t -> {args: unit -> Type.t vector,
				   instance: Type.t}
	    val layout: t -> Layout.t
	    val layoutPretty: t -> Layout.t
	    val make: {canGeneralize: bool,
		       ty: Type.t,
		       tyvars: Tyvar.t vector} -> t
	    val ty: t -> Type.t
	 end

      (* close (e, t, ts, r) = {bound, scheme} close type
       * t with respect to environment e, including all the tyvars in ts
       * and ensuring than no tyvar in ts occurs free in e.  bound returns
       * the vector of type variables in t that do not occur in e, which
       * isn't known until all flexible record fields are determined,
       * after unification is complete.
       *)
      val close:
	 Tyvar.t vector * Region.t
	 -> Type.t vector
	 -> {bound: unit -> Tyvar.t vector,
	     schemes: InferScheme.t vector}
      val closeTop: Region.t -> unit
   end

signature INFER_TYPE_ENV = TYPE_ENV



1.13      +25 -23    mlton/mlton/front-end/ml.grm

Index: ml.grm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/ml.grm,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- ml.grm	12 Sep 2003 01:22:56 -0000	1.12
+++ ml.grm	9 Oct 2003 18:17:33 -0000	1.13
@@ -1,4 +1,4 @@
-(* Heavily modified from SML/NJ sources by sweeks@research.nj.nec.com *)
+(* Heavily modified from SML/NJ sources by sweeks@sweeks.com *)
 
 (* ml.grm
  *
@@ -136,8 +136,7 @@
 type clause = {pats : Pat.t vector,
 	       resultType : Type.t option,
 	       body : Exp.t}
-type clauses = {clauses: clause vector,
-		filePos: string}
+type clauses = clause vector
 type eb = Con.t * EbRhs.t
 type db = {tyvars: Tyvar.t vector,
 	   tycon: Tycon.t,
@@ -172,8 +171,7 @@
 		body : Strexp.t}
 
 type vb = {pat: Pat.t,
-	   exp: Exp.t,
-	   filePos: string}
+	   exp: Exp.t}
    
 type rvb = {pat: Pat.t,
 	    match: Match.t}
@@ -701,18 +699,23 @@
 	| fixity vids		(Dec.Fix {fixity = fixity,
 					  ops = Vector.fromList vids})
 	| OVERLOAD var COLON ty AS longvarands
-	                        (Dec.Overload (var, ty,
+	                        (Dec.Overload (var,
+					       Vector.new0 (),
+					       ty,
 					       Vector.fromList longvarands))
 
-valbindTop : valbind (let val (vbs, rvbs) = valbind
-		      in (Vector.fromList vbs,
+valbindTop : valbind (let
+			 val (vbs, rvbs) = valbind
+		      in
+			 (Vector.fromList vbs,
 			  Vector.fromList rvbs)
 		      end)
 
 valbind	: pat EQUALOP exp valbindRest
-          (let val (vbs, rvbs) = valbindRest
-	   in ({pat = pat, exp = exp, filePos = SourcePos.toString pat1left}
-	       :: vbs,
+          (let
+	      val (vbs, rvbs) = valbindRest
+	   in
+	      ({pat = pat, exp = exp} :: vbs,
 	       rvbs)
 	   end)
         | REC rvalbind                 (([], rvalbind))
@@ -734,8 +737,7 @@
 funs	: clausesTop               ([clausesTop])
 	| clausesTop AND funs	   (clausesTop :: funs)
 
-clausesTop: clauses ({clauses = Vector.fromList clauses,
-		      filePos = SourcePos.toString clauses1left})
+clausesTop: clauses (Vector.fromList clauses)
 
 clauses	: clause		([clause])
 	| clause BAR clauses	(clause :: clauses)
@@ -849,8 +851,8 @@
 longvarands : longvar  ([longvar])
             | longvar AND longvarands (longvar :: longvarands)
 
-match : rules           (Match.T {rules = Vector.fromList rules,
-				  filePos = SourcePos.toString rules1left})
+match : rules           (Match.makeRegion' (Match.T (Vector.fromList rules),
+					    rulesleft, rulesright))
 
 rules : rule            ([rule])
       | rule BAR rules  (rule :: rules)
@@ -862,7 +864,7 @@
 elabels : elabel COMMA elabels	(elabel :: elabels)
 	| elabel	        ([elabel])
 
-exp_ps	: exp		        ([exp])
+exp_ps	: exp SEMICOLON exp     ([exp1, exp2])
 	| exp SEMICOLON exp_ps	(exp :: exp_ps)
 
 exp : expnode (Exp.makeRegion' (expnode, expnodeleft, expnoderight))
@@ -876,9 +878,7 @@
 	| CASE exp OF match	(Exp.Case (exp, match))
 	| WHILE exp DO exp	(Exp.While {test = exp1, expr = exp2})
 	| IF exp THEN exp ELSE exp (Exp.If (exp1, exp2, exp3))
-	| RAISE exp	        (Exp.Raise
-				 {exn = exp,
-				  filePos = SourcePos.toString exp1left})
+	| RAISE exp	        (Exp.Raise exp)
 
 app_exp	: aexp app_exp1     (Exp.makeRegion' (aexp, aexpleft, aexpright)
 			     :: app_exp1)
@@ -898,10 +898,12 @@
 	    (Exp.Record (Record.fromVector (Vector.fromList elabels)))
 	| LBRACE RBRACE		(Exp.unit)
 	| LPAREN RPAREN		(Exp.unit)
+	| LPAREN expnode RPAREN (expnode)
 	| LPAREN exp_ps RPAREN	(Exp.Seq (Vector.fromList exp_ps))
 	| LPAREN exp_2c RPAREN	(Exp.tuple (Vector.fromList exp_2c))
-	| LBRACKET exp_list RBRACKET  (Exp.List exp_list)
-	| LBRACKET RBRACKET           (Exp.List nil)
+	| LBRACKET exp_list RBRACKET  (Exp.List (Vector.fromList exp_list))
+	| LBRACKET RBRACKET           (Exp.List (Vector.new0 ()))
+	| LET decs IN exp END   (Exp.Let (decs, exp))
 	| LET decs IN exp_ps END
 	    (Exp.Let (decs, Exp.makeRegion' (Exp.Seq (Vector.fromList exp_ps),
 					     exp_psleft,
@@ -956,12 +958,12 @@
 
 apatnode : longvidNoEqual        (Pat.Var {name = longvidNoEqual,
 					   fixop = Fixop.None})
-        | OP vidNoEqual          (Pat.Var {name = Longvid.short vidNoEqual,
+        | OP vid                 (Pat.Var {name = Longvid.short vid,
 					   fixop = Fixop.Op})
 	| const		         (Pat.Const const)
 	| WILD			 (Pat.Wild)
 	| LPAREN pats RPAREN     (Pat.tuple (Vector.fromList pats))
-	| LBRACKET pats RBRACKET (Pat.List pats)
+	| LBRACKET pats RBRACKET (Pat.List (Vector.fromList pats))
 	| LBRACE RBRACE          (Pat.unit)
 	| LBRACE patitems RBRACE (let val (items, f) = patitems
 				  in Pat.Record {items = Vector.fromList items,



1.9       +8 -0      mlton/mlton/main/compile.sig

Index: compile.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.sig,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- compile.sig	16 Aug 2003 21:29:18 -0000	1.8
+++ compile.sig	9 Oct 2003 18:17:33 -0000	1.9
@@ -5,8 +5,16 @@
  * MLton is released under the GNU General Public License (GPL).
  * Please see the file MLton-LICENSE for license information.
  *)
+type int = Int.t
+
+signature COMPILE_STRUCTS =
+   sig
+   end
+
 signature COMPILE =
    sig
+      include COMPILE_STRUCTS
+	 
       val compile: {input: File.t list,
 		    outputC: unit -> {file: File.t,
 				      print: string -> unit,



1.4       +11 -0     mlton/mlton/main/main.sig

Index: main.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- main.sig	10 Apr 2002 07:02:20 -0000	1.3
+++ main.sig	9 Oct 2003 18:17:33 -0000	1.4
@@ -5,9 +5,20 @@
  * MLton is released under the GNU General Public License (GPL).
  * Please see the file MLton-LICENSE for license information.
  *)
+
+type int = Int.t
+
+signature MAIN_STRUCTS =
+   sig
+   end
+
 signature MAIN =
    sig
+      include MAIN_STRUCTS
+	 
       val commandLine: string list -> OS.Process.status
       val exportMLton: unit -> unit
       val exportNJ: Dir.t * File.t -> unit
+
+      val doit: unit -> unit
    end



1.157     +1 -780    mlton/mlton/main/main.sml

Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.156
retrieving revision 1.157
diff -u -r1.156 -r1.157
--- main.sml	29 Aug 2003 00:25:21 -0000	1.156
+++ main.sml	9 Oct 2003 18:17:33 -0000	1.157
@@ -1,780 +1 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
- *    Jagannathan, and Stephen Weeks.
- * Copyright (C) 1997-1999 NEC Research Institute.
- *
- * MLton is released under the GNU General Public License (GPL).
- * Please see the file MLton-LICENSE for license information.
- *)
-structure Main: MAIN =
-struct
-
-type int = Int.t
-
-structure Place =
-   struct
-      datatype t = CM | Files | Generated | O | OUT | SML
-
-      val toInt: t -> int =
-	 fn CM => 0
-	  | Files => 1
-	  | SML => 2
-	  | Generated => 3
-	  | O => 4
-	  | OUT => 5
-
-      val toString =
-	 fn CM => "cm"
-	  | Files => "files"
-	  | SML => "sml"
-	  | Generated => "g"
-	  | O => "o"
-	  | OUT => "out"
-
-      val layout = Layout.str o toString
-
-      fun compare (p, p') = Int.compare (toInt p, toInt p')
-   end
-
-structure OptPred =
-   struct
-      datatype t =
-	 Target of string
-       | Yes 
-   end
-
-val buildConstants: bool ref = ref false
-val ccOpts: {opt: string, pred: OptPred.t} list ref = ref []
-val coalesce: int option ref = ref NONE
-val expert: bool ref = ref false
-val gcc: string ref = ref "<unset>"
-val keepGenerated = ref false
-val keepO = ref false
-val keepSML = ref false
-val linkOpts: {opt: string, pred: OptPred.t} list ref = ref []
-val output: string option ref = ref NONE
-val profileSet: bool ref = ref false
-val runtimeArgs: string list ref = ref ["@MLton"]
-val showBasis: bool ref = ref false
-val stop = ref Place.OUT
-
-val targetMap: unit -> {arch: MLton.Platform.Arch.t,
-			os: MLton.Platform.OS.t,
-			target: string} list =
-   Promise.lazy
-   (fn () =>
-    List.map
-    (File.lines (concat [!Control.libDir, "/target-map"]), fn line =>
-     case String.tokens (line, Char.isSpace) of
-	[target, arch, os] =>
-	   let
-	      val arch =
-		 case MLton.Platform.Arch.fromString arch of
-		    NONE => Error.bug (concat ["strange arch: ", arch])
-		  | SOME a => a
-	      val os =
-		 case MLton.Platform.OS.fromString os of
-		    NONE => Error.bug (concat ["strange os: ", os])
-		  | SOME os => os
-	   in
-	      {arch = arch, os = os, target = target}
-	   end
-      | _ => Error.bug (concat ["strange target mapping: ", line])))
-
-fun setTargetType (target: string, usage): unit =
-   case List.peek (targetMap (), fn {target = t, ...} => t = target) of
-      NONE => usage (concat ["invalid target ", target])
-    | SOME {arch, os, ...} =>
-	 let
-	    datatype z = datatype MLton.Platform.Arch.t
-	    open Control
-	 in
-	    targetArch := arch
-	    ; targetOS := os
-	    ; (case arch of
-		  Sparc =>
-		     (align := Align8
-		      ; Native.native := false)
-		| _ => ())
-	 end
-   
-fun makeOptions {usage} = 
-   let
-      val usage = fn s => (usage s; raise Fail "unreachable")
-      open Control Popt
-      fun push r = SpaceString (fn s => List.push (r, s))
-      datatype z = datatype MLton.Platform.Arch.t
-   in
-      List.map
-      (
-       [
-       (Normal, "align",
-	case !targetArch of
-	   Sparc => " {8|4}"
-	 | X86 => " {4|8}",
-	"object alignment",
-	(SpaceString (fn s =>
-		      align
-		      := (case s of
-			     "4" => Align4
-			   | "8" => Align8
-			   | _ => usage (concat ["invalid -align flag: ",
-						 s]))))),
-       (Normal, "basis", " {2002|1997|...}",
-	"select basis library to prefix to the program",
-	SpaceString (fn s =>
-		     let
-			val s' = concat ["basis-", s]
-		     in
-			if List.contains (basisLibs, s', String.equals)
-			   then basisLibrary := s'
-			else usage (concat ["invalid -basis flag: ", s])
-		     end)),
-       (Expert, "build-constants", " {false|true}",
-	"output C file that prints basis constants",
-	boolRef buildConstants),
-       (Expert, "card-size-log2", " <n>",
-	"log (base 2) of card size used by GC",
-	intRef cardSizeLog2),
-       (Expert, "cc", " <gcc>", "path to gcc executable",
-	SpaceString (fn s => gcc := s)),
-       (Normal, "cc-opt", " <opt>", "pass option to C compiler",
-	SpaceString (fn s =>
-		     List.push (ccOpts, {opt = s, pred = OptPred.Yes}))),
-       (Expert, "coalesce", " <n>", "coalesce chunk size for C codegen",
-	Int (fn n => coalesce := SOME n)),
-       (Expert, "debug", " {false|true}", "produce executable with debug info",
-	boolRef debug),
-       (Normal, "detect-overflow", " {true|false}",
-	"overflow checking on integer arithmetic",
-	boolRef detectOverflow),
-       (Expert, "diag-pass", " <pass>", "keep diagnostic info for pass",
-	SpaceString (fn s =>
-		     (case Regexp.fromString s of
-			 SOME (re,_) => let val re = Regexp.compileDFA re
-					in 
-					   List.push (keepDiagnostics, re)
-					   ; List.push (keepPasses, re)
-					end
-		       | NONE => usage (concat ["invalid -diag-pass flag: ", s])))),
-       (Expert, "drop-pass", " <pass>", "omit optimization pass",
-	SpaceString
-	(fn s => (case Regexp.fromString s of
-		     SOME (re,_) => let val re = Regexp.compileDFA re
-				    in List.push (dropPasses, re)
-				    end
-		   | NONE => usage (concat ["invalid -drop-pass flag: ", s])))),
-       (Expert, "eliminate-overflow", " {true|false}",
-	"eliminate useless overflow tests",
-	boolRef eliminateOverflow),
-       (Normal, "exn-history", " {false|true}",
-	"enable Exn.history",
-	boolRef exnHistory),
-       (Expert, "expert", " {false|true}",
-	"enable expert status",
-	boolRef expert),
-       (Normal, "export-header", " {false|true}",
-	"output header file for _export's",
-	boolRef exportHeader),
-       (Expert, "gc-check", " {limit|first|every}", "force GCs",
-	SpaceString (fn s =>
-		     gcCheck :=
-		     (case s of
-			 "limit" => Limit
-		       | "first" => First
-		       | "every" => Every
-		       | _ => usage (concat ["invalid -gc-check flag: ", s])))),
-       (Expert, "handlers", " {flow|pushpop|simple}",
-	"how to implement handlers",
-	SpaceString (fn s =>
-		     case s of
-			"flow" => handlers := Flow
-		      | "simple" => handlers := Simple
-		      | _ => usage (concat ["invalid -handlers flag: ", s]))),
-       (Normal, "ieee-fp", " {false|true}", "use strict IEEE floating-point",
-	boolRef Native.IEEEFP),
-       (Expert, "indentation", " <n>", "indentation level in ILs",
-	intRef indentation),
-       (Normal, "inline", " <n>", "inlining threshold", Int setInlineSize),
-       (Normal, "keep", " {g|o|sml}", "save intermediate files",
-	SpaceString (fn s =>
-		     case s of
-			"dot" => keepDot := true
-		      | "g" => keepGenerated := true
-		      | "machine" => keepMachine := true
-		      | "o" => keepO := true
-		      | "sml" => keepSML := true
-		      | "rssa" => keepRSSA := true
-		      | "ssa" => keepSSA := true
-		      | _ => usage (concat ["invalid -keep flag: ", s]))),
-       (Expert, "keep-pass", " <pass>", "keep the results of pass",
-	SpaceString
-	(fn s => (case Regexp.fromString s of
-		     SOME (re,_) => let val re = Regexp.compileDFA re
-				    in List.push (keepPasses, re)
-				    end
-		   | NONE => usage (concat ["invalid -keep-pass flag: ", s])))),
-       (Expert, "limit-check", " {lhle|pb|ebb|lh|lhf|lhfle}",
-	"limit check insertion algorithm",
-	SpaceString (fn s =>
-		     case s of
-		        "pb" => limitCheck := PerBlock
-		      | "ebb" => limitCheck := ExtBasicBlocks
-		      | "lh" => limitCheck := LoopHeaders {fullCFG = false,
-							   loopExits = false}
-		      | "lhf" => limitCheck := LoopHeaders {fullCFG = true,
-							    loopExits = false}
-		      | "lhle" => limitCheck := LoopHeaders {fullCFG = false,
-							     loopExits = true}
-		      | "lhfle" => limitCheck := LoopHeaders {fullCFG = true,
-							      loopExits = true}
-		      | _ => usage (concat ["invalid -limit-check flag: ", s]))),
-       (Expert, "limit-check-counts", " {false|true}",
-	"compute dynamic counts of limit checks",
-	boolRef limitCheckCounts),
-       (Normal, "link-opt", " <opt>", "pass option to linker",
-	SpaceString (fn s =>
-		     List.push (linkOpts, {opt = s, pred = OptPred.Yes}))),
-       (Expert, "loop-passes", " <n>", "loop optimization passes (1)",
-	Int 
-	(fn i => 
-	 if i >= 1
-	    then loopPasses := i
-	    else usage (concat ["invalid -loop-passes arg: ", Int.toString i]))),
-       (Expert, "mark-cards", " {true|false}", "mutator marks cards",
-	boolRef markCards),
-       (Normal, "native",
-	if !targetArch = Sparc then " {false}" else " {true|false}",
-	"use native code generator",
-	boolRef Native.native),
-       (Expert, "native-commented", " <n>", "level of comments  (0)",
-	intRef Native.commented),
-       (Expert, "native-copy-prop", " {true|false}", 
-	"use copy propagation",
-	boolRef Native.copyProp),
-       (Expert, "native-cutoff", " <n>", 
-	"live transfer cutoff distance",
-	intRef Native.cutoff),
-       (Expert, "native-live-transfer", " {0,...,8}",
-	"use live transfer",
-	intRef Native.liveTransfer),
-       (Expert, "native-live-stack", " {false|true}",
-	"track liveness of stack slots",
-	boolRef Native.liveStack),
-       (Expert, "native-move-hoist", " {true|false}",
-	"use move hoisting",
-	boolRef Native.moveHoist),
-       (Expert, "native-optimize", " <n>", "level of optimizations",
-        intRef Native.optimize),
-       (Expert, "native-split", " <n>", "split assembly files at ~n lines",
-	Int (fn i => Native.split := SOME i)),
-       (Expert, "native-shuffle", " {true|false}",
-	"shuffle registers at C-calls",
-	Bool (fn b => Native.shuffle := b)),
-       (Expert, "new-return", " {false|true}", "non-tail call return convention",
-	boolRef newReturn),
-       (Expert, "polyvariance", " {true|false}", "use polyvariance",
-	Bool (fn b => if b then () else polyvariance := NONE)),
-       (Normal, "output", " <file>", "name of output file",
-	SpaceString (fn s => output := SOME s)),
-       (Normal, "profile", " {no|alloc|time}",
-	"produce executable suitable for profiling",
-	SpaceString
-	(fn s =>
-	 if !profileSet
-	    then usage "can't have multiple -profile switches"
-	 else
-	    (profileSet := true
-	     ; profile := (case s of
-			      "no" => ProfileNone
-			    | "alloc" => ProfileAlloc
-			    | "time" => ProfileTime
-			    | _ => usage (concat
-					  ["invalid -profile arg: ", s]))))),
-       (Expert, "profile-basis", " {false|true}",
-	"profile the basis implementation",
-	boolRef profileBasis),
-       (Expert, "profile-il", " {source}", "where to insert profile exps",
-	SpaceString
-	(fn s =>
-	 case s of
-	    "source" => profileIL := ProfileSource
-	  | _ => usage (concat ["invalid -profile-il arg: ", s]))),
-       (Normal, "profile-stack", " {false|true}", "profile the stack",
-	boolRef profileStack),
-       (Normal, "runtime", " <arg>", "pass arg to runtime via @MLton",
-	push runtimeArgs),
-       (Normal, "safe", " {true|false}", "bounds checking and other checks",
-	boolRef safe),
-       (Normal, "show-basis", " {false|true}", "display the basis library",
-	boolRef showBasis),
-       (Normal, "show-basis-used", " {false|true}",
-	"display the basis library used by the program",
-	boolRef showBasisUsed),
-       (Expert, "show-types", " {false|true}", "print types in ILs",
-	boolRef showTypes),
-       (Expert, "stack-cont", " {false|true}",
-	"force continuation formals to stack",
-	boolRef stackCont),
-       (Normal, "static", " {false|true}",
-	"produce a statically linked executable",
-	boolRef static),
-       (Normal, "stop", " {f|g|o|sml}", "where to stop",
-	SpaceString
-	(fn s =>
-	 stop := (case s of
-		     "f" => Place.Files
-		   | "g" => Place.Generated	
-		   | "o" => Place.O
-		   | "sml" => Place.SML
-		   | _ => usage (concat ["invalid -stop arg: ", s])))),
-       (Normal, "target",
-	concat [" {",
-		concat (List.separate (List.map (targetMap (), #target), "|")),
-		"}"],
-	"platform that executable will run on",
-	SpaceString (fn s =>
-		     (setTargetType (s, usage)
-		      ; target := (if s = "self" then Self else Cross s)))),
-       (Expert, "target-cc-opt", " <target> <opt>", "target-dependent CC option",
-	(SpaceString2
-	 (fn (target, opt) =>
-	  List.push (ccOpts, {opt = opt, pred = OptPred.Target target})))),
-       (Expert, "target-link-opt", " <target> <opt>",
-	"target-dependent link option",
-	(SpaceString2
-	 (fn (target, opt) =>
-	  List.push (linkOpts, {opt = opt, pred = OptPred.Target target})))),
-       (Expert, #1 trace, " name1,...", "trace compiler internals", #2 trace),
-       (Expert, "text-io-buf-size", " <n>", "TextIO buffer size",
-	intRef textIOBufSize),
-       (Expert, "type-check", " {false|true}", "type check ILs",
-	boolRef typeCheck),
-       (Normal, "verbose", " {0|1|2|3}", "how verbose to be",
-	SpaceString
-	(fn s =>
-	 verbosity := (case s of
-			  "0" => Silent
-			| "1" => Top
-			| "2" => Pass
-			| "3" =>  Detail
-			| _ => usage (concat ["invalid -verbose arg: ", s])))),
-       (Expert, "variant", " {header|first-word}",
-	"how to represent variant tags",
-	SpaceString
-	(fn s =>
-	 variant := (case s of
-			"first-word" => FirstWord
-		      | "header" => Header
-		      | _ => usage (concat ["invalid -variant arg: ", s]))))
-       ],
-       fn (style, name, arg, desc, opt) =>
-       {arg = arg, desc = desc, name = name, opt = opt, style = style})
-   end
-
-val mainUsage =
-   "mlton [option ...] file.{cm|sml|c|o} [file.{c|S|o} ...]"
-
-val {parse, usage} =
-   Popt.makeUsage {mainUsage = mainUsage,
-		   makeOptions = makeOptions,
-		   showExpert = fn () => !expert}
-
-val usage = fn s => (usage s; raise Fail "unreachable")
-   
-fun commandLine (args: string list): unit =
-   let
-      open Control
-      val args =
-	 case args of
-	    lib :: args => (libDir := lib; args)
-	  | _ => Error.bug "incorrect args from shell script"
-      val _ = setTargetType ("self", usage)
-      val result = parse args
-      val gcc = !gcc
-      val target = !target
-      val targetStr =
-	 case target of
-	    Cross s => s
-	  | Self => "self"
-      val _ = libTargetDir := concat [!libDir, "/", targetStr]
-      val targetArch = !targetArch
-      val archStr = MLton.Platform.Arch.toString targetArch
-      val targetOS = !targetOS
-      val OSStr = MLton.Platform.OS.toString targetOS
-      fun tokenize l =
-	 String.tokens (concat (List.separate (l, " ")), Char.isSpace)
-      fun addTargetOpts opts =
-	 tokenize
-	 (List.fold
-	  (!opts, [], fn ({opt, pred}, ac) =>
-	   if (case pred of
-		  OptPred.Target s => s = archStr orelse s = OSStr
-		| OptPred.Yes => true)
-	      then opt :: ac
-	   else ac))
-      val ccOpts = addTargetOpts ccOpts
-      val linkOpts = addTargetOpts linkOpts
-      datatype z = datatype MLton.Platform.OS.t
-      val linkWithGmp =
-	 case targetOS of
-	    Cygwin => ["-lgmp"]
-	  | FreeBSD => ["-L/usr/local/lib/", "-lgmp"]
-	  | Linux =>
-	       (* This mess is necessary because the linker on linux
-		* adds a dependency to a shared library even if there are
-		* no references to it.  So, on linux, we explicitly link
-		* with libgmp.a instead of using -lgmp.
-		*)
-	       let
-		  val conf = "/etc/ld.so.conf"
-		  val dirs = if File.canRead conf then File.lines conf else []
-		  val dirs = "/lib\n" :: "/usr/lib\n" :: dirs
-	       in
-		  case (List.peekMap
-			(dirs, fn d =>
-			 let
-			    val lib =
-			       concat [String.dropSuffix (d, 1), "/libgmp.a"]
-			 in
-			    if File.canRead lib
-			       then SOME lib
-			    else NONE
-			 end)) of
-		     NONE => ["-lgmp"]
-		   | SOME lib => [lib]
-	       end
-	  | NetBSD => ["-Wl,-R/usr/pkg/lib", "-L/usr/pkg/lib", "-lgmp"]
-	  | Sun => ["-lgmp"]
-      val linkOpts =
-	 List.concat [[concat ["-L", !libTargetDir],
-		       if !debug then "-lmlton-gdb" else "-lmlton"],
-		      linkWithGmp,
-		      linkOpts]
-      val _ =
-	 if !Native.native andalso targetArch = Sparc
-	    then usage "can't use -native true on Sparc"
-	 else ()
-      val _ =
-	 chunk := (if !Native.native
-		      then
-			 if isSome (!coalesce)
-			    then usage "can't use -coalesce and -native true"
-			 else ChunkPerFunc
-		   else Coalesce {limit = (case !coalesce of
-					      NONE => 4096
-					    | SOME n => n)})
-      val _ = if not (!Native.native) andalso !Native.IEEEFP
-		 then usage "can't use -native false and -ieee-fp true"
-	      else ()
-      val _ =
-	 if !keepDot andalso List.isEmpty (!keepPasses)
-	    then keepSSA := true
-	 else ()
-      val _ =
-	 if targetOS = Cygwin andalso !profile = ProfileTime
-	    then usage "can't use -profile time on Cygwin"
-	 else ()
-      fun printVersion (out: Out.t): unit =
-	 Out.output (out, concat [version, " ", build, "\n"])
-   in
-      case result of
-      Result.No msg => usage msg
-    | Result.Yes [] =>
-	 (case !verbosity of
-	     Silent =>
-		if !showBasis
-		   then Layout.outputl (Compile.layoutBasisLibrary (),
-					Out.standard)
-		else if !buildConstants
-		   then Compile.outputBasisConstants Out.standard
-	        else printVersion Out.standard
-	   | Top => printVersion Out.standard
-	   | _ => (inputFile := ""
-		   ; outputHeader' (No, Out.standard)))
-    | Result.Yes (input :: rest) =>
-	 let
-	    val _ = inputFile := File.base (File.fileOf input)
-	    val (start, base) =
-	       let
-		  val rec loop =
-		     fn [] => usage (concat ["invalid file suffix on ", input])
-		      | (suf, start, hasNum) :: sufs =>
-			   if String.isSuffix {string = input, suffix = suf}
-			      then (start,
-				    let
-				       val f = File.base input
-				    in
-				       if hasNum
-					  then File.base f
-				       else f
-				    end)
-			   else loop sufs
-		  datatype z = datatype Place.t
-	       in
-		  loop [(".cm", CM, false),
-			(".sml", SML, false),
-			(".c", Generated, true),
-			(".o", O, true)]
-	       end
-	    val _ =
-	       List.foreach
-	       (rest, fn f =>
-		if List.exists ([".c", ".o", ".s", ".S"], fn suffix =>
-				String.isSuffix {string = f, suffix = suffix})
-		   andalso File.canRead f
-		   then ()
-		else usage (concat ["invalid file: ", f]))
-	    val csoFiles = rest
-	    val stop = !stop
-	 in
-	    case Place.compare (start, stop) of
-	       GREATER => usage (concat ["cannot go from ", Place.toString start,
-					 " to ", Place.toString stop])
-	     | EQUAL => usage "nothing to do"
-	     | LESS =>
-		  let
-		     val _ =
-			if !verbosity = Top
-			   then printVersion Out.error
-			else ()
-		     val tempFiles: File.t list ref = ref []
-		     val tmpDir =
-			case Process.getEnv "TMPDIR" of
-			   NONE => "/tmp"
-			 | SOME d => d
-		     fun temp (suf: string): File.t =
-			let
-			   val (f, out) =
-			      File.temp {prefix = concat [tmpDir, "/file"],
-					 suffix = suf}
-			   val _ = Out.close out
-			   val _ = List.push (tempFiles, f)
-			in
-			   f
-			end
-		     fun suffix s = concat [base, s]
-		     fun maybeOut suf =
-			case !output of
-			   NONE => suffix suf
-			 | SOME f => f
-		     val _ =
-			atMLtons :=
-			Vector.fromList
-			(maybeOut "" :: tokenize (rev ("--" :: (!runtimeArgs))))
-		     datatype debugFormat =
-			Dwarf | DwarfPlus | Dwarf2 | Stabs | StabsPlus
-		     (* The -Wa,--gstabs says to pass the --gstabs option to the
-		      * assembler. This tells the assembler to generate stabs
-		      * debugging information for each assembler line.
-		      *)
-		     val debugFormat = StabsPlus
-		     val (gccDebug, asDebug) =
-			case debugFormat of
-			   Dwarf => (["-gdwarf", "-g2"], "-Wa,--gdwarf2")
-			 | DwarfPlus => (["-gdwarf+", "-g2"], "-Wa,--gdwarf2")
-			 | Dwarf2 => (["-gdwarf-2", "-g2"], "-Wa,--gdwarf2")
-			 | Stabs => (["-gstabs", "-g2"], "-Wa,--gstabs")
-			 | StabsPlus => (["-gstabs+", "-g2"], "-Wa,--gstabs")
-		     fun compileO (inputs: File.t list): unit =
-			let
-			   val output = maybeOut ""
-			   val _ =
-			      trace (Top, "Link")
-			      (fn () =>
-			       System.system
-			       (gcc,
-				List.concat
-				[["-o", output],
-				 (case target of
-				     Cross s => ["-b", s]
-				   | Self => []),
-				 if !debug then gccDebug else [],
-				 if !static then ["-static"] else [],
-				 inputs,
-				 linkOpts]))
-			      ()
-			   (* gcc on Cygwin appends .exe, which I don't want, so
-			    * move the output file to it's rightful place.
-			    * Notice that we do not use targetOS here, since we
-			    * care about the platform we're running on, not the
-			    * platform we're generating for.
-			    *)
-			   val _ =
-			      if MLton.Platform.OS.host = Cygwin
-				 then
-				    if String.contains (output, #".")
-				       then ()
-				    else
-				       File.move {from = concat [output, ".exe"],
-						  to = output}
-			      else ()
-			in
-			   ()
-			end
-		  fun compileCSO (inputs: File.t list): unit =
-		     if List.forall (inputs, fn f =>
-				     SOME "o" = File.extension f)
-			then compileO inputs
-		     else
-		     let
-			val c = Counter.new 0
-			val oFiles =
-			   trace (Top, "Compile C and Assemble")
-			   (fn () =>
-			    List.fold
-			    (inputs, [], fn (input, ac) =>
-			     let
-				val extension = File.extension input
-			     in
-				if SOME "o" = extension
-				   then input :: ac
-				else
-				   let
-				      val (debugSwitches, switches) =
-					 if SOME "c" = extension
-					    then
-					       (gccDebug @ ["-DASSERT=1"],
-						ccOpts)
-					 else ([asDebug], [])
-				      val switches =
-					 if !debug
-					    then debugSwitches @ switches
-					 else switches
-				      val switches =
-					 case target of
-					    Cross s => "-b" :: s :: switches
-					  | Self => switches
-				      val switches = "-c" :: switches
-				      val output =
-					 if stop = Place.O orelse !keepO
-					    then
-					       if !keepGenerated 
-						  orelse start = Place.Generated
-						  then
-						     concat [String.dropSuffix
-							     (input, 1),
-							     "o"]
-					       else 
-						  suffix
-						  (concat [".",
-							   Int.toString
-							   (Counter.next c),
-							   ".o"])
-					 else temp ".o"
-				      val _ =
-					 System.system
-					 (gcc,
-					  List.concat [switches,
-						       ["-o", output, input]])
-
-				   in
-				      output :: ac
-				   end
-			     end))
-			   ()
-		     in
-			case stop of
-			   Place.O => ()
-			 | _ => compileO (rev oFiles)
-		     end
-		  fun compileSml (files: File.t list) =
-		     let
-			val outputs: File.t list ref = ref []
-			val r = ref 0
-			fun make (style: style, suf: string) () =
-			   let
-			      val suf = concat [".", Int.toString (!r), suf]
-			      val _ = Int.inc r
-			      val file = (if !keepGenerated
-					     orelse stop = Place.Generated
-					     then suffix
-					  else temp) suf
-			      val _ = List.push (outputs, file)
-			      val out = Out.openOut file
-			      fun print s = Out.output (out, s)
-			      val _ = outputHeader' (style, out)
-			      fun done () = Out.close out
-			   in
-			      {file = file,
-			       print = print,
-			       done = done}
-			   end
-			val _ =
-			   case !verbosity of
-			      Silent => ()
-			    | Top => ()
-			    | _ => 
-				 outputHeader
-				 (Control.No, fn l =>
-				  let val out = Out.error
-				  in Layout.output (l, out)
-				     ; Out.newline out
-				  end)
-			val _ =
-			   trace (Top, "Compile SML")
-			   Compile.compile
-			   {input = files,
-			    outputC = make (Control.C, ".c"),
-			    outputS = make (Control.Assembly,
-					    if !debug then ".s" else ".S")}
-			(* Shrink the heap before calling gcc. *)
-			val _ = MLton.GC.pack ()
-		     in
-			case stop of
-			   Place.Generated => ()
-			 | _ => compileCSO (List.concat [!outputs, csoFiles])
-		     end
-		  fun compileCM input =
-		     let
-			val files = CM.cm {cmfile = input}
-			fun saveSML smlFile =
-			   File.withOut
-			   (smlFile, fn out =>
-			    (outputHeader' (ML, out)
-			     ; (List.foreach
-				(files, fn f =>
-				 (Out.output
-				  (out, concat ["(*#line 0.0 \"", f, "\"*)\n"])
-				  ; File.outputContents (f, out))))))
-		     in
-			case stop of
-			   Place.Files =>
-			      List.foreach
-			      (files, fn f => print (concat [f, "\n"]))
-			 | Place.SML => saveSML (maybeOut ".sml")
-			 | _ =>
-			      (if !keepSML
-				  then saveSML (suffix ".sml")
-			       else ()
-				  ; compileSml files)
-		     end
-		  fun compile () =
-		     case start of
-			Place.CM => compileCM input
-		      | Place.SML => compileSml [input]
-		      | Place.Generated => compileCSO (input :: csoFiles)
-		      | Place.O => compileCSO (input :: csoFiles)
-		      | _ => Error.bug "invalid start"
-		  val doit 
-		    = trace (Top, "MLton")
-		      (fn () => 
-		       DynamicWind.wind
-		       (compile, fn () =>
-			List.foreach (!tempFiles, File.remove)))
-	       in doit ()
-	       end
-	 end
-   end
-
-val commandLine = Process.makeCommandLine commandLine
-   
-fun exportNJ (root: Dir.t, file: File.t): unit =
-   (Compile.forceBasisLibrary root
-    ; SMLofNJ.exportFn (file, fn (_, args) => commandLine args))
-   
-fun exportMLton (): unit =
-   case CommandLine.arguments () of
-      [root, file] => exportNJ (root, file)
-    | _ => Error.bug "usage: exportMLton root file"
-
-end
+structure Main = Main ()



1.5       +5 -3      mlton/mlton/main/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/sources.cm,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- sources.cm	16 Apr 2002 12:10:52 -0000	1.4
+++ sources.cm	9 Oct 2003 18:17:33 -0000	1.5
@@ -8,7 +8,6 @@
 Group
 
 structure Char
-structure Compile
 structure Control
 structure Date
 structure Dir
@@ -38,13 +37,16 @@
 ../codegen/sources.cm
 ../control/sources.cm
 ../core-ml/sources.cm
+../defunctorize/sources.cm
 ../elaborate/sources.cm
 ../front-end/sources.cm
 ../ssa/sources.cm
-../type-inference/sources.cm
 ../xml/sources.cm
 
+compile.fun
 compile.sig
-compile.sml
+lookup-constant.sig
+lookup-constant.fun
+main.fun
 main.sig
 main.sml



1.1                  mlton/mlton/main/compile.fun

Index: compile.fun
===================================================================
(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 * Copyright (C) 1997-1999 NEC Research Institute.
 *
 * MLton is released under the GNU General Public License (GPL).
 * Please see the file MLton-LICENSE for license information.
 *)
functor Compile (S: COMPILE_STRUCTS): COMPILE =
struct

(*---------------------------------------------------*)
(*              Intermediate Languages               *)
(*---------------------------------------------------*)
   
structure Field = Field ()
structure Record = Record (val isSorted = false
			   structure Field = Field)
structure SortedRecord = Record (val isSorted = true
				 structure Field = Field)
structure Tyvar = Tyvar ()
structure Ast = Ast (structure Record = Record
		     structure SortedRecord = SortedRecord
		     structure Tyvar = Tyvar)
local
   open Ast.Tycon
in
   structure IntSize = IntSize
   structure RealSize = RealSize
   structure WordSize = WordSize
end
structure Atoms = Atoms (structure Ast = Ast
			 structure Field = Field
			 structure IntSize = IntSize
			 structure RealSize = RealSize
			 structure Record = Record
			 structure SortedRecord = SortedRecord
			 structure Tyvar = Tyvar
			 structure WordSize = WordSize)
local
   open Atoms
in
   structure Const = Const
   structure Ffi = Ffi
   structure IntX = IntX
end
structure TypeEnv = TypeEnv (Atoms)
structure CoreML = CoreML (open Atoms
			   structure Type =
			      struct
				 open TypeEnv.Type

				 val layout = layoutPretty
			      end)
structure Xml = Xml (open Atoms)
structure Sxml = Sxml (open Xml)
structure Ssa = Ssa (open Atoms)
structure Machine = Machine (open Atoms
			     structure Label = Ssa.Label)
local
   open Machine
in
   structure Runtime = Runtime
end

(*---------------------------------------------------*)
(*                  Compiler Passes                  *)
(*---------------------------------------------------*)

structure FrontEnd = FrontEnd (structure Ast = Ast)
(* structure DeadCode = DeadCode (structure CoreML = CoreML) *)
structure Defunctorize = Defunctorize (structure CoreML = CoreML
				       structure Xml = Xml)
structure Elaborate = Elaborate (structure Ast = Ast
				 structure CoreML = CoreML
				 structure TypeEnv = TypeEnv)
local
   open Elaborate
in
   structure ConstType = ConstType
   structure Decs = Decs
   structure Env = Env
end
structure LookupConstant = LookupConstant (structure Const = Const
					   structure ConstType = ConstType
					   structure Ffi = Ffi)
structure Monomorphise = Monomorphise (structure Xml = Xml
				       structure Sxml = Sxml)
structure ClosureConvert = ClosureConvert (structure Ssa = Ssa
					   structure Sxml = Sxml)
structure Backend = Backend (structure Ssa = Ssa
			     structure Machine = Machine
			     fun funcToLabel f = f)
structure CCodegen = CCodegen (structure Ffi = Ffi
			       structure Machine = Machine)
structure x86Codegen = x86Codegen (structure CCodegen = CCodegen
				   structure Machine = Machine)

local
   open Elaborate
in 
   structure Decs = Decs
end
   
(* ------------------------------------------------- *)
(*                 parseAndElaborate                 *)
(* ------------------------------------------------- *)

val (lexAndParse, lexAndParseMsg) =
   Control.traceBatch (Control.Pass, "lex and parse") FrontEnd.lexAndParse

fun lexAndParseFile (f: File.t): Ast.Program.t =
   let
      val ast = lexAndParse f
      val _ = Control.checkForErrors "parse"
   in ast
   end

fun lexAndParseFiles (fs: File.t list): Ast.Program.t =
   List.fold
   (fs, Ast.Program.empty, fn (f, ast) =>
    Ast.Program.append (ast, lexAndParseFile f))

val (elaborate, elaborateMsg) =
   Control.traceBatch (Control.Pass, "elaborate") Elaborate.elaborateProgram

fun elaborateProg z: Decs.t =
   let
      val decs = elaborate z
      val _ = Control.checkForErrors "elaborate"
   in
      decs
   end

val displayDecs =
   Control.Layout
   (fn ds => CoreML.Program.layout (CoreML.Program.T
				    {decs = Decs.toVector ds}))
   
fun parseAndElaborateFiles (fs: File.t list, E: Env.t, lookupConstant): Decs.t =
   Control.pass
   {name = "parseAndElaborate",
    suffix = "core-ml",
    style = Control.ML,
    thunk = fn () => (List.fold
		      (fs, Decs.empty, fn (f, ds) =>
		       Decs.append 
		       (ds, elaborateProg (lexAndParseFile f,
					   E,
					   lookupConstant)))),
    display = displayDecs}

(* ------------------------------------------------- *)   
(*                   Primitive Env                   *)
(* ------------------------------------------------- *)

local
   structure Con = TypeEnv.Con
   structure Scheme = TypeEnv.InferScheme
   structure Tycon = TypeEnv.Tycon
   structure Type = TypeEnv.Type
   structure Tyvar = TypeEnv.Tyvar
in
   val primitiveDatatypes =
      Vector.new3
      ({tycon = Tycon.bool,
	tyvars = Vector.new0 (),
	cons = Vector.new2 ({con = Con.falsee, arg = NONE},
			    {con = Con.truee, arg = NONE})},
       let
	  val a = Tyvar.newNoname {equality = false}
       in
	  {tycon = Tycon.list,
	   tyvars = Vector.new1 a,
	   cons = Vector.new2 ({con = Con.nill, arg = NONE},
			       {con = Con.cons,
				arg = SOME (Type.tuple
					    (Vector.new2
					     (Type.var a,
					      Type.list (Type.var a))))})}
       end,
       let
	  val a = Tyvar.newNoname {equality = false}
       in
	  {tycon = Tycon.reff,
	   tyvars = Vector.new1 a,
	   cons = Vector.new1 {con = Con.reff, arg = SOME (Type.var a)}}
       end)

   val primitiveExcons =
      let
	 open CoreML.Con
      in
	 [bind, match, overflow]
      end

   structure Con =
      struct
	 open Con

	 fun toAst c = Ast.Con.fromString (Con.toString c, Region.bogus)
      end

   structure Tycon =
      struct
	 open Tycon

	 fun toAst c = Ast.Tycon.fromString (Tycon.toString c, Region.bogus)
      end
   
   structure Env =
      struct
	 open Env 

	 structure Type = TypeEnv.Type
	 structure Scheme = TypeEnv.InferScheme

	 fun addPrim (E: t): unit =
	    let
	       val _ =
		  List.foreach
		  (Tycon.prims, fn (tycon, kind) =>
		   extendTycon
		   (E, Ast.Tycon.fromString (Tycon.originalName tycon,
					     Region.bogus),
		    TypeStr.tycon (tycon, kind)))
	       val _ =
		  Vector.foreach
		  (primitiveDatatypes, fn {tyvars, tycon, cons} =>
		   let
		      val cs =
			 Vector.map
			 (cons, fn {arg, con} =>
			  let
			     val resultType =
				Type.con (tycon, Vector.map (tyvars, Type.var))
			     val scheme =
				Scheme.make
				{canGeneralize = true,
				 ty = (case arg of
					  NONE => resultType
					| SOME t => Type.arrow (t, resultType)),
				 tyvars = tyvars}
			  in
			     {con = con,
			      name = Con.toAst con,
			      scheme = scheme}
			  end)
		      val _ =
			 Vector.foreach (cs, fn {con, name, scheme} =>
					 extendCon (E, name, con, scheme))
		   in
		      extendTycon
		      (E, Tycon.toAst tycon,
		       TypeStr.data (tycon,
				     TypeStr.Kind.Arity (Vector.length tyvars),
				     cs))
		   end)
	       val _ =
		  extendTycon (E, Ast.Tycon.fromString ("unit", Region.bogus),
			       TypeStr.def (Scheme.fromType Type.unit,
					    TypeStr.Kind.Arity 0))
	       val scheme = Scheme.fromType Type.exn
	       val _ = List.foreach (primitiveExcons, fn c =>
				     extendCon (E, Con.toAst c, c, scheme))
	    in
	       ()
	    end
      end
end

(* ------------------------------------------------- *)
(*                   Basis Library                   *)
(* ------------------------------------------------- *)

val basisEnv = Env.empty ()

val allConstants: (string * ConstType.t) list ref = ref []

val amBuildingConstants: bool ref = ref false
   
val lookupConstant =
   let
      val zero = Const.int (IntX.make (0, IntSize.default))
      val f =
	 Promise.lazy
	 (fn () =>
	  if !amBuildingConstants
	     then fn ct => (List.push (allConstants, ct)
			    ; zero)
	  else
	     File.withIn
	     (concat [!Control.libTargetDir, "/constants"], fn ins =>
	      LookupConstant.load ins))
   in
      fn z => f () z
   end

local
   val dir = ref NONE
in
   fun setBasisLibraryDir (d: Dir.t): unit =
      dir := SOME d
   fun basisLibrary ()
      : {build: Decs.t,
	 localTopFinish: (unit -> Decs.t * Decs.t * Decs.t) -> 
	 Decs.t * Decs.t * Decs.t,
	 libs: {name: string,
		bind: Ast.Program.t,
		prefix: Ast.Program.t,
		suffix: Ast.Program.t} list} =
       let
	  val d =
	     case !dir of
		NONE => Error.bug "basis library dir not set"
	      | SOME d => d
	  fun basisFile f = String./ (d, f)
	  fun libsFile f = basisFile (String./ ("libs", f))
	  fun withFiles (f, g) =
	     let
	        val fs = File.foldLines
		         (f, [], fn (s, ac) =>
			  if s <> "\n" andalso #"#" <> String.sub (s, 0)
			     then basisFile (String.dropLast s) :: ac
			  else ac)
	     in
	        g (List.rev fs)
	     end
	  val (build, localTopFinish) =
	     Env.localTop
	     (basisEnv,
	      fn () =>
	      (Env.addPrim basisEnv
	       ; withFiles (libsFile "build", 
			    fn fs => parseAndElaborateFiles (fs, basisEnv,
							     lookupConstant))))
	  val _ =
	     Env.Structure.ffi
	     := SOME (Env.lookupLongstrid
		      (basisEnv,
		       Ast.Longstrid.short
		       (Ast.Strid.fromString ("MLtonFFI", Region.bogus))))
	  val localTopFinish = fn g =>
	     (localTopFinish g) before ((* Env.addEquals basisEnv *)
					Env.clean basisEnv)

	  fun doit name =
	    let
	      fun libFile f = libsFile (String./ (name, f))
	      val bind = withFiles (libFile "bind", lexAndParseFiles)
	      val prefix = withFiles (libFile "prefix", lexAndParseFiles)
	      val suffix = withFiles (libFile "suffix", lexAndParseFiles)
	    in
	      {name = name,
	       bind = bind,
	       prefix = prefix,
	       suffix = suffix}
	    end
       in
	  {build = build,
	   localTopFinish = localTopFinish,
	   libs = List.map (Control.basisLibs, doit)}
       end
end

val basisLibrary = Promise.lazy basisLibrary
    
fun forceBasisLibrary d =
   (setBasisLibraryDir d
    ; basisLibrary ()
    ; ())

val primitiveDecs: CoreML.Dec.t vector =
   let
      open CoreML.Dec
   in
      Vector.concat [Vector.new1 (Datatype primitiveDatatypes),
		     Vector.fromListMap
		     (primitiveExcons, fn c =>
		      Exception {con = c, arg = NONE})]
   end

fun outputBasisConstants (out: Out.t): unit =
   let
      val _ = amBuildingConstants := true
      val {build, ...} = basisLibrary ()
      (* Need to defunctorize so the constants are forced. *)
      val _ =
	 Defunctorize.defunctorize
	 (CoreML.Program.T {decs = Vector.concat [primitiveDecs,
						  Decs.toVector build]})
      val _ = LookupConstant.build (!allConstants, out)
   in
      ()
   end

fun lookupConstantError _ = Error.bug "const in user input"

fun selectBasisLibrary () =
   let
     val {build, localTopFinish, libs} = basisLibrary ()
     val lib = !Control.basisLibrary
   in
      case List.peek (libs, fn {name, ...} => name = lib) of
	 NONE => Error.bug (concat ["Missing basis library: ", lib])
       | SOME {bind, prefix, suffix, ...} =>
	   let
	     val (bind, prefix, suffix) = 
	        localTopFinish 
		(fn () =>
		 (elaborateProg (bind, basisEnv, lookupConstantError),
		  elaborateProg (prefix, basisEnv, lookupConstantError),
		  elaborateProg (suffix, basisEnv, lookupConstantError)))
	   in
	     {basis = Decs.append (build, bind),
	      prefix = prefix,
	      suffix = suffix}
	   end
   end

fun layoutBasisLibrary () = 
   let val _ = selectBasisLibrary ()
   in Env.layoutPretty basisEnv
   end

(* ------------------------------------------------- *)
(*                      compile                      *)
(* ------------------------------------------------- *)
   
fun preCodegen {input}: Machine.Program.t =
   let
      fun parseElabMsg () = (lexAndParseMsg (); elaborateMsg ())
      val decs =
	 let 
	    val {basis, prefix, suffix, ...} = selectBasisLibrary ()
	    fun parseAndElab () =
	       parseAndElaborateFiles (input, basisEnv, lookupConstantError)
	    val input =
	       if !Control.showBasisUsed
		  then let
			  val input =
			     Elaborate.Env.scopeAll (basisEnv, parseAndElab)
			  val _ =
			     Layout.outputl
			     (Elaborate.Env.layoutUsed basisEnv,
			      Out.standard)
		       in
			  Process.succeed ()
		       end
	       else
		  parseAndElab () 
	    val _ =
	       if not (!Control.exportHeader)
		  then ()
	       else 
		  let
		     val _ =
			File.outputContents
			(concat [!Control.libDir, "/include/types.h"],
			 Out.standard)
		     val _ = print "\n"
		     val _ = Ffi.declareHeaders {print = print}
		  in
		     Process.succeed ()
		  end
	    val user = Decs.appends [prefix, input, suffix]
	    val _ = parseElabMsg ()
	    val basis = Decs.toList basis
	    val user = Decs.toList user
(* 	    val basis = 
 * 	       Control.pass
 * 	       {name = "deadCode",
 * 		suffix = "basis",
 * 		style = Control.ML,
 * 		thunk = fn () => DeadCode.deadCode {basis = basis,
 * 						    user = user},
 * 		display = Control.Layout (List.layout CoreML.Dec.layout)}
 *)
	 in Vector.concat [primitiveDecs,
			   Vector.fromList basis,
			   Vector.fromList user]
	 end
      val coreML = CoreML.Program.T {decs = decs}
(*       val _ = Control.message (Control.Detail, fn () =>
 * 			       CoreML.Program.layoutStats coreML)
 *)
      (* Set GC_state offsets. *)
      val _ =
	 let
	    fun get (s: string): int =
	       case lookupConstant (s, ConstType.Int) of
		  Const.Int i => IntX.toInt i
		| _ => Error.bug "GC_state offset must be an int"
	 in
	    Runtime.GCField.setOffsets
	    {
	     canHandle = get "canHandle",
	     cardMap = get "cardMapForMutator",
	     currentThread = get "currentThread",
	     exnStack = get "exnStack",
	     frontier = get "frontier",
	     limit = get "limit",
	     limitPlusSlop = get "limitPlusSlop",
	     maxFrameSize = get "maxFrameSize",
	     signalIsPending = get "signalIsPending",
	     stackBottom = get "stackBottom",
	     stackLimit = get "stackLimit",
	     stackTop = get "stackTop"
	     }
	 end
      val xml =
	 Control.passSimplify
	 {name = "defunctorize",
	  suffix = "xml",
	  style = Control.ML,
	  thunk = fn () => Defunctorize.defunctorize coreML,
	  display = Control.Layout Xml.Program.layout,
	  typeCheck = Xml.typeCheck,
	  simplify = Xml.simplify}
      val _ = Control.message (Control.Detail, fn () =>
			       Xml.Program.layoutStats xml)
      val sxml =
	 Control.passSimplify
	 {name = "mono",
	  suffix = "sxml",
	  style = Control.ML,
	  thunk = fn () => Monomorphise.monomorphise xml,
	  display = Control.Layout Sxml.Program.layout,
	  typeCheck = Sxml.typeCheck,
	  simplify = Sxml.simplify}
      val _ = Control.message (Control.Detail, fn () =>
			       Sxml.Program.layoutStats sxml)
      val ssa =
	 Control.passSimplify
	 {name = "closureConvert",
	  suffix = "ssa",
	  style = Control.No,
	  thunk = fn () => ClosureConvert.closureConvert sxml,
	  typeCheck = Ssa.typeCheck,
	  display = Control.Layouts Ssa.Program.layouts,
	  simplify = Ssa.simplify}
      val _ =
	 let
	    open Control
	 in
	    if !keepSSA
	       then saveToFile ({suffix = "ssa"}, No, ssa,
				 Layouts Ssa.Program.layouts)
	    else ()
	 end
      val machine =
	 Control.pass
	 {name = "backend",
	  suffix = "machine",
	  style = Control.No,
	  thunk = fn () => Backend.toMachine ssa,
	  display = Control.Layouts Machine.Program.layouts}
      val _ =
	 let
	    open Control
	 in
	    if !keepMachine
	       then saveToFile ({suffix = "machine"}, No, machine,
				 Layouts Machine.Program.layouts)
	    else ()
	 end
      val _ =
	 Control.trace (Control.Pass, "machine type check")
	 Machine.Program.typeCheck machine
   in
      machine
   end

fun compile {input: File.t list, outputC, outputS}: unit =
   let
      val machine =
	 Control.trace (Control.Top, "pre codegen")
	 preCodegen {input = input}
      val _ =
	 if !Control.Native.native
	    then
	       Control.trace (Control.Top, "x86 code gen")
	       x86Codegen.output {program = machine,
				  outputC = outputC,
				  outputS = outputS}
	 else
	    Control.trace (Control.Top, "C code gen")
	    CCodegen.output {program = machine,
			     outputC = outputC}
      val _ = Control.message (Control.Detail, PropertyList.stats)
      val _ = Control.message (Control.Detail, HashSet.stats)
   in
      ()
   end
   
end



1.1                  mlton/mlton/main/lookup-constant.fun

Index: lookup-constant.fun
===================================================================
(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 * Copyright (C) 1997-1999 NEC Research Institute.
 *
 * MLton is released under the GNU General Public License (GPL).
 * Please see the file MLton-LICENSE for license information.
 *)
functor LookupConstant (S: LOOKUP_CONSTANT_STRUCTS): LOOKUP_CONSTANT = 
struct

open S
local
   open Const
in
   structure IntX = IntX
   structure RealX = RealX
   structure WordX = WordX
end
structure IntSize = IntX.IntSize
structure RealSize = RealX.RealSize
structure WordSize = WordX.WordSize

val buildConstants: (string * (unit -> string)) list =
   let
      val bool = Bool.toString
      val int = Int.toString
      open Control
   in
      [("Exn_keepHistory", fn () => bool (!exnHistory)),
       ("MLton_detectOverflow", fn () => bool (!detectOverflow)),
       ("MLton_native", fn () => bool (!Native.native)),
       ("MLton_profile_isOn", fn () => bool (!profile <> ProfileNone)),
       ("MLton_safe", fn () => bool (!safe)),
       ("MLton_FFI_numExports", fn () => int (Ffi.numExports ())),
       ("TextIO_bufSize", fn () => int (!textIOBufSize))]
   end

datatype z = datatype ConstType.t

fun escape s =
   String.translate (s, fn c =>
		     let
			val i = Char.ord c
			fun dig j =
			   Char.chr
			   (Char.ord #"0" + Int.rem (Int.quot (i, j), 10))
		     in
			implode [dig 100, dig 10, dig 1]
		     end)
   
fun unescape s =
   let
      fun sub i = Char.toInt (String.sub (s, i)) - Char.toInt #"0"
      fun loop (i, ac) =
	 if i < 0
	    then ac
	 else
	    loop (i - 3,
		  Char.fromInt ((sub (i - 2) * 10 + sub (i - 1)) * 10 + sub i)
		  :: ac)
   in
      implode (loop (String.size s - 1, []))
   end

val unescape = Trace.trace ("unescape", String.layout, String.layout) unescape

val gcFields =
   [
    "canHandle",
    "currentThread",
    "exnStack",
    "frontier",
    "cardMapForMutator",
    "limit",
    "limitPlusSlop",
    "maxFrameSize",
    "signalIsPending",
    "stackBottom",
    "stackLimit",
    "stackTop"
    ]

val gcFields =
   List.map (gcFields, fn s =>
	     {name = s,
	      value = concat ["offsetof (struct GC_state, ", s, ")"],
	      ty = ConstType.Int})

fun build (constants, out) =
   let
      val constants =
	 List.fold
	 (constants, gcFields, fn ((name, ty), ac) =>
	  if List.exists (buildConstants, fn (name', _) => name = name')
	     then ac
	  else {name = name, value = name, ty = ty} :: ac)
   in
      List.foreach
      (List.concat
       [["#include <stddef.h>", (* for offsetof *)
	 "#include <stdio.h>"],
	List.map (["libmlton.h"], fn i =>
		  concat ["#include <", i, ">"]),
	["struct GC_state gcState;",
	 "int main (int argc, char **argv) {"],
	List.revMap
	(constants, fn {name, value, ty} =>
	 let
	    val (format, value) =
	       case ty of
		  Bool => ("%s", concat [value, "? \"true\" : \"false\""])
		| Int => ("%d", value)
		| Real => ("%.20f", value)
		| String => ("%s", concat ["\"", escape value, "\""])
		| Word => ("%u", value)
	 in
	    concat ["fprintf (stdout, \"", name, " = ", format, "\\n\", ",
		    value, ");"]
	 end),
	["return 0;}"]],
       fn l => (Out.output (out, l); Out.newline out))
   end

fun load (ins: In.t): string * ConstType.t -> Const.t =
   let
      val table: {hash: word, name: string, value: string} HashSet.t =
	 HashSet.new {hash = #hash}
      fun add {name, value} =
	 let
	    val hash = String.hash name
	    val _ = 
	       HashSet.lookupOrInsert
	       (table, hash,
		fn {name = name', ...} => name = name',
		fn () => {hash = hash, name = name, value = value})
	 in
	    ()
	 end
      val buildConstants =
	 List.foreach (buildConstants, fn (name, f) =>
		       add {name = name, value = f ()})
      val _ = 
	 In.foreachLine
	 (ins, fn l =>
	  case String.tokens (l, Char.isSpace) of
	     [name, "=", value] => add {name = name, value = value}
	   | _ => Error.bug (concat ["strange constants line: ", l]))
      fun lookupConstant (name: string, ty: ConstType.t): Const.t =
	 let
 	    val {value, ...} =
 	       HashSet.lookupOrInsert
 	       (table, String.hash name,
 		fn {name = name', ...} => name = name',
 		fn () => Error.bug (concat ["constant not found: ", name]))
	    fun int i = Const.int (IntX.make (i, IntSize.default))
	 in
	    case ty of
	       Bool =>
		  (case Bool.fromString value of
		      NONE => Error.bug "strange Bool constante"
		    | SOME b => int (if b then 1 else 0))
	     | Int => 
		  (case IntInf.fromString value of
		      NONE => Error.bug "strange Int constant"
		    | SOME i => int i)
	     | Real => Const.Real (RealX.make (value, RealSize.default))
	     | String => Const.string (unescape value)
	     | Word =>
		  (case IntInf.fromString value of
		      NONE => Error.bug "strange Word constant"
		    | SOME i =>
			 Const.Word (WordX.make (LargeWord.fromIntInf i,
						 WordSize.default)))
	 end
   in
      lookupConstant
   end

end



1.1                  mlton/mlton/main/lookup-constant.sig

Index: lookup-constant.sig
===================================================================
(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 * Copyright (C) 1997-1999 NEC Research Institute.
 *
 * MLton is released under the GNU General Public License (GPL).
 * Please see the file MLton-LICENSE for license information.
 *)
type int = Int.t
type word = Word.t
   
signature LOOKUP_CONSTANT_STRUCTS = 
   sig
      structure Const: CONST
      structure ConstType: CONST_TYPE
      structure Ffi: FFI
   end

signature LOOKUP_CONSTANT = 
   sig
      include LOOKUP_CONSTANT_STRUCTS

      val build: (string * ConstType.t) list * Out.t -> unit
      val load: In.t -> string * ConstType.t -> Const.t
   end



1.1                  mlton/mlton/main/main.fun

Index: main.fun
===================================================================
(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 * Copyright (C) 1997-1999 NEC Research Institute.
 *
 * MLton is released under the GNU General Public License (GPL).
 * Please see the file MLton-LICENSE for license information.
 *)
functor Main (S: MAIN_STRUCTS): MAIN =
struct

open S

structure Compile = Compile ()

structure Place =
   struct
      datatype t = CM | Files | Generated | O | OUT | SML

      val toInt: t -> int =
	 fn CM => 0
	  | Files => 1
	  | SML => 2
	  | Generated => 3
	  | O => 4
	  | OUT => 5

      val toString =
	 fn CM => "cm"
	  | Files => "files"
	  | SML => "sml"
	  | Generated => "g"
	  | O => "o"
	  | OUT => "out"

      val layout = Layout.str o toString

      fun compare (p, p') = Int.compare (toInt p, toInt p')
   end

structure OptPred =
   struct
      datatype t =
	 Target of string
       | Yes 
   end

val buildConstants: bool ref = ref false
val ccOpts: {opt: string, pred: OptPred.t} list ref = ref []
val coalesce: int option ref = ref NONE
val expert: bool ref = ref false
val gcc: string ref = ref "<unset>"
val keepGenerated = ref false
val keepO = ref false
val keepSML = ref false
val linkOpts: {opt: string, pred: OptPred.t} list ref = ref []
val output: string option ref = ref NONE
val profileSet: bool ref = ref false
val runtimeArgs: string list ref = ref ["@MLton"]
val showBasis: bool ref = ref false
val stop = ref Place.OUT

val targetMap: unit -> {arch: MLton.Platform.Arch.t,
			os: MLton.Platform.OS.t,
			target: string} list =
   Promise.lazy
   (fn () =>
    List.map
    (File.lines (concat [!Control.libDir, "/target-map"]), fn line =>
     case String.tokens (line, Char.isSpace) of
	[target, arch, os] =>
	   let
	      val arch =
		 case MLton.Platform.Arch.fromString arch of
		    NONE => Error.bug (concat ["strange arch: ", arch])
		  | SOME a => a
	      val os =
		 case MLton.Platform.OS.fromString os of
		    NONE => Error.bug (concat ["strange os: ", os])
		  | SOME os => os
	   in
	      {arch = arch, os = os, target = target}
	   end
      | _ => Error.bug (concat ["strange target mapping: ", line])))

fun setTargetType (target: string, usage): unit =
   case List.peek (targetMap (), fn {target = t, ...} => t = target) of
      NONE => usage (concat ["invalid target ", target])
    | SOME {arch, os, ...} =>
	 let
	    datatype z = datatype MLton.Platform.Arch.t
	    open Control
	 in
	    targetArch := arch
	    ; targetOS := os
	    ; (case arch of
		  Sparc =>
		     (align := Align8
		      ; Native.native := false)
		| _ => ())
	 end
   
fun makeOptions {usage} = 
   let
      val usage = fn s => (usage s; raise Fail "unreachable")
      open Control Popt
      fun push r = SpaceString (fn s => List.push (r, s))
      datatype z = datatype MLton.Platform.Arch.t
   in
      List.map
      (
       [
       (Normal, "align",
	case !targetArch of
	   Sparc => " {8|4}"
	 | X86 => " {4|8}",
	"object alignment",
	(SpaceString (fn s =>
		      align
		      := (case s of
			     "4" => Align4
			   | "8" => Align8
			   | _ => usage (concat ["invalid -align flag: ",
						 s]))))),
       (Normal, "basis", " {2002|1997|...}",
	"select basis library to prefix to the program",
	SpaceString (fn s =>
		     let
			val s' = concat ["basis-", s]
		     in
			if List.contains (basisLibs, s', String.equals)
			   then basisLibrary := s'
			else usage (concat ["invalid -basis flag: ", s])
		     end)),
       (Expert, "build-constants", " {false|true}",
	"output C file that prints basis constants",
	boolRef buildConstants),
       (Expert, "card-size-log2", " <n>",
	"log (base 2) of card size used by GC",
	intRef cardSizeLog2),
       (Expert, "cc", " <gcc>", "path to gcc executable",
	SpaceString (fn s => gcc := s)),
       (Normal, "cc-opt", " <opt>", "pass option to C compiler",
	SpaceString (fn s =>
		     List.push (ccOpts, {opt = s, pred = OptPred.Yes}))),
       (Expert, "coalesce", " <n>", "coalesce chunk size for C codegen",
	Int (fn n => coalesce := SOME n)),
       (Expert, "debug", " {false|true}", "produce executable with debug info",
	boolRef debug),
       (Normal, "detect-overflow", " {true|false}",
	"overflow checking on integer arithmetic",
	boolRef detectOverflow),
       (Expert, "diag-pass", " <pass>", "keep diagnostic info for pass",
	SpaceString (fn s =>
		     (case Regexp.fromString s of
			 SOME (re,_) => let val re = Regexp.compileDFA re
					in 
					   List.push (keepDiagnostics, re)
					   ; List.push (keepPasses, re)
					end
		       | NONE => usage (concat ["invalid -diag-pass flag: ", s])))),
       (Expert, "drop-pass", " <pass>", "omit optimization pass",
	SpaceString
	(fn s => (case Regexp.fromString s of
		     SOME (re,_) => let val re = Regexp.compileDFA re
				    in List.push (dropPasses, re)
				    end
		   | NONE => usage (concat ["invalid -drop-pass flag: ", s])))),
       (Expert, "eliminate-overflow", " {true|false}",
	"eliminate useless overflow tests",
	boolRef eliminateOverflow),
       (Normal, "exn-history", " {false|true}",
	"enable Exn.history",
	boolRef exnHistory),
       (Expert, "expert", " {false|true}",
	"enable expert status",
	boolRef expert),
       (Normal, "export-header", " {false|true}",
	"output header file for _export's",
	boolRef exportHeader),
       (Expert, "gc-check", " {limit|first|every}", "force GCs",
	SpaceString (fn s =>
		     gcCheck :=
		     (case s of
			 "limit" => Limit
		       | "first" => First
		       | "every" => Every
		       | _ => usage (concat ["invalid -gc-check flag: ", s])))),
       (Expert, "handlers", " {flow|pushpop|simple}",
	"how to implement handlers",
	SpaceString (fn s =>
		     case s of
			"flow" => handlers := Flow
		      | "simple" => handlers := Simple
		      | _ => usage (concat ["invalid -handlers flag: ", s]))),
       (Normal, "ieee-fp", " {false|true}", "use strict IEEE floating-point",
	boolRef Native.IEEEFP),
       (Expert, "indentation", " <n>", "indentation level in ILs",
	intRef indentation),
       (Normal, "inline", " <n>", "inlining threshold", Int setInlineSize),
       (Normal, "keep", " {g|o|sml}", "save intermediate files",
	SpaceString (fn s =>
		     case s of
			"dot" => keepDot := true
		      | "g" => keepGenerated := true
		      | "machine" => keepMachine := true
		      | "o" => keepO := true
		      | "sml" => keepSML := true
		      | "rssa" => keepRSSA := true
		      | "ssa" => keepSSA := true
		      | _ => usage (concat ["invalid -keep flag: ", s]))),
       (Expert, "keep-pass", " <pass>", "keep the results of pass",
	SpaceString
	(fn s => (case Regexp.fromString s of
		     SOME (re,_) => let val re = Regexp.compileDFA re
				    in List.push (keepPasses, re)
				    end
		   | NONE => usage (concat ["invalid -keep-pass flag: ", s])))),
       (Expert, "limit-check", " {lhle|pb|ebb|lh|lhf|lhfle}",
	"limit check insertion algorithm",
	SpaceString (fn s =>
		     case s of
		        "pb" => limitCheck := PerBlock
		      | "ebb" => limitCheck := ExtBasicBlocks
		      | "lh" => limitCheck := LoopHeaders {fullCFG = false,
							   loopExits = false}
		      | "lhf" => limitCheck := LoopHeaders {fullCFG = true,
							    loopExits = false}
		      | "lhle" => limitCheck := LoopHeaders {fullCFG = false,
							     loopExits = true}
		      | "lhfle" => limitCheck := LoopHeaders {fullCFG = true,
							      loopExits = true}
		      | _ => usage (concat ["invalid -limit-check flag: ", s]))),
       (Expert, "limit-check-counts", " {false|true}",
	"compute dynamic counts of limit checks",
	boolRef limitCheckCounts),
       (Normal, "link-opt", " <opt>", "pass option to linker",
	SpaceString (fn s =>
		     List.push (linkOpts, {opt = s, pred = OptPred.Yes}))),
       (Expert, "loop-passes", " <n>", "loop optimization passes (1)",
	Int 
	(fn i => 
	 if i >= 1
	    then loopPasses := i
	    else usage (concat ["invalid -loop-passes arg: ", Int.toString i]))),
       (Expert, "mark-cards", " {true|false}", "mutator marks cards",
	boolRef markCards),
       (Normal, "native",
	if !targetArch = Sparc then " {false}" else " {true|false}",
	"use native code generator",
	boolRef Native.native),
       (Expert, "native-commented", " <n>", "level of comments  (0)",
	intRef Native.commented),
       (Expert, "native-copy-prop", " {true|false}", 
	"use copy propagation",
	boolRef Native.copyProp),
       (Expert, "native-cutoff", " <n>", 
	"live transfer cutoff distance",
	intRef Native.cutoff),
       (Expert, "native-live-transfer", " {0,...,8}",
	"use live transfer",
	intRef Native.liveTransfer),
       (Expert, "native-live-stack", " {false|true}",
	"track liveness of stack slots",
	boolRef Native.liveStack),
       (Expert, "native-move-hoist", " {true|false}",
	"use move hoisting",
	boolRef Native.moveHoist),
       (Expert, "native-optimize", " <n>", "level of optimizations",
        intRef Native.optimize),
       (Expert, "native-split", " <n>", "split assembly files at ~n lines",
	Int (fn i => Native.split := SOME i)),
       (Expert, "native-shuffle", " {true|false}",
	"shuffle registers at C-calls",
	Bool (fn b => Native.shuffle := b)),
       (Expert, "new-return", " {false|true}", "non-tail call return convention",
	boolRef newReturn),
       (Expert, "polyvariance", " {true|false}", "use polyvariance",
	Bool (fn b => if b then () else polyvariance := NONE)),
       (Normal, "output", " <file>", "name of output file",
	SpaceString (fn s => output := SOME s)),
       (Normal, "profile", " {no|alloc|time}",
	"produce executable suitable for profiling",
	SpaceString
	(fn s =>
	 if !profileSet
	    then usage "can't have multiple -profile switches"
	 else
	    (profileSet := true
	     ; profile := (case s of
			      "no" => ProfileNone
			    | "alloc" => ProfileAlloc
			    | "time" => ProfileTime
			    | _ => usage (concat
					  ["invalid -profile arg: ", s]))))),
       (Expert, "profile-basis", " {false|true}",
	"profile the basis implementation",
	boolRef profileBasis),
       (Expert, "profile-il", " {source}", "where to insert profile exps",
	SpaceString
	(fn s =>
	 case s of
	    "source" => profileIL := ProfileSource
	  | _ => usage (concat ["invalid -profile-il arg: ", s]))),
       (Normal, "profile-stack", " {false|true}", "profile the stack",
	boolRef profileStack),
       (Normal, "runtime", " <arg>", "pass arg to runtime via @MLton",
	push runtimeArgs),
       (Normal, "safe", " {true|false}", "bounds checking and other checks",
	boolRef safe),
       (Normal, "show-basis", " {false|true}", "display the basis library",
	boolRef showBasis),
       (Normal, "show-basis-used", " {false|true}",
	"display the basis library used by the program",
	boolRef showBasisUsed),
       (Expert, "show-types", " {false|true}", "print types in ILs",
	boolRef showTypes),
       (Expert, "stack-cont", " {false|true}",
	"force continuation formals to stack",
	boolRef stackCont),
       (Normal, "static", " {false|true}",
	"produce a statically linked executable",
	boolRef static),
       (Normal, "stop", " {f|g|o|sml}", "where to stop",
	SpaceString
	(fn s =>
	 stop := (case s of
		     "f" => Place.Files
		   | "g" => Place.Generated	
		   | "o" => Place.O
		   | "sml" => Place.SML
		   | _ => usage (concat ["invalid -stop arg: ", s])))),
       (Normal, "target",
	concat [" {",
		concat (List.separate (List.map (targetMap (), #target), "|")),
		"}"],
	"platform that executable will run on",
	SpaceString (fn s =>
		     (setTargetType (s, usage)
		      ; target := (if s = "self" then Self else Cross s)))),
       (Expert, "target-cc-opt", " <target> <opt>", "target-dependent CC option",
	(SpaceString2
	 (fn (target, opt) =>
	  List.push (ccOpts, {opt = opt, pred = OptPred.Target target})))),
       (Expert, "target-link-opt", " <target> <opt>",
	"target-dependent link option",
	(SpaceString2
	 (fn (target, opt) =>
	  List.push (linkOpts, {opt = opt, pred = OptPred.Target target})))),
       (Expert, #1 trace, " name1,...", "trace compiler internals", #2 trace),
       (Expert, "text-io-buf-size", " <n>", "TextIO buffer size",
	intRef textIOBufSize),
       (Expert, "type-check", " {false|true}", "type check ILs",
	boolRef typeCheck),
       (Normal, "verbose", " {0|1|2|3}", "how verbose to be",
	SpaceString
	(fn s =>
	 verbosity := (case s of
			  "0" => Silent
			| "1" => Top
			| "2" => Pass
			| "3" =>  Detail
			| _ => usage (concat ["invalid -verbose arg: ", s])))),
       (Expert, "variant", " {header|first-word}",
	"how to represent variant tags",
	SpaceString
	(fn s =>
	 variant := (case s of
			"first-word" => FirstWord
		      | "header" => Header
		      | _ => usage (concat ["invalid -variant arg: ", s]))))
       ],
       fn (style, name, arg, desc, opt) =>
       {arg = arg, desc = desc, name = name, opt = opt, style = style})
   end

val mainUsage =
   "mlton [option ...] file.{cm|sml|c|o} [file.{c|S|o} ...]"

val {parse, usage} =
   Popt.makeUsage {mainUsage = mainUsage,
		   makeOptions = makeOptions,
		   showExpert = fn () => !expert}

val usage = fn s => (usage s; raise Fail "unreachable")
   
fun commandLine (args: string list): unit =
   let
      open Control
      val args =
	 case args of
	    lib :: args => (libDir := lib; args)
	  | _ => Error.bug "incorrect args from shell script"
      val _ = setTargetType ("self", usage)
      val result = parse args
      val gcc = !gcc
      val target = !target
      val targetStr =
	 case target of
	    Cross s => s
	  | Self => "self"
      val _ = libTargetDir := concat [!libDir, "/", targetStr]
      val targetArch = !targetArch
      val archStr = MLton.Platform.Arch.toString targetArch
      val targetOS = !targetOS
      val OSStr = MLton.Platform.OS.toString targetOS
      fun tokenize l =
	 String.tokens (concat (List.separate (l, " ")), Char.isSpace)
      fun addTargetOpts opts =
	 tokenize
	 (List.fold
	  (!opts, [], fn ({opt, pred}, ac) =>
	   if (case pred of
		  OptPred.Target s => s = archStr orelse s = OSStr
		| OptPred.Yes => true)
	      then opt :: ac
	   else ac))
      val ccOpts = addTargetOpts ccOpts
      val linkOpts = addTargetOpts linkOpts
      datatype z = datatype MLton.Platform.OS.t
      val linkWithGmp =
	 case targetOS of
	    Cygwin => ["-lgmp"]
	  | FreeBSD => ["-L/usr/local/lib/", "-lgmp"]
	  | Linux =>
	       (* This mess is necessary because the linker on linux
		* adds a dependency to a shared library even if there are
		* no references to it.  So, on linux, we explicitly link
		* with libgmp.a instead of using -lgmp.
		*)
	       let
		  val conf = "/etc/ld.so.conf"
		  val dirs = if File.canRead conf then File.lines conf else []
		  val dirs = "/lib\n" :: "/usr/lib\n" :: dirs
	       in
		  case (List.peekMap
			(dirs, fn d =>
			 let
			    val lib =
			       concat [String.dropSuffix (d, 1), "/libgmp.a"]
			 in
			    if File.canRead lib
			       then SOME lib
			    else NONE
			 end)) of
		     NONE => ["-lgmp"]
		   | SOME lib => [lib]
	       end
	  | NetBSD => ["-Wl,-R/usr/pkg/lib", "-L/usr/pkg/lib", "-lgmp"]
	  | Sun => ["-lgmp"]
      val linkOpts =
	 List.concat [[concat ["-L", !libTargetDir],
		       if !debug then "-lmlton-gdb" else "-lmlton"],
		      linkWithGmp,
		      linkOpts]
      val _ =
	 if !Native.native andalso targetArch = Sparc
	    then usage "can't use -native true on Sparc"
	 else ()
      val _ =
	 chunk := (if !Native.native
		      then
			 if isSome (!coalesce)
			    then usage "can't use -coalesce and -native true"
			 else ChunkPerFunc
		   else Coalesce {limit = (case !coalesce of
					      NONE => 4096
					    | SOME n => n)})
      val _ = if not (!Native.native) andalso !Native.IEEEFP
		 then usage "can't use -native false and -ieee-fp true"
	      else ()
      val _ =
	 if !keepDot andalso List.isEmpty (!keepPasses)
	    then keepSSA := true
	 else ()
      val _ =
	 if targetOS = Cygwin andalso !profile = ProfileTime
	    then usage "can't use -profile time on Cygwin"
	 else ()
      fun printVersion (out: Out.t): unit =
	 Out.output (out, concat [version, " ", build, "\n"])
   in
      case result of
      Result.No msg => usage msg
    | Result.Yes [] =>
	 (case !verbosity of
	     Silent =>
		if !showBasis
		   then Layout.outputl (Compile.layoutBasisLibrary (),
					Out.standard)
		else if !buildConstants
		   then Compile.outputBasisConstants Out.standard
	        else printVersion Out.standard
	   | Top => printVersion Out.standard
	   | _ => (inputFile := ""
		   ; outputHeader' (No, Out.standard)))
    | Result.Yes (input :: rest) =>
	 let
	    val _ = inputFile := File.base (File.fileOf input)
	    val (start, base) =
	       let
		  val rec loop =
		     fn [] => usage (concat ["invalid file suffix on ", input])
		      | (suf, start, hasNum) :: sufs =>
			   if String.isSuffix {string = input, suffix = suf}
			      then (start,
				    let
				       val f = File.base input
				    in
				       if hasNum
					  then File.base f
				       else f
				    end)
			   else loop sufs
		  datatype z = datatype Place.t
	       in
		  loop [(".cm", CM, false),
			(".sml", SML, false),
			(".c", Generated, true),
			(".o", O, true)]
	       end
	    val _ =
	       List.foreach
	       (rest, fn f =>
		if List.exists ([".c", ".o", ".s", ".S"], fn suffix =>
				String.isSuffix {string = f, suffix = suffix})
		   andalso File.canRead f
		   then ()
		else usage (concat ["invalid file: ", f]))
	    val csoFiles = rest
	    val stop = !stop
	 in
	    case Place.compare (start, stop) of
	       GREATER => usage (concat ["cannot go from ", Place.toString start,
					 " to ", Place.toString stop])
	     | EQUAL => usage "nothing to do"
	     | LESS =>
		  let
		     val _ =
			if !verbosity = Top
			   then printVersion Out.error
			else ()
		     val tempFiles: File.t list ref = ref []
		     val tmpDir =
			case Process.getEnv "TMPDIR" of
			   NONE => "/tmp"
			 | SOME d => d
		     fun temp (suf: string): File.t =
			let
			   val (f, out) =
			      File.temp {prefix = concat [tmpDir, "/file"],
					 suffix = suf}
			   val _ = Out.close out
			   val _ = List.push (tempFiles, f)
			in
			   f
			end
		     fun suffix s = concat [base, s]
		     fun maybeOut suf =
			case !output of
			   NONE => suffix suf
			 | SOME f => f
		     val _ =
			atMLtons :=
			Vector.fromList
			(maybeOut "" :: tokenize (rev ("--" :: (!runtimeArgs))))
		     datatype debugFormat =
			Dwarf | DwarfPlus | Dwarf2 | Stabs | StabsPlus
		     (* The -Wa,--gstabs says to pass the --gstabs option to the
		      * assembler. This tells the assembler to generate stabs
		      * debugging information for each assembler line.
		      *)
		     val debugFormat = StabsPlus
		     val (gccDebug, asDebug) =
			case debugFormat of
			   Dwarf => (["-gdwarf", "-g2"], "-Wa,--gdwarf2")
			 | DwarfPlus => (["-gdwarf+", "-g2"], "-Wa,--gdwarf2")
			 | Dwarf2 => (["-gdwarf-2", "-g2"], "-Wa,--gdwarf2")
			 | Stabs => (["-gstabs", "-g2"], "-Wa,--gstabs")
			 | StabsPlus => (["-gstabs+", "-g2"], "-Wa,--gstabs")
		     fun compileO (inputs: File.t list): unit =
			let
			   val output = maybeOut ""
			   val _ =
			      trace (Top, "Link")
			      (fn () =>
			       System.system
			       (gcc,
				List.concat
				[["-o", output],
				 (case target of
				     Cross s => ["-b", s]
				   | Self => []),
				 if !debug then gccDebug else [],
				 if !static then ["-static"] else [],
				 inputs,
				 linkOpts]))
			      ()
			   (* gcc on Cygwin appends .exe, which I don't want, so
			    * move the output file to it's rightful place.
			    * Notice that we do not use targetOS here, since we
			    * care about the platform we're running on, not the
			    * platform we're generating for.
			    *)
			   val _ =
			      if MLton.Platform.OS.host = Cygwin
				 then
				    if String.contains (output, #".")
				       then ()
				    else
				       File.move {from = concat [output, ".exe"],
						  to = output}
			      else ()
			in
			   ()
			end
		  fun compileCSO (inputs: File.t list): unit =
		     if List.forall (inputs, fn f =>
				     SOME "o" = File.extension f)
			then compileO inputs
		     else
		     let
			val c = Counter.new 0
			val oFiles =
			   trace (Top, "Compile C and Assemble")
			   (fn () =>
			    List.fold
			    (inputs, [], fn (input, ac) =>
			     let
				val extension = File.extension input
			     in
				if SOME "o" = extension
				   then input :: ac
				else
				   let
				      val (debugSwitches, switches) =
					 if SOME "c" = extension
					    then
					       (gccDebug @ ["-DASSERT=1"],
						ccOpts)
					 else ([asDebug], [])
				      val switches =
					 if !debug
					    then debugSwitches @ switches
					 else switches
				      val switches =
					 case target of
					    Cross s => "-b" :: s :: switches
					  | Self => switches
				      val switches = "-c" :: switches
				      val output =
					 if stop = Place.O orelse !keepO
					    then
					       if !keepGenerated 
						  orelse start = Place.Generated
						  then
						     concat [String.dropSuffix
							     (input, 1),
							     "o"]
					       else 
						  suffix
						  (concat [".",
							   Int.toString
							   (Counter.next c),
							   ".o"])
					 else temp ".o"
				      val _ =
					 System.system
					 (gcc,
					  List.concat [switches,
						       ["-o", output, input]])

				   in
				      output :: ac
				   end
			     end))
			   ()
		     in
			case stop of
			   Place.O => ()
			 | _ => compileO (rev oFiles)
		     end
		  fun compileSml (files: File.t list) =
		     let
			val outputs: File.t list ref = ref []
			val r = ref 0
			fun make (style: style, suf: string) () =
			   let
			      val suf = concat [".", Int.toString (!r), suf]
			      val _ = Int.inc r
			      val file = (if !keepGenerated
					     orelse stop = Place.Generated
					     then suffix
					  else temp) suf
			      val _ = List.push (outputs, file)
			      val out = Out.openOut file
			      fun print s = Out.output (out, s)
			      val _ = outputHeader' (style, out)
			      fun done () = Out.close out
			   in
			      {file = file,
			       print = print,
			       done = done}
			   end
			val _ =
			   case !verbosity of
			      Silent => ()
			    | Top => ()
			    | _ => 
				 outputHeader
				 (Control.No, fn l =>
				  let val out = Out.error
				  in Layout.output (l, out)
				     ; Out.newline out
				  end)
			val _ =
			   trace (Top, "Compile SML")
			   Compile.compile
			   {input = files,
			    outputC = make (Control.C, ".c"),
			    outputS = make (Control.Assembly,
					    if !debug then ".s" else ".S")}
			(* Shrink the heap before calling gcc. *)
			val _ = MLton.GC.pack ()
		     in
			case stop of
			   Place.Generated => ()
			 | _ => compileCSO (List.concat [!outputs, csoFiles])
		     end
		  fun compileCM input =
		     let
			val files = CM.cm {cmfile = input}
			fun saveSML smlFile =
			   File.withOut
			   (smlFile, fn out =>
			    (outputHeader' (ML, out)
			     ; (List.foreach
				(files, fn f =>
				 (Out.output
				  (out, concat ["(*#line 0.0 \"", f, "\"*)\n"])
				  ; File.outputContents (f, out))))))
		     in
			case stop of
			   Place.Files =>
			      List.foreach
			      (files, fn f => print (concat [f, "\n"]))
			 | Place.SML => saveSML (maybeOut ".sml")
			 | _ =>
			      (if !keepSML
				  then saveSML (suffix ".sml")
			       else ()
				  ; compileSml files)
		     end
		  fun compile () =
		     case start of
			Place.CM => compileCM input
		      | Place.SML => compileSml [input]
		      | Place.Generated => compileCSO (input :: csoFiles)
		      | Place.O => compileCSO (input :: csoFiles)
		      | _ => Error.bug "invalid start"
		  val doit 
		    = trace (Top, "MLton")
		      (fn () => 
		       DynamicWind.wind
		       (compile, fn () =>
			List.foreach (!tempFiles, File.remove)))
	       in doit ()
	       end
	 end
   end

val commandLine = Process.makeCommandLine commandLine
   
fun exportNJ (root: Dir.t, file: File.t): unit =
   (Compile.forceBasisLibrary root
    ; SMLofNJ.exportFn (file, fn (_, args) => commandLine args))
   
fun exportMLton (): unit =
   case CommandLine.arguments () of
      [root, file] => exportNJ (root, file)
    | _ => Error.bug "usage: exportMLton root file"

val _ =
   let
      open Trace.Immediate
   in
      debug := Out Out.error
      ; flagged ()
(*      ; on ["setConTycon"] *)
(*      ; on ["elaborateDec", "elaborateExp", "elaboratePat"] *)
(*      ; on ["coalesce"] *)
(*      ; on ["elaborateStrdec"] *)
(*      ; on ["extendVar"] *)
(*      ; on ["elaborateStrdec", "elaborateTopdec"] *)
(*      ; on ["unify"] *)
(*      ; on ["Scheme.instantiate"] *)
(*      ; on ["Unknown.minTime"] *)
(*      ; on ["Xml.checkExp", "Xml.checkPrimExp"] *)
(*      ; on ["Xml.Shrink.varInfo", "Xml.Shrink.setVarInfo"] *)
   end

fun doit () =
   let
   in
      Compile.forceBasisLibrary "/home/sweeks/mlton/src/basis-library"
   end

end



1.1                  mlton/mlton/match-compile/match-compile.fun

Index: match-compile.fun
===================================================================
(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 * Copyright (C) 1997-1999 NEC Research Institute.
 *
 * MLton is released under the GNU General Public License (GPL).
 * Please see the file MLton-LICENSE for license information.
 *)
functor MatchCompile (S: MATCH_COMPILE_STRUCTS): MATCH_COMPILE =
struct

open S

structure Env = MonoEnv (structure Domain = Var
			 structure Range = Var)
   
structure FlatPat =
   struct
      datatype t =
	 Any
       | Const of Const.t
       | Con of {arg: NestedPat.t option,
		 con: Con.t,
		 targs: Type.t vector}
       | Tuple of NestedPat.t vector

      fun layout p =
	 let
	    open Layout
	 in
	    case p of
	       Any => str "Any"
	     | Const c => Const.layout c
	     | Con {con, arg, ...} => seq [Con.layout con, str " ",
					   Option.layout NestedPat.layout arg]
	     | Tuple v => Vector.layout NestedPat.layout v
	 end

      val isRefutable =
	 fn Any => false
	  | Const _ => true
	  | Con _ => true
	  | Tuple ps => Vector.exists (ps, NestedPat.isRefutable)

      val isAny =
	 fn Any => true
	  | _ => false

      (* get rid of Wild, Var, Layered - also remove unary tuples *)
      fun flatten (var: Var.t, pat: NestedPat.t, env: Env.t): t * Env.t =
	 let
	    fun extend x = Env.extend (env, x, var)
	 in
	    case NestedPat.node pat of
	       NestedPat.Con x => (Con x, env)
	     | NestedPat.Const c => (Const c, env)
	     | NestedPat.Layered (x, p) => flatten (var, p, extend x)
	     | NestedPat.Tuple ps =>
		  if 1 = Vector.length ps
		     then flatten (var, Vector.sub (ps, 0), env)
		  else (Tuple ps, env)
	     | NestedPat.Var x => (Any, extend x)
	     | NestedPat.Wild => (Any, env)
	 end

      fun flattens (vars: Var.t vector,
		    pats: NestedPat.t vector,
		    env: Env.t): t vector * Env.t =
	 Vector.map2AndFold (vars, pats, env, flatten)
   end   

structure Continue =
   struct
      datatype t =
	 Finish of (Var.t -> Var.t) -> Exp.t
       | Matches of FlatPat.t vector option * t

      fun layout c =
	 let
	    open Layout
	 in
	    case c of
	       Finish _ => str "Finish"
	     | Matches (opt, c) =>
		  seq [str "Matches",
		       tuple [Option.layout (Vector.layout FlatPat.layout) opt,
			      layout c]]
	 end
   end
datatype z = datatype Continue.t

structure Info =
   struct
      datatype t = T of {accum: Env.t,
			 continue: Continue.t}

      fun layout (T {accum, continue}) =
	 Layout.record [("accum", Env.layout accum),
			("continue", Continue.layout continue)]
   end

structure Rule =
   struct
      datatype t = T of {info: Info.t,
			 pat: NestedPat.t}

      fun layout (T {info, pat}) =
	 Layout.record [("info", Info.layout info),
			("pat", NestedPat.layout pat)]
   end

structure FlatRule =
   struct
      datatype t = T of {info: Info.t,
			 pat: FlatPat.t}

      local
	 fun make f (T r) = f r
      in
	 val info = make #info
      end

      fun layout (T {info, pat}) =
	 Layout.record [("info", Info.layout info),
			("pat", FlatPat.layout pat)]
   end

structure Finish =
   struct
      type t = Info.t vector -> Exp.t
	 
      fun layout (_: t) = Layout.str "<finish>"
   end

local
   fun make (name, layout) = 
      Trace.trace4
      (concat ["MatchCompile.", name],
       layout, Type.layout, Vector.layout FlatRule.layout, Finish.layout,
       Exp.layout)
in
   val traceMatchFlat = make ("matchFlat", Var.layout)
   val traceTuple = make ("tuple", Exp.layout)
   val traceConst = make ("const", Exp.layout)
end

local
   fun make (all, ty, inj, get) =
      List.map (all, fn s =>
		(ty s,
		 fn (cases, finish) =>
		 inj (s,
		      Vector.map
		      (cases, fn {const, infos: Info.t list} =>
		       (get const, finish (Vector.fromList infos))))))
in
   val directCases = 
      make (List.remove (IntSize.all, fn s => IntSize.I64 = s),
	    Type.int, Cases.int,
	    fn Const.Int i => i
	     | _ => Error.bug "caseInt type error")
      @ make (List.remove (WordSize.all, fn s => WordSize.W64 = s),
	      Type.word, Cases.word,
	      fn Const.Word w => w
	       | _ => Error.bug "caseWord type error")
end

(*---------------------------------------------------*)
(*                   matchCompile                    *)
(*---------------------------------------------------*)

fun matchCompile {caseType: Type.t,
		  cases: (NestedPat.t * ((Var.t -> Var.t) -> Exp.t)) vector,
		  conTycon: Con.t -> Tycon.t,
		  region: Region.t,
		  test: Var.t,
		  testType: Type.t,
		  tyconCons: Tycon.t -> Con.t vector}: Exp.t =
   let
      fun match (var: Var.t,
		 ty: Type.t,
		 rules: Rule.t vector,
		 finish: Finish.t): Exp.t =
	 let
	    val rules =
	       Vector.map
	       (rules, fn Rule.T {pat, info as Info.T {accum, continue}} =>
		let
		   val (pat, accum) = FlatPat.flatten (var, pat, accum)
		in
		   FlatRule.T {pat = pat,
			       info = Info.T {accum = accum,
					      continue = continue}}
		end)
	 in matchFlat (var, ty, rules, finish)
	 end
      and matchFlat arg: Exp.t =
	 traceMatchFlat
	 (fn (var: Var.t,
	      ty: Type.t,
	      rules: FlatRule.t vector,
	      finish: Finish.t) =>
	  let
	     val test = Exp.var (var, ty)
	  in
	     case Vector.peek (rules, fn FlatRule.T {pat, ...} =>
			       case pat of
				  FlatPat.Any => false
				| _ => true) of
		NONE => finish (Vector.map (rules, FlatRule.info))
	      | SOME (FlatRule.T {pat, info}) =>
		   case pat of
		      FlatPat.Any => Error.bug "matchFlat"
		    | FlatPat.Const _ => const (test, ty, rules, finish)
		    | FlatPat.Con _ => sum (test, rules, finish)
		    | FlatPat.Tuple ps => tuple (test, ty, rules, finish)
	  end) arg
      and matches (vars: (Var.t * Type.t) vector,
		   rules: {pats: NestedPat.t vector option, info: Info.t} vector,
		   finish: Finish.t): Exp.t =
	 let
	    val rules =
	       Vector.map
	       (rules, fn {pats, info as Info.T {accum, continue}} =>
		case pats of
		   NONE => {pats = NONE, info = info}
		 | SOME pats =>
		      let
			 val (pats, accum) =
			    FlatPat.flattens (Vector.map (vars, #1),
					      pats,
					      accum)
		      in {pats = SOME pats,
			  info = Info.T {accum = accum, continue = continue}}
		      end)
	 in matchesFlat (0, vars, rules, finish)
	 end
      and matchesFlat (i: int,
		       vars: (Var.t * Type.t) vector,
		       rules: {pats: FlatPat.t vector option,
			       info: Info.t} vector,
		       finish: Finish.t): Exp.t =
	 if i = Vector.length vars
	    then finish (Vector.map (rules, #info))
	 else
	    let
	       val (var, ty) = Vector.sub (vars, i)
	       val rules =
		  Vector.map
		  (rules, fn {pats, info as Info.T {accum, continue}} =>
		   case pats of
		      NONE =>
			 FlatRule.T
			 {pat = FlatPat.Any,
			  info = Info.T {accum = accum,
					 continue =
					 Matches (NONE, continue)}}
		    | SOME pats =>
			 FlatRule.T
			 {pat = Vector.sub (pats, i),
			  info =
			  Info.T {accum = accum,
				  continue = Matches (SOME pats, continue)}})
	    in matchFlat
	       (var, ty, rules, fn infos =>
		matchesFlat
		(i + 1, vars,
		 Vector.map (infos, fn Info.T {accum, continue} =>
			     case continue of
				Matches (pats, continue) =>
				   {pats = pats,
				    info = Info.T {accum = accum,
						   continue = continue}}
			      | _ => Error.bug "matchesFlat:"),
		 finish))
	    end
      (*------------------------------------*)
      (*               tuple                *)
      (*------------------------------------*)
      and tuple arg =
	 traceTuple
	 (fn (test: Exp.t,
	      ty: Type.t,
	      rules: FlatRule.t vector,
	      finish: Finish.t) =>
	  let
	     val rules =
		Vector.map
		(rules, fn FlatRule.T {pat, info} =>
		 case pat of
		    FlatPat.Any => {pats = NONE, info = info}
		  | FlatPat.Tuple pats => {pats = SOME pats, info = info}
		  | _ => Error.bug "expected tuple pattern")
	  in Exp.detuple
	     {tuple = test,
	      body = fn vars => matches (vars, rules, finish)}
	  end) arg
      (*------------------------------------*)
      (*                sum                 *)
      (*------------------------------------*)
      and sum (test, rules: FlatRule.t vector, finish: Finish.t) =
	 let
	    datatype arg = 
	       NoArg of Info.t list
	     | Arg of {var: Var.t,
		       ty: Type.t,
		       rules: Rule.t list}
	    val (cases, defaults) =
	       Vector.foldr
	       (rules, ([], []),
		fn (FlatRule.T {pat, info}, (cases, defaults)) =>
		case pat of
		   FlatPat.Any =>
		      (List.map
		       (cases, fn {con, tys, arg} =>
			{con = con, tys = tys,
			 arg = (case arg of
				   NoArg infos => NoArg (info :: infos)
				 | Arg {var, ty, rules} =>
				      Arg {var = var,
					   ty = ty,
					   rules = Rule.T {pat = NestedPat.wild ty,
							   info = info} :: rules})}),
		       info :: defaults)
		 | FlatPat.Con {con=c, targs=tys, arg} => 
		      let
			 fun insert cases =
			    case cases of
			       [] =>
				  [{con = c, tys = tys,
				    arg =
				    (case arg of
					NONE => NoArg (info :: defaults)
				      | SOME p =>
					   let val ty = NestedPat.ty p
					   in Arg {var = Var.newNoname (),
						   ty = ty,
						   rules =
						   Rule.T {pat = p, info = info}
						   :: (List.map
						       (defaults, fn info =>
							Rule.T
							{pat = NestedPat.wild ty,
							 info = info}))}
					   end)}]
			     | (cas as {con, tys, arg=a}) :: cases =>
				  if Con.equals (c, con)
				     then {con = con, tys = tys,
					   arg = (case (a, arg) of
						     (NoArg infos, NONE) =>
							NoArg (info :: infos)
						      | (Arg {var, ty, rules},
							 SOME p) =>
							Arg {var = var,
							     ty = ty,
							     rules = 
							     Rule.T {pat = p,
								     info = info}
							     :: rules}
						       | _ => Error.bug "use of constructor with and without arg in pattern match")}
					:: cases
				  else cas :: (insert cases)
		      in (insert cases, defaults)
		      end
		 | _ => Error.bug "expected constructor pat")
	    val cases = Vector.fromList cases
	    val defaults = Vector.fromList defaults
	    val default =
	       if Vector.isEmpty cases
		  then
		     SOME (finish defaults, region)
	       else
		  let
		     val {con, ...} = Vector.sub (cases, 0)
		     val tycon = conTycon con
		  in if Tycon.equals (tycon, Tycon.exn)
		     orelse Vector.length cases <> (Vector.length
						    (tyconCons tycon))
			then SOME (finish defaults, region)
		     else NONE
		  end
	    fun normal () =
	       Exp.casee
	       {test = test, default = default,
		ty = caseType,
		cases =
		Cases.con (Vector.map
			   (cases, fn {con, tys, arg} =>
			    let
			       val (arg, rhs) =
				  case arg of
				     NoArg infos =>
					(NONE, finish (Vector.fromList infos))
				   | Arg {var, ty, rules} =>
					(SOME (var, ty),
					 match (var, ty,
						Vector.fromList rules,
						finish))
			    in {con = con,
				targs = tys,
				arg = arg,
				rhs = rhs}
			    end))}
	 in
	    if 1 = Vector.length cases
	       then
		  let
		     val {con, arg, ...} = Vector.sub (cases, 0)
		  in
		     case arg of
			Arg {var, ty, rules} =>
			   if Con.equals (con, Con.reff)
			      then (Exp.lett
				    {var = var,
				     exp = Exp.deref test,
				     body = match (var, ty,
						   Vector.fromList rules,
						   finish)})
			   else normal ()
		      | _ => normal ()
		  end
	    else normal ()
	 end
      (*------------------------------------*)
      (*               const                *)
      (*------------------------------------*)
      and const arg =
	 traceConst
	 (fn (test: Exp.t,
	      ty: Type.t,
	      rules: FlatRule.t vector,
	      finish: Finish.t) =>
	 let
	    val (cases, defaults) =
	       Vector.foldr
	       (rules, ([], []),
		fn (FlatRule.T {pat, info}, (cases, defaults)) =>
		case pat of
		   FlatPat.Any =>
		      (List.map (cases, fn {const, infos} =>
				 {const = const, infos = info :: infos}),
		       info :: defaults)
		 | FlatPat.Const c =>
		      let
			 fun insert (cases, ac) =
			    case cases of
			       [] => Error.bug "match-compile insert"
			     | (casee as {const, infos}) :: cases =>
				  if Const.equals (c, const)
				     then
					{const = c,
					 infos = info :: infos}
					:: List.appendRev (ac, cases)
				  else insert (cases, casee :: ac)
			 val cases =
			    if List.exists (cases, fn {const, ...} =>
					    Const.equals (c, const))
			       then insert (cases, [])
			    else {const = c, infos = info :: defaults} :: cases
		      in (cases, defaults)
		      end
		 | _ => Error.bug "expected Const pat")
	    val default = finish (Vector.fromList defaults)
	    fun loop ds =
	       case ds of
		  [] =>
		     List.fold
		     (cases, default, fn ({const, infos}, rest) =>
		      Exp.iff {test = Exp.equal (test, Exp.const const),
			       thenn = finish (Vector.fromList infos),
			       elsee = rest,
			       ty = caseType})
		| (ty', make) :: ds  =>
		     if Type.equals (ty, ty')
			then Exp.casee {test = test,
					default = SOME (default, region),
					ty = caseType,
					cases = make (Vector.fromList cases,
						      finish)}
		     else loop ds
	 in loop directCases
	 end) arg
   (*------------------------------------*)
   (*    main code for match compile     *)
   (*------------------------------------*)
   in match (test, testType,
	     Vector.map (cases, fn (p, f) =>
			 Rule.T {pat = p,
				 info = Info.T {accum = Env.empty,
						continue = Finish f}}),
	     fn infos =>
	     if Vector.isEmpty infos
		then Error.bug "matchRules: no default"
	     else
		let val Info.T {accum = env, continue} = Vector.sub (infos, 0)
		in
		   case continue of
		      Finish f => f (fn x => Env.lookup (env, x))
		    | _ => Error.bug "matchRules: expecting Finish"
		end)
   end

val matchCompile =
   Trace.trace
   ("matchCompile",
    fn {cases, ...} => Vector.layout (NestedPat.layout o #1) cases,
    Exp.layout)
   matchCompile
   
end



1.1                  mlton/mlton/match-compile/match-compile.sig

Index: match-compile.sig
===================================================================
(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 * Copyright (C) 1997-1999 NEC Research Institute.
 *
 * MLton is released under the GNU General Public License (GPL).
 * Please see the file MLton-LICENSE for license information.
 *)

type int = Int.t
type word = Word.t
   
signature MATCH_COMPILE_STRUCTS =
   sig
      include ATOMS
      structure Type:
	 sig
	    type t

	    val deTuple: t -> t vector
	    val equals: t * t -> bool
	    val int: IntSize.t -> t
	    val layout: t -> Layout.t
	    val word: WordSize.t -> t
	 end
      structure Cases:
	 sig
	    type exp
	    type t

	    val con: {con: Con.t,
		      targs: Type.t vector,
		      arg: (Var.t * Type.t) option,
		      rhs: exp} vector -> t
	    val int: IntSize.t * (IntX.t * exp) vector -> t
	    val word: WordSize.t * (WordX.t * exp) vector -> t
	 end
      structure Exp:
	 sig
	    type t
	       
	    val const: Const.t -> t
	    val var: Var.t * Type.t -> t
	    val detuple: {tuple: t,
			  body: (Var.t * Type.t) vector -> t} -> t
	    val casee:
	       {cases: Cases.t,
		default: (t * Region.t) option,
		test: t,
		ty: Type.t}  (* type of entire case expression *)
	       -> t
	    val lett: {var: Var.t, exp: t, body: t} -> t
	    val iff: {test: t, thenn: t, elsee: t, ty: Type.t} -> t
	    val equal: t * t -> t
	    val deref: t -> t
	    val layout: t -> Layout.t
	 end
      sharing type Cases.exp = Exp.t
      structure NestedPat: NESTED_PAT
      sharing Atoms = NestedPat.Atoms
      sharing Type = NestedPat.Type
   end

signature MATCH_COMPILE =
   sig
      include MATCH_COMPILE_STRUCTS

      val matchCompile:
	 {caseType: Type.t, (* type of entire expression *)
	  cases: (NestedPat.t * ((Var.t -> Var.t) -> Exp.t)) vector,
	  conTycon: Con.t -> Tycon.t,
	  region: Region.t,
	  test: Var.t,
	  testType: Type.t,
	  tyconCons: Tycon.t -> Con.t vector}
	 -> Exp.t
   end



1.1                  mlton/mlton/match-compile/nested-pat.fun

Index: nested-pat.fun
===================================================================
(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 * Copyright (C) 1997-1999 NEC Research Institute.
 *
 * MLton is released under the GNU General Public License (GPL).
 * Please see the file MLton-LICENSE for license information.
 *)
functor NestedPat (S: NESTED_PAT_STRUCTS): NESTED_PAT = 
struct

open S

datatype t = T of {pat: node, ty: Type.t}
and node =
   Con of {arg: t option,
	   con: Con.t,
	   targs: Type.t vector}
  | Const of Const.t
  | Layered of Var.t * t
  | Tuple of t vector
  | Var of Var.t
  | Wild

local
   fun make f (T r) = f r
in
   val node = make #pat
   val ty = make #ty
end
   
fun tuple ps =
   if 1 = Vector.length ps
      then Vector.sub (ps, 0)
   else T {pat = Tuple ps,
	   ty = Type.tuple (Vector.map (ps, ty))}

fun layout p =
   let
      open Layout
   in
      case node p of
	 Con {arg, con, targs} =>
	    Pretty.conApp {arg = Option.map (arg, layout),
			   con = Con.layout con,
			   targs = Vector.map (targs, Type.layout)}
       | Const c => Const.layout c
       | Layered (x, p) => seq [Var.layout x, str " as ", layout p]
       | Tuple ps => tuple (Vector.toListMap (ps, layout))
       | Var x => Var.layout x
       | Wild => str "_"
end

fun make (p, t) =
   case p of
      Tuple ps =>
	 if 1 = Vector.length ps
	    then Vector.sub (ps, 0)
	 else T {pat = p, ty = t}
    | _ => T {pat = p, ty = t}

fun wild t = make (Wild, t)
   
fun isRefutable p =
   case node p of
      Wild => false
    | Var _ => false
    | Const _ => true
    | Con _ => true
    | Tuple ps => Vector.exists (ps, isRefutable)
    | Layered (_, p) => isRefutable p

fun isVar p =
   case node p of
      Var _ => true
    | _ => false

val unit =
   T {pat = Tuple (Vector.new0 ()),
      ty = Type.tuple (Vector.new0 ())}
   
fun removeOthersReplace (p, {new, old}) =
   let
      fun loop (T {pat, ty}) =
	 let
	    val pat =
	       case pat of
		  Con {arg, con, targs} =>
		     Con {arg = Option.map (arg, loop),
			  con = con,
			  targs = targs}
		| Const _ => pat
		| Layered (x, p) =>
		     let
			val p = loop p
		     in
			if Var.equals (x, old)
			   then Layered (new, p)
			else node p
		     end
		| Tuple ps => Tuple (Vector.map (ps, loop))
		| Var x =>
		     if Var.equals (x, old)
			then Var new
		     else Wild
		| Wild => Wild
	 in
	    T {pat = pat, ty = ty}
	 end
   in
      loop p
   end

val removeOthersReplace =
   Trace.trace ("NestedPat.removeOthersReplace", fn (p, _) => layout p, layout)
   removeOthersReplace
   
local
   val bogus = Var.newNoname ()
in
   fun removeVars (p: t): t =
      removeOthersReplace (p, {new = bogus, old = bogus})
end

fun replaceTypes (p: t, f: Type.t -> Type.t): t =
   let
      fun loop (T {pat, ty}) =
	 let
	    val pat =
	       case pat of
		  Con {arg, con, targs} =>
		     Con {arg = Option.map (arg, loop),
			  con = con,
			  targs = Vector.map (targs, f)}
		| Const _ => pat
		| Layered (x, p) => Layered (x, loop p)
		| Tuple ps => Tuple (Vector.map (ps, loop))
		| Var x => Var x
		| Wild => Wild
	 in
	    T {pat = pat, ty = f ty}
	 end
   in
      loop p
   end

fun varsAndTypes (p: t): (Var.t * Type.t) list =
   let
      fun loop (p: t, accum: (Var.t * Type.t) list) =
	 case node p of
	    Wild => accum
	  | Const _ => accum
	  | Var x => (x, ty p) :: accum
	  | Tuple ps => Vector.fold (ps, accum, loop)
	  | Con {arg, ...} => (case arg of
				NONE => accum
			      | SOME p => loop (p, accum))
	  | Layered (x, p) => loop (p, (x, ty p) :: accum)
   in loop (p, [])
   end

fun vars (p: t): Var.t list =
   List.revMap (varsAndTypes p, #1)

end



1.1                  mlton/mlton/match-compile/nested-pat.sig

Index: nested-pat.sig
===================================================================
(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 * Copyright (C) 1997-1999 NEC Research Institute.
 *
 * MLton is released under the GNU General Public License (GPL).
 * Please see the file MLton-LICENSE for license information.
 *)
signature NESTED_PAT_STRUCTS = 
   sig
      include ATOMS
      structure Type:
	 sig
	    type t

	    val layout: t -> Layout.t
	    val tuple: t vector -> t
	 end
   end

signature NESTED_PAT = 
   sig
      include NESTED_PAT_STRUCTS
      
      datatype t = T of {pat: node, ty: Type.t}
      and node =
	 Con of {arg: t option,
		 con: Con.t,
		 targs: Type.t vector}
	| Const of Const.t
	| Layered of Var.t * t
	| Tuple of t vector
	| Var of Var.t
	| Wild

      (* isRefutable p iff p contains a constant, constructor or variable. *)
      val isRefutable: t -> bool
      val isVar: t -> bool
      val layout: t -> Layout.t
      val make: node * Type.t -> t
      val node: t -> node
      val removeOthersReplace: t * {new: Var.t, old: Var.t} -> t
      val removeVars: t -> t
      val replaceTypes: t * (Type.t -> Type.t) -> t
      val tuple: t vector -> t
      val ty: t -> Type.t
      val unit: t
      (* varsAndTypes returns a list of the variables in the pattern, along with
       * their types.  It is used for match compilation in order to build a
       * function that abstracts over the expression of a case rule p => e.
       * See infer.fun.
       *)
      val varsAndTypes: t -> (Var.t * Type.t) list
      val wild: Type.t -> t
   end



1.1                  mlton/mlton/match-compile/sources.cm

Index: sources.cm
===================================================================
Group

functor MatchCompile
functor NestedPat
   
is

../atoms/sources.cm
../control/sources.cm
../../lib/mlton/sources.cm

match-compile.fun
match-compile.sig
nested-pat.fun
nested-pat.sig




1.17      +2 -2      mlton/mlton/ssa/constant-propagation.fun

Index: constant-propagation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/constant-propagation.fun,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- constant-propagation.fun	23 Jun 2003 04:58:59 -0000	1.16
+++ constant-propagation.fun	9 Oct 2003 18:17:34 -0000	1.17
@@ -350,7 +350,7 @@
 				      Exp.PrimApp {args = args,
 						   prim = Prim.array,
 						   targs = targs},
-				      Type.dearray ty)
+				      Type.deArray ty)
 			  | Const (Const.T {const, ...}) =>
 			       (case !const of
 				   Const.Const c => yes (Exp.Const c)
@@ -371,7 +371,7 @@
 				      Exp.PrimApp {args = args,
 						   prim = Prim.reff,
 						   targs = targs},
-				      Type.deref ty)
+				      Type.deRef ty)
 			  | Tuple vs =>
 			       (case globals (vs, newGlobal) of
 				   NONE => No



1.15      +2 -2      mlton/mlton/ssa/direct-exp.fun

Index: direct-exp.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/direct-exp.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- direct-exp.fun	23 Jun 2003 04:58:59 -0000	1.14
+++ direct-exp.fun	9 Oct 2003 18:17:34 -0000	1.15
@@ -338,7 +338,7 @@
 fun selects (tuple: Var.t, ty: Type.t, components: Var.t vector)
    : Statement.t list =
    let
-      val ts = Type.detuple ty
+      val ts = Type.deTuple ty
    in
       Vector.foldi
       (ts, [], fn (i, t, ss) =>
@@ -544,7 +544,7 @@
 		   val l = reify (k, ty)
 		   val k = Cont.goto l
 		   val (args, exps) =
-		      case Type.detupleOpt ty of
+		      case Type.deTupleOpt ty of
 			 NONE =>
 			    let
 			       val res = Var.newNoname ()



1.13      +5 -5      mlton/mlton/ssa/flatten.fun

Index: flatten.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/flatten.fun,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- flatten.fun	10 Jan 2003 18:36:13 -0000	1.12
+++ flatten.fun	9 Oct 2003 18:17:34 -0000	1.13
@@ -36,7 +36,7 @@
       val isFlat = not o isTop
 
       fun fromType t =
-	 case Type.detupleOpt t of
+	 case Type.deTupleOpt t of
 	    NONE => let val r = new () in makeTop r; r end
 	  | SOME l => new ()
 
@@ -214,7 +214,7 @@
 	 Vector.fromList
 	 (Vector.fold2 (ts, rs, [], fn (t, r, ts) =>
 			if Rep.isFlat r
-			   then Vector.fold (Type.detuple t, ts, op ::)
+			   then Vector.fold (Type.deTuple t, ts, op ::)
 			else t :: ts))
       val datatypes =
 	 Vector.map
@@ -265,7 +265,7 @@
 		     (args, reps, ([], []), fn ((x, ty), r, (args, stmts)) =>
 		      if Rep.isFlat r
 			 then let
-			         val tys = Type.detuple ty
+			         val tys = Type.deTuple ty
 				 val xs = Vector.map (tys, fn _ => Var.newNoname ())
 				 val _ = varTuple x := SOME xs
 				 val args =
@@ -316,7 +316,7 @@
 				   let
 				      val xts =
 					 Vector.map
-					 (Type.detuple ty, fn ty =>
+					 (Type.deTuple ty, fn ty =>
 					  (Var.newNoname (), ty))
 				      val xs = Vector.map (xts, #1)
 				      val formals =
@@ -349,7 +349,7 @@
 					 let
 					    val xts =
 					       Vector.map
-					       (Type.detuple ty, fn ty =>
+					       (Type.deTuple ty, fn ty =>
 						(Var.newNoname (), ty))
 					    val xs = Vector.map (xts, #1)
 					    val actuals =



1.16      +2 -2      mlton/mlton/ssa/local-flatten.fun

Index: local-flatten.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/local-flatten.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- local-flatten.fun	19 Dec 2002 23:43:36 -0000	1.15
+++ local-flatten.fun	9 Oct 2003 18:17:34 -0000	1.16
@@ -192,7 +192,7 @@
 			    else
 			       let
 				  val vars = Vector.map
-				             (Type.detuple ty, fn ty =>
+				             (Type.deTuple ty, fn ty =>
 					      (Var.newNoname (), ty))
 			       in
 				  (vars,
@@ -220,7 +220,7 @@
 			       let
 				  val (vars, stmts) =
 				     Vector.foldi
-				     (Type.detuple t, ([], stmts),
+				     (Type.deTuple t, ([], stmts),
 				      fn (i, ty, (vars, stmts)) =>
 				      let val var = Var.newNoname ()
 				      in (var :: vars,



1.19      +1 -1      mlton/mlton/ssa/local-ref.fun

Index: local-ref.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/local-ref.fun,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- local-ref.fun	19 Dec 2002 23:43:36 -0000	1.18
+++ local-ref.fun	9 Oct 2003 18:17:34 -0000	1.19
@@ -317,7 +317,7 @@
 		     = Option.app
 		       (var, fn var =>
 			let
-			  val vi = VarInfo.new (SOME (label, Type.deref ty))
+			  val vi = VarInfo.new (SOME (label, Type.deRef ty))
 			  val _ = setVarInfo (var, vi)
 			in
 			  List.push (refs, var) ;



1.32      +1 -1      mlton/mlton/ssa/shrink.fun

Index: shrink.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/shrink.fun,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- shrink.fun	23 Jun 2003 04:58:59 -0000	1.31
+++ shrink.fun	9 Oct 2003 18:17:34 -0000	1.32
@@ -1227,7 +1227,7 @@
 					        NONE => 
 						   (case VarInfo.ty tuple of
 						       SOME ty =>
-							  (case Type.detupleOpt ty of
+							  (case Type.deTupleOpt ty of
 							      SOME ts =>
 								 if Vector.length xs =
 								    Vector.length ts



1.13      +1 -1      mlton/mlton/ssa/simplify-types.fun

Index: simplify-types.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/simplify-types.fun,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- simplify-types.fun	13 May 2003 20:20:15 -0000	1.12
+++ simplify-types.fun	9 Oct 2003 18:17:34 -0000	1.13
@@ -545,7 +545,7 @@
 		end)
 	  | Select {tuple, offset} =>
 	       let
-		  val ts = Type.detuple (oldVarType tuple)
+		  val ts = Type.deTuple (oldVarType tuple)
 	       in Vector.fold'
 		  (ts, 0, (offset, 0), fn (pos, t, (n, offset)) =>
 		   if n = 0



1.60      +1 -3      mlton/mlton/ssa/ssa-tree.fun

Index: ssa-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.fun,v
retrieving revision 1.59
retrieving revision 1.60
diff -u -r1.59 -r1.60
--- ssa-tree.fun	23 Jun 2003 04:58:59 -0000	1.59
+++ ssa-tree.fun	9 Oct 2003 18:17:34 -0000	1.60
@@ -299,9 +299,7 @@
 				  then empty
 			       else Vector.layout Type.layout targs
 		       else empty,
-		       if isSome (Prim.numArgs prim)
-			  then seq [str " ", layoutTuple args]
-		       else empty]
+		       seq [str " ", layoutTuple args]]
 	     | Profile p => ProfileExp.layout p
 	     | Select {tuple, offset} =>
 		  seq [str "#", Int.layout (offset + 1), str " ",



1.25      +2 -17     mlton/mlton/ssa/type-check.fun

Index: type-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/type-check.fun,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- type-check.fun	10 Sep 2003 01:00:12 -0000	1.24
+++ type-check.fun	9 Oct 2003 18:17:34 -0000	1.25
@@ -341,7 +341,7 @@
 				       end,
 				    Unit.layout) coerce
       fun select {tuple: Type.t, offset: int, resultType}: Type.t =
-	 case Type.detupleOpt tuple of
+	 case Type.deTupleOpt tuple of
 	    NONE => error "select of non tuple"
 	  | SOME ts => Vector.sub (ts, offset)
       val {get = conInfo: Con.t -> {args: Type.t vector,
@@ -373,22 +373,7 @@
 	 in ()
 	 end
       fun filterGround to (t: Type.t): unit = coerce {from = t, to = to}
-      fun primApp {prim, targs, args, resultType, resultVar} =
-	 case Prim.checkApp {prim = prim,
-			     targs = targs,
-			     args = args,
-			     con = Type.con,
-			     equals = Type.equals,
-			     dearrowOpt = Type.dearrowOpt,
-			     detupleOpt = Type.detupleOpt,
-			     isUnit = Type.isUnit
-			     } of
-	    NONE => error (concat
-			   ["bad primapp ",
-			    Prim.toString prim,
-			    ", args = ",
-			    Layout.toString (Vector.layout Type.layout args)])
-	  | SOME t => t
+      fun primApp {prim, targs, args, resultType, resultVar} = resultType
       val primApp =
 	 Trace.trace ("checkPrimApp",
 		      fn {prim, targs, args, ...} =>



1.20      +5 -5      mlton/mlton/ssa/useless.fun

Index: useless.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/useless.fun,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- useless.fun	23 Jun 2003 04:58:59 -0000	1.19
+++ useless.fun	9 Oct 2003 18:17:34 -0000	1.20
@@ -771,11 +771,11 @@
 		   targs = Prim.extractTargs {prim = prim,
 					      args = argTypes,
 					      result = resultType,
-					      dearray = Type.dearray,
-					      dearrow = Type.dearrow,
-					      deref = Type.deref,
-					      devector = Type.devector,
-					      deweak = Type.deweak}}
+					      deArray = Type.deArray,
+					      deArrow = Type.deArrow,
+					      deRef = Type.deRef,
+					      deVector = Type.deVector,
+					      deWeak = Type.deWeak}}
 	       end
 	  | Select {tuple, offset} =>
 	       let



1.10      +9 -7      mlton/mlton/xml/implement-exceptions.fun

Index: implement-exceptions.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/implement-exceptions.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- implement-exceptions.fun	23 Jun 2003 04:59:00 -0000	1.9
+++ implement-exceptions.fun	9 Oct 2003 18:17:34 -0000	1.10
@@ -226,11 +226,13 @@
 	   | SOME e => SOME (loop e))
       and loops es = List.map (es, loop)
       and loop (e: Exp.t): Exp.t =
-	 let val {decs, result} = Exp.dest e
+	 let
+	    val {decs, result} = Exp.dest e
 	    val decs = List.concatRev (List.fold (decs, [], fn (d, ds) =>
 						  loopDec d :: ds))
-	 in Exp.new {decs = decs,
-		     result = result}
+	 in
+	    Exp.make {decs = decs,
+		      result = result}
 	 end
       and loopDec (dec: Dec.t): Dec.t list =
 	 case dec of
@@ -438,9 +440,9 @@
 	 let
 	    val {arg, argType, body} = Lambda.dest l
 	 in
-	    Lambda.new {arg = arg,
-			argType = argType,
-			body = loop body}
+	    Lambda.make {arg = arg,
+			 argType = argType,
+			 body = loop body}
 	 end
       val body =
 	 let
@@ -489,7 +491,7 @@
 			 val exn = Var.newNoname ()
 		      in
 			 Lambda
-			 (Lambda.new
+			 (Lambda.make
 			  {arg = exn,
 			   argType = Type.exn,
 			   body =



1.10      +13 -9     mlton/mlton/xml/monomorphise.fun

Index: monomorphise.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/monomorphise.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- monomorphise.fun	23 Jun 2003 04:59:00 -0000	1.9
+++ monomorphise.fun	9 Oct 2003 18:17:34 -0000	1.10
@@ -10,7 +10,8 @@
 
 open S
 open Xml.Atoms
-local open Xml
+local
+   open Xml
 in
    structure Xcases = Cases
    structure Xpat = Pat
@@ -22,7 +23,8 @@
    structure Xtype = Type
    structure XvarExp = VarExp
 end
-local open Sxml
+local
+   open Sxml
 in
    structure Scases = Cases
    structure Spat = Pat
@@ -185,7 +187,7 @@
 	 Property.destGetSet (Tycon.plist,
 			      Property.initRaise ("mono", Tycon.layout))
       val _ =
-	 List.foreach (Tycon.prims, fn t =>
+	 List.foreach (Tycon.prims, fn (t, _) =>
 		       setTycon (t, fn ts => Stype.con (t, ts)))
       val {set = setTyvar, get = getTyvar: Tyvar.t -> Stype.t, ...} =
 	 Property.getSet (Tyvar.plist,
@@ -344,14 +346,16 @@
       fun monoExp (arg: Xexp.t): Sexp.t =
 	 traceMonoExp
 	 (fn (e: Xexp.t) =>
-	  let val {decs, result} = Xexp.dest e
+	  let
+	     val {decs, result} = Xexp.dest e
 	     val thunks = List.fold (decs, [], fn (d, thunks) =>
 				     monoDec d :: thunks)
 	     val result = monoVarExp result
 	     val decs =
 		List.fold (thunks, [], fn (thunk, decs) => thunk () @ decs)
-	  in Sexp.new {decs = decs,
-		       result = result}
+	  in
+	     Sexp.make {decs = decs,
+			result = result}
 	  end) arg
       and monoPrimExp (e: XprimExp.t): SprimExp.t =
 	 case e of
@@ -403,9 +407,9 @@
 	    val {arg, argType, body} = Xlambda.dest l
 	    val (arg, argType) = renameMono (arg, argType)
 	 in
-	    Slambda.new {arg = arg,
-			 argType = argType,
-			 body = monoExp body}
+	    Slambda.make {arg = arg,
+			  argType = argType,
+			  body = monoExp body}
 	 end
       (*------------------------------------*)
       (*              monoDec               *)



1.12      +8 -6      mlton/mlton/xml/polyvariance.fun

Index: polyvariance.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/polyvariance.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- polyvariance.fun	23 Jun 2003 04:59:00 -0000	1.11
+++ polyvariance.fun	9 Oct 2003 18:17:34 -0000	1.12
@@ -24,7 +24,7 @@
       fun containsArrow t = containsTycon (t, Tycon.arrow)
 
       fun isHigherOrder t =
-	 case dearrowOpt t of
+	 case deArrowOpt t of
 	    NONE => false
 	  | SOME (t1, t2) => containsArrow t1 orelse isHigherOrder t2
 
@@ -264,16 +264,18 @@
 	    then setVarInfo (var, Dup {duplicates = ref []})
 	 else (bind var; ())
       fun loopExp (e: Exp.t): Exp.t =
-	 let val {decs, result} = Exp.dest e
-	 in Exp.new (loopDecs (decs, result))
+	 let
+	    val {decs, result} = Exp.dest e
+	 in
+	    Exp.make (loopDecs (decs, result))
 	 end
       and loopLambda (l: Lambda.t): Lambda.t =
 	 let
 	    val {arg, argType, body} = Lambda.dest l
 	 in
-	    Lambda.new {arg = bind arg,
-			argType = argType,
-			body = loopExp body}
+	    Lambda.make {arg = bind arg,
+			 argType = argType,
+			 body = loopExp body}
 	 end
       and loopDecs (ds: Dec.t list, result): {decs: Dec.t list,
 					      result: VarExp.t} =



1.10      +9 -7      mlton/mlton/xml/scc-funs.fun

Index: scc-funs.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/scc-funs.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- scc-funs.fun	12 Feb 2003 05:11:29 -0000	1.9
+++ scc-funs.fun	9 Oct 2003 18:17:34 -0000	1.10
@@ -18,7 +18,7 @@
    let
       (* For each function appearing in a fun dec record its node, which will
        * have edges to the nodes of other functions declared in the same dec
-       * if they appear in it's body.
+       * if they appear in its body.
        *)
       val {get = funInfo: Var.t -> {
 				    node: unit Node.t,
@@ -39,9 +39,9 @@
 	 let
 	    val {arg, argType, body} = Lambda.dest l
 	 in
-	    Lambda.new {arg = arg,
-			argType = argType,
-			body = loopExp body}
+	    Lambda.make {arg = arg,
+			 argType = argType,
+			 body = loopExp body}
 	 end
       and loopPrimExp (e: PrimExp.t): PrimExp.t =
 	 case e of
@@ -66,7 +66,8 @@
 	  | Tuple xs => (loopVarExps xs; e)
 	  | Var x => (loopVarExp x; e)
       and loopExp (e: Exp.t): Exp.t =
-	 let val {decs, result} = Exp.dest e
+	 let
+	    val {decs, result} = Exp.dest e
 	    val decs =
 	       List.rev
 	       (List.fold
@@ -116,9 +117,10 @@
 		       end))
 	    val _ = loopVarExp result
 	 in
-	    Exp.new {decs = decs, result = result}
+	    Exp.make {decs = decs, result = result}
 	 end
-   in Program.T {datatypes = datatypes,
+   in
+      Program.T {datatypes = datatypes,
 		 body = loopExp body,
 		 overflow = overflow}
    end



1.3       +77 -49    mlton/mlton/xml/shrink.fun

Index: shrink.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/shrink.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- shrink.fun	23 Jun 2003 04:59:00 -0000	1.2
+++ shrink.fun	9 Oct 2003 18:17:34 -0000	1.3
@@ -76,7 +76,7 @@
 	 fn (i, n) =>
 	 case i of
 	    Mono {numOccurrences = r, ...} => inc (r, n)
-	  | _ => ()
+	  | Poly _ => ()
 
       val inc =
 	 Trace.trace2 ("VarInfo.inc", layout, Int.layout, Unit.layout) inc
@@ -92,6 +92,17 @@
 	  | Poly x => x
    end
 
+structure InternalVarInfo =
+   struct
+      datatype t =
+	 VarInfo of VarInfo.t
+       | Self
+
+      val layout =
+	 fn VarInfo i => VarInfo.layout i
+	  | Self => Layout.str "self"
+   end
+
 structure MonoVarInfo =
    struct
       type t = VarInfo.monoVarInfo
@@ -136,20 +147,24 @@
 		 andalso (Vector.length v
 			  = conNumCons (Pat.con (#1 (Vector.sub (v, 0)))))))
 	  | _ => false
-      val {get = varInfo: Var.t -> VarInfo.t, set = setVarInfo, ...} =
+      val {get = varInfo: Var.t -> InternalVarInfo.t, set = setVarInfo, ...} =
 	 Property.getSet (Var.plist,
 			  Property.initRaise ("shrink varInfo", Var.layout))
+      val setVarInfo =
+	 Trace.trace2 ("Xml.Shrink.setVarInfo",
+		       Var.layout, InternalVarInfo.layout, Unit.layout)
+	 setVarInfo
       val varInfo =
-	 Trace.trace ("Xml.Shrink.varInfo", Var.layout, VarInfo.layout) varInfo
+	 Trace.trace ("Xml.Shrink.varInfo", Var.layout, InternalVarInfo.layout)
+	 varInfo
       fun monoVarInfo x =
 	 case varInfo x of
-	    VarInfo.Mono i => i
+	    InternalVarInfo.VarInfo (VarInfo.Mono i) => i
 	  | _ => Error.bug "monoVarInfo"
-      fun varInfos xs = List.map (xs, varInfo)
-      fun varExpInfo (x as VarExp.T {var, targs, ...}): VarInfo.t =
-	 if Vector.isEmpty targs
-	    then varInfo var
-	 else VarInfo.Poly x
+      fun varExpInfo (x as VarExp.T {var, ...}): VarInfo.t =
+	 case varInfo var of
+	    InternalVarInfo.Self => VarInfo.Poly x
+	  | InternalVarInfo.VarInfo i => i
       val varExpInfo =
 	 Trace.trace ("varExpInfo", VarExp.layout, VarInfo.layout) varExpInfo
       fun varExpInfos xs = Vector.map (xs, varExpInfo)
@@ -157,7 +172,7 @@
 		       {numOccurrences = r, ...}: MonoVarInfo.t,
 		       i: VarInfo.t): unit =
 	 (VarInfo.inc (i, !r)
-	  ; setVarInfo (x, i))
+	  ; setVarInfo (x, InternalVarInfo.VarInfo i))
       val replaceInfo =
 	 Trace.trace ("replaceInfo",
 		      fn (x, _, i) => Layout.tuple [Var.layout x,
@@ -167,16 +182,16 @@
       fun replace (x, i) = replaceInfo (x, monoVarInfo x, i)
       val shrinkVarExp = VarInfo.varExp o varExpInfo
       fun shrinkVarExps xs = Vector.map (xs, shrinkVarExp)
-      val dummyVarExp = VarExp.mono (Var.newString "dummy")
       local
 	 fun handleBoundVar (x, ts, ty) =
 	    setVarInfo (x,
 			if Vector.isEmpty ts
-			   then VarInfo.Mono {numOccurrences = ref 0,
-					      value = ref NONE,
-					      varExp = VarExp.mono x}
-			else VarInfo.Poly dummyVarExp)
-	 fun handleVarExp x = VarInfo.inc (varInfo (VarExp.var x), 1)
+			   then (InternalVarInfo.VarInfo
+				 (VarInfo.Mono {numOccurrences = ref 0,
+						value = ref NONE,
+						varExp = VarExp.mono x}))
+			else InternalVarInfo.Self)
+	 fun handleVarExp x = VarInfo.inc (varExpInfo x, 1)
       in
 	 fun countExp (e: Exp.t): unit =
 	    Exp.foreach {exp = e,
@@ -186,7 +201,7 @@
 			 handleVarExp = handleVarExp}
       end
       fun deleteVarExp (x: VarExp.t): unit =
-	 VarInfo.inc (varInfo (VarExp.var x), ~1)
+	 VarInfo.inc (varExpInfo x, ~1)
       fun deleteExp (e: Exp.t): unit = Exp.foreachVarExp (e, deleteVarExp)
       val deleteExp =
 	 Trace.trace ("deleteExp", Exp.layout, Unit.layout) deleteExp
@@ -197,9 +212,11 @@
       fun shrinkExp arg: Exp.t =
 	 traceShrinkExp
 	 (fn (e: Exp.t) =>
-	  let val {decs, result} = Exp.dest e
-	  in Exp.new {decs = shrinkDecs decs,
-		      result = shrinkVarExp result}
+	  let
+	     val {decs, result} = Exp.dest e
+	  in
+	     Exp.make {decs = shrinkDecs decs,
+		       result = shrinkVarExp result}
 	  end) arg
       and shrinkDecs (decs: Dec.t list): Dec.t list =
 	 case decs of
@@ -275,7 +292,7 @@
 		| MonoVal b =>
 		     shrinkMonoVal (b, fn () => shrinkDecs decs)
       and shrinkMonoVal ({var, ty, exp},
-			   rest: unit -> Dec.t list) =
+			 rest: unit -> Dec.t list) =
 	 let
 	    val info as {numOccurrences, value, ...} = monoVarInfo var
 	    fun finish (exp, decs) =
@@ -308,7 +325,28 @@
 	       end
 	 in
 	    case exp of
-	       Case {test, cases, default} =>
+	       App {func, arg} =>
+		  let
+		     val arg = varExpInfo arg
+		     fun normal func =
+			expansive (App {func = func,
+					arg = VarInfo.varExp arg})
+		  in case varExpInfo func of
+		     VarInfo.Poly x => normal x
+		   | VarInfo.Mono {numOccurrences, value, varExp, ...} => 
+			case (!numOccurrences, !value) of
+			   (1, SOME (Value.Lambda {isInlined, lam = l})) =>
+			      let
+				 val {arg = form, body, ...} = Lambda.dest l
+			      in VarInfo.inc (arg, ~1)
+				 ; replace (form, arg)
+				 ; isInlined := true
+				 ; numOccurrences := 0
+				 ; expression body
+			      end
+			 | _ => normal varExp
+		  end
+	     | Case {test, cases, default} =>
 		  let
 		     fun match (cases, f): Dec.t list =
 			let
@@ -448,27 +486,6 @@
 			   ; VarInfo.inc (x, ~1)
 			   ; rest ()
 			end
-	     | App {func, arg} =>
-		  let
-		     val arg = varExpInfo arg
-		     fun normal func =
-			expansive (App {func = func,
-					arg = VarInfo.varExp arg})
-		  in case varExpInfo func of
-		     VarInfo.Poly x => normal x
-		   | VarInfo.Mono {numOccurrences, value, varExp, ...} => 
-			case (!numOccurrences, !value) of
-			   (1, SOME (Value.Lambda {isInlined, lam = l})) =>
-			      let
-				 val {arg = form, body, ...} = Lambda.dest l
-			      in VarInfo.inc (arg, ~1)
-				 ; replace (form, arg)
-				 ; isInlined := true
-				 ; numOccurrences := 0
-				 ; expression body
-			      end
-			 | _ => normal varExp
-		  end
 	 end
       and shrinkLambda l: Lambda.t =
 	 traceShrinkLambda
@@ -476,16 +493,27 @@
 	  let
 	     val {arg, argType, body} = Lambda.dest l
 	  in
-	     Lambda.new {arg = arg,
-			 argType = argType,
-			 body = shrinkExp body}
+	     Lambda.make {arg = arg,
+			  argType = argType,
+			  body = shrinkExp body}
 	  end) l
       val _ = countExp body
-      val _ = Option.app (overflow, fn x => VarInfo.inc (varInfo x, 1))
+      val _ =
+	 Option.app
+	 (overflow, fn x =>
+	  case varInfo x of
+	     InternalVarInfo.VarInfo i => VarInfo.inc (i, 1)
+	   | _ => Error.bug "strange overflow var")
       val body = shrinkExp body
+      (* Must lookup the overflow variable again because it may have been set
+       * during shrinking.
+       *)
       val overflow =
-	 Option.map (overflow, fn x =>
-		     VarExp.var (VarInfo.varExp (varInfo x)))
+	 Option.map
+	 (overflow, fn x =>
+	  case varInfo x of
+	     InternalVarInfo.VarInfo i => VarExp.var (VarInfo.varExp i)
+	   | _ => Error.bug "strange overflow var")
       val _ = Exp.clear body
       val _ = Vector.foreach (datatypes, fn {cons, ...} =>
 			      Vector.foreach (cons, Con.clear o #con))



1.8       +5 -5      mlton/mlton/xml/simplify-types.fun

Index: simplify-types.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/simplify-types.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- simplify-types.fun	23 Jun 2003 04:59:00 -0000	1.7
+++ simplify-types.fun	9 Oct 2003 18:17:34 -0000	1.8
@@ -229,16 +229,16 @@
 	 let
 	    val {decs, result} = I.Exp.dest e
 	 in
-	    O.Exp.new {decs = List.map (decs, fixDec),
-		       result = fixVarExp result}
+	    O.Exp.make {decs = List.map (decs, fixDec),
+			result = fixVarExp result}
 	 end
       and fixLambda (l: I.Lambda.t): O.Lambda.t =
 	 let
 	    val {arg, argType, body} = I.Lambda.dest l
 	 in
-	    O.Lambda.new {arg = arg,
-			  argType = fixType argType,
-			  body = fixExp body}
+	    O.Lambda.make {arg = arg,
+			   argType = fixType argType,
+			   body = fixExp body}
 	 end
       and fixPrimExp (e: I.PrimExp.t): O.PrimExp.t =
 	 case e of



1.14      +20 -30    mlton/mlton/xml/type-check.fun

Index: type-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/type-check.fun,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- type-check.fun	14 Jul 2003 20:42:17 -0000	1.13
+++ type-check.fun	9 Oct 2003 18:17:34 -0000	1.14
@@ -58,8 +58,8 @@
 	 end
       val {get = getVar: Var.t -> {tyvars: Tyvar.t vector, ty: Type.t},
 	   set = setVar, ...} =
-	 Property.getSetOnce (Var.plist,
-			      Property.initRaise ("var scheme", Var.layout))
+	 Property.getSet (Var.plist,
+			  Property.initRaise ("var scheme", Var.layout))
       (* val getVar = Trace.trace ("getVar", Var.layout, Layout.ignore) getVar *)
       (* val setVar = Trace.trace2 ("setVar", Var.layout, Layout.ignore, Layout.ignore) setVar *)
       fun checkVarExp (VarExp.T {var, targs}): Type.t =
@@ -83,7 +83,7 @@
 	 let
 	    val t = checkConExp (con, targs)
 	 in
-	    case (arg, Type.dearrowOpt t) of
+	    case (arg, Type.deArrowOpt t) of
 	         (NONE, NONE) => t
 	       | (SOME (x, ty), SOME (t1, t2)) =>
 		    (checkType ty
@@ -93,8 +93,8 @@
 		       else (Type.error
 			     ("argument constraint of wrong type",
 			      let open Layout
-			      in align [seq [str "t1: ", Type.layout t1],
-					seq [str "ty: ", Type.layout ty],
+			      in align [seq [str "constructor expects : ", Type.layout t1],
+					seq [str "but got: ", Type.layout ty],
 					seq [str "p: ", Pat.layout p]]
 			      end)))
 	       | _ => Type.error ("constructor pattern mismatch", Pat.layout p)
@@ -139,7 +139,7 @@
 	       let
 		  val t2 = checkVarExp x
 	       in
-		  case Type.dearrowOpt t1 of
+		  case Type.deArrowOpt t1 of
 		     NONE => error "function not of arrow type"
 		   | SOME (t2', t3) =>
 			if Type.equals (t2, t2') then t3
@@ -224,30 +224,20 @@
 		     else error "bad handle"
 		  end
 	     | Lambda l => checkLambda l
-	     | PrimApp {prim, targs, args} =>
+	     | PrimApp {prim, targs, args} => 
 		  let
 		     val _ = checkTypes targs
 		  in
-		     case Prim.checkApp {prim = prim,
-					 targs = targs,
-					 args = checkVarExps args,
-					 con = Type.con,
-					 equals = Type.equals,
-					 dearrowOpt = Type.dearrowOpt,
-					 detupleOpt = Type.detupleOpt,
-					 isUnit = Type.isUnit
-					 } of
-			NONE => error "bad primapp"
-		      | SOME t => t
+		     ty
 		  end
 	     | Profile _ => Type.unit
 	     | Raise {exn, ...} => if isExnType (checkVarExp exn)
 				      then ty
 				   else error "bad raise"
 	     | Select {tuple, offset} =>
-		  (case Type.detupleOpt (checkVarExp tuple) of
-		      SOME ts => Vector.sub (ts, offset)
-		    | NONE => error "selection from nontuple")
+		  (case Type.deTupleOpt (checkVarExp tuple) of
+		      NONE => error "selection from nontuple"
+		    | SOME ts => Vector.sub (ts, offset))
 	     | Tuple xs =>
 		  if 1 = Vector.length xs
 		     then error "unary tuple"
@@ -268,6 +258,15 @@
 	 in
 	    case d of
 	       Exception c => setCon (c, Vector.new0 (), Type.exn)
+	     | Fun {tyvars, decs} =>
+		  (bindTyvars tyvars
+		   ; (Vector.foreach
+		      (decs, fn {lambda, ty, var} =>
+		       (checkType ty
+			; setVar (var, {tyvars = tyvars, ty = ty}))))
+		   ; Vector.foreach (decs, fn {ty, lambda, ...} =>
+				     check (ty, checkLambda lambda))
+		   ; unbindTyvars tyvars)
 	     | MonoVal {var, ty, exp} =>
 		  (checkType ty
 		   ; check (ty, checkPrimExp (exp, ty))
@@ -278,15 +277,6 @@
 		   ; check (ty, checkExp exp)
 		   ; unbindTyvars tyvars
 		   ; setVar (var, {tyvars = tyvars, ty = ty}))
-	     | Fun {tyvars, decs} =>
-		  (bindTyvars tyvars
-		   ; (Vector.foreach
-		      (decs, fn {var, ty, lambda} =>
-		       (checkType ty
-			; setVar (var, {tyvars = tyvars, ty = ty}))))
-		   ; Vector.foreach (decs, fn {ty, lambda, ...} =>
-				     check (ty, checkLambda lambda))
-		   ; unbindTyvars tyvars)
 	 end handle e => (Layout.outputl (Dec.layout d, Out.error)
 			  ; raise e)
       val _ =



1.17      +197 -253  mlton/mlton/xml/xml-tree.fun

Index: xml-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml-tree.fun,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- xml-tree.fun	23 Jun 2003 04:59:00 -0000	1.16
+++ xml-tree.fun	9 Oct 2003 18:17:34 -0000	1.17
@@ -9,13 +9,6 @@
 struct
 
 open S
-local open Ast
-in
-   structure Adec = Dec
-   structure Aexp = Exp
-   structure Amatch = Match
-   structure Apat = Pat
-end
 
 structure Type =
    struct
@@ -32,35 +25,40 @@
 	  | Dest.Con x => Con x
    end
 
+fun maybeConstrain (x, t) =
+   let
+      open Layout
+   in
+      if !Control.showTypes
+	 then seq [x, str ": ", Type.layout t]
+      else x
+   end
+   
 structure Pat =
    struct
-      structure Apat = Ast.Pat
-	 
-      datatype t = T of {con: Con.t,
-			 targs: Type.t vector,
-			 arg: (Var.t * Type.t) option}
+      datatype t = T of {arg: (Var.t * Type.t) option,
+			 con: Con.t,
+			 targs: Type.t vector}
 	 
+      local
+	 open Layout
+      in
+	 fun layout (T {arg, con, targs}) =
+	    seq [Con.layout con,
+		 case arg of
+		    NONE => empty
+		  | SOME (x, t) =>
+		       maybeConstrain (seq [str " ", Var.layout x], t)]
+      end
+
       fun con (T {con, ...}) = con
 
-      local fun make c = T {con = c, targs = Vector.new0 (), arg = NONE}
-      in val truee = make Con.truee
+      local
+	 fun make c = T {con = c, targs = Vector.new0 (), arg = NONE}
+      in 
 	 val falsee = make Con.falsee
+	 val truee = make Con.truee
       end
-
-      fun toAst (T {con, arg, ...}) =
-	 let
-	    val con = Con.toAst con
-	 in
-	    case arg of
-	       NONE => Apat.con con
-	     | SOME (x, t) =>
-		  if !Control.showTypes
-		     then Apat.app (con, Apat.constraint (Apat.var (Var.toAst x),
-							  Type.toAst t))
-		  else Apat.app (con, Apat.var (Var.toAst x))
-	 end
-
-      val layout = Apat.layout o toAst
    end
 
 structure Cases =
@@ -70,6 +68,20 @@
        | Int of IntSize.t * (IntX.t * 'a) vector
        | Word of WordSize.t * (WordX.t * 'a) vector
 
+      fun layout (cs, layout) =
+	 let
+	    open Layout
+	    fun doit (v, f) =
+	       align (Vector.toListMap (v, fn (x, e) =>
+					align [seq [f x, str " => "],
+					       indent (layout e, 3)]))
+	 in
+	    case cs of
+	       Con v => doit (v, Pat.layout)
+	     | Int (_, v) => doit (v, IntX.layout)
+	     | Word (_, v) => doit (v, WordX.layout)
+	 end
+
       fun fold (c: 'a t, b: 'b, f: 'a * 'b -> 'b): 'b =
 	 let
 	    fun doit l = Vector.fold (l, b, fn ((_, a), b) => f (a, b))
@@ -115,14 +127,10 @@
 	 end
    end
 
-(*---------------------------------------------------*)
-(*                      VarExp                       *)
-(*---------------------------------------------------*)
-
 structure VarExp =
    struct
-      datatype t = T of {var: Var.t,
-			 targs: Type.t vector}
+      datatype t = T of {targs: Type.t vector,
+			 var: Var.t}
 
       fun mono var = T {var = var, targs = Vector.new0 ()}
 
@@ -133,10 +141,6 @@
 	 val var = make #var
       end
    
-      val toAst = Aexp.var o Var.toAst o var
-
-      fun toAsts (xs: t list): Aexp.t list = List.map (xs, toAst)
-
       fun layout (T {var, targs, ...}) =
 	 if !Control.showTypes
 	    then let open Layout
@@ -170,9 +174,9 @@
 	       catch: Var.t * Type.t,
 	       handler: exp}
   | Lambda of lambda
-  | PrimApp of {prim: Prim.t,
-		targs: Type.t vector,
-		args: VarExp.t vector}
+  | PrimApp of {args: VarExp.t vector,
+		prim: Prim.t,
+		targs: Type.t vector}
   | Profile of ProfileExp.t
   | Raise of {exn: VarExp.t,
 	      filePos: string option}
@@ -181,190 +185,134 @@
   | Tuple of VarExp.t vector
   | Var of VarExp.t
 and dec =
-   Exception of {con: Con.t,
-		 arg: Type.t option}
-  | Fun of {tyvars: Tyvar.t vector,
-	    decs: {var: Var.t,
+   Exception of {arg: Type.t option,
+		 con: Con.t}
+  | Fun of {decs: {lambda: lambda,
 		   ty: Type.t,
-		   lambda: lambda} vector}
-  | MonoVal of {var: Var.t,
-	       ty: Type.t,
-	       exp: primExp}
-  | PolyVal of {tyvars: Tyvar.t vector,
+		   var: Var.t} vector,
+	    tyvars: Tyvar.t vector}
+  | MonoVal of {exp: primExp,
+		ty: Type.t,
+		var: Var.t}
+  | PolyVal of {exp: exp,
 		ty: Type.t,
-		var: Var.t,
-		exp: exp}
+		tyvars: Tyvar.t vector,
+		var: Var.t}
 and lambda = Lam of {arg: Var.t,
 		     argType: Type.t,
 		     body: exp,
 		     plist: PropertyList.t}
 
-(*---------------------------------------------------*)
-(*                 Conversion to Ast                 *)
-(*---------------------------------------------------*)
-
-fun expToAst (Exp {decs, result, ...}): Aexp.t =
-   Aexp.lett (decsToAst decs, VarExp.toAst result)
-and expsToAsts es = List.map (es, expToAst)
-and decsToAst decs = Vector.fromListMap (decs, decToAst)
-and decToAst d : Adec.t =
-   let
-      fun doit n = Adec.makeRegion (n, Region.bogus)
-   in
+local
+   open Layout
+in
+   fun layoutConArg {arg, con} =
+      seq [Con.layout con,
+	   case arg of
+	      NONE => empty
+	    | SOME t => seq [str " of ", Type.layout t]]
+   fun layoutTyvars ts =
+      case Vector.length ts of
+	 0 => empty
+       | 1 => seq [str " ", Tyvar.layout (Vector.sub (ts, 0))]
+       | _ => seq [str " ", tuple (Vector.toListMap (ts, Tyvar.layout))]
+   fun layoutDec d =
       case d of
-	 MonoVal {var, ty, exp} =>
-	    doit
-	    (Adec.Val
-	     {tyvars = Vector.new0 (),
-	      vbs = (Vector.new1
-		     {filePos = "",
-		      exp = primExpToAst exp,
-		      pat = if !Control.showTypes
-			       then Apat.constraint (Apat.var (Var.toAst var),
-						     Type.toAst ty)
-			    else  Apat.var (Var.toAst var)}),
-	      rvbs = Vector.new0 ()})
-       | PolyVal {tyvars, var, exp, ...} =>
-	    Adec.vall (tyvars, Var.toAst var, expToAst exp)
-       | Fun {tyvars, decs} =>
-	    doit
-	    (Adec.Fun
-	     (tyvars,
-	      Vector.map
-	      (decs, fn {var, ty, lambda = Lam {arg, argType, body, ...}, ...} =>
-	       {filePos = "",
-		clauses =
-		Vector.new1
-		{pats = (Vector.new2
-			 (Apat.var (Var.toAst var),
-			  if !Control.showTypes
-			     then Apat.constraint (Apat.var (Var.toAst arg),
-						   Type.toAst argType)
-			  else Apat.var (Var.toAst arg))),
-		 resultType = SOME (Type.toAst (#2 (Type.dearrow ty))),
-		 body = expToAst body}})))
-       | Exception {con, arg} =>
-	    Adec.exceptionn (Con.toAst con, Type.optionToAst arg)
-   end
-and primExpToAst e : Aexp.t =
-   case e of
-      App {func, arg} => Aexp.app (VarExp.toAst func, VarExp.toAst arg)
-    | Case {test, cases, default, ...} =>
-	 let
-	    fun doit (l, f) =
-	       Vector.map (l, fn (i, exp) => (f i, expToAst exp))
-	    datatype z = datatype Cases.t
-	    val make =
-	       fn n => Ast.Pat.const (Ast.Const.makeRegion (n, Region.bogus))
-	    val cases =
-	       case cases of
-		  Con l => Vector.map (l, fn (pat, exp) =>
-				       (Pat.toAst pat, expToAst exp))
-		| Int (_, l) => doit (l, make o Ast.Const.Int o IntX.toIntInf)
-		| Word (_, l) => doit (l, make o Ast.Const.Word o WordX.toIntInf)
-	    val cases =
-	       case default of
-		  NONE => cases
-		| SOME (e, _) =>
-		     Vector.concat [cases,
-				    Vector.new1 (Ast.Pat.wild, expToAst e)]
-	 in
-	    Aexp.casee (VarExp.toAst test,
-			Amatch.T {rules = cases,
-				  filePos = ""})
-	 end
-    | ConApp {con, arg, ...} =>
-	 let val con = Aexp.con (Con.toAst con)
-	 in case arg of
-	    NONE => con
-	  | SOME e => Aexp.app (con, VarExp.toAst e)
-	 end
-    | Const c => Const.toAstExp c
-    | Handle {try, catch, handler} =>
-	 Aexp.handlee
-	 (expToAst try,
-	  Amatch.T {filePos = "",
-		    rules = Vector.new1 (Apat.var (Var.toAst (#1 catch)),
-					 expToAst handler)})
-    | Lambda lambda => Aexp.fnn (lambdaToAst lambda)
-    | PrimApp {prim, args, ...} =>
-	 let
-	    val p = Aexp.longvid (Ast.Longvid.short
-				  (Ast.Longvid.Id.fromString
-				   (Prim.toString prim,
-				    Region.bogus)))
-	 in
-	    case Prim.numArgs prim of
-	       NONE => p
-	     | SOME _ => Aexp.app (p, Aexp.tuple (Vector.map
-						  (args, VarExp.toAst)))
-	 end
-    | Profile s =>
-	 let
-	    val (oper, si) =
-	       case s of
-		  ProfileExp.Enter si => ("ProfileEnter", si)
-		| ProfileExp.Leave si => ("ProfileLeave", si)
-	 in
-	    Aexp.app
-	    (Aexp.var (Ast.Var.fromString (oper, Region.bogus)),
-	     Aexp.const (Ast.Const.makeRegion
-			 (Ast.Const.String (SourceInfo.toString si),
-			  Region.bogus)))
-	 end
-    | Raise {exn, filePos} =>
-	 Aexp.raisee {exn = VarExp.toAst exn,
-		      filePos = (case filePos of
-				    NONE => ""
-				  | SOME s => s)}
-    | Select {tuple, offset} =>
-	 Aexp.select {tuple = VarExp.toAst tuple,
-		      offset = offset}
-    | Tuple xs => Aexp.tuple (Vector.map (xs, VarExp.toAst))
-    | Var x => VarExp.toAst x
-
-and lambdaToAst (Lam {arg, body, argType, ...}): Amatch.t =
-   Amatch.T
-   {filePos = "",
-    rules = Vector.new1 ((if !Control.showTypes
-			     then Apat.constraint (Apat.var (Var.toAst arg),
-						   Type.toAst argType)
-			  else Apat.var (Var.toAst arg), 
-			     expToAst body))}
-
-fun layoutLambda f = Aexp.layout (Aexp.fnn (lambdaToAst f))
-
-(*---------------------------------------------------*)
-(*                   Declarations                    *)
-(*---------------------------------------------------*)
+	 Exception ca =>
+	    seq [str "exception ", layoutConArg ca]
+       | Fun {decs, tyvars} =>
+	    align [seq [str "val rec", layoutTyvars tyvars, str " "],
+		   indent (align (Vector.toListMap
+				  (decs, fn {lambda, ty, var} =>
+				   align [seq [maybeConstrain (Var.layout var, ty),
+					       str " = "],
+					  indent (layoutLambda lambda, 3)])),
+			   3)]
+       | MonoVal {exp, ty, var} =>
+	    align [seq [str "val ",
+			maybeConstrain (Var.layout var, ty), str " = "],
+		   indent (layoutPrimExp exp, 3)]
+       | PolyVal {exp, ty, tyvars, var} =>
+	    align [seq [str "val",
+			if !Control.showTypes
+			   then layoutTyvars tyvars
+			else empty,
+			   str " ",
+			   maybeConstrain (Var.layout var, ty),
+			   str " = "],
+		   indent (layoutExp exp, 3)]
+   and layoutExp (Exp {decs, result}) =
+      align [str "let",
+	     indent (align (List.map (decs, layoutDec)), 3),
+	     str "in",
+	     indent (VarExp.layout result, 3),
+	     str "end"]
+   and layoutPrimExp e =
+      case e of
+	 App {arg, func} => seq [VarExp.layout func, str " ", VarExp.layout arg]
+       | Case {test, cases, default} =>
+	    align [seq [str "case ", VarExp.layout test, str " of"],
+		   indent
+		   (align
+		    [case default of
+			NONE => empty
+		      | SOME (e, _) => seq [str "_ => ", layoutExp e]],
+		    2),
+		   Cases.layout (cases, layoutExp)]
+       | ConApp {arg, con, ...} =>
+	    seq [Con.layout con,
+		 case arg of
+		    NONE => empty
+		  | SOME x => seq [str " ", VarExp.layout x]]
+       | Const c => Const.layout c
+       | Handle {catch, handler, try} =>
+	    align [layoutExp try,
+		   seq [str "handle ",
+			Var.layout (#1 catch),
+			str " => ", layoutExp handler]]
+       | Lambda l => layoutLambda l
+       | PrimApp {args, prim, targs} =>
+	    seq [Prim.layout prim,
+		 if !Control.showTypes
+		    andalso 0 < Vector.length targs
+		    then list (Vector.toListMap (targs, Type.layout))
+		 else empty,
+		 str " ", tuple (Vector.toListMap (args, VarExp.layout))]
+       | Profile e => ProfileExp.layout e
+       | Raise {exn, ...} => seq [str "raise ", VarExp.layout exn]
+       | Select {offset, tuple} =>
+	    seq [str "#", Int.layout offset, str " ", VarExp.layout tuple]
+       | Tuple xs => tuple (Vector.toListMap (xs, VarExp.layout))
+       | Var x => VarExp.layout x
+   and layoutLambda (Lam {arg, argType, body, ...}) =
+      align [seq [str "fn ", maybeConstrain (Var.layout arg, argType),
+		  str " => "],
+	     layoutExp body]
+	    
+end   
 
 structure Dec =
    struct
       type exp = exp
       datatype t = datatype dec
 
-      val toAst = decToAst
-      val layout = Ast.Dec.layout o toAst
+      val layout = layoutDec
    end
 
-(*---------------------------------------------------*)
-(*                    Expressions                    *)
-(*---------------------------------------------------*)
-
 structure PrimExp =
    struct
       type exp = exp
       datatype t = datatype primExp
 
-      val toAst = primExpToAst
-      val layout = Aexp.layout o toAst
+      val layout = layoutPrimExp
    end
 
 structure Exp =
    struct
       datatype t = datatype exp
 
-      val new = Exp
+      val layout = layoutExp
+      val make = Exp
       fun dest (Exp r) = r
       val decs = #decs o dest
       val result = #result o dest
@@ -383,9 +331,6 @@
 	 val prefixs = make (op @)
       end
 
-      val toAst = expToAst
-      val layout = Ast.Exp.layout o toAst
-
       fun enterLeave (e: t, ty: Type.t, si: SourceInfo.t): t =
 	 if !Control.profile = Control.ProfileNone
 	    orelse !Control.profileIL <> Control.ProfileSource
@@ -401,18 +346,18 @@
 	    val exn = Var.newNoname ()
 	    val res = Var.newNoname ()
 	    val handler =
-	       new {decs = [prof ProfileExp.Leave,
-			    MonoVal {exp = Raise {exn = VarExp.mono exn,
-						  filePos = NONE},
-				     ty = ty,
-				     var = res}],
-		    result = VarExp.mono res}
+	       make {decs = [prof ProfileExp.Leave,
+			     MonoVal {exp = Raise {exn = VarExp.mono exn,
+						   filePos = NONE},
+				      ty = ty,
+				      var = res}],
+		     result = VarExp.mono res}
 	    val {decs, result} = dest e
 	    val decs =
 	       List.concat [[prof ProfileExp.Enter],
 			    decs,
 			    [prof ProfileExp.Leave]]
-	    val try = new {decs = decs, result = result}
+	    val try = make {decs = decs, result = result}
 	 in
 	    fromPrimExp (Handle {catch = (exn, Type.exn),
 				 handler = handler,
@@ -589,7 +534,7 @@
 	 val body = make #body
       end
 
-      fun new {arg, argType, body} =
+      fun make {arg, argType, body} =
 	 Lam {arg = arg,
 	      argType = argType,
 	      body = body,
@@ -750,8 +695,10 @@
 
       fun deref (e: t): t =
 	 convert (e, fn (x, t) =>
-		  let val t = Type.deref t
-		  in (PrimApp {prim = Prim.deref,
+		  let
+		     val t = Type.deRef t
+		  in
+		     (PrimApp {prim = Prim.deref,
 			       targs = Vector.new1 t,
 			       args = Vector.new1 x},
 		      t)
@@ -797,9 +744,9 @@
 			   Dec.MonoVal {var = var, ty = ty, exp = exp}))
 	 
       fun lambda {arg, argType, body, bodyType} =
-	 simple (Lambda (Lambda.new {arg = arg,
-				     argType = argType,
-				     body = toExp body}),
+	 simple (Lambda (Lambda.make {arg = arg,
+				      argType = argType,
+				      body = toExp body}),
 		 Type.arrow (argType, bodyType))
       
       fun detupleGen (e: PrimExp.t,
@@ -813,7 +760,7 @@
 	   | 1 => [MonoVal {var = Vector.sub (components, 0), ty = t, exp = e}]
 	   | _ =>
 		let
-		   val ts = Type.detuple t
+		   val ts = Type.deTuple t
 		   val tupleVar = Var.newNoname ()
 		in MonoVal {var = tupleVar, ty = t, exp = e}
 		   ::
@@ -835,17 +782,20 @@
 	 tuple
 	 (fn (e, t) =>
 	  let
-	     val ts = Type.detuple t
-	  in case e of
-	     Tuple xs => send (body (Vector.zip (xs, ts)), k)
-	   | _ => let
-		     val components = Vector.map (ts, fn _ => Var.newNoname ())
-		  in detupleGen (e, t, components,
-				 send (body (Vector.map2
-					     (components, ts, fn (x, t) =>
-					      (VarExp.mono x, t))),
-				       k))
-		  end
+	     val ts = Type.deTuple t
+	  in
+	     case e of
+		Tuple xs => send (body (Vector.zip (xs, ts)), k)
+	      | _ => let
+			val components =
+			   Vector.map (ts, fn _ => Var.newNoname ())
+		     in
+			detupleGen (e, t, components,
+				    send (body (Vector.map2
+						(components, ts, fn (x, t) =>
+						 (VarExp.mono x, t))),
+					  k))
+		     end
 	  end)
    end
 
@@ -865,16 +815,20 @@
 
 structure Datatype =
    struct
-      type t = {tycon: Tycon.t,
-		tyvars: Tyvar.t vector,
-		cons: {con: Con.t,
-		       arg: Type.t option} vector}
+      type t = {cons: {arg: Type.t option,
+		       con: Con.t} vector,
+		tycon: Tycon.t,
+		tyvars: Tyvar.t vector}
 
-      fun toAst ({tyvars, tycon, cons}:t) =
-	 {tyvars = tyvars,
-	  tycon = Tycon.toAst tycon,
-	  cons = Vector.map (cons, fn {con, arg} =>
-			     (Con.toAst con, Type.optionToAst arg))}
+      fun layout ({cons, tycon, tyvars}: t): Layout.t =
+	 let
+	    open Layout
+	 in
+	    seq [layoutTyvars tyvars, str " ", Tycon.layout tycon, str " = ",
+		 align
+		 (separateLeft (Vector.toListMap (cons, layoutConArg),
+				"| "))]
+	 end
    end
 
 (*---------------------------------------------------*)
@@ -883,31 +837,21 @@
 
 structure Program =
    struct
-      datatype t = T of {datatypes: Datatype.t vector,
-			 body: Exp.t,
+      datatype t = T of {body: Exp.t,
+			 datatypes: Datatype.t vector,
 			 overflow: Var.t option}
 
       fun size (T {body, ...}) = Exp.size body
 
-      fun toAst (T {datatypes, body, ...}) =
-	 let
-	    val body = Exp.toAst body
-	 in
-	    if Vector.isEmpty datatypes
-	       then body
-	    else
-	       Aexp.lett (Vector.new1
-			  (Adec.datatypee (Vector.map
-					   (datatypes, Datatype.toAst))),
-			  body)
-	 end
-
-      fun layout (p as T {overflow, ...}) =
+      fun layout (p as T {body, datatypes, overflow, ...}) =
 	 let
 	    open Layout
 	 in
 	    align [seq [str "Overflow: ", Option.layout Var.layout overflow],
-		   Ast.Exp.layout (toAst p)]
+		   str "Datatypes:",
+		   align (Vector.toListMap (datatypes, Datatype.layout)),
+		   str "Body:",
+		   Exp.layout body]
 	 end
 
       fun clear (T {datatypes, body, ...}) =



1.13      +17 -19    mlton/mlton/xml/xml-tree.sig

Index: xml-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml-tree.sig,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- xml-tree.sig	23 Jun 2003 04:59:00 -0000	1.12
+++ xml-tree.sig	9 Oct 2003 18:17:35 -0000	1.13
@@ -37,7 +37,6 @@
 	    val falsee: t
 	    val truee: t
 	    val con: t -> Con.t
-	    val toAst: t -> Ast.Pat.t
 	    val layout: t -> Layout.t
 	 end
 
@@ -67,9 +66,9 @@
 			    body: exp}
 	    val equals: t * t -> bool
 	    val layout: t -> Layout.t
-	    val new: {arg: Var.t,
-		      argType: Type.t,
-		      body: exp} -> t
+	    val make: {arg: Var.t,
+		       argType: Type.t,
+		       body: exp} -> t
 	    val plist: t -> PropertyList.t
 	 end
 
@@ -136,7 +135,6 @@
 			   tyvars: Tyvar.t vector,
 			   var: Var.t}
 
-	    val toAst: t -> Ast.Dec.t
 	    val layout: t -> Layout.t
 	 end
 
@@ -171,7 +169,7 @@
 	    val fromPrimExp: PrimExp.t * Type.t -> t
 	    val hasPrim: t * (Prim.t -> bool) -> bool
 	    val layout: t -> Layout.t
-	    val new: {decs: Dec.t list, result: VarExp.t} -> t
+	    val make: {decs: Dec.t list, result: VarExp.t} -> t
 	    val prefix: t * Dec.t -> t
 	    val result: t -> VarExp.t
 	    val size: t -> int
@@ -188,9 +186,9 @@
 		test: t,
 		ty: Type.t} (* type of entire case expression *)
 	       -> t
-	    val conApp: {con: Con.t,
+	    val conApp: {arg: t option,
+			 con: Con.t,
 			 targs: Type.t vector,
-			 arg: t option,
 			 ty: Type.t} -> t
 	    val const: Const.t -> t
 	    val deref: t -> t
@@ -199,10 +197,10 @@
 	    val equal: t * t -> t
 	    val falsee: unit -> t
 	    val fromExp: Exp.t * Type.t -> t
-	    val handlee: {try: t,
-			  ty: Type.t,
-			  catch: Var.t * Type.t,
-			  handler: t} -> t
+	    val handlee: {catch: Var.t * Type.t,
+			  handler: t,
+			  try: t,
+			  ty: Type.t} -> t
 	    val iff: {test: t, thenn: t, elsee: t, ty: Type.t} -> t
 	    val lambda: {arg: Var.t,
 			 argType: Type.t,
@@ -212,9 +210,9 @@
 	    val let1: {var: Var.t, exp: t, body: t} -> t
 	    val lett: {decs: Dec.t list, body: t} -> t
 	    val monoVar: Var.t * Type.t -> t
-	    val primApp: {prim: Prim.t,
+	    val primApp: {args: t vector,
+			  prim: Prim.t,
 			  targs: Type.t vector,
-			  args: t vector,
 			  ty: Type.t} -> t
 	    val raisee: {exn: t, filePos: string option} * Type.t -> t
 	    val reff: t -> t
@@ -227,20 +225,20 @@
 	    val tuple: {exps: t vector, ty: Type.t} -> t
 	    val unit: unit -> t
 	    val vall: {var: Var.t, exp: t} -> Dec.t list
-	    val var: {var: Var.t,
-		      targs: Type.t vector,
-		      ty: Type.t} -> t
+	    val var: {targs: Type.t vector,
+		      ty: Type.t,
+		      var: Var.t} -> t
 	    val varExp: VarExp.t * Type.t -> t
 	 end
 
       structure Program:
 	 sig
 	    datatype t =
-	       T of {datatypes: {cons: {arg: Type.t option,
+	       T of {body: Exp.t,
+		     datatypes: {cons: {arg: Type.t option,
 					con: Con.t} vector,
 				 tycon: Tycon.t,
 				 tyvars: Tyvar.t vector} vector,
-		     body: Exp.t,
 		     (* overflow is SOME only after exceptions have been
 		      * implemented.
 		      *)



1.8       +2 -0      mlton/regression/.cvsignore

Index: .cvsignore
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/.cvsignore,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- .cvsignore	2 Jan 2003 17:45:22 -0000	1.7
+++ .cvsignore	9 Oct 2003 18:17:35 -0000	1.8
@@ -1,3 +1,5 @@
+*.ui
+*.uo
 *.dat
 *.dot
 *.ssa



1.2       +1 -1      mlton/regression/6.sml

Index: 6.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/6.sml,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- 6.sml	18 Jul 2001 05:51:07 -0000	1.1
+++ 6.sml	9 Oct 2003 18:17:35 -0000	1.2
@@ -1,6 +1,6 @@
 fun f x = x
 
-val r = ref f
+val r: (int -> int) ref = ref f
 
 val _ = r := (fn y => y)
 



1.2       +5 -5      mlton/regression/asterisk.sml

Index: asterisk.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/asterisk.sml,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- asterisk.sml	5 Oct 2001 19:07:42 -0000	1.1
+++ asterisk.sml	9 Oct 2003 18:17:35 -0000	1.2
@@ -1,5 +1,5 @@
-(* asterisk.sml *)
-
-(* Checks parsing of "* )". *)
-
-val op* = (op*);
+(* asterisk.sml *)
+
+(* Checks parsing of "* )". *)
+
+val op* : int * int -> int = (op*);



1.2       +11 -11    mlton/regression/exnHistory.ok

Index: exnHistory.ok
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/exnHistory.ok,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- exnHistory.ok	1 Oct 2001 17:10:31 -0000	1.1
+++ exnHistory.ok	9 Oct 2003 18:17:35 -0000	1.2
@@ -1,11 +1,11 @@
-exnHistory.sml:4.26
-exnHistory.sml:4.26
-exnHistory.sml:4.26
-exnHistory.sml:4.26
-exnHistory.sml:4.26
-exnHistory.sml:4.26
-exnHistory.sml:4.26
-exnHistory.sml:4.26
-exnHistory.sml:4.26
-exnHistory.sml:4.26
-exnHistory.sml:3.18
+exnHistory.sml 4.26
+exnHistory.sml 4.26
+exnHistory.sml 4.26
+exnHistory.sml 4.26
+exnHistory.sml 4.26
+exnHistory.sml 4.26
+exnHistory.sml 4.26
+exnHistory.sml 4.26
+exnHistory.sml 4.26
+exnHistory.sml 4.26
+exnHistory.sml 3.18



1.5       +1 -1      mlton/regression/exnHistory2.ok

Index: exnHistory2.ok
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/exnHistory2.ok,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- exnHistory2.ok	24 Sep 2003 17:27:54 -0000	1.4
+++ exnHistory2.ok	9 Oct 2003 18:17:35 -0000	1.5
@@ -1,4 +1,4 @@
 unhandled exception: Fail: foo
 with history:
-	exnHistory2.sml:1.15
+	exnHistory2.sml 1.15
 Nonzero exit status.



1.2       +22 -22    mlton/regression/exnHistory3.ok

Index: exnHistory3.ok
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/exnHistory3.ok,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- exnHistory3.ok	25 Aug 2002 22:23:58 -0000	1.1
+++ exnHistory3.ok	9 Oct 2003 18:17:35 -0000	1.2
@@ -1,23 +1,23 @@
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:5.18
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 5.18
 ZZZ
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:5.18
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 5.18



1.4       +8 -11     mlton/regression/flexrecord.sml

Index: flexrecord.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/flexrecord.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- flexrecord.sml	18 Oct 2001 21:19:50 -0000	1.3
+++ flexrecord.sml	9 Oct 2003 18:17:35 -0000	1.4
@@ -83,16 +83,13 @@
 (* flexrecord7 *)
 
 (* flexrecord8 *)
-val f = #foo
-val g = (fn x => x) f
-val _ = f {foo=0, bar=1}
-(* flexrecord8 *)
-
-(* flexrecord9 *)
-structure S =
-   struct
+val _ =
+   fn _ =>
+   let
       val f = #foo
+      val g = (fn x => x) f
+      val _ = f {foo=0, bar=1}
+   in
+      ()
    end
-
-val _ = S.f {foo=1, goo=2}
-(* flexrecord9 *)
+(* flexrecord8 *)



1.2       +2 -2      mlton/regression/undetermined.sml

Index: undetermined.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/undetermined.sml,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- undetermined.sml	5 Oct 2001 19:07:42 -0000	1.1
+++ undetermined.sml	9 Oct 2003 18:17:35 -0000	1.2
@@ -7,10 +7,10 @@
 
 structure A : sig val a : int list ref end =
 struct
-    val a = ref nil
+    val a: int list ref = ref nil
 end;
 
 structure B : sig end =
 struct
-    val a = ref nil
+    val a: unit list ref = ref nil
 end;



1.2       +1 -0      mlton/regression/valrec.ok

Index: valrec.ok
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/valrec.ok,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- valrec.ok	18 Jul 2001 05:51:07 -0000	1.1
+++ valrec.ok	9 Oct 2003 18:17:35 -0000	1.2
@@ -1,2 +1,3 @@
 Hello, world!
 Hello, world!
+13



1.3       +4 -8      mlton/regression/valrec.sml

Index: valrec.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/valrec.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- valrec.sml	5 Oct 2001 19:07:42 -0000	1.2
+++ valrec.sml	9 Oct 2003 18:17:35 -0000	1.3
@@ -50,11 +50,7 @@
 and rec e as f as g = fn x => x
 and h : 'b -> 'b : 'b -> 'b = fn x => x;
 
-val x =
-let
-    val rec LESS = fn x => x	(* will raise Bind *)
-    and NONE as SOME = fn x => x
-    val SOME = 1;
-in
-    raise Fail "should not get here!"
-end handle Bind => ();
+val rec LESS = fn x => x
+and NONE as SOME = fn x => x
+val SOME = 13
+val _ = print (concat [Int.toString SOME, "\n"])



1.10      +0 -10     mlton/runtime/libmlton.c

Index: libmlton.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/libmlton.c,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- libmlton.c	1 Jun 2003 00:31:33 -0000	1.9
+++ libmlton.c	9 Oct 2003 18:17:35 -0000	1.10
@@ -9,16 +9,6 @@
 #include <string.h>
 #include "libmlton.h"
 
-void MLton_printStringEscaped (FILE *f, unsigned char *s) {
-	int i;
-	for (i = 0; s[i] != '\0'; i++)
-		fprintf(f, "%d%d%d", 
-				s[i] / 100 % 10,
-				s[i] / 10 % 10,
-				s[i] % 10);
-	fprintf(f, "\n");
-}
-
 /* ------------------------------------------------- */
 /*                     MLton_init                     */
 /* ------------------------------------------------- */




-------------------------------------------------------
This SF.net email is sponsored by: SF.net Giveback Program.
SourceForge.net hosts over 70,000 Open Source Projects.
See the people who have HELPED US provide better services:
Click here: http://sourceforge.net/supporters.php
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel