[MLton] cvs commit: mlb integration

Matthew Fluet fluet@mlton.org
Wed, 28 Jul 2004 14:05:17 -0700


fluet       04/07/28 14:05:15

  Modified:    .        Makefile
               basis-library/misc primitive.sml
               basis-library/mlton syslog.sml
               bin      mlton
               doc      changelog
               doc/user-guide Makefile bib.bib credits.tex main.tex
               lib/mlton/basic instream.sig
               lib/mlton-stubs-in-smlnj os.sml
               mlton    Makefile
               mlton/ast ast-atoms.fun ast-atoms.sig ast.fun ast.sig
                        sources.cm
               mlton/backend backend.fun
               mlton/control control.sig control.sml source-pos.sml
               mlton/core-ml core-ml.fun core-ml.sig dead-code.fun
                        dead-code.sig
               mlton/defunctorize defunctorize.fun
               mlton/elaborate elaborate-core.fun elaborate-core.sig
                        elaborate-env.fun elaborate-env.sig
                        elaborate-sigexp.fun elaborate-sigexp.sig
                        elaborate.fun elaborate.sig sources.cm
               mlton/front-end .cvsignore Makefile front-end.fun
                        front-end.sig import.cm sources.cm
               mlton/main compile.fun compile.sig main.fun main.sig
               mlton/xml implement-suffix.fun
  Added:       basis-library basis-1997.mlb basis-2002-strict.mlb
                        basis-2002.mlb basis-none.mlb basis.mlb
               basis-library/libs build.mlb primitive.mlb
               doc/user-guide mlb-formal.tex
               mlton/ast ast-mlbs.fun ast-mlbs.sig ast-modules.fun
                        ast-modules.sig ast-programs.fun ast-programs.sig
               mlton/elaborate elaborate-controls.fun
                        elaborate-controls.sig elaborate-mlbs.fun
                        elaborate-mlbs.sig elaborate-modules.fun
                        elaborate-modules.sig elaborate-programs.fun
                        elaborate-programs.sig
               mlton/front-end mlb-front-end.fun mlb-front-end.sig mlb.grm
                        mlb.lex
  Removed:     basis-library/libs build
               basis-library/libs/basis-1997 bind
               basis-library/libs/basis-2002 bind
               basis-library/libs/basis-2002-strict bind
               basis-library/libs/basis-none bind
  Log:
  MAIL mlb integration
  
  This commit brings an alternative "programming in the large" model to MLton.
  It is essentially the model described at:
    http://www.mlton.org/pipermail/mlton/2004-March/015645.html
  with some modifications to be consistent with Standard ML.
  
  A good place to start is "Formal Specification of MLBs" in the User
  Guide.  It is written in the style of the Definition (i.e., terse),
  but gives a fairly detailed semantics for MLB behavior.  The only
  missing piece there is annotations.  Steve, can you check that this
  converts to HTML correctly? I don't have heava on any system I use.
  
  Compiles of .sml and .cm files are transparently handled as implicit
  MLB basdecs.  I've disabled the implicit compile of the basis file
  when there are no file inputs and a def-use flag is set.  If you want
  to compile the basis, do something like
    mlton -stop tc -show-basis basis.basis '$(SML_LIB)/basis/basis.mlb'
  
  Please report bugs or suggestions.

Revision  Changes    Path
1.115     +15 -12    mlton/Makefile

Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/Makefile,v
retrieving revision 1.114
retrieving revision 1.115
diff -u -r1.114 -r1.115
--- Makefile	24 Jun 2004 02:05:29 -0000	1.114
+++ Makefile	28 Jul 2004 21:05:07 -0000	1.115
@@ -39,6 +39,13 @@
 	$(MAKE) script targetmap constants compiler world tools
 	@echo 'Build of MLton succeeded.'
 
+.PHONY: basis
+basis:
+	rm -rf $(LIB)/sml
+	mkdir $(LIB)/sml
+	$(CP) $(SRC)/basis-library $(LIB)/sml/basis
+	find $(LIB)/sml -type f -name .cvsignore | xargs rm -rf
+
 .PHONY: bootstrap-nj
 bootstrap-nj:
 	$(MAKE) nj-mlton
@@ -141,16 +148,16 @@
 
 .PHONY: nj-mlton
 nj-mlton:
-	$(MAKE) dirs
+	$(MAKE) dirs runtime 
 	$(MAKE) -C $(COMP) nj-mlton
-	$(MAKE) script runtime targetmap constants
+	$(MAKE) script basis targetmap constants
 	@echo 'Build of MLton succeeded.'
 
 .PHONY: nj-mlton-dual
 nj-mlton-dual:
-	$(MAKE) dirs	
+	$(MAKE) dirs runtime
 	$(MAKE) -C $(COMP) nj-mlton-dual
-	$(MAKE) script runtime targetmap constants
+	$(MAKE) script basis targetmap constants
 	@echo 'Build of MLton succeeded.'
 
 .PHONY: profiled
@@ -231,19 +238,15 @@
 world: 
 	$(MAKE) world-no-check
 	@echo 'Type checking basis.'
-	$(MLTON) -dead-code false	\
-		-sequence-unit true 	\
-		-stop tc 		\
-		-warn-unused true	\
+	$(MLTON) -disable-ann deadCode \
+		-stop tc \
+		$(LIB)/sml/basis/basis.mlb \
 		>/dev/null
 
 .PHONY: world-no-check
 world-no-check: 
 	@echo 'Making world.'
-	rm -rf $(LIB)/sml
-	mkdir $(LIB)/sml
-	$(CP) $(SRC)/basis-library $(LIB)/sml
-	find $(LIB)/sml -type f -name .cvsignore | xargs rm -rf
+	$(MAKE) basis
 	$(LIB)/$(AOUT) @MLton -- $(LIB)/world
 
 # The TBIN and TLIB are where the files are going to be after installing.



1.1                  mlton/basis-library/basis-1997.mlb

Index: basis-1997.mlb
===================================================================
ann  
   deadCode true,
   sequenceUnit true,
   warnMatch true,
   warnUnused true, forceUsed
in
   local
      ann forceUsed in libs/build.mlb end
   in
      libs/basis-1997/top-level/infixes.sml
      libs/basis-1997/top-level/basis-funs.sml
      libs/basis-1997/top-level/basis-sigs.sml
      ann allowRebindEquals true in libs/basis-1997/top-level/top-level.sml end
      ann allowOverload true in libs/basis-1997/top-level/overloads.sml end
  end
end



1.1                  mlton/basis-library/basis-2002-strict.mlb

Index: basis-2002-strict.mlb
===================================================================
ann  
   deadCode true,
   sequenceUnit true,
   warnMatch true,
   warnLocalUnused true  
in
   local
      libs/build.mlb
   in
      libs/basis-2002/top-level/infixes.sml
      libs/basis-2002/top-level/basis-funs.sml
      libs/basis-2002/top-level/basis-sigs.sml
      ann allowRebindEquals true in libs/basis-2002-strict/top-level/top-level.sml end
      ann allowOverload true in libs/basis-2002/top-level/overloads.sml end
   end
end



1.1                  mlton/basis-library/basis-2002.mlb

Index: basis-2002.mlb
===================================================================
ann  
   deadCode true,
   sequenceUnit true,
   warnMatch true,
   warnUnused true, forceUsed
in
   local
      libs/build.mlb
   in
      libs/basis-2002/top-level/infixes.sml
      libs/basis-2002/top-level/basis-funs.sml
      libs/basis-2002/top-level/basis-sigs.sml
      ann allowRebindEquals true in libs/basis-2002/top-level/top-level.sml end
      ann allowOverload true in libs/basis-2002/top-level/overloads.sml end
    end
end



1.1                  mlton/basis-library/basis-none.mlb

Index: basis-none.mlb
===================================================================
ann  
   deadCode true,
   sequenceUnit true,
   warnMatch true,
   warnUnused true, forceUsed
in
   local
      ann forceUsed in libs/build.mlb end
   in
      libs/basis-none/top-level/infixes.sml
      ann allowRebindEquals true in libs/basis-none/top-level/top-level.sml end
   end
end



1.1                  mlton/basis-library/basis.mlb

Index: basis.mlb
===================================================================
basis-2002.mlb



1.1                  mlton/basis-library/libs/build.mlb

Index: build.mlb
===================================================================
ann  
   deadCode true,
   sequenceUnit true,
   warnMatch true,
   warnUnused true  
in
primitive.mlb
(*
#
# Common basis implementation.
#
*)
../top-level/infixes.sml
../misc/basic.sml
../misc/dynamic-wind.sig
../misc/dynamic-wind.sml
../general/general.sig
../general/general.sml
../misc/util.sml
../general/option.sig
../general/option.sml
../list/list.sig
../list/list.sml
../list/list-pair.sig
../list/list-pair.sml
../arrays-and-vectors/slice.sig
../arrays-and-vectors/sequence.sig
../arrays-and-vectors/sequence.fun
../arrays-and-vectors/vector-slice.sig
../arrays-and-vectors/vector.sig
../arrays-and-vectors/vector.sml
../arrays-and-vectors/array-slice.sig
../arrays-and-vectors/array.sig
../arrays-and-vectors/array.sml
../arrays-and-vectors/array2.sig
../arrays-and-vectors/array2.sml
../arrays-and-vectors/mono-vector-slice.sig
../arrays-and-vectors/mono-vector.sig
../arrays-and-vectors/mono-vector.fun
../arrays-and-vectors/mono-array-slice.sig
../arrays-and-vectors/mono-array.sig
../arrays-and-vectors/mono-array.fun
../arrays-and-vectors/mono-array2.sig
../arrays-and-vectors/mono-array2.fun
../arrays-and-vectors/mono.sml
../text/string0.sml
../text/char0.sml
../misc/reader.sig
../misc/reader.sml
../text/string-cvt.sig
../text/string-cvt.sml
../general/bool.sig
../general/bool.sml
../integer/integer.sig
../integer/int.sml
../text/char.sig
../text/char.sml
../text/substring.sig
../text/substring.sml
../text/string.sig
../text/string.sml
../misc/C.sig
../misc/C.sml
../integer/word.sig
../integer/word.sml
../integer/int-inf.sig
../integer/int-inf.sml
../real/IEEE-real.sig
../real/IEEE-real.sml
../real/math.sig
../real/real.sig
../real/real.fun
../integer/pack-word.sig
../integer/pack-word32.sml
../text/byte.sig
../text/byte.sml
../text/text.sig
../text/text.sml
../real/pack-real.sig
../real/pack-real.sml
../real/real32.sml
../real/real64.sml
../integer/patch.sml
../integer/embed-int.sml
../integer/embed-word.sml

../top-level/arithmetic.sml

(*
# misc/unique-id.sig
# misc/unique-id.fun
*)
../misc/cleaner.sig
../misc/cleaner.sml

../system/pre-os.sml
../system/time.sig
../system/time.sml
../system/date.sig
../system/date.sml

../io/io.sig
../io/io.sml
../io/prim-io.sig
../io/prim-io.fun
../io/bin-prim-io.sml
../io/text-prim-io.sml

../posix/error.sig
../posix/error.sml
../posix/flags.sig
../posix/flags.sml
../posix/signal.sig
../posix/signal.sml
../posix/proc-env.sig
../posix/proc-env.sml
../posix/file-sys.sig
../posix/file-sys.sml
../posix/io.sig
../posix/io.sml
../posix/process.sig
../posix/process.sml
../posix/sys-db.sig
../posix/sys-db.sml
../posix/tty.sig
../posix/tty.sml
../posix/posix.sig
../posix/posix.sml

../io/stream-io.sig
../io/stream-io.fun
../io/imperative-io.sig
../io/imperative-io.fun
../io/bin-stream-io.sig
../io/bin-io.sig
../io/bin-io.sml
../io/text-stream-io.sig
../io/text-io.sig
../io/text-io.sml

../system/path.sig
../system/path.sml
../system/file-sys.sig
../system/file-sys.sml
../system/command-line.sig
../system/command-line.sml

../general/sml90.sig
../general/sml90.sml

../mlton/process.sig
../mlton/process.sml
../mlton/exn.sig
../mlton/exn.sml
../mlton/thread.sig
../mlton/thread.sml
../mlton/signal.sig
../mlton/signal.sml
../mlton/rusage.sig
../mlton/rusage.sml

../system/process.sig
../system/process.sml
../system/io.sig
../system/io.sml
../system/os.sig
../system/os.sml
../system/unix.sig
../system/unix.sml
../system/timer.sig
../system/timer.sml

../net/net.sig
../net/net.sml
../net/net-host-db.sig
../net/net-host-db.sml
../net/net-prot-db.sig
../net/net-prot-db.sml
../net/net-serv-db.sig
../net/net-serv-db.sml
../net/socket.sig
../net/socket.sml
../net/generic-sock.sig
../net/generic-sock.sml
../net/inet-sock.sig
../net/inet-sock.sml
../net/unix-sock.sig
../net/unix-sock.sml

../mlton/array.sig
../mlton/cont.sig
../mlton/cont.sml
../mlton/random.sig
../mlton/random.sml
../mlton/io.sig
../mlton/io.fun
../mlton/text-io.sig
../mlton/bin-io.sig
../mlton/itimer.sig
../mlton/itimer.sml
../mlton/ffi.sig
../mlton/ffi.sml
../mlton/gc.sig
../mlton/gc.sml
../mlton/int-inf.sig
../mlton/platform.sig
../mlton/platform.sml
../mlton/pointer.sig
../mlton/pointer.sml
../mlton/proc-env.sig
../mlton/proc-env.sml
../mlton/profile.sig
../mlton/profile.sml
(*
# mlton/ptrace.sig
# mlton/ptrace.sml
*)
../mlton/rlimit.sig
../mlton/rlimit.sml
../mlton/socket.sig
../mlton/socket.sml
../mlton/syslog.sig
../mlton/syslog.sml
../mlton/vector.sig
../mlton/weak.sig
../mlton/weak.sml
../mlton/finalizable.sig
../mlton/finalizable.sml
../mlton/word.sig
../mlton/world.sig
../mlton/world.sml
../mlton/mlton.sig
../mlton/mlton.sml

../sml-nj/sml-nj.sig
../sml-nj/sml-nj.sml
../sml-nj/unsafe.sig
../sml-nj/unsafe.sml

(*
#
# Basis2002
#
*)
basis-2002/top-level/basis.sig
ann allowRebindEquals true 
in basis-2002/top-level/basis.sml 
end

(*
#
# Basis1997
#
*)
basis-1997/arrays-and-vectors/vector.sig
basis-1997/arrays-and-vectors/array.sig
basis-1997/arrays-and-vectors/vector-array-convert.fun
basis-1997/arrays-and-vectors/mono-vector.sig
basis-1997/arrays-and-vectors/mono-array.sig
basis-1997/arrays-and-vectors/mono-array2.sig
basis-1997/arrays-and-vectors/mono-vector-array-array2-convert.fun
basis-1997/integer/word.sig
basis-1997/text/string.sig
basis-1997/text/substring.sig
basis-1997/text/text-convert.fun
basis-1997/real/IEEE-real.sig
basis-1997/real/IEEE-real-convert.fun
basis-1997/real/real.sig
basis-1997/real/real-convert.fun
basis-1997/posix/flags.sig
basis-1997/posix/flags-convert.fun
basis-1997/posix/process.sig
basis-1997/posix/process-convert.fun
basis-1997/posix/file-sys.sig
basis-1997/posix/file-sys-convert.fun
basis-1997/posix/io.sig
basis-1997/posix/io-convert.fun
basis-1997/posix/tty.sig
basis-1997/posix/tty-convert.fun
basis-1997/posix/posix.sig
basis-1997/posix/posix-convert.fun
basis-1997/system/timer.sig
basis-1997/system/timer-convert.fun
basis-1997/system/file-sys.sig
basis-1997/system/file-sys-convert.fun
basis-1997/system/path.sig
basis-1997/system/path-convert.fun
basis-1997/system/process.sig
basis-1997/system/process-convert.fun
basis-1997/system/os.sig
basis-1997/system/os-convert.fun
basis-1997/system/unix.sig
basis-1997/system/unix-convert.fun
basis-1997/io/io.sig
basis-1997/io/io-convert.fun
basis-1997/io/stream-io.sig
basis-1997/io/text-stream-io.sig
basis-1997/io/text-io.sig
basis-1997/io/text-io-convert.fun
basis-1997/io/bin-stream-io.sig
basis-1997/io/bin-io.sig
basis-1997/io/bin-io-convert.fun
basis-1997/top-level/basis.sig
basis-1997/top-level/basis.sml

(*
#
# BasisNone
#
*)
basis-none/top-level/basis.sig
ann allowRebindEquals true 
in basis-none/top-level/basis.sml 
end

end


1.1                  mlton/basis-library/libs/primitive.mlb

Index: primitive.mlb
===================================================================

ann 
   allowConstant true, 
   allowPrim true, 
   allowRebindEquals true,
   deadCode true,
   sequenceUnit true,
   warnMatch true,
   warnUnused true  
in
   _prim
   ../misc/primitive.sml
   ../posix/primitive.sml
end



1.115     +50 -8     mlton/basis-library/misc/primitive.sml

Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.114
retrieving revision 1.115
diff -u -r1.114 -r1.115
--- primitive.sml	1 Jul 2004 17:26:00 -0000	1.114
+++ primitive.sml	28 Jul 2004 21:05:08 -0000	1.115
@@ -792,6 +792,16 @@
 		     end
 	       end
 
+	    structure Process =
+	       struct
+		  val spawne =
+		     _import "MLton_Process_spawne"
+		     : NullString.t * NullString.t array * NullString.t array -> Pid.t;
+		  val spawnp =
+		     _import "MLton_Process_spawnp"
+		     : NullString.t * NullString.t array -> Pid.t;
+	       end
+	    
 	    structure Profile =
 	       struct
 		  val isOn = _build_const "MLton_profile_isOn": bool;
@@ -856,16 +866,48 @@
 		 val gc_stime_usec = _import "MLton_Rusage_gc_stime_usec": unit -> int;
 	       end
 
-	    structure Process =
+	    structure Syslog =
 	       struct
-		  val spawne =
-		     _import "MLton_Process_spawne"
-		     : NullString.t * NullString.t array * NullString.t array -> Pid.t;
-		  val spawnp =
-		     _import "MLton_Process_spawnp"
-		     : NullString.t * NullString.t array -> Pid.t;
+		  type openflag = int
+		     
+		  val CONS = _const "LOG_CONS" : openflag;
+		  val NDELAY = _const "LOG_NDELAY" : openflag;
+		  val PERROR = _const "LOG_PERROR" : openflag;
+		  val PID = _const "LOG_PID" : openflag;
+		     
+		  type facility = int
+		     
+		  val AUTHPRIV = _const "LOG_AUTHPRIV" : facility;
+		  val CRON = _const "LOG_CRON" : facility;
+		  val DAEMON = _const "LOG_DAEMON" : facility;
+		  val KERN = _const "LOG_KERN" : facility;
+		  val LOCAL0 = _const "LOG_LOCAL0" : facility;
+		  val LOCAL1 = _const "LOG_LOCAL1" : facility;
+		  val LOCAL2 = _const "LOG_LOCAL2" : facility;
+		  val LOCAL3 = _const "LOG_LOCAL3" : facility;
+		  val LOCAL4 = _const "LOG_LOCAL4" : facility;
+		  val LOCAL5 = _const "LOG_LOCAL5" : facility;
+		  val LOCAL6 = _const "LOG_LOCAL6" : facility;
+		  val LOCAL7 = _const "LOG_LOCAL7" : facility;
+		  val LPR = _const "LOG_LPR" : facility;
+		  val MAIL = _const "LOG_MAIL" : facility;
+		  val NEWS = _const "LOG_NEWS" : facility;
+		  val SYSLOG = _const "LOG_SYSLOG" : facility;
+		  val USER = _const "LOG_USER" : facility;
+		  val UUCP = _const "LOG_UUCP" : facility;
+		     
+		  type loglevel = int
+		     
+		  val EMERG = _const "LOG_EMERG" : loglevel;
+		  val ALERT = _const "LOG_ALERT" : loglevel;
+		  val CRIT = _const "LOG_CRIT" : loglevel;
+		  val ERR = _const "LOG_ERR" : loglevel;
+		  val WARNING = _const "LOG_WARNING" : loglevel;
+		  val NOTICE = _const "LOG_NOTICE" : loglevel;
+		  val INFO = _const "LOG_INFO" : loglevel;
+		  val DEBUG = _const "LOG_DEBUG" : loglevel;
 	       end
-	    
+
 	    structure Weak =
 	       struct
 		  type 'a t = 'a weak



1.5       +1 -38     mlton/basis-library/mlton/syslog.sml

Index: syslog.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/syslog.sml,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- syslog.sml	19 Jul 2003 01:23:25 -0000	1.4
+++ syslog.sml	28 Jul 2004 21:05:09 -0000	1.5
@@ -6,44 +6,7 @@
 structure MLtonSyslog :> MLTON_SYSLOG =
 struct
 
-type openflag = int
-        
-val CONS = _const "LOG_CONS" : openflag;
-val NDELAY = _const "LOG_NDELAY" : openflag;
-val PERROR = _const "LOG_PERROR" : openflag;
-val PID = _const "LOG_PID" : openflag;
-
-type facility = int
-
-val AUTHPRIV = _const "LOG_AUTHPRIV" : facility;
-val CRON = _const "LOG_CRON" : facility;
-val DAEMON = _const "LOG_DAEMON" : facility;
-val KERN = _const "LOG_KERN" : facility;
-val LOCAL0 = _const "LOG_LOCAL0" : facility;
-val LOCAL1 = _const "LOG_LOCAL1" : facility;
-val LOCAL2 = _const "LOG_LOCAL2" : facility;
-val LOCAL3 = _const "LOG_LOCAL3" : facility;
-val LOCAL4 = _const "LOG_LOCAL4" : facility;
-val LOCAL5 = _const "LOG_LOCAL5" : facility;
-val LOCAL6 = _const "LOG_LOCAL6" : facility;
-val LOCAL7 = _const "LOG_LOCAL7" : facility;
-val LPR = _const "LOG_LPR" : facility;
-val MAIL = _const "LOG_MAIL" : facility;
-val NEWS = _const "LOG_NEWS" : facility;
-val SYSLOG = _const "LOG_SYSLOG" : facility;
-val USER = _const "LOG_USER" : facility;
-val UUCP = _const "LOG_UUCP" : facility;
-
-type loglevel = int
-
-val EMERG = _const "LOG_EMERG" : loglevel;
-val ALERT = _const "LOG_ALERT" : loglevel;
-val CRIT = _const "LOG_CRIT" : loglevel;
-val ERR = _const "LOG_ERR" : loglevel;
-val WARNING = _const "LOG_WARNING" : loglevel;
-val NOTICE = _const "LOG_NOTICE" : loglevel;
-val INFO = _const "LOG_INFO" : loglevel;
-val DEBUG = _const "LOG_DEBUG" : loglevel;
+open Primitive.MLton.Syslog
 
 fun zt s = s ^ "\000"
 



1.32      +2 -0      mlton/bin/mlton

Index: mlton
===================================================================
RCS file: /cvsroot/mlton/mlton/bin/mlton,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- mlton	2 Jan 2004 03:57:20 -0000	1.31
+++ mlton	28 Jul 2004 21:05:09 -0000	1.32
@@ -8,6 +8,8 @@
 gcc='gcc'
 mlton="$lib/mlton-compile"
 world="$lib/world.mlton"
+SML_LIB="$lib/sml"
+export SML_LIB
 nj='sml'
 eval `$lib/platform`
 njHeap="$lib/mlton.$HOST_ARCH-$HOST_OS"



1.131     +4 -0      mlton/doc/changelog

Index: changelog
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/changelog,v
retrieving revision 1.130
retrieving revision 1.131
diff -u -r1.130 -r1.131
--- changelog	11 Jul 2004 07:28:02 -0000	1.130
+++ changelog	28 Jul 2004 21:05:09 -0000	1.131
@@ -1,5 +1,9 @@
 Here are the changes since version 20040227.
 
+* 2004-07-28
+  - Added support for programming in the large using the ML Basis
+    system.
+
 * 2004-07-11
   - Fixed bugs in ListPair.*Eq functions, which incorrectly raised
     the UnequalLengths exception.



1.19      +2 -1      mlton/doc/user-guide/Makefile

Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/Makefile,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- Makefile	21 Feb 2004 04:10:17 -0000	1.18
+++ Makefile	28 Jul 2004 21:05:09 -0000	1.19
@@ -17,6 +17,7 @@
 	macros.tex		\
 	main.tex		\
 	man-page.tex		\
+	mlb-formal.tex		\
 	nj-deviations.tex	\
 	platform.tex		\
 	profiling.tex		\
@@ -43,7 +44,7 @@
 
 main.pdf: main.ps
 	ps2pdf main.ps
-	
+
 main.ps: main.dvi
 	dvips -o main.ps main
 



1.2       +1 -1      mlton/doc/user-guide/bib.bib

Index: bib.bib
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/bib.bib,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- bib.bib	20 Jul 2001 17:01:38 -0000	1.1
+++ bib.bib	28 Jul 2004 21:05:09 -0000	1.2
@@ -1,6 +1,6 @@
 @string{and = " and "}
 @string{harper = "Robert Harper"}
-@string{macqueen = "David~B. Macqueen"}
+@string{macqueen = "David~B. MacQueen"}
 @string{milner = "Robin Milner"}
 @string{tofte = "Mads Tofte"}
 



1.37      +6 -1      mlton/doc/user-guide/credits.tex

Index: credits.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/credits.tex,v
retrieving revision 1.36
retrieving revision 1.37
diff -u -r1.36 -r1.37
--- credits.tex	13 Jun 2004 03:54:57 -0000	1.36
+++ credits.tex	28 Jul 2004 21:05:09 -0000	1.37
@@ -15,7 +15,8 @@
 {\intel} native code generator, ported {\tt mlprof} to work with the
 native code generator, did a lot of work on the SSA optimizer, both
 adding new optimizations and improving or porting existing
-optimizations, and updated the basis library implementation.
+optimizations, updated the basis library implementation, and
+implemented MLBs.
 
 \item
 Suresh Jagannathan (\mailto{suresh}{cs.purdue.edu}) implemented
@@ -45,6 +46,10 @@
 Technologies}{http://www.polyspace.com/} provided many bug fixes and
 runtime system improvements, as well as some code to help the Sparc
 port.
+
+\item
+Martin Elsman (\mailto{mael}{itu.dk}) provided helpful discussions in the 
+development of MLBs.
 
 \item
 Simon Helsen (\mailto{shelsen}{acm.org}) has provided bug reports, suggestions,



1.13      +2 -1      mlton/doc/user-guide/main.tex

Index: main.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/main.tex,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- main.tex	21 Feb 2004 04:10:17 -0000	1.12
+++ main.tex	28 Jul 2004 21:05:09 -0000	1.13
@@ -1,5 +1,5 @@
 \documentclass[12pt]{article}
-\usepackage{alltt,latexsym,longtable,psfrag}
+\usepackage{alltt,amsmath,latexsym,longtable,psfrag}
 
 \setlength{\topmargin}{-0.5in}
 \setlength{\textheight}{8.5in}
@@ -45,5 +45,6 @@
 \bibliographystyle{alpha}
 \bibliography{bib}
 \appendix
+\input{mlb-formal}
 \input{nj-deviations}
 \end{document}



1.1                  mlton/doc/user-guide/mlb-formal.tex

Index: mlb-formal.tex
===================================================================
%% \documentclass[draft]{article}
%% \usepackage{fullpage}
%% \usepackage{amsmath}
%% \usepackage{amssymb}
%% \usepackage[mathscr]{eucal}
%% \usepackage{stmaryrd}

% math fonts
\newcommand{\mbb}[1]{\mathbb{#1}}
\newcommand{\mbf}[1]{\mathbf{#1}}
\renewcommand{\mit}[1]{\mathit{#1}}
\newcommand{\mrm}[1]{\mathrm{#1}}
\newcommand{\mtt}[1]{\mathtt{#1}}
\newcommand{\mcal}[1]{\mathcal{#1}}
\newcommand{\msf}[1]{\mathsf{#1}}

% text fonts
\newcommand{\ttt}[1]{\texttt{#1}}

% formatting
\newenvironment{stackAux}[2]{%
\setlength{\arraycolsep}{0pt}
\begin{array}[#1]{#2}}{
\end{array}}
\newenvironment{stackCC}{
\begin{stackAux}{c}{c}}{\end{stackAux}}
\newenvironment{stackCL}{
\begin{stackAux}{c}{l}}{\end{stackAux}}
\newenvironment{stackTL}{
\begin{stackAux}{t}{l}}{\end{stackAux}}
\newenvironment{stackTR}{
\begin{stackAux}{t}{r}}{\end{stackAux}}
\newenvironment{stackBC}{
\begin{stackAux}{b}{c}}{\end{stackAux}}
\newenvironment{stackBL}{
\begin{stackAux}{b}{l}}{\end{stackAux}}

\newcommand{\stagger}[2]{%
\begin{array}{ccc}%
\multicolumn{2}{l}{#1}&\\%
&\multicolumn{2}{r}{#2}%
\end{array}}

\newcommand{\axiom}[1]{{\displaystyle\strut{#1}}}
\newcommand{\infrule}[2]{{\frac{\displaystyle\strut{#1}}{\displaystyle\strut{#2}}}} 
\newcommand{\judge}[2]{\infrule{#1}{#2}}

%% \begin{document}

\sec{Formal Specification of MLBs}{mlb-formal}
    {Formal_Spec_MLBs.html}
%
This section formally specifies the ML Basis system in {\mlton} used
to program in the large.  The system has been designed to be a natural
extension of Standard ML, and the specification is given in the style
of The Definition of Standard ML (henceforeth, the Definition).  This
section adopts (often silently) abbreviations, conventions,
definitions, and notation from the Definition.

\subsection{Syntax of MLBs}

For MLBs there are further reserved words, identifier classes and
derived forms.  There are no further special constants; comments and
lexical analysis are as for the Core and Modules.  The derived forms
appear in Section~\ref{sec:mlb:DerivedForms}.

\subsubsection{Reserved Words}
The following are the additional reserved words used in MLBs.
\begin{displaymath}
\mtt{bas} \quad\quad \mtt{basis}
\end{displaymath}
Note that many of the reserved words from the Core and Modules are not
used by the grammar of MLBs.  However, as the grammar includes
identifiers from the grammars of the Core and Modules, it is useful to
consider the reserved words from the Core and Modules to be reserved
in MLBs as well.

\subsubsection{Identifiers}
The additional identifier class for MLBs are $\mrm{BasId}$ (basis
identifiers).  Basis identifiers must be alphanumeric, not starting
with a prime.  The class of each identifier occurence is determined by
the grammatical rules which follow.  Henceforth, therefore, we
consider all identifier classes to be disjoint.

\subsubsection{Infixed operators}
The grammar of MLBs does not directly admit fixity directives.
However, the static and dynamic semantics for MLBs will import source
files that must be parsed in the scope of fixity directives and that
may introduce additional fixity directives into scope.
Figure~\ref{fig:mlb:S:FixityEnv} formalizes the Definition's notion of
\emph{infix status} as a \emph{fixity environment}.
\begin{figure}[h]
\begin{displaymath}
\begin{array}{rcl}
 & & \mrm{InfixStatus} = \{\mtt{nonfix}\} \cup \bigcup_{d \in \{0,\ldots,9\}} \{\mtt{infix}~d, \mtt{infixr}~d\} \\
\mit{FE} & \in & \mrm{FixEnv} = \mrm{VId} \xrightarrow{\mrm{fin}} \mrm{InfixStatus} \end{array}
\end{displaymath}
\caption{Fixity Environment}\label{fig:mlb:S:FixityEnv}
\end{figure}

\subsubsection{Grammar for MLBs}
The phrase classes for MLBs are shown in
Figure~\ref{fig:mlb:S:PhraseClasses}.
\begin{figure}[h]
\begin{displaymath}
\begin{array}{ll}
\mrm{BasExp} & \mbox{basis expressions} \\
\mrm{BasDec} & \mbox{basis-level declaration} \\
\mrm{BasBind} & \mbox{basis bindings} \\
\mrm{BStrBind} & \mbox{(basis) structure bindings} \\
\mrm{BSigBind} & \mbox{(basis) signature bindings} \\
\mrm{BFunBind} & \mbox{(basis) functor bindings}
\end{array}
\end{displaymath}
\caption{MLBs Phrase Classes}\label{fig:mlb:S:PhraseClasses}
\end{figure}
We use the variable $\mit{basexp}$ to range over $\mrm{BasExp}$, etc.
The conventions adopted in presenting the grammatical rulse for MLBs
are the same as for the Core and Modules.  The grammatical rules are
showin in Figure~\ref{fig:mlb:S:GrammaticalRules}.
\begin{figure}[h]
\begin{displaymath}
\begin{array}{rcll}
\mit{basexp} & ::= & 
\mtt{bas}~ \mit{basdec} ~\mtt{end} 
& \mbox{basic} \\&& 
\mit{basid} 
& \mbox{basis identifier} \\&&
\mtt{let}~ \mit{basdec} ~\mtt{in}~ \mit{basexp} ~\mtt{end} 
& \mbox{local declaration} \\

\mit{basdec} & ::= & 
\mtt{basis}~ \mit{basbind}
& \mbox{basis} \\&&
\mtt{local}~ \mit{basdec}_1 ~\mtt{in}~ \mit{basdec}_2 ~\mtt{end} 
& \mbox{local} \\&&
\mtt{open}~ \mit{basid}_1 \cdots \mit{basid}_n 
& \mbox{open ($n \geq 1$)} \\&&
\mtt{structure}~ \mit{bstrbind}
& \mbox{(basis) structure binding} \\&&
\mtt{signature}~ \mit{bsigbind}
& \mbox{(basis) signature binding} \\&&
\mtt{functor}~ \mit{bfunbind}
& \mbox{(basis) functor binding} \\&&
\quad
& \mbox{empty} \\&&
\mit{basdec}_1~\langle\mtt{;}\rangle~\mit{basdec}_2 
& \mbox{sequential} \\&&
\msf{path.mlb} &
\mbox{import ML basis} \\&&
\msf{path.sml} 
& \mbox{import source} \\

\mit{basbind} & ::= &  
\mit{basid} ~\mtt{=}~ \mit{basexp} ~\langle\mtt{and}~ \mit{basbind}\rangle \\
\mit{bstrbind} & ::= &  
\mit{strid}_1 ~\mtt{=}~ \mit{strid}_2 ~\langle\mtt{and}~ \mit{bstrbind}\rangle \\
\mit{bsigbind} & ::= &  
\mit{sigid}_1 ~\mtt{=}~ \mit{sigid}_2 ~\langle\mtt{and}~ \mit{bsigbind}\rangle \\
\mit{bfunbind} & ::= &  
\mit{funid}_1 ~\mtt{=}~ \mit{funid}_2 ~\langle\mtt{and}~ \mit{bfunbind}\rangle
\end{array}
\end{displaymath}
\caption{Grammar: Basis Expressions}\label{fig:mlb:S:GrammaticalRules}
\end{figure}

\subsubsection{Syntactic Restrictions}
\begin{itemize}
\item No binding $\mit{basbind}$ may bind the same identifier twice.
\item No binding $\mit{bstrbind}$, $\mit{bsigbind}$ or $\mit{bfunbind}$ may bind the same identifier twice.
\item MLBs may not be cyclic; i.e., successively replacing
  $\msf{path.mlb}$ with it's parsed $\mrm{BasDec}$ must terminate.
\end{itemize}

\subsubsection{Parsing}
The static and dynamic semantics for MLBs will interpret
$\msf{path.sml}$ as a parsed $\mrm{TopDec}$ and
$\msf{path.mlb}$ as a parsed $\mrm{BasDec}$.  Parsing a $\mrm{TopDec}$
must be performed against a fixity environment, and may result in a
modified fixity environment.  

Paths and parsers are given in Figure~\ref{fig:mlb:S:PathsParser}.  A
(fixed) $\mrm{Parser}$ $\mcal{P}$ provides the interpretation of
$\msf{path.sml}$ and $\msf{path.mlb}$ imports.
\begin{figure}[h]
\begin{displaymath}
\begin{array}{c}
\begin{array}{rcl}
\msf{path.sml} & \in & \mrm{SourcePath} \\
\msf{path.mlb} & \in & \mrm{MLBasisPath} 
\end{array} \\
\begin{array}{rcl}
\mcal{P} & \in & \mrm{Parser} = 
((\mrm{FixEnv} \times \mrm{SourcePath})
 \xrightarrow{\mrm{fin}} (\mrm{FixEnv} \times \mrm{TopDec})) 
\times 
(\mrm{MLBasisPath} \xrightarrow{\mrm{fin}} \mrm{BasDec}) 
\end{array}
\end{array}
\end{displaymath}
\caption{Parser}\label{fig:mlb:S:PathsParser}
\end{figure}

For a file extension $\msf{.ext}$, $\msf{path.ext}$ denotes either an
absolute path or a relative path (relative to the $\mrm{BasDec}$ being
parsed) to a file in the underlying file system.  An implementation
may allow additional extensions (e.g., $\mtt{.ML}$, $\mtt{.fun}$,
$\mtt{.sig}$) in elements of $\mrm{SourcePath}$.  An implementation
may additionally allow system environment variables to appear in
paths.  $\mrm{Parser}$ could be refined by a \emph{current working
directory}, to formally specify the interpretation of relative paths,
and an \emph{system environment}, to formally specify the
interpretation of system environment variables, but the above suffices
for the development in the following sections.

\subsection{Static Semantics for MLBs}

\subsubsection{Semantic Objects}

The simple objects for the MLBs static semantics are exactly as for
Modules.  The compound objects are those for Modules, augmented by
those in Figure~\ref{fig:mlb:SS:CompoundObjects}.
\begin{figure}[h]
\begin{displaymath}
\begin{array}{rcl}
\mit{BE} & \in & \mrm{BasEnv} = \mrm{BasId} \xrightarrow{\mrm{fin}} \mrm{MBasis} \\
\mit{M} ~\mrm{or}~ \mit{FE},\mit{BE},\mit{B} & \in & 
\mrm{MBasis} = \mrm{FixEnv} \times \mrm{BasEnv} \times \mrm{Basis} \\
\Psi & \in & \mrm{BasCache} = \mrm{MLBasisPath} \xrightarrow{\mrm{fin}} \mrm{MBasis} 
\end{array}
\end{displaymath}
\caption{Compound Semantic Objects}\label{fig:mlb:SS:CompoundObjects}
\end{figure}
The operations of projection, injection and modification are as for
Modules.

\subsubsection{Inference Rules}

As for the Core and for Modules, the rules for MLBs static semantics
allow sentences of the form
\begin{displaymath}
A \vdash \mit{phrase} \longrightarrow A'
\end{displaymath}
to be inferred.  Some hypotheses in rules are not of this form; they
are called \emph{side-conditions}.  The convention for options is as
in the Core and Modules semantics.

\vspace{2\parsep}

{\large\noindent
\textbf{Basis Expressions} \hfill 
\fbox{$\mit{M}, \Psi \vdash \mit{basexp} \longrightarrow \mit{M}', \Psi'$}
}

\begin{equation}
\judge{
\mit{M}, \Psi \vdash \mit{basdec} \longrightarrow \mit{M}', \Psi'
}{
\mit{M}, \Psi \vdash \mtt{bas}~ \mit{basdec} ~\mtt{end} \longrightarrow \mit{M}', \Psi'
}
\end{equation}

\begin{equation}
\judge{
\mit{M}(\mit{basid}) = \mit{M}'
}{
\mit{M}, \Psi \vdash \mit{basid} \longrightarrow \mit{M}', \Psi
}
\end{equation}

\begin{equation}
\label{eqn:mlb:SS:localDeclaration}
\judge{
\mit{M}, \Psi \vdash \mit{basdec} \longrightarrow \mit{M}_1, \Psi_1 \quad
\mit{M} \oplus \mit{M}_1, \Psi_1 \vdash \mit{basexp} \longrightarrow \mit{M}_2, \Psi_2
}{
\mit{M}, \Psi \vdash \mtt{let}~ \mit{basdec} ~\mtt{in}~ \mit{basexp} ~\mtt{end} \longrightarrow \mit{M}_2, \Psi_2
}
\end{equation}

\noindent
\textit{Comments}:
\begin{itemize}
\item[(\ref{eqn:mlb:SS:localDeclaration})] The use of $\oplus$, here
  and elsewhere, ensures that the type names generated by the first
  sub-phrase are distinct from the names generated by the second sub-phrase.
\end{itemize}


{\large\noindent
\textbf{Basis-level Declarations} \hfill 
\fbox{$\mit{M}, \Psi \vdash \mit{basdec} \longrightarrow \mit{M}', \Psi'$}
}

\begin{equation}
\judge{
\mit{M}, \Psi  \vdash \mit{basbind} \longrightarrow \mit{BE}', \Psi'
}{
\mit{M}, \Psi  \vdash \msf{basis}~ \mit{basbind} \longrightarrow \mit{BE}' ~\mrm{in}~ \mrm{MBasis}, \Psi'
}
\end{equation}

\begin{equation}
\judge{
\mit{M}, \Psi  \vdash \mit{basdec}_1 \longrightarrow \mit{M}_1, \Psi_2 \quad
\mit{M} \oplus \mit{M}_1, \Psi_1  \vdash \mit{basdec}_2 \longrightarrow \mit{M}_2, \Psi_2 \quad
}{
\mit{M}, \Psi  \vdash \mtt{local}~ \mit{basdec}_1 ~\mtt{in}~ \mit{basdec}_2 ~\mtt{end} \longrightarrow \mit{M}_2, \Psi_2
}
\end{equation}

\begin{equation}
\judge{
\mit{M}(\mit{basid}_1) = \mit{M}_1 \quad \cdots \quad
\mit{M}(\mit{basid}_n) = \mit{M}_n 
}{
\mit{M}, \Psi  \vdash \mtt{open}~ \mit{basid}_1 \cdots \mit{basid}_n \longrightarrow \mit{M}_1 \oplus \cdots \oplus \mit{M}_n, \Psi
}
\end{equation}

\begin{equation}
\judge{
\mit{B}~\mrm{of}~\mit{M} \vdash \mit{bstrbind} \longrightarrow SE
}{
\mit{M}, \Psi  \vdash \mtt{structure}~ \mit{bstrbind}
\longrightarrow \mit{SE} ~\mrm{in}~ \mrm{MBasis}, \Psi
}
\end{equation}

\begin{equation}
\judge{
\mit{B}~\mrm{of}~\mit{M} \vdash \mit{bsigbind} \longrightarrow G
}{
\mit{M}, \Psi  \vdash \mtt{signature}~ \mit{bsigbind}
\longrightarrow \mit{G } ~\mrm{in}~ \mrm{MBasis}, \Psi
}
\end{equation}

\begin{equation}
\judge{
\mit{B}~\mrm{of}~\mit{M} \vdash \mit{bfunbind} \longrightarrow F
}{
\mit{M}, \Psi  \vdash \mtt{functor}~ \mit{bfunbind}
\longrightarrow \mit{F} ~\mrm{in}~ \mrm{MBasis}, \Psi
}
\end{equation}

\begin{equation}
\judge{
}{
\mit{M}, \Psi  \vdash \quad \longrightarrow \{\} ~\mrm{in}~ \mrm{MBasis}, \Psi
}
\end{equation}

\begin{equation}
\judge{
\mit{M}, \Psi  \vdash \mit{basdec}_1 \longrightarrow \mit{M}_1, \Psi_2 \quad
\mit{M} \oplus \mit{M}_1, \Psi_1  \vdash \mit{basdec}_2 \longrightarrow \mit{M}_2, \Psi_2 
}{
\mit{M}, \Psi  \vdash \mit{basdec}_1 ~\langle\mtt{;}\rangle~ \mit{basdec}_2 \longrightarrow \mit{M}_1 \oplus \mit{M}_2, \Psi_2
}
\end{equation}

\begin{equation}
\judge{
\mcal{P}(\mit{FE}~\mrm{of}~\mit{M}, \msf{path.sml}) = (\mit{FE}', \mit{topdec}) \quad
\mit{B}~\mrm{of}~\mit{M} \vdash \mit{topdec} \Rightarrow \mit{B}'
}{
\mit{M}, \Psi  \vdash \msf{path.sml}  \longrightarrow (\mit{FE}',\{\},\mit{B}'), \Psi
}
\end{equation}

\begin{equation}
\judge{
\Psi(\msf{path.mlb}) = \mit{M}'
}{
\mit{M}, \Psi  \vdash \msf{path.mlb}  \longrightarrow \mit{M}', \Psi
}
\end{equation}

\begin{equation}
\judge{
\msf{path.mlb} \notin \mrm{Dom}~\Psi \quad
\mcal{P}(\msf{path.mlb}) = \mit{basdec} \quad
\{\} ~\mrm{in}~ \mrm{MBasis}, \Psi  \vdash \mit{basdec} \longrightarrow \mit{M}', \Psi'
}{
\mit{M}, \Psi  \vdash \msf{path.mlb}  \longrightarrow \mit{M}', \Psi' + \{\msf{path.mlb} \mapsto \mit{M}'\} 
}
\end{equation}

{\large\noindent
\textbf{Basis Bindings} \hfill 
\fbox{$\mit{M}, \Psi \vdash \mit{basbind} \longrightarrow \mit{BE}', \Psi'$}
}

\begin{equation}
\judge{
\mit{M}, \Psi \vdash \mit{basexp} \longrightarrow \mit{M}', \Psi' \quad
\langle\mit{M} + \mrm{tynames}~\mit{M}', \Psi' \vdash \mit{basbind} \longrightarrow \mit{BE}'', \Psi''\rangle
}{
\mit{M}, \Psi  \vdash \mit{basid} ~\mtt{=}~ \mit{basexp} ~\langle\mtt{and}~\mit{basbind}\rangle \longrightarrow 
\{\mit{basid} \mapsto \mit{M}'\} \langle+ \mit{BE}''\rangle, \Psi'\langle'\rangle
}
\end{equation}

{\large\noindent
\textbf{(Basis) Structure Bindings} \hfill 
\fbox{$\mit{B} \vdash \mit{bstrbind} \longrightarrow \mit{SE}$}
}

\begin{equation}
\label{eqn:mlb:SS:bstrbind}
\judge{
\mit{B}(\mit{strid}_2) = E \quad
\langle\mit{B} + \mrm{tynames}~\mit{E} \vdash \mit{bstrbind} \longrightarrow \mit{SE}\rangle
}{
\mit{B} \vdash \mit{strid}_1 ~\mtt{=}~ \mit{strid}_2 ~\langle\mtt{and}~\mit{bstrbind}\rangle \longrightarrow 
\{\mit{strid}_1 \mapsto \mit{E}\} \langle+ \mit{SE}\rangle
}
\end{equation}

\noindent
\textit{Comments}:
\begin{itemize}
\item[(\ref{eqn:mlb:SS:bstrbind})] Note that $\mit{fstrbind} \subset
\mit{strbind}$.  Hence, this rule can be derived from the
Definition's $B \vdash \mit{strbind} \Rightarrow SE$.
\end{itemize}

{\large\noindent
\textbf{(Basis) Signature Bindings} \hfill 
\fbox{$\mit{B} \vdash \mit{bsigbind} \longrightarrow \mit{G}$}
}

\begin{equation}
\label{eqn:mlb:SS:bsigbind}
\judge{
\begin{stackCC}
\mit{B}(\mit{strid}_2) = \Sigma \quad \Sigma = (\mit{T})\mit{E} \quad
\mit{T} \cap (\mit{T}~\mrm{of}~\mit{B}) = \emptyset \\
\mit{T} = \mrm{tynames}~\mit{E} \setminus (\mit{T}~\mrm{of}~\mit{B}) \quad
\langle\mit{B} \vdash \mit{bsigbind} \longrightarrow \mit{G}\rangle
\end{stackCC}
}{
\mit{B} \vdash \mit{sigid}_1 ~\mtt{=}~ \mit{sigid}_2 ~\langle\mtt{and}~\mit{bsigbind}\rangle \longrightarrow 
\{\mit{sigid}_1 \mapsto \Sigma\} \langle+ \mit{G}\rangle
}
\end{equation}

\noindent
\textit{Comments}:
\begin{itemize}
\item[(\ref{eqn:mlb:SS:bsigbind})] Note that $\mit{fsigbind} \subset
\mit{sigbind}$.  Hence, this rule can be derived from the
Definition's $B \vdash \mit{sigbind} \Rightarrow G$.  As such, the
following comment from the Definition applies:
\begin{quote}
The bound names of $\mit{B}(\mit{sigid}_2)$ can always be renamed to
satisfy $\mit{T} \cap (\mit{T}~\mrm{of}~\mit{B}) = \emptyset$, if necessary.
\end{quote}
\end{itemize}

{\large\noindent
\textbf{(Basis) Functor Bindings} \hfill 
\fbox{$\mit{B} \vdash \mit{bfunbind} \longrightarrow \mit{F}$}
}

\begin{equation}
\judge{
\begin{stackCC}
\mit{B}(\mit{funid}_2) = \Phi \quad \Phi = (\mit{T})(\mit{E},(\mit{T}')\mit{E}') \quad
\mit{T} \cap (\mit{T}~\mrm{of}~\mit{B}) = \emptyset \\
\mit{T}' = \mrm{tynames}~\mit{E}' \setminus ((\mit{T}~\mrm{of}~\mit{B}) \cup \mit{T}) \quad
\langle\mit{B} \vdash \mit{bfunbind} \longrightarrow \mit{F}\rangle
\end{stackCC}
}{
\mit{B} \vdash \mit{funid}_1 ~\mtt{=}~ \mit{funid}_2 ~\langle\mtt{and}~\mit{bfunbind}\rangle \longrightarrow 
\{\mit{funid}_1 \mapsto \Phi\} \langle+ \mit{F}\rangle
}
\end{equation}

\subsection{Dynamic Semantics for MLBs}

\subsubsection{Reduced Syntax}
The syntax of MLBs is unchanged for the purposes of the dynamic
semantics for MLBs.  However, the $\mrm{Parser}$ $\mcal{P}$ returns a
$\mit{topdec}$ in the reduced syntax of Modules.

\subsubsection{Compound Objects}
The compound objects for the MLBs dynamic semantics, extra to those
for the Modules dynamic semantics, are shown in Figure~\ref{fig:mlb:DS:CompoundObjects}.
\begin{figure}[h]
\begin{displaymath}
\begin{array}{rcl}
\mit{BE} & \in & \mrm{BasEnv} = \mrm{BasId} \xrightarrow{\mrm{fin}} \mrm{MBasis} \\
\mit{M} ~\mrm{or}~ \mit{FE},\mit{BE},\mit{B} & \in & \mrm{MBasis} =
\mrm{FixEnv} \times \mrm{BasEnv} \times \mrm{Basis} \\
\Psi & \in & \mrm{BasCache} = \mrm{MLBasisPath} \xrightarrow{\mrm{fin}} \mrm{MBasis} 
\end{array}
\end{displaymath}
\caption{Compound Semantic Objects}\label{fig:mlb:DS:CompoundObjects}
\end{figure}

\subsubsection{Inference Rules}

The semantic rules allow sentences of the form
\begin{displaymath}
s, A \vdash \mit{phrase} \longrightarrow A', s'
\end{displaymath}
to be inferred, where $s$, $s'$ are the states before and after the
evaluation represented by the sentence.  Some hypotheses in rules are
not of this form; they are called \emph{side-conditions}. The
convention for options is as in the Core and Modules semantics.

The state and exception conventions are adopted as in the Core and
Modules dynamic semantics.  However, it may be shown that the only
MLBs phrases whose evaluation may cause a side-effect or generate an
exception packet are of the form $\mit{basexp}$, $\mit{basdec}$ or
$\mit{basbind}$.

\vspace{2\parsep}

{\large\noindent
\textbf{Basis Expressions} \hfill 
\fbox{$\mit{M}, \Psi \vdash \mit{basexp} \longrightarrow \mit{M}', \Psi' / p$}
}

\begin{equation}
\judge{
\mit{M}, \Psi \vdash \mit{basdec} \longrightarrow \mit{M}', \Psi'
}{
\mit{M}, \Psi \vdash \mtt{bas}~ \mit{basdec} ~\mtt{end} \longrightarrow \mit{M}', \Psi'
}
\end{equation}

\begin{equation}
\judge{
\mit{M}(\mit{basid}) = \mit{M}'
}{
\mit{M}, \Psi \vdash \mit{basid} \longrightarrow \mit{M}', \Psi
}
\end{equation}

\begin{equation}
\judge{
\mit{M}, \Psi \vdash \mit{basdec} \longrightarrow \mit{M}_1, \Psi_1 \quad
\mit{M} \oplus \mit{M}_1, \Psi_1 \vdash \mit{basexp} \longrightarrow \mit{M}_2, \Psi_2
}{
\mit{M}, \Psi \vdash \mtt{let}~ \mit{basdec} ~\mtt{in}~ \mit{basexp} ~\mtt{end} \longrightarrow \mit{M}_2, \Psi_2
}
\end{equation}

{\large\noindent
\textbf{Basis-level Declarations} \hfill 
\fbox{$\mit{M}, \Psi \vdash \mit{basdec} \longrightarrow \mit{M}', \Psi' / p$}
}

\begin{equation}
\judge{
\mit{M}, \Psi  \vdash \mit{basbind} \longrightarrow \mit{BE}', \Psi'
}{
\mit{M}, \Psi  \vdash \msf{basis}~ \mit{basbind} \longrightarrow \mit{BE}' ~\mrm{in}~ \mrm{MBasis}, \Psi'
}
\end{equation}

\begin{equation}
\judge{
\mit{M}, \Psi  \vdash \mit{basdec}_1 \longrightarrow \mit{M}_1, \Psi_2 \quad
\mit{M} + \mit{M}_1, \Psi_1  \vdash \mit{basdec}_2 \longrightarrow \mit{M}_2, \Psi_2 \quad
}{
\mit{M}, \Psi  \vdash \mtt{local}~ \mit{basdec}_1 ~\mtt{in}~ \mit{basdec}_2 ~\mtt{end} \longrightarrow \mit{M}_2, \Psi_2
}
\end{equation}

\begin{equation}
\judge{
\mit{M}(\mit{basid}_1) = \mit{M}_1 \quad \cdots \quad
\mit{M}(\mit{basid}_n) = \mit{M}_n 
}{
\mit{M}, \Psi  \vdash \mtt{open}~ \mit{basid}_1 \cdots \mit{basid}_n \longrightarrow \mit{M}_1 + \cdots + \mit{M}_n, \Psi
}
\end{equation}

\begin{equation}
\judge{
\mit{B}~\mrm{of}~\mit{M} \vdash \mit{bstrbind} \longrightarrow SE
}{
\mit{M}, \Psi  \vdash \mtt{structure}~ \mit{bstrbind}
\longrightarrow \mit{SE} ~\mrm{in}~ \mrm{MBasis}, \Psi
}
\end{equation}

\begin{equation}
\judge{
\mrm{Inter}~(\mit{B}~\mrm{of}~\mit{M}) \vdash \mit{bsigbind} \longrightarrow G
}{
\mit{M}, \Psi  \vdash \mtt{signature}~ \mit{bsigbind}
\longrightarrow \mit{G } ~\mrm{in}~ \mrm{MBasis}, \Psi
}
\end{equation}

\begin{equation}
\judge{
\mit{B}~\mrm{of}~\mit{M} \vdash \mit{bfunbind} \longrightarrow F
}{
\mit{M}, \Psi  \vdash \mtt{functor}~ \mit{bfunbind}
\longrightarrow \mit{F} ~\mrm{in}~ \mrm{MBasis}, \Psi
}
\end{equation}

\begin{equation}
\judge{
}{
\mit{M}, \Psi  \vdash \quad \longrightarrow \{\} ~\mrm{in}~ \mrm{MBasis}, \Psi
}
\end{equation}

\begin{equation}
\judge{
\mit{M}, \Psi  \vdash \mit{basdec}_1 \longrightarrow \mit{M}_1, \Psi_2 \quad
\mit{M} + \mit{M}_1, \Psi_1  \vdash \mit{basdec}_2 \longrightarrow \mit{M}_2, \Psi_2 
}{
\mit{M}, \Psi  \vdash \mit{basdec}_1 ~\langle\mtt{;}\rangle~ \mit{basdec}_2 \longrightarrow \mit{M}_1 \oplus \mit{M}_2, \Psi_2
}
\end{equation}

\begin{equation}
\judge{
\mcal{P}(\mit{FE}~\mrm{of}~\mit{M}, \msf{path.sml}) = (\mit{FE}', \mit{topdec}) \quad
\mit{B}~\mrm{of}~\mit{M} \vdash \mit{topdec} \Rightarrow \mit{B}'
}{
\mit{M}, \Psi  \vdash \msf{path.sml}  \longrightarrow (\mit{FE}',\{\},\mit{B}'), \Psi
}
\end{equation}

\begin{equation}
\judge{
\Psi(\msf{path.mlb}) = \mit{M}'
}{
\mit{M}, \Psi  \vdash \msf{path.mlb}  \longrightarrow \mit{M}', \Psi
}
\end{equation}

\begin{equation}
\judge{
\msf{path.mlb} \notin \mrm{Dom}~\Psi \quad
\mcal{P}(\msf{path.mlb}) = \mit{basdec} \quad
\{\} ~\mrm{in}~ \mrm{MBasis}, \Psi  \vdash \mit{basdec} \longrightarrow \mit{M}', \Psi'
}{
\mit{M}, \Psi  \vdash \msf{path.mlb}  \longrightarrow \mit{M}', \Psi' + \{\msf{path.mlb} \mapsto \mit{M}'\} 
}
\end{equation}

{\large\noindent
\textbf{Basis Bindings} \hfill 
\fbox{$\mit{M}, \Psi \vdash \mit{basbind} \longrightarrow \mit{BE}', \Psi' / p$}
}

\begin{equation}
\judge{
\mit{M}, \Psi \vdash \mit{basexp} \longrightarrow \mit{M}', \Psi' \quad
\langle\mit{M}, \Psi' \vdash \mit{basbind} \longrightarrow \mit{BE}'', \Psi''\rangle
}{
\mit{M}, \Psi  \vdash \mit{basid} ~\mtt{=}~ \mit{basexp} ~\langle\mtt{and}~\mit{basbind}\rangle \longrightarrow 
\{\mit{basid} \mapsto \mit{M}'\} \langle+ \mit{BE}''\rangle, \Psi'\langle'\rangle
}
\end{equation}

{\large\noindent
\textbf{(Basis) Structure Bindings} \hfill 
\fbox{$\mit{B} \vdash \mit{bstrbind} \longrightarrow \mit{SE}$}
}

\begin{equation}
\label{eqn:mlb:DS:bstrbind}
\judge{
\mit{B}(\mit{strid}_2) = E \quad
\langle\mit{B} \vdash \mit{bstrbind} \longrightarrow \mit{SE}\rangle
}{
\mit{B} \vdash \mit{strid}_1 ~\mtt{=}~ \mit{strid}_2 ~\langle\mtt{and}~\mit{bstrbind}\rangle \longrightarrow 
\{\mit{strid}_1 \mapsto \mit{E}\} \langle+ \mit{SE}\rangle
}
\end{equation}

\noindent
\textit{Comments}:
\begin{itemize}
\item[(\ref{eqn:mlb:DS:bstrbind})] Note that $\mit{fstrbind} \subset
\mit{strbind}$.  Hence, this rule can be derived from the
Definition's $B \vdash \mit{strbind} \Rightarrow SE / p$, noting that
the derivation may neither cause a side-effect nor generate an
exception packet.
\end{itemize}

{\large\noindent
\textbf{(Basis) Signature Bindings} \hfill 
\fbox{$\mit{IB} \vdash \mit{bsigbind} \longrightarrow \mit{G}$}
}

\begin{equation}
\label{eqn:mlb:DS:bsigbind}
\judge{
\mit{IB}(\mit{strid}_2) = I \quad 
\langle\mit{IB} \vdash \mit{bsigbind} \longrightarrow \mit{G}\rangle
}{
\mit{IB} \vdash \mit{sigid}_1 ~\mtt{=}~ \mit{sigid}_2 ~\langle\mtt{and}~\mit{bsigbind}\rangle \longrightarrow 
\{\mit{sigid}_1 \mapsto I\} \langle+ \mit{G}\rangle
}
\end{equation}

\noindent
\textit{Comments}:
\begin{itemize}
\item[(\ref{eqn:mlb:DS:bsigbind})] Note that $\mit{fsigbind} \subset
\mit{sigbind}$.  Hence, this rule can be derived from the
Definition's $IB \vdash \mit{sigbind} \Rightarrow G$, noting that
the derivation may neither cause a side-effect nor generate an
exception packet.
\end{itemize}

{\large\noindent
\textbf{(Basis) Functor Bindings} \hfill 
\fbox{$\mit{B} \vdash \mit{bfunbind} \longrightarrow \mit{F}$}
}

\begin{equation}
\judge{
\mit{B}(\mit{funid}_2) = (\mit{strid}:\mit{I},\mit{strexp},\mit{B}) \quad
\langle\mit{B} \vdash \mit{bfunbind} \longrightarrow \mit{F}\rangle
}{
\mit{B} \vdash \mit{funid}_1 ~\mtt{=}~ \mit{funid}_2 ~\langle\mtt{and}~\mit{bfunbind}\rangle \longrightarrow 
\{\mit{funid}_1 \mapsto (\mit{strid}:\mit{I},\mit{strexp},\mit{B})\} \langle+ \mit{F}\rangle
}
\end{equation}


\subsection{Derived Forms}
\label{sec:mlb:DerivedForms}

Figure~\ref{fig:mlb:DF:bindings} shows derived forms for structure,
signature, and functor bindings in MLBs.  These derived forms are
a useful shorthand for specifying import and export filters.

\begin{figure}[h]
\begin{center}
\begin{tabular}{|l|l|}
\multicolumn{1}{c}{Derived Form} &
\multicolumn{1}{c}{Equivalent Form} \\
\multicolumn{2}{c}{} \\
\multicolumn{2}{l}{\textbf{(Basis) Structure Bindings} $\mit{bstrbind}$} \\
\hline
$\mit{strid} ~\langle\mtt{and}~ \mit{bstrbind}\rangle$ &
$\mit{strid} ~\mtt{=}~ \mit{strid} ~\langle\mtt{and}~ \mit{bstrbind}\rangle$ \\
\hline
\multicolumn{2}{c}{} \\
\multicolumn{2}{l}{\textbf{(Basis) Signature Bindings} $\mit{bsigbind}$} \\
\hline
$\mit{sigid} ~\langle\mtt{and}~ \mit{bsigbind}\rangle$ &
$\mit{sigid} ~\mtt{=}~ \mit{sigid} ~\langle\mtt{and}~ \mit{bsigbind}\rangle$ \\
\hline
\multicolumn{2}{c}{} \\
\multicolumn{2}{l}{\textbf{(Basis) Functor Bindings} $\mit{bfunbind}$} \\
\hline
$\mit{funid} ~\langle\mtt{and}~ \mit{bfunbind}\rangle$ &
$\mit{funid} ~\mtt{=}~ \mit{funid} ~\langle\mtt{and}~ \mit{bfunbind}\rangle$ \\
\hline
\end{tabular}
\end{center}
\caption{Derived forms of (Basis) Structure, Signature, and Functor Bindings}\label{fig:mlb:DF:bindings}
\end{figure}

%% \end{document}



1.5       +2 -1      mlton/lib/mlton/basic/instream.sig

Index: instream.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/instream.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- instream.sig	24 Sep 2003 17:45:26 -0000	1.4
+++ instream.sig	28 Jul 2004 21:05:09 -0000	1.5
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  *
  * MLton is released under the GNU General Public License (GPL).
@@ -33,6 +33,7 @@
       (* Each line includes the newline. *)
       val lines: t -> string list
       val openIn: string -> t	 
+      val openString: string -> t
       val outputAll: t * Out.t -> unit
       val peekChar: t -> char option
       val sameContents: t * t -> bool



1.4       +1 -0      mlton/lib/mlton-stubs-in-smlnj/os.sml

Index: os.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs-in-smlnj/os.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- os.sml	24 Nov 2002 01:19:42 -0000	1.3
+++ os.sml	28 Jul 2004 21:05:09 -0000	1.4
@@ -7,5 +7,6 @@
 	    open FileSys
 	       
 	    val fileSize = Pervasive.Int32.fromInt o fileSize
+	    val hash = Pervasive.Word32.fromLargeWord o Pervasive.Word.toLargeWord o hash
 	 end
    end



1.91      +6 -3      mlton/mlton/Makefile

Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/Makefile,v
retrieving revision 1.90
retrieving revision 1.91
diff -u -r1.90 -r1.91
--- Makefile	31 May 2004 21:37:56 -0000	1.90
+++ Makefile	28 Jul 2004 21:05:09 -0000	1.91
@@ -44,12 +44,15 @@
 	front-end/ml.lex.sml 	\
 	front-end/ml.grm.sig 	\
 	front-end/ml.grm.sml	\
+	front-end/mlb.lex.sml 	\
+	front-end/mlb.grm.sig 	\
+	front-end/mlb.grm.sml	\
 	$(shell if [ -r mlton.cm ]; then mlton -stop f mlton.cm; fi)
 
 .PHONY: all
 all: $(AOUT)
 
-front-end/ml.lex.sml front-end/ml.grm.sig front-end/ml.grm.sml:
+front-end/ml.lex.sml front-end/ml.grm.sig front-end/ml.grm.sml front-end/mlb.lex.sml front-end/mlb.grm.sig front-end/mlb.grm.sml:
 	$(MAKE) -C front-end
 
 $(AOUT): $(SOURCES)
@@ -96,7 +99,7 @@
 		echo '#set CM.Control.warn_obsolete false;';			\
 		echo 'Control.polyEqWarn := false;';				\
 		echo 'CM.make "sources.cm";';					\
-		echo 'Main.exportNJ ("$(SRC)/basis-library", "$(LIB)/mlton");'	\
+		echo 'Main.exportNJ ("$(LIB)/mlton");'	\
 	) | $(SML)
 
 .PHONY: nj-mlton-dual
@@ -110,7 +113,7 @@
 		echo 'val _ = CM.Server.start {cmd = (CommandLine.name (), ["@CMslave"]), name = "server1", pathtrans = NONE, pref = 0};';\
 		echo 'val _ = CM.Server.start {cmd = (CommandLine.name (), ["@CMslave"]), name = "server2", pathtrans = NONE, pref = 0};';\
 		echo 'CM.make "sources.cm";';					\
-		echo 'Main.exportNJ ("$(SRC)/basis-library", "$(LIB)/mlton");'	\
+		echo 'Main.exportNJ ("$(LIB)/mlton");'	\
 	) | $(SML)
 
 .PHONY: nj-whole



1.16      +31 -0     mlton/mlton/ast/ast-atoms.fun

Index: ast-atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-atoms.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- ast-atoms.fun	28 Apr 2004 03:17:04 -0000	1.15
+++ ast-atoms.fun	28 Jul 2004 21:05:10 -0000	1.16
@@ -70,6 +70,7 @@
       val ensureSpecify = ensure "specify"
    end
 
+structure Basid = AstId (structure Symbol = Symbol)
 structure Sigid = AstId (structure Symbol = Symbol)
 structure Strid = AstId (structure Symbol = Symbol)
 structure Fctid = AstId (structure Symbol = Symbol)
@@ -339,6 +340,36 @@
 	  | Repl {lhs, rhs} =>
 	       seq [str "datatype ", Tycon.layout lhs,
 		   str " = datatype ", Longtycon.layout rhs]
+   end
+
+(*---------------------------------------------------*)
+(*                      ModIdBind                    *)
+(*---------------------------------------------------*)
+
+structure ModIdBind =
+   struct
+      datatype node =
+	 Fct of {lhs: Fctid.t, rhs: Fctid.t} vector
+       | Sig of {lhs: Sigid.t, rhs: Sigid.t} vector
+       | Str of {lhs: Strid.t, rhs: Strid.t} vector
+
+      open Wrap
+      type t = node Wrap.t
+      type node' = node
+      type obj = t
+
+      fun layout d =
+	 let
+	    fun doit (prefix, l, bds) =
+	       layoutAndsBind
+	       (prefix, "=", Vector.toList bds, fn {lhs, rhs} =>
+		(OneLine, l lhs, l rhs))
+	 in
+	    case node d of
+	       Fct bds => doit ("functor", Fctid.layout, bds)
+	     | Sig bds => doit ("signature", Sigid.layout, bds)
+	     | Str bds => doit ("structure", Strid.layout, bds)
+	 end
    end
 
 end



1.10      +13 -1     mlton/mlton/ast/ast-atoms.sig

Index: ast-atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-atoms.sig,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- ast-atoms.sig	28 Apr 2004 03:17:04 -0000	1.9
+++ ast-atoms.sig	28 Jul 2004 21:05:10 -0000	1.10
@@ -42,6 +42,7 @@
             val ensureSpecify: t -> unit
 	 end
 
+      structure Basid: AST_ID
       structure Sigid: AST_ID
       structure Strid: AST_ID
       structure Fctid: AST_ID
@@ -89,7 +90,7 @@
       sharing Strid = Longtycon.Strid = Longvar.Strid = Longcon.Strid
 	 = Longvid.Strid = Longstrid.Strid
 
-      sharing Symbol = Con.Symbol = Fctid.Symbol = Longcon.Symbol
+      sharing Symbol = Basid.Symbol = Con.Symbol = Fctid.Symbol = Longcon.Symbol
 	 = Longstrid.Symbol = Longtycon.Symbol = Longvar.Symbol = Longvid.Symbol
 	 = Sigid.Symbol = Strid.Symbol = Tycon.Symbol = Vid.Symbol = Var.Symbol
 
@@ -145,6 +146,17 @@
 	    datatype node =
 	       DatBind of DatBind.t
 	     | Repl of {lhs: Tycon.t, rhs: Longtycon.t}
+	    include WRAPPED sharing type node' = node
+			    sharing type obj = t
+	    val layout: t -> Layout.t
+	 end
+      structure ModIdBind:
+	 sig
+	    type t
+	    datatype node = 
+	       Fct of {lhs: Fctid.t, rhs: Fctid.t} vector
+	     | Sig of {lhs: Sigid.t, rhs: Sigid.t} vector
+	     | Str of {lhs: Strid.t, rhs: Strid.t} vector
 	    include WRAPPED sharing type node' = node
 			    sharing type obj = t
 	    val layout: t -> Layout.t



1.17      +3 -501    mlton/mlton/ast/ast.fun

Index: ast.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast.fun,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- ast.fun	19 Feb 2004 22:42:08 -0000	1.16
+++ ast.fun	28 Jul 2004 21:05:10 -0000	1.17
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-1999 NEC Research Institute.
  *
@@ -10,505 +10,7 @@
 
 open S
 
-structure AstCore = AstCore (AstAtoms (S))
-
-open AstCore Layout
-   
-val layouts = List.map
-structure Wrap = Region.Wrap
-val node = Wrap.node
-   
-structure Equation =
-   struct
-      open Wrap
-      datatype node =
-	 Type of Longtycon.t list
-       | Structure of Longstrid.t list
-      type t = node Wrap.t
-      type node' = node
-      type obj = t
-
-      fun layout eq =
-	 case node eq of
-	    Type longtycons =>
-	       seq (str "sharing type "
-		    :: separate (List.map (longtycons, Longtycon.layout), " = "))
-	  | Structure longstrids =>
-	       seq (str "sharing "
-		    :: separate (List.map (longstrids, Longstrid.layout), " = "))
-   end
-
-type typedescs = {tyvars: Tyvar.t vector,
-		  tycon: Tycon.t} list
-
-datatype sigexpNode =
-   Var of Sigid.t
- | Where of sigexp * {tyvars: Tyvar.t vector,
-		      longtycon: Longtycon.t,
-		      ty: Type.t} list
- | Spec of spec
-and sigConst =
-   None
-  | Transparent of sigexp
-  | Opaque of sigexp
-and specNode =
-   Datatype of DatatypeRhs.t
-  | Empty
-  | Eqtype of typedescs
-  | Exception of (Con.t * Type.t option) list
-  | IncludeSigexp of sigexp
-  | IncludeSigids of Sigid.t list
-  | Seq of spec * spec
-  | Sharing of {spec: spec, equations: Equation.t list}
-  | Structure of (Strid.t * sigexp) list
-  | Type of typedescs
-  | TypeDefs of TypBind.t
-  | Val of (Var.t * Type.t) list
-withtype spec = specNode Wrap.t
-and sigexp = sigexpNode Wrap.t
-
-fun layoutTypedescs (prefix, typedescs) =
-   layoutAnds (prefix, typedescs, fn (prefix, {tyvars, tycon}) =>
-	       seq [prefix,
-		    Type.layoutApp (Tycon.layout tycon, tyvars, Tyvar.layout)])
-
-fun layoutTypedefs (prefix, typBind) =
-   let
-      val TypBind.T ds = TypBind.node typBind
-   in
-      layoutAnds (prefix, Vector.toList ds, fn (prefix, {def, tycon, tyvars}) =>
-		  seq [prefix,
-		       Type.layoutApp (Tycon.layout tycon, tyvars, Tyvar.layout),
-		       str " = ", Type.layout def])
-   end
-
-fun layoutSigexp (e: sigexp): Layout.t =
-   case node e of
-      Var s => Sigid.layout s
-    | Where (e, ws) =>
-	 let val e = layoutSigexp e
-	 in case ws of
-	    [] => e
-	  | _ => 
-	       seq [e, 
-		    layoutAndsBind
-		    (" where", "=", ws, fn {tyvars, longtycon, ty} =>
-		     (OneLine,
-		      seq [str "type ",
-			   Type.layoutApp
-			   (Longtycon.layout longtycon, tyvars,
-			    Tyvar.layout)],
-		      Type.layout ty))]
-	 end
-    | Spec s => align [str "sig",
-		       indent (layoutSpec s, 3),
-		       str "end"]
-
-and layoutSigConst sigConst =
-   case sigConst of
-      None => empty
-    | Transparent s => seq [str ": ", layoutSigexp s]
-    | Opaque s => seq [str " :> ", layoutSigexp s]
-
-and layoutSpec (s: spec): t =
-   case node s of
-      Empty => empty
-    | Seq (s, s') => align [layoutSpec s, layoutSpec s']
-    | Structure l =>
-	 layoutAndsBind ("structure", ":", l, fn (strid, sigexp) =>
-			 (case node sigexp of
-			     Var _ => OneLine
-			   | _ => Split 3,
-				Strid.layout strid,
-				layoutSigexp sigexp))
-    | Type typedescs => layoutTypedescs ("type", typedescs)
-    | TypeDefs typedefs => layoutTypedefs ("type", typedefs)
-    | Eqtype typedescs => layoutTypedescs ("eqtype", typedescs)
-    | Val sts =>
-	 layoutAndsBind
-	 ("val", ":", sts, fn (x, t) => (OneLine, Var.layout x, Type.layout t))
-    | Datatype rhs => DatatypeRhs.layout rhs
-    | Exception sts =>
-	 layoutAnds
-	 ("exception", sts, fn (prefix, (c, to)) => seq [prefix,
-							 Con.layout c,
-							 Type.layoutOption to])
-    | IncludeSigexp s => seq [str "include ", layoutSigexp s]
-    | IncludeSigids sigids =>
-	 seq (str "include "
-	      :: separate (List.map (sigids, Sigid.layout), " "))
-    | Sharing {spec, equations} =>
-	 align [layoutSpec spec,
-		align (List.map (equations, Equation.layout))]
-
-structure Sigexp =
-   struct
-      open Wrap
-      type spec = spec
-      type t = sigexp
-      datatype node = datatype sigexpNode
-      type node' = node
-      type obj = t
-	 
-      fun wheree (sigexp: t, wherespecs, region): t =
-	 case wherespecs of
-	    [] => sigexp
-	  | _ => makeRegion (Where (sigexp, wherespecs),
-			     region)
-
-      fun make n = makeRegion (n, Region.bogus)
-	 
-      val spec = make o Spec
-      val var = make o Var
-	 
-      val layout = layoutSigexp
-   end
-
-structure SigConst =
-   struct
-      datatype t = datatype sigConst
-      val layout = layoutSigConst
-   end
-
-structure Spec =
-   struct
-      open Wrap
-      datatype node = datatype specNode
-      type t = spec
-      type node' = node
-      type obj = t
-	 
-      val layout = layoutSpec
-   end
-
-(*---------------------------------------------------*)
-(*                Strdecs and Strexps                *)
-(*---------------------------------------------------*)
-
-datatype strdecNode =
-   Core of Dec.t
-  | Local of strdec * strdec
-  | Seq of strdec list
-  | Structure of {constraint: SigConst.t,
-		  def: strexp,
-		  name: Strid.t} vector
-
-and strexpNode =
-   App of Fctid.t * strexp
-  | Constrained of strexp * SigConst.t
-  | Let of strdec * strexp
-  | Struct of strdec
-  | Var of Longstrid.t
-withtype strexp = strexpNode Wrap.t
-and strdec = strdecNode Wrap.t
-
-fun layoutStrdec d =
-   case node d of
-      Core d => Dec.layout d
-    | Local (d, d') => Pretty.locall (layoutStrdec d, layoutStrdec d')
-    | Seq ds => align (layoutStrdecs ds)
-    | Structure strbs =>
-	 layoutAndsBind ("structure", "=", Vector.toList strbs,
-			 fn {name, def, constraint} =>
-			 (case node def of
-			     Var _ => OneLine
-			   | _ => Split 3,
-				seq [Strid.layout name, SigConst.layout constraint],
-				layoutStrexp def))
-
-and layoutStrdecs ds = layouts (ds, layoutStrdec)
-   
-and layoutStrexp exp =
-   case node exp of
-      App (f, e) => seq [Fctid.layout f, str " ", paren (layoutStrexp e)]
-    | Constrained (e, c) => mayAlign [layoutStrexp e, SigConst.layout c]
-    | Let (dec, strexp) => Pretty.lett (layoutStrdec dec, layoutStrexp strexp)
-    | Struct d => align [str "struct",
-			 indent (layoutStrdec d, 3),
-			 str "end"]
-    | Var s => Longstrid.layout s
-	 
-structure Strexp =
-   struct
-      open Wrap
-      type strdec = strdec
-      type t = strexp
-      datatype node = datatype strexpNode
-      type node' = node
-      type obj = t
-
-      fun make n = makeRegion (n, Region.bogus)
-      val var = make o Var
-      val structt = make o Struct
-      val constrained = make o Constrained
-      val app = make o App
-      val lett = make o Let
-      val layout = layoutStrexp
-   end
-
-structure Strdec =
-   struct
-      open Wrap
-      type t = strdec
-      datatype node = datatype strdecNode
-      type node' = node
-      type obj = t
-
-      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
-
-      val openn = core o Dec.openn
-
-      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 =
-   struct
-      open Wrap
-      datatype node =
-	 Structure of Strid.t * Sigexp.t
-       | Spec of Spec.t
-      type t = node Wrap.t
-      type node' = node
-      type obj = t
-
-      fun layout a =
-	 case node a of
-	    Structure (strid, sigexp) =>
-	       seq [Strid.layout strid, str ": ", Sigexp.layout sigexp]
-	  | Spec spec => Spec.layout spec
-   end
-
-structure Topdec =
-   struct
-      open Wrap
-      datatype node =
-	 BasisDone of {ffi: Longstrid.t}
-       | Functor of {arg: FctArg.t,
-		     body: Strexp.t,
-		     name: Fctid.t,
-		     result: SigConst.t} vector
-       | Signature of (Sigid.t * Sigexp.t) vector
-       | Strdec of Strdec.t
-      type t = node Wrap.t
-      type node' = node
-      type obj = t
-	 
-      fun layout d =
-	 case node d of
-	    BasisDone {ffi} => seq [str "_basis_done ", Longstrid.layout ffi]
-	  | Functor fctbs =>
-	       layoutAndsBind ("functor", "=", Vector.toList fctbs,
-			       fn {name, arg, result, body} =>
-			       (Split 0,
-				seq [Fctid.layout name, str " ",
-				     paren (FctArg.layout arg),
-				     layoutSigConst result],
-				layoutStrexp body))
-	  | Signature sigbs =>
-	       layoutAndsBind ("signature", "=", Vector.toList sigbs,
-			       fn (name, def) =>
-			       (case Sigexp.node def of
-				   Sigexp.Var _ => OneLine
-				 | _ => Split 3,
-				      Sigid.layout name,
-				      Sigexp.layout def))
-	  | Strdec d => Strdec.layout d
-
-
-      fun make n = makeRegion (n, Region.bogus)
-      val fromExp = make o Strdec o Strdec.fromExp
-      val functorr = make o Functor
-      val signaturee = make o Signature
-      val strdec = make o Strdec
-   end			
-
-structure Program =
-   struct
-      datatype t = T of Topdec.t list list
-
-      val empty = T []
-
-      fun append (T ds1, T ds2) = T (ds1 @ ds2)
-
-      fun layout (T dss) =
-	 Layout.align (List.map (dss, fn ds =>
-				 Layout.paren 
-				 (Layout.align (List.map (ds, Topdec.layout)))))
-
-      fun coalesce (T dss): t =
-	 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 (List.map (dss, fn ds => rev (loop (ds, [], []))))
-	 end
-
-      val coalesce =
-	 Trace.trace ("Ast.Program.coalesce", layout, layout) coalesce
-
-      fun size (T dss): int =
-	 let
-	    val n = ref 0
-	    fun inc () = n := 1 + !n
-	    fun dec (d: Dec.t): unit =
-	       let
-		  datatype z = datatype Dec.node
-	       in
-		  case Dec.node d of
-		     Abstype {body, ...} => dec body
-		   | Exception cs => Vector.foreach (cs, fn _ => inc ())
-		   | Fun (_, ds) =>
-			Vector.foreach (ds, fn clauses =>
-					Vector.foreach (clauses, exp o #body))
-		   | Local (d, d') => (dec d; dec d')
-		   | SeqDec ds => Vector.foreach (ds, dec)
-		   | Val {vbs, rvbs, ...} =>
-			(Vector.foreach (vbs, exp o #exp)
-			 ; Vector.foreach (rvbs, match o #match))
-		   | _ => ()
-	       end
-	    and exp (e: Exp.t): unit =
-	       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 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
-		  Core d => dec d
-		| Local (d, d') => (strdec d; strdec d')
-		| Seq ds => List.foreach (ds, strdec)
-		| Structure ds =>
-		     Vector.foreach (ds, fn {def, ...} => strexp def)
-	    and strexp e =
-	       case Strexp.node e of
-		  Struct d => strdec d
-		| Constrained (e, _) => strexp e
-		| App (_, e) => strexp e
-		| Let (d, e) => (strdec d; strexp e)
-		| _ => ()
-
-	    fun topdec d =
-	       let
-		  datatype z = datatype Topdec.node
-	       in
-		  case Topdec.node d of
-		     Functor ds =>
-			Vector.foreach (ds, fn {body, ...} => strexp body)
-		   | Strdec d => strdec d
-		   | _ => ()
-	       end
-	    val _ = List.foreach (dss, fn ds => List.foreach (ds, topdec))
-	 in
-	    !n
-	 end
-   end
+structure AstMLBs = AstMLBs (S)
 
+open AstMLBs
 end



1.11      +2 -167    mlton/mlton/ast/ast.sig

Index: ast.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast.sig,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- ast.sig	16 Feb 2004 22:42:09 -0000	1.10
+++ ast.sig	28 Jul 2004 21:05:10 -0000	1.11
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-1999 NEC Research Institute.
  *
@@ -12,170 +12,5 @@
 
 signature AST =
    sig
-      include AST_CORE
-
-      structure Sigexp:
-	 sig
-	    type spec
-
-	    type t
-	    datatype node =
-	       Spec of spec
-	     | Var of Sigid.t
-             | Where of t * {tyvars: Tyvar.t vector,
-			     longtycon: Longtycon.t,
-			     ty: Type.t} list
-
-	    include WRAPPED sharing type node' = node
-			    sharing type obj = t
-
-            val var: Sigid.t -> t
-	    val wheree: t * {tyvars: Tyvar.t vector,
-			     longtycon: Longtycon.t,
-			     ty: Type.t} list * Region.t -> t
-	    val spec: spec -> t
-
-	    val layout: t -> Layout.t
-	 end
-
-      structure SigConst:
-	 sig
-	    datatype t =
-	       None
-	     | Opaque of Sigexp.t
-	     | Transparent of Sigexp.t
-	 end
-
-      structure Equation:
-	 sig
-	    type t
-	    datatype node =
-	       Structure of Longstrid.t list
-	     | Type of Longtycon.t list
-	    include WRAPPED sharing type node' = node
-			    sharing type obj = t
-	 end
-
-      structure Spec:
-	 sig
-	    type t
-	    datatype node =
-	       Datatype of DatatypeRhs.t
-	     | Eqtype of {tycon: Tycon.t,
-			  tyvars: Tyvar.t vector} list
-	     | Empty
-	     | Exception of (Con.t * Type.t option) list
-	     | IncludeSigexp of Sigexp.t
-	     | IncludeSigids of Sigid.t list
-	     | Seq of t * t
-	     | Sharing of {equations: Equation.t list,
-			   spec: t}
-	     | Structure of (Strid.t * Sigexp.t) list
-	     | Type of {tycon: Tycon.t,
-			tyvars: Tyvar.t vector} list
-	     | TypeDefs of TypBind.t
-	     | Val of (Var.t * Type.t) list
-
-	    include WRAPPED sharing type node' = node
-			    sharing type obj = t
-
-	    val layout: t -> Layout.t
-	 end
-      sharing type Spec.t = Sigexp.spec
-
-      structure Strexp:
-	 sig
-	    type strdec
-
-	    type t
-	    datatype node =
-	       App of Fctid.t * t
-             | Constrained of t * SigConst.t
-	     | Let of strdec * t
-	     | Struct of strdec
-	     | Var of Longstrid.t
-
-	    include WRAPPED sharing type node' = node
-			    sharing type obj = t
-
-            val var: Longstrid.t -> t
-	    val structt: strdec -> t
-	    val constrained: t * SigConst.t -> t
-	    val app: Fctid.t * t -> t
-	    val lett: strdec * t -> t
-	       
-	    val layout: t -> Layout.t
-	 end
-
-      structure Strdec:
-	 sig
-	    type t
-	    datatype node =
-	       Core of Dec.t
-	     | Local of t * t
-	     | Seq of t list
-	     | Structure of {name: Strid.t,
-			     def: Strexp.t,
-			     constraint: SigConst.t} vector
-
-	    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
-	    val openn: Longstrid.t vector -> t
-	    val seq: t list -> t
-            val structuree: {name: Strid.t,
-			     def: Strexp.t,
-			     constraint: SigConst.t} vector -> t
-	 end
-      sharing type Strdec.t = Strexp.strdec
-
-      structure FctArg:
-	 sig
-	    type t
-	    datatype node =
-	       Structure of Strid.t * Sigexp.t
-	     | Spec of Spec.t
-	    include WRAPPED sharing type node' = node
-			    sharing type obj = t
-	 end
-      
-      structure Topdec:
-	 sig
-	    type t
-	    datatype node =
-	       BasisDone of {ffi: Longstrid.t}
-	     | Functor of {arg: FctArg.t,
-			   body: Strexp.t,
-			   name: Fctid.t,
-			   result: SigConst.t} vector
-	     | Signature of (Sigid.t * Sigexp.t) vector
-	     | Strdec of Strdec.t
-
-	    include WRAPPED sharing type node' = node
-			    sharing type obj = t
-
-            val fromExp: Exp.t -> t
-	    val functorr: {name: Fctid.t,
-			   arg: FctArg.t,
-			   result: SigConst.t,
-			   body: Strexp.t} vector -> t
-	    val layout: t -> Layout.t
-	    val signaturee: (Sigid.t * Sigexp.t) vector -> t
-            val strdec: Strdec.t -> t
-	 end
-
-      structure Program:
-	 sig
-	    datatype t = T of Topdec.t list list
-
-	    val append: t * t -> t
-	    val coalesce: t -> t
-	    val empty: t
-	    val size: t -> int
-	    val layout: t -> Layout.t
-	 end
+      include AST_MLBS
    end



1.10      +7 -1      mlton/mlton/ast/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/sources.cm,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- sources.cm	4 Apr 2004 06:50:14 -0000	1.9
+++ sources.cm	28 Jul 2004 21:05:10 -0000	1.10
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-1999 NEC Research Institute.
  *
@@ -70,5 +70,11 @@
 ast-atoms.fun
 ast-core.sig
 ast-core.fun
+ast-modules.sig
+ast-modules.fun
+ast-programs.sig
+ast-programs.fun
+ast-mlbs.sig
+ast-mlbs.fun
 ast.sig
 ast.fun



1.1                  mlton/mlton/ast/ast-mlbs.fun

Index: ast-mlbs.fun
===================================================================
(* Copyright (C) 1999-2004 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 AstMLBs (S: AST_MLBS_STRUCTS): AST_MLBS = 
struct

open S

structure AstPrograms = AstPrograms (S)

open AstPrograms Layout
   
val layouts = List.map
structure Wrap = Region.Wrap
val node = Wrap.node

(*---------------------------------------------------*)
(*                Basdecs and Basexps                *)
(*---------------------------------------------------*)

datatype annNode =
   Ann of string list
datatype basexpNode =
   Bas of basdec
 | Var of Basid.t
 | Let of basdec * basexp
and basdecNode =
   Defs of ModIdBind.t
 | Basis of {name: Basid.t,
	     def: basexp} vector
 | Local of basdec * basdec
 | Seq of basdec list
 | Open of Basid.t vector   
 | Prog of File.t * Program.t
 | MLB of File.t * OS.FileSys.file_id option * basdec
 | Prim
 | Ann of ann list * basdec
withtype ann = annNode Wrap.t
     and basexp = basexpNode Wrap.t
     and basdec = basdecNode Wrap.t

fun layoutAnn ann =
   let datatype z = datatype annNode
   in
      case node ann of
	 Ann ann => (seq o separate) (List.map (ann, str), " ")
   end
and layoutBasexp exp =
   case node exp of
      Bas dec => align [str "bas", indent (layoutBasdec dec, 3), str "end"]
    | Var basid => Basid.layout basid
    | Let (dec, exp) => Pretty.lett (layoutBasdec dec, layoutBasexp exp)
and layoutBasdec dec =
   case node dec of
      Defs def => ModIdBind.layout def
    | Basis basbnds =>
	 layoutAndsBind
	 ("basis", "=", Vector.toList basbnds, fn {name, def} =>
	  (case node def of Var _ => OneLine | _ => Split 3,
	   Basid.layout name, layoutBasexp def))
    | Local (dec1, dec2) => Pretty.locall (layoutBasdec dec1, layoutBasdec dec2)
    | Seq decs => align (layoutBasdecs decs)
    | Open bs => seq [str "open ",
		      seq (separate (Vector.toListMap (bs, Basid.layout),
				     " "))]
    | Prog (f,_) => File.layout f
    | MLB (f,_,_) => File.layout f
    | Prim => str "_prim"
    | Ann (anns, dec) => align [str "ann", 
				indent ((seq o separate)
					(List.map (anns, layoutAnn), 
					 ","),
					3),
				str "in", 
				indent (layoutBasdec dec, 3), str "end"]
and layoutBasdecs decs = layouts (decs, layoutBasdec)

structure Ann =
   struct
      open Wrap
      type ann = ann
      type t = ann
      datatype node = datatype annNode
      type node' = node
      type obj = t

      fun make n = makeRegion (n, Region.bogus)
      val ann = make o Ann

      val layout = layoutAnn
   end

structure Basexp =
   struct
      open Wrap
      type basdec = basdec
      type t = basexp
      datatype node = datatype basexpNode
      type node' = node
      type obj = t

      fun make n = makeRegion (n, Region.bogus)
      val bas = make o Bas
      val lett = make o Let
      val var = make o Var
      val layout = layoutBasexp
   end

structure Basdec =
   struct
      open Wrap
      type t = basdec
      datatype node = datatype basdecNode
      type node' = node
      type obj = t

      fun make n = makeRegion (n, Region.bogus)
      val ann = make o Ann
      val defs = make o Defs
      val basis = make o Basis
      val locall = make o Local
      val seq = make o Seq
      val empty = seq []
      val openn = make o Open
      val prim = make Prim
      val prog = make o Prog
      val mlb = make o MLB
      val layout = layoutBasdec
   end
end



1.1                  mlton/mlton/ast/ast-mlbs.sig

Index: ast-mlbs.sig
===================================================================
(* Copyright (C) 1999-2004 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 AST_MLBS_STRUCTS =
   sig
      include AST_ATOMS_STRUCTS
   end

signature AST_MLBS =
   sig
      include AST_PROGRAMS

      structure Ann:
	 sig
	    type t
	    datatype node =
	       Ann of string list

	    include WRAPPED sharing type node' = node
	                    sharing type obj = t

	    val ann : string list -> t

	    val layout : t -> Layout.t
	 end

      structure Basexp:
	 sig
	    type basdec

	    type t
	    datatype node =
	       Bas of basdec
	     | Var of Basid.t
	     | Let of basdec * t
	       
	    include WRAPPED sharing type node' = node
	                    sharing type obj = t

	    val bas: basdec -> t
	    val lett: basdec * t -> t
	    val var: Basid.t -> t

	    val layout: t -> Layout.t
	 end

      structure Basdec:
	 sig
	    type t
	    datatype node =
	       Defs of ModIdBind.t
	     | Basis of {name: Basid.t,
			 def: Basexp.t} vector
	     | Local of t * t
	     | Seq of t list
	     | Open of Basid.t vector
	     | Prog of File.t * Program.t
	     | MLB of File.t * OS.FileSys.file_id option * t
	     | Prim
	     | Ann of Ann.t list * t

	    include WRAPPED sharing type node' = node
	                    sharing type obj = t

	    val defs: ModIdBind.t -> t
	    val basis: {name: Basid.t, def: Basexp.t} vector -> t
	    val locall: t * t -> t
	    val empty: t
	    val seq: t list -> t
	    val openn: Basid.t vector -> t
	    val prog: File.t * Program.t -> t
	    val mlb: File.t * OS.FileSys.file_id option * t -> t
	    val prim: t
	    val ann: Ann.t list * t -> t

	    val layout: t -> Layout.t
	 end
      sharing type Basdec.t = Basexp.basdec
   end



1.1                  mlton/mlton/ast/ast-modules.fun

Index: ast-modules.fun
===================================================================
(* Copyright (C) 1999-2004 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 AstModules (S: AST_MODULES_STRUCTS): AST_MODULES = 
struct

open S

structure AstCore = AstCore (AstAtoms (S))

open AstCore Layout
   
val layouts = List.map
structure Wrap = Region.Wrap
val node = Wrap.node
   
structure Equation =
   struct
      open Wrap
      datatype node =
	 Type of Longtycon.t list
       | Structure of Longstrid.t list
      type t = node Wrap.t
      type node' = node
      type obj = t

      fun layout eq =
	 case node eq of
	    Type longtycons =>
	       seq (str "sharing type "
		    :: separate (List.map (longtycons, Longtycon.layout), " = "))
	  | Structure longstrids =>
	       seq (str "sharing "
		    :: separate (List.map (longstrids, Longstrid.layout), " = "))
   end

type typedescs = {tyvars: Tyvar.t vector,
		  tycon: Tycon.t} list

datatype sigexpNode =
   Var of Sigid.t
 | Where of sigexp * {tyvars: Tyvar.t vector,
		      longtycon: Longtycon.t,
		      ty: Type.t} list
 | Spec of spec
and sigConst =
   None
  | Transparent of sigexp
  | Opaque of sigexp
and specNode =
   Datatype of DatatypeRhs.t
  | Empty
  | Eqtype of typedescs
  | Exception of (Con.t * Type.t option) list
  | IncludeSigexp of sigexp
  | IncludeSigids of Sigid.t list
  | Seq of spec * spec
  | Sharing of {spec: spec, equations: Equation.t list}
  | Structure of (Strid.t * sigexp) list
  | Type of typedescs
  | TypeDefs of TypBind.t
  | Val of (Var.t * Type.t) list
withtype spec = specNode Wrap.t
and sigexp = sigexpNode Wrap.t

fun layoutTypedescs (prefix, typedescs) =
   layoutAnds (prefix, typedescs, fn (prefix, {tyvars, tycon}) =>
	       seq [prefix,
		    Type.layoutApp (Tycon.layout tycon, tyvars, Tyvar.layout)])

fun layoutTypedefs (prefix, typBind) =
   let
      val TypBind.T ds = TypBind.node typBind
   in
      layoutAnds (prefix, Vector.toList ds, fn (prefix, {def, tycon, tyvars}) =>
		  seq [prefix,
		       Type.layoutApp (Tycon.layout tycon, tyvars, Tyvar.layout),
		       str " = ", Type.layout def])
   end

fun layoutSigexp (e: sigexp): Layout.t =
   case node e of
      Var s => Sigid.layout s
    | Where (e, ws) =>
	 let val e = layoutSigexp e
	 in case ws of
	    [] => e
	  | _ => 
	       seq [e, 
		    layoutAndsBind
		    (" where", "=", ws, fn {tyvars, longtycon, ty} =>
		     (OneLine,
		      seq [str "type ",
			   Type.layoutApp
			   (Longtycon.layout longtycon, tyvars,
			    Tyvar.layout)],
		      Type.layout ty))]
	 end
    | Spec s => align [str "sig",
		       indent (layoutSpec s, 3),
		       str "end"]

and layoutSigConst sigConst =
   case sigConst of
      None => empty
    | Transparent s => seq [str ": ", layoutSigexp s]
    | Opaque s => seq [str " :> ", layoutSigexp s]

and layoutSpec (s: spec): t =
   case node s of
      Empty => empty
    | Seq (s, s') => align [layoutSpec s, layoutSpec s']
    | Structure l =>
	 layoutAndsBind ("structure", ":", l, fn (strid, sigexp) =>
			 (case node sigexp of
			     Var _ => OneLine
			   | _ => Split 3,
				Strid.layout strid,
				layoutSigexp sigexp))
    | Type typedescs => layoutTypedescs ("type", typedescs)
    | TypeDefs typedefs => layoutTypedefs ("type", typedefs)
    | Eqtype typedescs => layoutTypedescs ("eqtype", typedescs)
    | Val sts =>
	 layoutAndsBind
	 ("val", ":", sts, fn (x, t) => (OneLine, Var.layout x, Type.layout t))
    | Datatype rhs => DatatypeRhs.layout rhs
    | Exception sts =>
	 layoutAnds
	 ("exception", sts, fn (prefix, (c, to)) => seq [prefix,
							 Con.layout c,
							 Type.layoutOption to])
    | IncludeSigexp s => seq [str "include ", layoutSigexp s]
    | IncludeSigids sigids =>
	 seq (str "include "
	      :: separate (List.map (sigids, Sigid.layout), " "))
    | Sharing {spec, equations} =>
	 align [layoutSpec spec,
		align (List.map (equations, Equation.layout))]

structure Sigexp =
   struct
      open Wrap
      type spec = spec
      type t = sigexp
      datatype node = datatype sigexpNode
      type node' = node
      type obj = t
	 
      fun wheree (sigexp: t, wherespecs, region): t =
	 case wherespecs of
	    [] => sigexp
	  | _ => makeRegion (Where (sigexp, wherespecs),
			     region)

      fun make n = makeRegion (n, Region.bogus)
	 
      val spec = make o Spec
      val var = make o Var
	 
      val layout = layoutSigexp
   end

structure SigConst =
   struct
      datatype t = datatype sigConst
      val layout = layoutSigConst
   end

structure Spec =
   struct
      open Wrap
      datatype node = datatype specNode
      type t = spec
      type node' = node
      type obj = t
	 
      val layout = layoutSpec
   end

(*---------------------------------------------------*)
(*                Strdecs and Strexps                *)
(*---------------------------------------------------*)

datatype strdecNode =
   Core of Dec.t
  | Local of strdec * strdec
  | Seq of strdec list
  | Structure of {constraint: SigConst.t,
		  def: strexp,
		  name: Strid.t} vector

and strexpNode =
   App of Fctid.t * strexp
  | Constrained of strexp * SigConst.t
  | Let of strdec * strexp
  | Struct of strdec
  | Var of Longstrid.t
withtype strexp = strexpNode Wrap.t
and strdec = strdecNode Wrap.t

fun layoutStrdec d =
   case node d of
      Core d => Dec.layout d
    | Local (d, d') => Pretty.locall (layoutStrdec d, layoutStrdec d')
    | Seq ds => align (layoutStrdecs ds)
    | Structure strbs =>
	 layoutAndsBind ("structure", "=", Vector.toList strbs,
			 fn {name, def, constraint} =>
			 (case node def of
			     Var _ => OneLine
			   | _ => Split 3,
				seq [Strid.layout name, SigConst.layout constraint],
				layoutStrexp def))

and layoutStrdecs ds = layouts (ds, layoutStrdec)
   
and layoutStrexp exp =
   case node exp of
      App (f, e) => seq [Fctid.layout f, str " ", paren (layoutStrexp e)]
    | Constrained (e, c) => mayAlign [layoutStrexp e, SigConst.layout c]
    | Let (dec, strexp) => Pretty.lett (layoutStrdec dec, layoutStrexp strexp)
    | Struct d => align [str "struct",
			 indent (layoutStrdec d, 3),
			 str "end"]
    | Var s => Longstrid.layout s
	 
structure Strexp =
   struct
      open Wrap
      type strdec = strdec
      type t = strexp
      datatype node = datatype strexpNode
      type node' = node
      type obj = t

      fun make n = makeRegion (n, Region.bogus)
      val var = make o Var
      val structt = make o Struct
      val constrained = make o Constrained
      val app = make o App
      val lett = make o Let
      val layout = layoutStrexp
   end

structure Strdec =
   struct
      open Wrap
      type t = strdec
      datatype node = datatype strdecNode
      type node' = node
      type obj = t

      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

      val openn = core o Dec.openn

      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 =
   struct
      open Wrap
      datatype node =
	 Structure of Strid.t * Sigexp.t
       | Spec of Spec.t
      type t = node Wrap.t
      type node' = node
      type obj = t

      fun layout a =
	 case node a of
	    Structure (strid, sigexp) =>
	       seq [Strid.layout strid, str ": ", Sigexp.layout sigexp]
	  | Spec spec => Spec.layout spec
   end

structure Topdec =
   struct
      open Wrap
      datatype node =
	 BasisDone of {ffi: Longstrid.t}
       | Functor of {arg: FctArg.t,
		     body: Strexp.t,
		     name: Fctid.t,
		     result: SigConst.t} vector
       | Signature of (Sigid.t * Sigexp.t) vector
       | Strdec of Strdec.t
      type t = node Wrap.t
      type node' = node
      type obj = t
	 
      fun layout d =
	 case node d of
	    BasisDone {ffi} => seq [str "_basis_done ", Longstrid.layout ffi]
	  | Functor fctbs =>
	       layoutAndsBind ("functor", "=", Vector.toList fctbs,
			       fn {name, arg, result, body} =>
			       (Split 0,
				seq [Fctid.layout name, str " ",
				     paren (FctArg.layout arg),
				     layoutSigConst result],
				layoutStrexp body))
	  | Signature sigbs =>
	       layoutAndsBind ("signature", "=", Vector.toList sigbs,
			       fn (name, def) =>
			       (case Sigexp.node def of
				   Sigexp.Var _ => OneLine
				 | _ => Split 3,
				      Sigid.layout name,
				      Sigexp.layout def))
	  | Strdec d => Strdec.layout d


      fun make n = makeRegion (n, Region.bogus)
      val fromExp = make o Strdec o Strdec.fromExp
      val functorr = make o Functor
      val signaturee = make o Signature
      val strdec = make o Strdec
   end			
end



1.1                  mlton/mlton/ast/ast-modules.sig

Index: ast-modules.sig
===================================================================
(* Copyright (C) 1999-2004 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 AST_MODULES_STRUCTS =
   sig
      include AST_ATOMS_STRUCTS
   end

signature AST_MODULES =
   sig
      include AST_CORE

      structure Sigexp:
	 sig
	    type spec

	    type t
	    datatype node =
	       Spec of spec
	     | Var of Sigid.t
             | Where of t * {tyvars: Tyvar.t vector,
			     longtycon: Longtycon.t,
			     ty: Type.t} list

	    include WRAPPED sharing type node' = node
			    sharing type obj = t

            val var: Sigid.t -> t
	    val wheree: t * {tyvars: Tyvar.t vector,
			     longtycon: Longtycon.t,
			     ty: Type.t} list * Region.t -> t
	    val spec: spec -> t

	    val layout: t -> Layout.t
	 end

      structure SigConst:
	 sig
	    datatype t =
	       None
	     | Opaque of Sigexp.t
	     | Transparent of Sigexp.t
	 end

      structure Equation:
	 sig
	    type t
	    datatype node =
	       Structure of Longstrid.t list
	     | Type of Longtycon.t list
	    include WRAPPED sharing type node' = node
			    sharing type obj = t
	 end

      structure Spec:
	 sig
	    type t
	    datatype node =
	       Datatype of DatatypeRhs.t
	     | Eqtype of {tycon: Tycon.t,
			  tyvars: Tyvar.t vector} list
	     | Empty
	     | Exception of (Con.t * Type.t option) list
	     | IncludeSigexp of Sigexp.t
	     | IncludeSigids of Sigid.t list
	     | Seq of t * t
	     | Sharing of {equations: Equation.t list,
			   spec: t}
	     | Structure of (Strid.t * Sigexp.t) list
	     | Type of {tycon: Tycon.t,
			tyvars: Tyvar.t vector} list
	     | TypeDefs of TypBind.t
	     | Val of (Var.t * Type.t) list

	    include WRAPPED sharing type node' = node
			    sharing type obj = t

	    val layout: t -> Layout.t
	 end
      sharing type Spec.t = Sigexp.spec

      structure Strexp:
	 sig
	    type strdec

	    type t
	    datatype node =
	       App of Fctid.t * t
             | Constrained of t * SigConst.t
	     | Let of strdec * t
	     | Struct of strdec
	     | Var of Longstrid.t

	    include WRAPPED sharing type node' = node
			    sharing type obj = t

            val var: Longstrid.t -> t
	    val structt: strdec -> t
	    val constrained: t * SigConst.t -> t
	    val app: Fctid.t * t -> t
	    val lett: strdec * t -> t
	       
	    val layout: t -> Layout.t
	 end

      structure Strdec:
	 sig
	    type t
	    datatype node =
	       Core of Dec.t
	     | Local of t * t
	     | Seq of t list
	     | Structure of {name: Strid.t,
			     def: Strexp.t,
			     constraint: SigConst.t} vector

	    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
	    val openn: Longstrid.t vector -> t
	    val seq: t list -> t
            val structuree: {name: Strid.t,
			     def: Strexp.t,
			     constraint: SigConst.t} vector -> t
	 end
      sharing type Strdec.t = Strexp.strdec

      structure FctArg:
	 sig
	    type t
	    datatype node =
	       Structure of Strid.t * Sigexp.t
	     | Spec of Spec.t
	    include WRAPPED sharing type node' = node
			    sharing type obj = t
	 end
      
      structure Topdec:
	 sig
	    type t
	    datatype node =
	       BasisDone of {ffi: Longstrid.t}
	     | Functor of {arg: FctArg.t,
			   body: Strexp.t,
			   name: Fctid.t,
			   result: SigConst.t} vector
	     | Signature of (Sigid.t * Sigexp.t) vector
	     | Strdec of Strdec.t

	    include WRAPPED sharing type node' = node
			    sharing type obj = t

            val fromExp: Exp.t -> t
	    val functorr: {name: Fctid.t,
			   arg: FctArg.t,
			   result: SigConst.t,
			   body: Strexp.t} vector -> t
	    val layout: t -> Layout.t
	    val signaturee: (Sigid.t * Sigexp.t) vector -> t
            val strdec: Strdec.t -> t
	 end
   end



1.1                  mlton/mlton/ast/ast-programs.fun

Index: ast-programs.fun
===================================================================
(* Copyright (C) 1999-2004 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 AstPrograms (S: AST_PROGRAMS_STRUCTS): AST_PROGRAMS = 
struct

open S

structure AstModules = AstModules (S)

open AstModules Layout
   
structure Program =
   struct
      datatype t = T of Topdec.t list list

      val empty = T []

      fun append (T ds1, T ds2) = T (ds1 @ ds2)

      fun layout (T dss) =
	 Layout.align (List.map (dss, fn ds =>
				 Layout.paren 
				 (Layout.align (List.map (ds, Topdec.layout)))))

      fun coalesce (T dss): t =
	 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 (List.map (dss, fn ds => rev (loop (ds, [], []))))
	 end

      val coalesce =
	 Trace.trace ("Ast.Program.coalesce", layout, layout) coalesce

      fun size (T dss): int =
	 let
	    val n = ref 0
	    fun inc () = n := 1 + !n
	    fun dec (d: Dec.t): unit =
	       let
		  datatype z = datatype Dec.node
	       in
		  case Dec.node d of
		     Abstype {body, ...} => dec body
		   | Exception cs => Vector.foreach (cs, fn _ => inc ())
		   | Fun (_, ds) =>
			Vector.foreach (ds, fn clauses =>
					Vector.foreach (clauses, exp o #body))
		   | Local (d, d') => (dec d; dec d')
		   | SeqDec ds => Vector.foreach (ds, dec)
		   | Val {vbs, rvbs, ...} =>
			(Vector.foreach (vbs, exp o #exp)
			 ; Vector.foreach (rvbs, match o #match))
		   | _ => ()
	       end
	    and exp (e: Exp.t): unit =
	       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 m =
	       let
		  val Match.T rules = Match.node m
	       in
		  Vector.foreach (rules, exp o #2)
	       end
	    fun strdec d =
	       let
		  datatype z = datatype Strdec.node
	       in
		  case Strdec.node d of
		     Core d => dec d
		   | Local (d, d') => (strdec d; strdec d')
		   | Seq ds => List.foreach (ds, strdec)
		   | Structure ds =>
			Vector.foreach (ds, fn {def, ...} => strexp def)
	       end
	    and strexp e =
	       let
		  datatype z = datatype Strexp.node
	       in
		  case Strexp.node e of
		     Struct d => strdec d
		   | Constrained (e, _) => strexp e
		   | App (_, e) => strexp e
		   | Let (d, e) => (strdec d; strexp e)
		   | _ => ()
	       end

	    fun topdec d =
	       let
		  datatype z = datatype Topdec.node
	       in
		  case Topdec.node d of
		     Functor ds =>
			Vector.foreach (ds, fn {body, ...} => strexp body)
		   | Strdec d => strdec d
		   | _ => ()
	       end
	    val _ = List.foreach (dss, fn ds => List.foreach (ds, topdec))
	 in
	    !n
	 end
   end

end



1.1                  mlton/mlton/ast/ast-programs.sig

Index: ast-programs.sig
===================================================================
(* Copyright (C) 1999-2004 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 AST_PROGRAMS_STRUCTS =
   sig
      include AST_ATOMS_STRUCTS
   end

signature AST_PROGRAMS =
   sig
      include AST_MODULES

      structure Program:
	 sig
	    datatype t = T of Topdec.t list list

	    val append: t * t -> t
	    val coalesce: t -> t
	    val empty: t
	    val size: t -> int
	    val layout: t -> Layout.t
	 end
   end



1.78      +12 -2     mlton/mlton/backend/backend.fun

Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.77
retrieving revision 1.78
diff -u -r1.77 -r1.78
--- backend.fun	24 Jul 2004 13:55:47 -0000	1.77
+++ backend.fun	28 Jul 2004 21:05:10 -0000	1.78
@@ -175,6 +175,13 @@
 				Layouts Rssa.Program.layouts)
 	    else ()
 	 end
+      val program =
+	 Control.pass
+	 {name = "toMachine",
+	  suffix = "machine",
+	  style = Control.No,
+	  thunk = fn () =>
+let
       val R.Program.T {functions, handlesSignals, main, objectTypes} = program
       (* Chunk information *)
       val {get = labelChunk, set = setLabelChunk, ...} =
@@ -1055,7 +1062,7 @@
 	   end))
       val maxFrameSize = Bytes.wordAlign maxFrameSize
       val profileInfo = makeProfileInfo {frames = frameLabels}
-   in
+in
       Machine.Program.T 
       {chunks = chunks,
        frameLayouts = frameLayouts,
@@ -1068,7 +1075,10 @@
        profileInfo = profileInfo,
        reals = allReals (),
        strings = allStrings ()}
+end,
+      display = Control.Layouts Machine.Program.layouts}         
+   in
+      program
    end
-
 end
    



1.104     +10 -12    mlton/mlton/control/control.sig

Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.103
retrieving revision 1.104
diff -u -r1.103 -r1.104
--- control.sig	3 Jul 2004 19:52:13 -0000	1.103
+++ control.sig	28 Jul 2004 21:05:11 -0000	1.104
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-1999 NEC Research Institute.
  *
@@ -22,7 +22,7 @@
       val align: align ref
 
       val atMLtons: string vector ref
-	 
+
       val basisLibs: string list
       val basisLibrary: string ref
 
@@ -47,7 +47,7 @@
 
       val contifyIntoMain: bool ref
 
-      val deadCode: bool ref
+      val deadCodeAnn: bool ref
 	 
       (* Generate an executable with debugging info. *)
       val debug: bool ref
@@ -105,8 +105,6 @@
       (* call count instrumentation *)
       val instrument: bool ref
 
-      val keepDefUse: bool ref
-
       (* Keep dot files for whatever SSA files are produced. *)
       val keepDot: bool ref
 
@@ -232,14 +230,12 @@
       val safe: bool ref
 
       (* in (e1; e2), require e1: unit. *)
-      val sequenceUnit: bool ref
+      val sequenceUnitAnn: bool ref
+      val sequenceUnitDef: bool ref
 
       (* Show the basis library. *)
       val showBasis: File.t option ref
 	 
-      (* Show the basis library used. *)
-      val showBasisUsed: File.t option ref
-
       (* Show def-use information. *)
       val showDefUse: File.t option ref
 	 
@@ -294,11 +290,13 @@
       (* version number *)
       val version: string
 
-      val warnNonExhaustive: bool ref
+      val warnAnn: bool ref
 
-      val warnRedundant: bool ref
+      val warnMatchAnn: bool ref
+      val warnMatchDef: bool ref
 
-      val warnUnused: bool ref
+      val warnUnusedAnn: bool ref
+      val warnUnusedDef: bool ref
 
       (* XML Passes *)
       val xmlPassesSet: (string -> string list Result.t) ref



1.130     +24 -23    mlton/mlton/control/control.sml

Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.129
retrieving revision 1.130
diff -u -r1.129 -r1.130
--- control.sml	3 Jul 2004 19:52:13 -0000	1.129
+++ control.sml	28 Jul 2004 21:05:11 -0000	1.130
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-1999 NEC Research Institute.
  *
@@ -83,9 +83,9 @@
 			       default = false,
 			       toString = Bool.toString}
 
-val deadCode = control {name = "dead code",
-			default = true,
-			toString = Bool.toString}
+val deadCodeAnn = control {name = "dead code (annotation)",
+			   default = true,
+			   toString = Bool.toString}
    
 val debug = control {name = "debug",
 		     default = false,
@@ -228,10 +228,6 @@
 			      default = false,
 			      toString = Bool.toString}
 
-val keepDefUse = control {name = "keep def-use",
-			  default = false,
-			  toString = Bool.toString}
-   
 val keepMachine = control {name = "keep Machine",
 			   default = false,
 			   toString = Bool.toString}
@@ -437,18 +433,17 @@
 		    default = true,
 		    toString = Bool.toString}
 
-val sequenceUnit = control {name = "sequence unit",
-			    default = false,
-			    toString = Bool.toString}
+val sequenceUnitAnn = control {name = "sequence unit (annotation)",
+			       default = true,
+			       toString = Bool.toString}
+val sequenceUnitDef = control {name = "sequence unit (default)",
+			       default = false,
+			       toString = Bool.toString}
 
 val showBasis = control {name = "show basis",
 			 default = NONE,
 			 toString = Option.toString File.toString}
    
-val showBasisUsed = control {name = "show basis used",
-			     default = NONE,
-			     toString = Option.toString File.toString}
-
 val showDefUse = control {name = "show def-use",
 			  default = NONE,
 			  toString = Option.toString File.toString}
@@ -575,17 +570,23 @@
 
 val version = "MLton MLTONVERSION"
 
-val warnNonExhaustive = control {name = "warn non-exhaustive",
-				 default = true,
-				 toString = Bool.toString}
+val warnAnn = control {name = "warn annotation",
+		       default = true,
+		       toString = Bool.toString}
+
+val warnMatchAnn = control {name = "warn match (annotation)",
+			    default = true,
+			    toString = Bool.toString}
+val warnMatchDef = control {name = "warn match (default)",
+			    default = true,
+			    toString = Bool.toString}
 
-val warnRedundant = control {name = "warn redundant",
+val warnUnusedAnn = control {name = "warn unused (annotation)",
 			     default = true,
 			     toString = Bool.toString}
-
-val warnUnused = control {name = "warn unused",
-			  default = false,
-			  toString = Bool.toString}
+val warnUnusedDef = control {name = "warn unused (default)",
+			     default = false,
+			     toString = Bool.toString}
 
 val xmlPassesSet: (string -> string list Result.t) ref = 
    control {name = "xmlPassesSet",



1.8       +2 -2      mlton/mlton/control/source-pos.sml

Index: source-pos.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/source-pos.sml,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- source-pos.sml	16 Feb 2004 22:42:10 -0000	1.7
+++ source-pos.sml	28 Jul 2004 21:05:12 -0000	1.8
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-1999 NEC Research Institute.
  *
@@ -35,7 +35,7 @@
       file = file,
       line = line}
 
-val basisString = "/basis-library/"
+val basisString = "/basis/"
 
 fun getBasis (T {file, ...}) =
    String.findSubstring {string = file, substring = basisString}



1.23      +7 -4      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.22
retrieving revision 1.23
diff -u -r1.22 -r1.23
--- core-ml.fun	1 Jul 2004 20:25:29 -0000	1.22
+++ core-ml.fun	28 Jul 2004 21:05:12 -0000	1.23
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-1999 NEC Research Institute.
  *
@@ -147,7 +147,8 @@
 	   vbs: {exp: exp,
 		 lay: unit -> Layout.t,
 		 pat: Pat.t,
-		 patRegion: Region.t} vector}
+		 patRegion: Region.t} vector,
+	   warnMatch: bool}
 and exp = Exp of {node: expNode,
 		  ty: Type.t}
 and expNode =
@@ -159,7 +160,8 @@
 	     rules: {exp: exp,
 		     lay: (unit -> Layout.t) option,
 		     pat: Pat.t} vector,
-	     test: exp}
+	     test: exp,
+	     warnMatch: bool}
   | Con of Con.t * Type.t vector
   | Const of unit -> Const.t
   | EnterLeave of exp * SourceInfo.t
@@ -365,7 +367,8 @@
 				     {exp = elseCase,
 				      lay = NONE,
 				      pat = Pat.falsee}),
-		test = test}
+		test = test,
+		warnMatch = false}
 
       fun andAlso (e1, e2) = iff (e1, e2, falsee)
 	 



1.23      +6 -3      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.22
retrieving revision 1.23
diff -u -r1.22 -r1.23
--- core-ml.sig	23 Jul 2004 23:26:49 -0000	1.22
+++ core-ml.sig	28 Jul 2004 21:05:12 -0000	1.23
@@ -78,7 +78,8 @@
 			rules: {exp: t,
 				lay: (unit -> Layout.t) option,
 				pat: Pat.t} vector,
-			test: t}
+			test: t,
+			warnMatch: bool}
 	     | Con of Con.t * Type.t vector
 	     | Const of unit -> Const.t
 	     | EnterLeave of t * SourceInfo.t
@@ -105,7 +106,8 @@
 			rules: {exp: t,
 				lay: (unit -> Layout.t) option,
 				pat: Pat.t} vector,
-			test: t} -> t
+			test: t,
+			warnMatch: bool} -> t
 	    val dest: t -> node * Type.t
 	    val iff: t * t * t -> t
 	    val falsee: t
@@ -160,7 +162,8 @@
 		       vbs: {exp: Exp.t,
 			     lay: unit -> Layout.t,
 			     pat: Pat.t,
-			     patRegion: Region.t} vector}
+			     patRegion: Region.t} vector,
+		       warnMatch: bool}
 
 	    val layout: t -> Layout.t
 	 end



1.9       +18 -9     mlton/mlton/core-ml/dead-code.fun

Index: dead-code.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/dead-code.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- dead-code.fun	1 Jul 2004 20:25:29 -0000	1.8
+++ dead-code.fun	28 Jul 2004 21:05:12 -0000	1.9
@@ -12,7 +12,7 @@
 open CoreML
 open Dec
 
-fun deadCode {basis, user} =
+fun deadCode {prog} =
    let
       val {get = varIsUsed, set = setVarIsUsed, destroy, ...} =
 	 Property.destGetSet (Var.plist, Property.initConst false)
@@ -55,15 +55,24 @@
 	  | Val {rvbs, vbs, ...} =>
 	       (Vector.foreach (rvbs, useLambda o #lambda)
 		; Vector.foreach (vbs, useExp o #exp))
-      val _ = List.foreach (user, useDec)
-      val _ = List.foreach (basis, fn d => if decIsWild d then useDec d else ())
-      val res =
-	 List.fold (rev basis, [], fn (d, b) =>
-		    if decIsNeeded d
-		       then (useDec d; d :: b)
-		    else b)
+
+      val n = Vector.length prog
+      val m = n - 1
+      val prog =
+	 Vector.tabulate
+	 (n, fn i =>
+	  let val (decs, deadCode) = Vector.sub (prog, m - i)
+	  in
+	     if deadCode
+		then List.fold (rev decs, [], fn (dec, decs) =>
+				if decIsWild dec orelse decIsNeeded dec
+				   then (useDec dec; dec :: decs)
+				   else decs)
+		else (List.foreach (decs, useDec)
+		      ; decs)
+	  end)
       val _ = destroy ()
-   in res
+   in {prog = Vector.rev prog}
    end
 
 end



1.3       +4 -4      mlton/mlton/core-ml/dead-code.sig

Index: dead-code.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/dead-code.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- dead-code.sig	10 Apr 2002 07:02:20 -0000	1.2
+++ dead-code.sig	28 Jul 2004 21:05:12 -0000	1.3
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-1999 NEC Research Institute.
  *
@@ -13,8 +13,8 @@
 signature DEAD_CODE = 
    sig
       include DEAD_CODE_STRUCTS
-      
+
       val deadCode:
-	 {basis: CoreML.Dec.t list,
-	  user: CoreML.Dec.t list} -> CoreML.Dec.t list (* basis *)
+         {prog: (CoreML.Dec.t list * bool) vector} ->
+         {prog: CoreML.Dec.t list vector}
    end



1.24      +6 -8      mlton/mlton/defunctorize/defunctorize.fun

Index: defunctorize.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/defunctorize/defunctorize.fun,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- defunctorize.fun	23 Jul 2004 23:26:49 -0000	1.23
+++ defunctorize.fun	28 Jul 2004 21:05:12 -0000	1.24
@@ -258,8 +258,7 @@
       fun warn () =
 	 let
 	    val _ =
-	       if !Control.warnNonExhaustive
-		  andalso noMatch <> Cexp.RaiseAgain
+	       if noMatch <> Cexp.RaiseAgain
 		  then
 		     case Vector.peeki (cases,
 					fn (_, {isDefault, numUses, ...}) =>
@@ -281,8 +280,7 @@
 	       Vector.keepAll (cases, fn {isDefault, numUses, ...} =>
 			       not isDefault andalso !numUses = 0)
 	    val _ =
-	       if not (!Control.warnRedundant)
-		  orelse 0 = Vector.length redundant
+	       if 0 = Vector.length redundant
 		  then ()
 	       else 
 		  let
@@ -685,7 +683,7 @@
 	     | Fun {decs, tyvars} =>
 		  prefix (Xdec.Fun {decs = processLambdas decs,
 				    tyvars = tyvars ()})
-	     | Val {rvbs, tyvars, vbs} =>
+	     | Val {rvbs, tyvars, vbs, warnMatch} =>
 	       let
 		  val tyvars = tyvars ()
 		  val bodyType = et
@@ -706,7 +704,7 @@
 				   conTycon = conTycon,
 				   kind = "declaration",
 				   lay = lay,
-				   mayWarn = mayWarn,
+				   mayWarn = warnMatch andalso mayWarn,
 				   noMatch = Cexp.RaiseBind,
 				   region = r,
 				   test = (e, NestedPat.ty p),
@@ -846,7 +844,7 @@
 					func = #1 (loopExp e1),
 					ty = ty}
 		     end
-		| Case {kind, lay, noMatch, region, rules, test, ...} =>
+		| Case {kind, lay, noMatch, region, rules, test, warnMatch, ...} =>
 		     casee {caseType = ty,
 			    cases = Vector.map (rules, fn {exp, lay, pat} =>
 						{exp = #1 (loopExp exp),
@@ -855,7 +853,7 @@
 			    conTycon = conTycon,
 			    kind = kind,
 			    lay = lay,
-			    mayWarn = true,
+			    mayWarn = warnMatch,
 			    noMatch = noMatch,
 			    region = region,
 			    test = loopExp test,



1.111     +98 -66    mlton/mlton/elaborate/elaborate-core.fun

Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.110
retrieving revision 1.111
diff -u -r1.110 -r1.111
--- elaborate-core.fun	6 Jul 2004 20:15:49 -0000	1.110
+++ elaborate-core.fun	28 Jul 2004 21:05:12 -0000	1.111
@@ -319,13 +319,11 @@
       val fromAst = fromString o Avar.toString
    end
 
-val allowRebindEquals = ref true
-   
 local
    val eq = Avar.fromSymbol (Symbol.equal, Region.bogus)
 in
    fun ensureNotEquals x =
-      if not (!allowRebindEquals) andalso Avar.equals (x, eq)
+      if not (!Ctrls.allowRebindEquals) andalso Avar.equals (x, eq)
 	 then
 	    let
 	       open Layout
@@ -958,9 +956,7 @@
      ...} =
    Property.get (Var.plist, Property.initFun (fn _ => ref NONE))
    
-fun elaborateDec (d, {env = E,
-		      lookupConstant: string * ConstType.t -> CoreML.Const.t,
-		      nest}) =
+fun elaborateDec (d, {env = E, nest}) =
    let
       fun recursiveFun () =
 	 let
@@ -1505,7 +1501,8 @@
 					     test = 
 					     Cexp.tuple
 					     (Vector.map2
-					      (xs, argTypes, Cexp.var))}
+					      (xs, argTypes, Cexp.var)),
+					     warnMatch = !Ctrls.warnMatch}
 				      in
 					 Cexp.enterLeave (e, sourceInfo)
 				      end
@@ -1583,22 +1580,27 @@
 		      Decs.empty
 		   end
 	      | Adec.Overload (p, x, tyvars, ty, xs) =>
-		   let
-		      (* 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.extendOverload
-			 (E, p, x, 
-			  Vector.map (ovlds, fn (x, s) => (x, Scheme.ty s)),
-			  Scheme.make {canGeneralize = false,
-				       tyvars = tyvars,
-				       ty = elabType ty})
-		   in
-		      Decs.empty
-		   end
+		   (if not (!Ctrls.allowOverload)
+		       then let open Layout
+			    in Control.error (region, str "_overload disallowed", empty)
+			    end
+		       else ()
+		    ; let
+			 (* 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.extendOverload
+			    (E, p, x, 
+			     Vector.map (ovlds, fn (x, s) => (x, Scheme.ty s)),
+			     Scheme.make {canGeneralize = false,
+					  tyvars = tyvars,
+					  ty = elabType ty})
+		      in
+			 Decs.empty
+		      end)
 	      | Adec.SeqDec ds =>
 		   Vector.fold (ds, Decs.empty, fn (d, decs) =>
 				Decs.append (decs, elabDec (d, isTop)))
@@ -1728,7 +1730,8 @@
 					     noMatch = Cexp.RaiseMatch,
 					     region = region,
 					     rules = rules,
-					     test = Cexp.var (arg, argType)},
+					     test = Cexp.var (arg, argType),
+					     warnMatch = !Ctrls.warnMatch},
 				 fn () => SourceInfo.function {name = nest,
 							       region = region})
 			     val lambda =
@@ -1806,7 +1809,8 @@
 		       *)
 		      Decs.single (Cdec.Val {rvbs = rvbs,
 					     tyvars = bound,
-					     vbs = vbs})
+					     vbs = vbs,
+					     warnMatch = !Ctrls.warnMatch})
 		   end
 	  end) arg
       and elabExp (arg: Aexp.t * Nest.t * string option): Cexp.t =
@@ -1887,7 +1891,8 @@
 				  noMatch = Cexp.RaiseMatch,
 				  region = region,
 				  rules = rules,
-				  test = e}
+				  test = e,
+				  warnMatch = !Ctrls.warnMatch}
 		   end
 	      | Aexp.Const c =>
 		   elabConst
@@ -2037,6 +2042,10 @@
 		   end
 	      | Aexp.Prim {kind, name, ty} =>
 		   let
+		      fun disallowed d =
+			 let open Layout
+			 in Control.error (region, str (d ^ " disallowed"), empty)
+			 end
 		      val ty = elabType ty
 		      val expandedTy =
 			 Type.hom
@@ -2108,7 +2117,8 @@
 						pat =
 						(Cpat.tuple
 						 (Vector.map (vars, Cpat.var)))},
-					       test = Cexp.var (arg, argType)}
+					       test = Cexp.var (arg, argType),
+					       warnMatch = !Ctrls.warnMatch}
 					   end
 			       in
 				  Cexp.make (Cexp.Lambda
@@ -2157,7 +2167,10 @@
 						then ConstType.String
 					     else
 						bug ()
-				  fun finish () = lookupConstant (name, ct)
+				  val finish =
+				     let val lookupConstant = !Ctrls.lookupConstant
+				     in fn () => lookupConstant (name, ct)
+				     end
 			       in
 				  Cexp.make (Cexp.Const finish, ty)
 			       end
@@ -2165,43 +2178,61 @@
 		      datatype z = datatype Ast.PrimKind.t
 		   in
 		      case kind of
-			 BuildConst => lookConst name
-		       | Const => lookConst name
+			 BuildConst => 
+			    (if not (!Ctrls.allowConstant)
+				then disallowed "_build_const"
+				else ()
+			     ; lookConst name)
+		       | Const => 
+			    (if not (!Ctrls.allowConstant)
+				then disallowed "_const"
+				else ()
+			     ; lookConst name)
 		       | Export attributes =>
-			    let
-			       val e =
-				  Env.scope
-				  (E, fn () =>
-				   (Env.openStructure
-				    (E, valOf (!Env.Structure.ffi))
-				    ; elabExp (export {attributes = attributes,
-						       name = name,
-						       region = region,
-						       ty = expandedTy},
-					       nest,
-					       NONE)))
-			       val _ =
-				  unify
-				  (Cexp.ty e,
-				   Type.arrow (expandedTy, Type.unit),
-				   fn (l1, l2) =>
-				   let
-				      open Layout
-				   in
-				      (region,
-				       str "export unify bug",
-				       align [seq [str "inferred: ", l1],
-					      seq [str "expanded: ", l2]])
-				   end)
-			    in
-			       wrap (e, Type.arrow (ty, Type.unit))
-			    end
+			    (if not (!Ctrls.allowExport)
+				then disallowed "_export"
+				else ()
+			     ; let
+				  val e =
+				     Env.scope
+				     (E, fn () =>
+				      (Env.openStructure
+				       (E, valOf (!Env.Structure.ffi))
+				       ; elabExp (export {attributes = attributes,
+							  name = name,
+							  region = region,
+							  ty = expandedTy},
+						  nest,
+						  NONE)))
+				  val _ =
+				     unify
+				     (Cexp.ty e,
+				      Type.arrow (expandedTy, Type.unit),
+				      fn (l1, l2) =>
+				      let
+					 open Layout
+				      in
+					 (region,
+					  str "_export unify bug",
+					  align [seq [str "inferred: ", l1],
+						 seq [str "expanded: ", l2]])
+				      end)
+			       in
+				  wrap (e, Type.arrow (ty, Type.unit))
+			       end)
 		       | Import attributes =>
-			    eta (import {attributes = attributes,
-					 name = name,
-					 region = region,
-					 ty = expandedTy})
-		       | Prim => eta (Prim.fromString name)
+			    (if not (!Ctrls.allowImport)
+				then disallowed "_import"
+				else ()
+			     ; eta (import {attributes = attributes,
+					    name = name,
+					    region = region,
+					    ty = expandedTy}))
+		       | Prim => 
+			    (if not (!Ctrls.allowPrim)
+				then disallowed "_prim"
+				else ()
+			     ; eta (Prim.fromString name))
 		   end
 	      | Aexp.Raise exn =>
 		   let
@@ -2237,7 +2268,7 @@
 		       * unit.
 		       *)
 		      val _ =
-			 if not (!Control.sequenceUnit)
+			 if not (!Ctrls.sequenceUnit)
 			    then ()
 			 else
 			    Vector.foreachi
@@ -2323,7 +2354,7 @@
 		      val expr = elab expr
 		      (* Error if expr is not of type unit. *)
 		      val _ =
-			 if not (!Control.sequenceUnit)
+			 if not (!Ctrls.sequenceUnit)
 			    then ()
 			 else
 			    unify (Cexp.ty expr, Type.unit, fn (l, _) =>
@@ -2344,7 +2375,8 @@
 			   noMatch = noMatch,
 			   region = region,
 			   rules = rules,
-			   test = Cexp.var (arg, argType)}
+			   test = Cexp.var (arg, argType),
+			   warnMatch = !Ctrls.warnMatch}
 	 in
 	   {arg = arg,
 	    argType = argType,



1.9       +8 -8      mlton/mlton/elaborate/elaborate-core.sig

Index: elaborate-core.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.sig,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- elaborate-core.sig	18 Mar 2004 03:22:25 -0000	1.8
+++ elaborate-core.sig	28 Jul 2004 21:05:12 -0000	1.9
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-1999 NEC Research Institute.
  *
@@ -6,29 +6,29 @@
  * Please see the file MLton-LICENSE for license information.
  *)
 type int = Int.t
-   
+
 signature ELABORATE_CORE_STRUCTS = 
    sig
       structure Ast: AST
       structure ConstType: CONST_TYPE
       structure CoreML: CORE_ML
+      structure Ctrls: ELABORATE_CONTROLS
       structure Decs: DECS
       structure Env: ELABORATE_ENV
-      sharing Ast = Env.Ast
+      sharing Ast = Ctrls.Ast = Env.Ast
       sharing Ast.Tyvar = CoreML.Tyvar
-      sharing CoreML = Decs.CoreML = Env.CoreML
+      sharing ConstType = Ctrls.ConstType
+      sharing CoreML = Ctrls.CoreML = Decs.CoreML = Env.CoreML
+      sharing Decs = Env.Decs
    end
 
 signature ELABORATE_CORE = 
    sig
       include ELABORATE_CORE_STRUCTS
 
-      val allowRebindEquals: bool ref
       (* Elaborate dec in env, returning Core ML decs. *)
       val elaborateDec:
-	 Ast.Dec.t * {env: Env.t,
-		      lookupConstant: string * ConstType.t -> CoreML.Const.t,
-		      nest: string list}
+	 Ast.Dec.t * {env: Env.t, nest: string list}
 	 -> Decs.t
       val reportUndeterminedTypes: unit -> unit
    end



1.96      +194 -54   mlton/mlton/elaborate/elaborate-env.fun

Index: elaborate-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.fun,v
retrieving revision 1.95
retrieving revision 1.96
diff -u -r1.95 -r1.96
--- elaborate-env.fun	3 Jun 2004 19:26:33 -0000	1.95
+++ elaborate-env.fun	28 Jul 2004 21:05:12 -0000	1.96
@@ -15,6 +15,7 @@
 local
    open Ast
 in
+   structure Basid = Basid
    structure Fctid = Fctid
    structure Strid = Strid
    structure Longvid = Longvid
@@ -123,10 +124,11 @@
 
 structure Class =
    struct
-      datatype t = Con | Exn | Fix | Fct | Sig | Str | Typ | Var
+      datatype t = Bas | Con | Exn | Fix | Fct | Sig | Str | Typ | Var
 
       val toString =
-	 fn Con => "constructor"
+	 fn Bas => "basis"
+	  | Con => "constructor"
 	  | Exn => "exception"
 	  | Fix => "fixity"
 	  | Fct => "functor"
@@ -876,6 +878,10 @@
       val ffi: t option ref = ref NONE
    end
 
+(* ------------------------------------------------- *)
+(*                     FunctorClosure                *)
+(* ------------------------------------------------- *)
+
 structure FunctorClosure =
    struct
       datatype t =
@@ -904,6 +910,54 @@
 	 apply
    end
 
+(* ------------------------------------------------- *)
+(*                     Basis                         *)
+(* ------------------------------------------------- *)
+
+structure Basis =
+   struct
+      datatype t = T of {plist: PropertyList.t,
+			 bass: (Ast.Basid.t, t) Info.t, 
+			 fcts: (Ast.Fctid.t, FunctorClosure.t) Info.t,
+			 fixs: (Ast.Vid.t, Ast.Fixity.t) Info.t,
+			 sigs: (Ast.Sigid.t, Interface.t) Info.t,
+			 strs: (Ast.Strid.t, Structure.t) Info.t,
+			 types: (Ast.Tycon.t, TypeStr.t) Info.t,
+			 vals: (Ast.Vid.t, Vid.t * Scheme.t) Info.t}
+
+      local
+	 fun make f (T r) = f r
+      in
+	 val plist = make #plist
+      end
+
+      fun eq (s: t, s': t): bool = PropertyList.equals (plist s, plist s')
+
+      local
+	 fun make (field, toSymbol) (T fields, domain) =
+	    Info.peek (field fields, domain, toSymbol)
+      in
+	 val peekFctid' = make (#fcts, Ast.Fctid.toSymbol)
+	 val peekSigid' = make (#sigs, Ast.Sigid.toSymbol)
+	 val peekStrid' = make (#strs, Ast.Strid.toSymbol)
+      end
+ 
+      fun peekFctid z = Option.map (peekFctid' z, #range)
+      fun peekSigid z = Option.map (peekSigid' z, #range)
+      fun peekStrid z = Option.map (peekStrid' z, #range)
+
+      fun layout (T {bass, fcts, sigs, strs, types, vals, ...}) =
+	 Layout.record
+	 [("bass", Info.layout (Ast.Basid.layout, layout) bass),
+	  ("fcts", Info.layout (Ast.Fctid.layout, FunctorClosure.layout) fcts),
+	  ("sigs", Info.layout (Ast.Sigid.layout, Interface.layout) sigs),
+	  ("strs", Info.layout (Ast.Strid.layout, Structure.layout) strs),
+	  ("types", Info.layout (Ast.Tycon.layout, TypeStr.layout) types),
+	  ("vals", (Info.layout (Ast.Vid.layout,
+				 Layout.tuple2 (Vid.layout, Scheme.layout))
+		    vals))]
+   end
+
 structure Time:>
    sig
       type t
@@ -1019,13 +1073,15 @@
 structure All =
    struct
       datatype t =
-	 Fct of (Fctid.t, FunctorClosure.t) Values.t
+         Bas of (Basid.t, Basis.t) Values.t
+       | Fct of (Fctid.t, FunctorClosure.t) Values.t
        | Fix of (Ast.Vid.t, Ast.Fixity.t) Values.t
        | Sig of (Sigid.t, Interface.t) Values.t
        | Str of (Strid.t, Structure.t) Values.t
        | Tyc of (Ast.Tycon.t, TypeStr.t) Values.t
        | Val of (Ast.Vid.t, Vid.t * Scheme.t) Values.t
 
+      val basOpt = fn Bas z => SOME z | _ => NONE
       val fctOpt = fn Fct z => SOME z | _ => NONE
       val fixOpt = fn Fix z => SOME z | _ => NONE
       val sigOpt = fn Sig z => SOME z | _ => NONE
@@ -1036,15 +1092,16 @@
 
 datatype t =
    T of {currentScope: Scope.t ref,
-	 fcts: (Fctid.t, FunctorClosure.t) NameSpace.t,
+	 bass: (Ast.Basid.t, Basis.t) NameSpace.t, 
+	 fcts: (Ast.Fctid.t, FunctorClosure.t) NameSpace.t,
 	 fixs: (Ast.Vid.t, Ast.Fixity.t) NameSpace.t,
-	 interface: {strs: (Strid.t, Interface.t) NameSpace.t,
+	 interface: {strs: (Ast.Strid.t, Interface.t) NameSpace.t,
 		     types: (Ast.Tycon.t, Interface.TypeStr.t) NameSpace.t,
 		     vals: (Ast.Vid.t, Interface.Status.t * Interface.Scheme.t) NameSpace.t},
 	 lookup: Symbol.t -> All.t list ref,
 	 maybeAddTop: Symbol.t -> unit,
-	 sigs: (Sigid.t, Interface.t) NameSpace.t,
-	 strs: (Strid.t, Structure.t) NameSpace.t,
+	 sigs: (Ast.Sigid.t, Interface.t) NameSpace.t,
+	 strs: (Ast.Strid.t, Structure.t) NameSpace.t,
 	 (* topSymbols is a list of all symbols that are defined at
 	  * the top level (in any namespace).
 	  *)
@@ -1095,6 +1152,8 @@
 			   region = region,
 			   toSymbol = toSymbol}
 	 end
+      val bass = make (fn _ => Class.Bas, Basid.region, Basid.toSymbol,
+		       All.basOpt, All.Bas)
       val fcts = make (fn _ => Class.Fct, Fctid.region, Fctid.toSymbol,
 		       All.fctOpt, All.Fct)
       val fixs = make (fn _ => Class.Fix, Ast.Vid.region, Ast.Vid.toSymbol,
@@ -1134,6 +1193,7 @@
       end
    in
       T {currentScope = ref (Scope.new {isTop = true}),
+	 bass = bass,
 	 fcts = fcts,
 	 fixs = fixs,
 	 interface = interface,
@@ -1147,14 +1207,15 @@
    end
 
 local
-   fun foreach (T {lookup, ...}, s, {fcts, fixs, sigs, strs, types, vals}) =
+   fun foreach (T {lookup, ...}, s, {bass, fcts, fixs, sigs, strs, types, vals}) =
       List.foreach
       (! (lookup s), fn a =>
        let
 	  datatype z = datatype All.t
        in
 	  case a of
-	     Fct vs => fcts vs
+	     Bas vs => bass vs
+	   | Fct vs => fcts vs
 	   | Fix vs => fixs vs
 	   | Sig vs => sigs vs
 	   | Str vs => strs vs
@@ -1174,6 +1235,7 @@
 	     le: {domain: Symbol.t, time: Time.t}
 	         * {domain: Symbol.t, time: Time.t} -> bool) =
    let
+      val bass = ref []
       val fcts = ref []
       val sigs = ref []
       val strs = ref []
@@ -1187,7 +1249,8 @@
 		  then List.push (ac, z)
 	       else ()
       val _ =
-	 foreachDefinedSymbol (E, {fcts = doit fcts,
+	 foreachDefinedSymbol (E, {bass = doit bass,
+				   fcts = doit fcts,
 				   fixs = fn _ => (),
 				   sigs = doit sigs,
 				   strs = doit strs,
@@ -1201,7 +1264,8 @@
 	  le ({domain = toSymbol d, time = t},
 	      {domain = toSymbol d', time = t'}))
    in
-      {fcts = finish (fcts, Fctid.toSymbol),
+      {bass = finish (bass, Basid.toSymbol),
+       fcts = finish (fcts, Fctid.toSymbol),
        sigs = finish (sigs, Sigid.toSymbol),
        strs = finish (strs, Strid.toSymbol),
        types = finish (types, Ast.Tycon.toSymbol),
@@ -1363,7 +1427,7 @@
 fun layout' (E: t, keep, showUsed): Layout.t =
    let
       val _ = setTyconNames E
-      val {fcts, sigs, strs, types, vals} =
+      val {bass, fcts, sigs, strs, types, vals} =
 	 collect (E, keep,
 		  fn ({domain = d, ...}, {domain = d', ...}) =>
 		  Symbol.<= (d, d'))
@@ -1378,6 +1442,9 @@
 	 Structure.layouts (showUsed, interfaceSigid)
       val {layoutAbbrev, layoutStr, ...} =
 	 Structure.layouts ({showUsed = false}, interfaceSigid)
+      val bass =
+	 doit (bass, fn {domain = basid, range = B, ...} =>
+	       seq [str "basis ", Basid.layout basid, str " = "])
       val sigs =
 	 doit (sigs, fn {domain = sigid, range = I, ...} =>
 	       let
@@ -1404,7 +1471,7 @@
 			typeSpec (domain, range))
       val strs = doit (strs, fn {domain, range, ...} => strSpec (domain, range))
    in
-      align [types, vals, strs, fcts, sigs]
+      align [types, vals, strs, fcts, sigs, bass]
    end
 
 fun layout E = layout' (E, fn _ => true, {showUsed = false})
@@ -1441,7 +1508,8 @@
 		; clearRange range)
       val _ =
 	 foreachDefinedSymbol
-	 (E, {fcts = doit ignore,
+	 (E, {bass = doit ignore,
+	      fcts = doit ignore,
 	      fixs = doit ignore,
 	      sigs = doit ignore,
 	      strs = doit Structure.clearUsed,
@@ -1462,7 +1530,8 @@
 		; forceRange range)
       val _ =
 	 foreachDefinedSymbol
-	 (E, {fcts = doit (fn f => Option.app (FunctorClosure.result f,
+	 (E, {bass = doit ignore,
+	      fcts = doit (fn f => Option.app (FunctorClosure.result f,
 					       Structure.forceUsed)),
 	      fixs = doit ignore,
 	      sigs = doit ignore,
@@ -1518,23 +1587,19 @@
 			 uses = uses @ u'} :: ac'
 		else z :: ac)
       val _ =
-	 if not (!Control.warnUnused)
-	    then ()
-	 else
-	    List.foreach
-	    (l, fn {class, def, isUsed, region, ...} =>
-	     if isUsed orelse Option.isNone (Region.left region)
-		then ()
-	     else
-		let
-		   open Layout
-		in
-		   Control.warning
-		   (region,
-		    seq [str (concat ["unused ", Class.toString class, ": "]),
-			 def],
-		    empty)
-		end)
+	 List.foreach
+	 (l, fn {class, def, isUsed, region, ...} =>
+	  if isUsed orelse Option.isNone (Region.left region)
+	     then ()
+	  else
+	     let
+		open Layout
+	     in
+		Control.warning
+		(region,
+		 seq [str (concat ["unused ", Class.toString class, ": "]), def],
+		 empty)
+	     end)
       val _ =
 	 case !Control.showDefUse of
 	    NONE => ()
@@ -1590,7 +1655,10 @@
 		     let
 			val uses = NameSpace.newUses (vals, Class.Con,
 						      Ast.Vid.fromCon name)
-			val _ = if forceUsed then Uses.forceUsed uses else ()
+			val () = 
+			   if not (!Ctrls.warnUnused) orelse forceUsed
+			      then Uses.forceUsed uses
+			      else ()
 		     in
 			{con = con,
 			 name = name,
@@ -1612,6 +1680,7 @@
 local
    fun make sel (T r, a) = NameSpace.peek (sel r, a, {markUse = fn _ => true})
 in
+   val peekBasid = make #bass
    val peekFctid = make #fcts
    val peekFix = make #fixs
    val peekSigid = make #sigs
@@ -1704,6 +1773,12 @@
     end,
     Layout.empty)
 
+fun lookupBasid (E, x) =
+   case peekBasid (E, x) of
+      NONE => (unbound (Ast.Basid.region x, "basis", Ast.Basid.layout x)
+	       ; NONE)
+    | SOME f => SOME f
+
 fun lookupFctid (E, x) =
    case peekFctid (E, x) of
       NONE => (unbound (Ast.Fctid.region x, "functor", Ast.Fctid.layout x)
@@ -1716,6 +1791,12 @@
 	       ; NONE)
     | SOME I => SOME I
 
+fun lookupStrid (E, x) =
+   case peekStrid (E, x) of
+      NONE => (unbound (Ast.Strid.region x, "structure", Ast.Strid.layout x)
+	       ; NONE)
+    | SOME S => SOME S
+
 local
    fun make (peek: t * 'a -> 'b PeekResult.t,
 	     bogus: unit -> 'b,
@@ -1797,7 +1878,10 @@
       fun newUses () =
 	 let
 	    val u = NameSpace.newUses (ns, class range, domain)
-	    val _ = if forceUsed then Uses.forceUsed u else ()
+	    val () = 
+	       if not (!Ctrls.warnUnused) orelse forceUsed
+		  then Uses.forceUsed u
+		  else ()
 	 in
 	    u
 	 end
@@ -1866,6 +1950,7 @@
 			 uses = uses})
       end
 in
+   fun extendBasid (E, d, r) = extend (E, #bass, d, r, false, ExtendUses.New)
    fun extendFctid (E, d, r) = extend (E, #fcts, d, r, false, ExtendUses.New)
    fun extendFix (E, d, r) = extend (E, #fixs, d, r, false, ExtendUses.New)
    fun extendSigid (E, d, r) = extend (E, #sigs, d, r, false, ExtendUses.New)
@@ -1947,10 +2032,11 @@
 	 end
       end
 in
-   fun localTop (E as T {currentScope, fcts, fixs, sigs, strs, types, vals, ...},
-		 f) =
+   fun localAll (E as T {currentScope, bass, fcts, fixs, sigs, strs, types, vals, ...},
+		 f1, f2) =
       let
 	 val s0 = !currentScope
+	 val bass = doit (E, bass, s0)
 	 val fcts = doit (E, fcts, s0)
 	 val fixs = doit (E, fixs, s0)
 	 val sigs = doit (E, sigs, s0)
@@ -1958,24 +2044,20 @@
 	 val types = doit (E, types, s0)
 	 val vals = doit (E, vals, s0)
 	 val _ = currentScope := Scope.new {isTop = true}
-	 val a = f ()
+	 val a1 = f1 ()
+	 val bass = bass ()
 	 val fcts = fcts ()
 	 val fixs = fixs ()
 	 val sigs = sigs ()
 	 val strs = strs ()
 	 val types = types ()
 	 val vals = vals ()
-	 fun finish g =
-	    let
-	       val _ = currentScope := Scope.new {isTop = true}
-	       val b = g ()
-	       val _ = (fcts (); fixs (); sigs (); strs (); types (); vals ())
-	       val _ = currentScope := s0
-	    in
-	       b
-	    end
+	 val _ = currentScope := Scope.new {isTop = true}
+	 val a2 = f2 a1
+	 val _ = (bass(); fcts (); fixs (); sigs (); strs (); types (); vals ())
+	 val _ = currentScope := s0
       in
-	 (a, finish)
+	 a2
       end
 
    fun localModule (E as T {currentScope, fixs, strs, types, vals, ...},
@@ -2026,6 +2108,31 @@
       (res, S)
    end
 
+fun makeBasis (T {currentScope, bass, fcts, fixs, sigs, strs, types, vals, ...}, make) =
+   let
+      val bass = NameSpace.collect bass
+      val fcts = NameSpace.collect fcts
+      val fixs = NameSpace.collect fixs
+      val sigs = NameSpace.collect sigs
+      val strs = NameSpace.collect strs
+      val types = NameSpace.collect types
+      val vals = NameSpace.collect vals
+      val s0 = !currentScope
+      val _ = currentScope := Scope.new {isTop = true}
+      val res = make ()
+      val B = Basis.T {plist = PropertyList.new (),
+		       bass = bass (),
+		       fcts = fcts (),
+		       fixs = fixs (),
+		       sigs = sigs (),
+		       strs = strs (),
+		       types = types (),
+		       vals = vals ()}
+      val _ = currentScope := s0
+   in
+      (res, B)
+   end
+
 fun scope (T {currentScope, fixs, strs, types, vals, ...}, th) =
    let
       fun doit (NameSpace.T {current, ...}) =
@@ -2048,7 +2155,7 @@
       res
    end
 
-fun scopeAll (T {currentScope, fcts, fixs, sigs, strs, types, vals, ...}, th) =
+fun scopeAll (T {currentScope, bass, fcts, fixs, sigs, strs, types, vals, ...}, th) =
    let
       fun doit (NameSpace.T {current, ...}) =
 	 let
@@ -2059,6 +2166,7 @@
 	 end
       val s0 = !currentScope
       val _ = currentScope := Scope.new {isTop = true}
+      val b = doit bass
       val fc = doit fcts
       val f = doit fixs
       val si = doit sigs
@@ -2066,7 +2174,7 @@
       val t = doit types
       val v = doit vals
       val res = th ()
-      val _ = (fc (); f (); si (); s (); t (); v ())
+      val _ = (b (); fc (); f (); si (); s (); t (); v ())
       val _ = currentScope := s0
    in
       res
@@ -2093,6 +2201,35 @@
       ()
    end
 
+fun openBasis (E as T {currentScope, bass, fcts, fixs, sigs, strs, vals, types, ...},
+	       Basis.T {bass = bass', 
+			fcts = fcts',
+			fixs = fixs',
+			sigs = sigs',
+			strs = strs',
+			vals = vals',
+			types = types', ...}): unit =
+   let
+      val scope = !currentScope
+      fun doit (ns, Info.T a) =
+	 Array.foreach (a, fn {domain, range, uses} =>
+			extend (E, ns, {domain = domain,
+					forceUsed = false,
+					range = range,
+					scope = scope,
+					time = Time.next (),
+					uses = ExtendUses.Old uses}))
+      val _ = doit (bass, bass')
+      val _ = doit (fcts, fcts')
+      val _ = doit (fixs, fixs')
+      val _ = doit (sigs, sigs')
+      val _ = doit (strs, strs')
+      val _ = doit (vals, vals')
+      val _ = doit (types, types')
+   in
+      ()
+   end
+
 fun makeOpaque (S: Structure.t, I: Interface.t, {prefix: string}) =
    let
       fun fixCons (Cons.T cs, Cons.T cs') =
@@ -2596,7 +2733,8 @@
 					     {exp = e,
 					      lay = fn _ => Layout.empty,
 					      pat = Pat.var (x, strType),
-					      patRegion = region})})
+					      patRegion = region}),
+				      warnMatch = !Ctrls.warnMatch})
 		      in
 			 Vid.Var x
 		      end
@@ -2707,7 +2845,7 @@
 (*                  functorClosure                   *)
 (* ------------------------------------------------- *)
 
-fun snapshot (E as T {currentScope, fcts, fixs, sigs, strs, types, vals, ...})
+fun snapshot (E as T {currentScope, bass, fcts, fixs, sigs, strs, types, vals, ...})
    : (unit -> 'a) -> 'a =
    let
       val add: (Scope.t -> unit) list ref = ref []
@@ -2725,7 +2863,8 @@
 				 uses = uses})
 		 ; List.push (current, v)))
       val _ =
-	 foreachTopLevelSymbol (E, {fcts = doit fcts,
+	 foreachTopLevelSymbol (E, {bass = doit bass,
+				    fcts = doit fcts,
 				    fixs = doit fixs,
 				    sigs = doit sigs,
 				    strs = doit strs,
@@ -2745,7 +2884,7 @@
 			  (List.foreach (!current, fn v => ignore (Values.pop v))
 			   ; current := current0))
 	    end
-	 val _ = (doit fcts; doit fixs; doit sigs
+	 val _ = (doit bass; doit fcts; doit fixs; doit sigs
 		  ; doit strs; doit types; doit vals)
 	 val _ = List.foreach (!add, fn f => f s0)
 	 (* Clear out any symbols that weren't available in the old scope. *)
@@ -2768,7 +2907,8 @@
 	     * originally would have elaborated as a variable instead elaborate
 	     * as a constructor.
 	     *)
-	    foreachDefinedSymbol (E, {fcts = doit,
+	    foreachDefinedSymbol (E, {bass = doit,
+				      fcts = doit,
 				      fixs = doit,
 				      sigs = doit,
 				      strs = doit,



1.33      +21 -13    mlton/mlton/elaborate/elaborate-env.sig

Index: elaborate-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.sig,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -r1.32 -r1.33
--- elaborate-env.sig	15 May 2004 21:24:29 -0000	1.32
+++ elaborate-env.sig	28 Jul 2004 21:05:12 -0000	1.33
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-1999 NEC Research Institute.
  *
@@ -9,10 +9,13 @@
    sig
       structure Ast: AST
       structure CoreML: CORE_ML
+      structure Ctrls: ELABORATE_CONTROLS
       structure TypeEnv: TYPE_ENV
+      sharing Ast = Ctrls.Ast
       sharing Ast.Record = CoreML.Record
       sharing Ast.SortedRecord = CoreML.SortedRecord
       sharing Ast.Tyvar = CoreML.Tyvar
+      sharing CoreML = Ctrls.CoreML
       sharing CoreML.Atoms = TypeEnv.Atoms
       sharing CoreML.Type = TypeEnv.Type
    end
@@ -145,10 +148,15 @@
       sharing Interface.Status = InterfaceEnv.Status
       sharing Interface.TypeStr = InterfaceEnv.TypeStr
 
+      structure Basis:
+	 sig
+	    type t
+	    val layout: t -> Layout.t
+	 end
+
       type t
 
       val amInsideFunctor: unit -> bool
-      val clearDefUses: t -> unit
       (* cut keeps only those bindings in the structure that also appear
        * in the interface.  It proceeds recursively on substructures.
        *)
@@ -157,6 +165,7 @@
 	 * {isFunctor: bool, opaque: bool, prefix: string} * Region.t
 	 -> Structure.t * Decs.t
       val empty: unit -> t
+      val extendBasid: t * Ast.Basid.t * Basis.t -> unit
       val extendExn: t * Ast.Con.t * CoreML.Con.t * Scheme.t -> unit
       val extendFctid: t * Ast.Fctid.t * FunctorClosure.t -> unit
       val extendFix: t * Ast.Vid.t * Ast.Fixity.t -> unit
@@ -169,6 +178,7 @@
       val extendOverload:
 	 t * Ast.Priority.t * Ast.Var.t * (CoreML.Var.t * Type.t) vector * Scheme.t
 	 -> unit
+      val forceUsed: t -> unit
       val functorClosure:
 	 t * string * Interface.t
 	 * (Structure.t * string list -> Decs.t * Structure.t option)
@@ -176,17 +186,10 @@
       val layout: t -> Layout.t
       val layoutCurrentScope: t -> Layout.t
       val layoutUsed: t -> Layout.t
+      val localAll: t * (unit -> 'a) * ('a -> 'b) -> 'b
       val localCore: t * (unit -> 'a) * ('a -> 'b) -> 'b
       val localModule: t * (unit -> 'a) * ('a -> 'b) -> 'b
-      (* localTop (E, f) = (a, finish)
-       * evaluates f () in a new scope.  finish g can then be called later to
-       * finish the local, evaluating g () within the scope and eventually
-       * leaving only the bindings introduced by g.  Thus, the whole thing is
-       * very much like the following.
-       *
-       *   local f () in g () end
-       *)
-      val localTop: t * (unit -> 'a) -> 'a * ((unit -> 'b) -> 'b)
+      val lookupBasid: t * Ast.Basid.t -> Basis.t option
       val lookupFctid: t * Ast.Fctid.t -> FunctorClosure.t option
       val lookupLongcon: t * Ast.Longcon.t -> CoreML.Con.t * Scheme.t
       val lookupLongstrid: t * Ast.Longstrid.t -> Structure.t option
@@ -194,7 +197,9 @@
       val lookupLongvar: t * Ast.Longvar.t -> CoreML.Var.t * Scheme.t
       val lookupLongvid: t * Ast.Longvid.t -> Vid.t * Scheme.t
       val lookupSigid: t * Ast.Sigid.t -> Interface.t option
+      val lookupStrid: t * Ast.Strid.t -> Structure.t option
       val makeStructure: t * (unit -> 'a) -> 'a * Structure.t
+      val makeBasis: t * (unit -> 'a) -> 'a * Basis.t
       val makeInterfaceEnv: t -> InterfaceEnv.t
       val newCons: ((t * {con: CoreML.Con.t,
 			  name: Ast.Con.t} vector)
@@ -203,18 +208,21 @@
       val newTycon: string * Tycon.Kind.t * AdmitsEquality.t -> Tycon.t
       (* openStructure (E, S) opens S in the environment E. *) 
       val openStructure: t * Structure.t -> unit
+      (* openBasis (E, B) opens B in the environment E. *) 
+      val openBasis: t * Basis.t -> unit
       val peekFix: t * Ast.Vid.t -> Ast.Fixity.t option
       val peekLongcon: t * Ast.Longcon.t -> (CoreML.Con.t * Scheme.t) option
       val peekLongtycon: t * Ast.Longtycon.t -> TypeStr.t option
+      val processDefUse: t -> unit
       (* scope f evaluates f () in a new scope so that extensions that occur
        * during f () are forgotten afterwards.
        * scope works for infixes, types, values, and structures
        *)
       val scope: t * (unit -> 'a) -> 'a
-      (* like scope, but works for signatures and functors as well *)
+      (* like scope, but works for bases, signatures and functors as well *)
       val scopeAll: t * (unit -> 'a) -> 'a
       val setTyconNames: t -> unit
       val sizeMessage: t -> Layout.t
-      val processDefUse: t -> unit
+      val snapshot: t -> (unit -> 'a) -> 'a
    end
 



1.24      +3 -3      mlton/mlton/elaborate/elaborate-sigexp.fun

Index: elaborate-sigexp.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-sigexp.fun,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- elaborate-sigexp.fun	1 May 2004 23:25:56 -0000	1.23
+++ elaborate-sigexp.fun	28 Jul 2004 21:05:13 -0000	1.24
@@ -271,7 +271,7 @@
 val info' = Trace.info "elaborateSpec"
  
 (* rule 65 *)
-fun elaborateSigexp (sigexp: Sigexp.t, E: StructureEnv.t): Interface.t option =
+fun elaborateSigexp (sigexp: Sigexp.t, {env = E: StructureEnv.t}): Interface.t option =
    let
       val _ = Interface.renameTycons := (fn () => StructureEnv.setTyconNames E)
       val E = StructureEnv.makeInterfaceEnv E
@@ -461,10 +461,10 @@
    end
 
 val elaborateSigexp =
-   fn (sigexp, E) =>
+   fn (sigexp, {env = E}) =>
    case Sigexp.node sigexp of
       Sigexp.Var x => StructureEnv.lookupSigid (E, x)
-    | _ => elaborateSigexp (sigexp, E)
+    | _ => elaborateSigexp (sigexp, {env = E})
 
 val elaborateSigexp = 
    Trace.trace2 ("elaborateSigexp",



1.4       +4 -2      mlton/mlton/elaborate/elaborate-sigexp.sig

Index: elaborate-sigexp.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-sigexp.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- elaborate-sigexp.sig	5 Feb 2004 06:11:42 -0000	1.3
+++ elaborate-sigexp.sig	28 Jul 2004 21:05:13 -0000	1.4
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-1999 NEC Research Institute.
  *
@@ -16,5 +16,7 @@
    sig
       include ELABORATE_SIGEXP_STRUCTS
 
-      val elaborateSigexp: Ast.Sigexp.t * Env.t -> Env.Interface.t option
+      val elaborateSigexp: 
+	 Ast.Sigexp.t * {env: Env.t} 
+	 -> Env.Interface.t option
    end



1.27      +19 -277   mlton/mlton/elaborate/elaborate.fun

Index: elaborate.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate.fun,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- elaborate.fun	1 May 2004 00:49:46 -0000	1.26
+++ elaborate.fun	28 Jul 2004 21:05:13 -0000	1.27
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-1999 NEC Research Institute.
  *
@@ -10,36 +10,6 @@
 
 open S
 
-local
-   open Ast
-in
-   structure FctArg = FctArg
-   structure Fctid = Fctid
-   structure Longstrid = Longstrid
-   structure SigConst = SigConst
-   structure Sigexp = Sigexp
-   structure Strdec = Strdec
-   structure Strexp = Strexp
-   structure Strid = Strid
-   structure Symbol = Symbol
-   structure Topdec = Topdec
-end
-
-structure Env = ElaborateEnv (structure Ast = Ast
-			      structure CoreML = CoreML
-			      structure TypeEnv = TypeEnv)
-
-local
-   open Env
-in
-   structure Decs = Decs
-   structure FunctorClosure = FunctorClosure
-   structure Structure = Structure
-end
-
-structure ElaborateSigexp = ElaborateSigexp (structure Ast = Ast
-					     structure Env = Env)
-
 structure ConstType =
    struct
       datatype t = Bool | Real | String | Word
@@ -51,255 +21,27 @@
 	  | Word => "Word"
    end
 
-structure ElaborateCore = ElaborateCore (structure Ast = Ast
+structure Ctrls = ElaborateControls(structure Ast = Ast
+				    structure ConstType = ConstType
+				    structure CoreML = CoreML)
+
+structure Env = ElaborateEnv (structure Ast = Ast
+			      structure CoreML = CoreML
+			      structure Ctrls = Ctrls
+			      structure TypeEnv = TypeEnv)
+
+local
+   open Env
+in
+   structure Decs = Decs
+end
+
+structure ElaborateMLBs = ElaborateMLBs (structure Ast = Ast
 					 structure ConstType = ConstType
 					 structure CoreML = CoreML
+					 structure Ctrls = Ctrls
 					 structure Decs = Decs
 					 structure Env = Env)
 
-val info = Trace.info "elaborateStrdec"
-val info' = Trace.info "elaborateTopdec"
-	  
-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 option,
-				nest: string list)
-	 : Decs.t * Structure.t option =
-	 let
-	    fun s (sigexp, opaque) =
-	       let
-		  val prefix =
-		     case nest of
-			[] => ""
-		      | _ => concat (List.fold (nest, [], fn (s, ac) =>
-						s :: "." :: ac))
-	       in
-		  case S of
-		     NONE => (Decs.empty, NONE)
-		   | SOME S => 
-			let
-			   val (S, decs) =
-			      case elabSigexp sigexp of
-				 NONE => (S, Decs.empty)
-			       | SOME I => 
-				    Env.cut (E, S, I,
-					     {isFunctor = false,
-					      opaque = opaque,
-					      prefix = prefix},
-					     Sigexp.region sigexp)
-			in
-			   (decs, SOME S)
-			end
-	       end
-	 in
-	    case cons of
-	       SigConst.None => (Decs.empty, S)
-	     | SigConst.Opaque sigexp => s (sigexp, true)
-	     | SigConst.Transparent sigexp => s (sigexp, false)
-	 end	 
-      fun elabStrdec (arg: Strdec.t * string list): Decs.t =
-	 Trace.traceInfo' (info,
-			   Layout.tuple2 (Strdec.layout,
-					  List.layout String.layout),
-			   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, {env = E,
-			lookupConstant = lookupConstant,
-			nest = nest})
-	      | Strdec.Local (d, d') => (* rule 58 *)
-		   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) =>
-		    Decs.append (decs, elabStrdec d))
-	      | Strdec.Structure strbinds => (* rules 57, 61 *)
-		   let
-		      val strbinds =
-			 Vector.map
-			 (strbinds, fn {name, def, constraint} =>
-			  let
-			     val nest = Strid.toString name :: nest
-			     val (decs', S) = elabStrexp (def, nest)
-			     val (decs'', S) =
-				elabSigexpConstraint (constraint, S, nest)
-			  in
-			     {decs = Decs.append (decs', decs''),
-			      name = name,
-			      S = S}
-			  end)
-		      val () =
-			 Vector.foreach
-			 (strbinds, fn {name, S, ...} =>
-			  Option.app (S, fn S => Env.extendStrid (E, name, S)))
-		    in
-		       Decs.appendsV (Vector.map (strbinds, #decs))
-		    end
-	  end) arg
-      and elabStrexp (e: Strexp.t, nest: string list)
-	 : Decs.t * Structure.t option =
-	 let
-	    val elabStrexp = fn e => elabStrexp (e, nest)
-	 in
-	    case Strexp.node e of
-	       Strexp.App (fctid, strexp) => (* rules 54, 154 *)
-		  let
-		     val (decs, S) = elabStrexp strexp
-		  in
-		     case S of
-			NONE => (decs, NONE)
-		      | SOME S =>
-			   case Env.lookupFctid (E, fctid) of
-			      NONE => (decs, NONE)
-			    | SOME fct  =>
-				 let
-				    val (S, decs') =
-				       Env.cut
-				       (E, S,
-					FunctorClosure.argInterface fct,
-					{isFunctor = true,
-					 opaque = false,
-					 prefix = ""},
-					Strexp.region strexp)
-				    val (decs'', S) =
-				       FunctorClosure.apply
-				       (fct, S, [Fctid.toString fctid])
-			   in
-			      (Decs.appends [decs, decs', decs''], S)
-			   end
-		  end
-	     | Strexp.Constrained (e, c) => (* rules 52, 53 *)
-		  let
-		     val (decs, S) = elabStrexp e
-		     val (decs', S) = elabSigexpConstraint (c, S, nest)
-		  in
-		     (Decs.append (decs, decs'), S)
-		  end
-	     | Strexp.Let (d, e) => (* rule 55 *)
-		  Env.scope
-		  (E, fn () =>
-		   let
-		      val decs = elabStrdec (d, nest)
-		      val (decs', S) = elabStrexp e
-		   in
-		      (Decs.append (decs, decs'), S)
-		   end)
-	     | Strexp.Struct d => (* rule 50 *)
-		  let
-		     val (decs, S) =
-			Env.makeStructure (E, fn () => elabStrdec (d, nest))
-		  in
-		     (decs, SOME S)
-		  end
-	     | Strexp.Var p => (* rule 51 *)
-		  (Decs.empty, Env.lookupLongstrid (E, p))
-	 end
-      fun elabFunctor {arg, result, body}: FunctorClosure.t option =
-	 let
-	    val body = Strexp.constrained (body, result)
-	    val (arg, argSig, body, prefix) =
-	       case FctArg.node arg of
-		  FctArg.Structure (arg, argSig) =>
-		     (arg, argSig, body, concat [Strid.toString arg, "."])
-		| FctArg.Spec spec =>
-		     let
-			val strid =
-			   Strid.fromSymbol (Symbol.fromString "ZZZNewStridZZZ",
-					     Region.bogus)
-		     in
-			(strid,
-			 Sigexp.spec spec,
-			 Strexp.lett (Strdec.openn (Vector.new1
-						    (Longstrid.short strid)),
-				      body),
-			 "")
-		     end
-	 in
-	    Option.map (elabSigexp argSig, fn argInt =>
-			Env.functorClosure
-			(E, prefix, argInt,
-			 fn (formal, nest) =>
-			 Env.scope (E, fn () =>
-				    (Env.extendStrid (E, arg, formal)
-				     ; elabStrexp (body, nest)))))
-	 end
-      fun elabTopdec arg: Decs.t =
-	 Trace.traceInfo' (info', Topdec.layout, Decs.layout)
-	 (fn (d: Topdec.t) =>
-	  case Topdec.node d of
-	     Topdec.BasisDone {ffi} =>
-		let
-		   val _ = ElaborateCore.allowRebindEquals := false
-		   val _ =
-		      Option.app
-		      (Env.lookupLongstrid (E, ffi), fn S =>
-		       (Env.Structure.ffi := SOME S
-			; Env.Structure.forceUsed S))
-		in
-		   Decs.empty
-		end
-	   | Topdec.Signature sigbinds =>
-		let
-		   val sigbinds =
-		      Vector.map
-		      (sigbinds, fn (sigid, sigexp) =>
-		       (sigid, elabSigexp sigexp))
-		   val () =
-		      Vector.foreach
-		      (sigbinds, fn (sigid, I) =>
-		       Option.app (I, fn I => Env.extendSigid (E, sigid, I)))
-		in
-		   Decs.empty
-		end
-	   | Topdec.Strdec d => elabStrdec (d, [])
-	   | Topdec.Functor funbinds =>
-		(* Rules 85, 86. Appendix A, p.58 *)
-		let
-		   val funbinds =
-		      Vector.map
-		      (funbinds, fn {arg, body, name, result} =>
-		       {closure = elabFunctor {arg = arg,
-					       body = body,
-					       result = result},
-			name = name})
-		   val () =
-		      Vector.foreach (funbinds, fn {closure, name} =>
-				      Option.app
-				      (closure, fn closure =>
-				       Env.extendFctid (E, name, closure)))
-		   (* Check for errors here so that we don't report duplicate
-		    * errors when re-elaborating the functor body.
-		    *)
-		   val () = Control.checkForErrors "elaborate"
-		in
-		   Decs.empty
-		end
-		) arg
-      val elabTopdec =
-	 fn d =>
-	 let
-	    val res = elabTopdec d
-	    val _ = ElaborateCore.reportUndeterminedTypes ()
-	 in
-	    res
-	 end
-   in
-      List.fold (decs, Decs.empty, fn (ds, decs) =>
-		 List.fold (ds, decs, fn (d, decs) =>
-			    Decs.append (decs, elabTopdec d)))
-   end
-
+open ElaborateMLBs
 end



1.9       +4 -4      mlton/mlton/elaborate/elaborate.sig

Index: elaborate.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate.sig,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- elaborate.sig	18 Mar 2004 03:22:25 -0000	1.8
+++ elaborate.sig	28 Jul 2004 21:05:13 -0000	1.9
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-1999 NEC Research Institute.
  *
@@ -22,10 +22,10 @@
       include ELABORATE_STRUCTS
 
       structure ConstType: CONST_TYPE
+      structure Ctrls: ELABORATE_CONTROLS
       structure Decs: DECS
       structure Env: ELABORATE_ENV
 
-      val elaborateProgram:
-	 Ast.Program.t * Env.t * (string * ConstType.t -> CoreML.Const.t)
-	 -> Decs.t
+      val elaborateMLB:
+	 Ast.Basdec.t * {addPrim: Env.t -> Decs.t} -> Env.t * (Decs.t * bool) vector
    end



1.8       +9 -1      mlton/mlton/elaborate/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/sources.cm,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- sources.cm	4 Apr 2004 06:50:21 -0000	1.7
+++ sources.cm	28 Jul 2004 21:05:13 -0000	1.8
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-1999 NEC Research Institute.
  *
@@ -27,6 +27,8 @@
 type-env.fun
 interface.sig
 interface.fun
+elaborate-controls.sig
+elaborate-controls.fun
 elaborate-env.sig
 elaborate-env.fun
 precedence-parse.sig
@@ -37,5 +39,11 @@
 elaborate-core.fun
 elaborate-sigexp.sig
 elaborate-sigexp.fun
+elaborate-modules.sig
+elaborate-modules.fun
+elaborate-programs.sig
+elaborate-programs.fun
+elaborate-mlbs.sig
+elaborate-mlbs.fun
 elaborate.sig
 elaborate.fun



1.1                  mlton/mlton/elaborate/elaborate-controls.fun

Index: elaborate-controls.fun
===================================================================
(* Copyright (C) 1999-2004 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 ElaborateControls (S: ELABORATE_CONTROLS_STRUCTS): ELABORATE_CONTROLS = 
struct
   open S

   val allowConstant : bool ref = ref false
   val allowExport : bool ref = ref true
   val allowImport : bool ref = ref true
   val allowOverload : bool ref = ref false
   val allowPrim : bool ref = ref false
   val allowRebindEquals : bool ref = ref false
   val deadCode : bool ref = ref false
   val forceUsed : int ref = ref 0
   val lookupConstant : (string * ConstType.t -> CoreML.Const.t) ref = 
      ref (fn _ => Error.bug "lookupConstant not set")
   val sequenceUnit : bool ref = ref false
   val warnMatch : bool ref = ref false
   val warnUnused : bool ref = ref false

   local
      fun make' (r : 'a ref, def: unit -> 'a): unit -> unit =
	 let 
	    val old = !r
	 in 
	    r := def ()
	    ; fn () => r := old
	 end
      fun make (r : 'a ref, def: 'a): unit -> unit =
	 make' (r, fn () => def)
   in
      fun withDefault f =
	 let
	    val restore =
	       (make (allowConstant, false)) o
	       (make (allowExport, true)) o
	       (make (allowImport, true)) o
	       (make (allowOverload, false)) o
	       (make (allowPrim, true)) o
	       (make (allowRebindEquals, false)) o
	       (make (deadCode, false)) o
	       (make (forceUsed, 0)) o
	       (make' (sequenceUnit, fn () => 
		       !Control.sequenceUnitAnn 
		       andalso !Control.sequenceUnitDef)) o
	       (make' (warnMatch, fn () => 
		       !Control.warnMatchAnn 
		       andalso !Control.warnMatchDef)) o
	       (make' (warnUnused, fn () => 
		       !Control.warnUnusedAnn 
		       andalso !Control.warnUnusedDef)) o
	       (fn () => ())
	 in
	    DynamicWind.wind (f, restore)
	 end 
   end

   fun withAnns (anns, f) =
      let
	 val restore =
	    List.fold
	    (anns, fn () => (), fn (ann, restore) =>
	     let
		fun warn () =
		   if !Control.warnAnn
		      then let open Layout
			   in
			      Control.warning
			      (Ast.Ann.region ann,
			       seq [str "unrecognized annotation: ",
				    Ast.Ann.layout ann],
			       empty)
			   end
		      else ()

		fun setCtrl'' (enabled, r, f) =
		   if enabled
		      then let 
			      val old = !r
			      val new = f old
			   in
			      r := new
			      ; (fn () => r := old) o restore
			   end
		      else restore
		fun setCtrl' (r, f) = setCtrl'' (true, r, f)
		fun setCtrl (r, v) =
		   setCtrl' (r, fn _ => v)

		fun setBool'' (enabled, r, b) =
		   case Bool.fromString b of
		      NONE => (warn (); restore)
		    | SOME b => setCtrl'' (enabled, r, fn _ => b)
		fun setBool (r, b) = setBool'' (true, r, b)
		fun incInt r =
		   setCtrl' (r, fn i => i + 1)
	     in
		case Ast.Ann.node ann of
		   Ast.Ann.Ann ["allowConstant", b] =>
		      setBool (allowConstant, b)
		 | Ast.Ann.Ann ["allowExport", b] =>
		      setBool (allowExport, b)
		 | Ast.Ann.Ann ["allowImport", b] =>
		      setBool (allowImport, b)
		 | Ast.Ann.Ann ["allowOverload", b] =>
		      setBool (allowOverload, b)
		 | Ast.Ann.Ann ["allowPrim", b] =>
		      setBool (allowPrim, b)
		 | Ast.Ann.Ann ["allowRebindEquals", b] =>
		      setBool (allowRebindEquals, b)
		 | Ast.Ann.Ann ["deadCode", b] =>
		      setBool'' (!Control.deadCodeAnn, deadCode, b)
		 | Ast.Ann.Ann ["forceUsed"] =>
		      incInt forceUsed
		 | Ast.Ann.Ann ["sequenceUnit", b] =>
		      setBool'' (!Control.sequenceUnitAnn, sequenceUnit, b)
		 | Ast.Ann.Ann ["warnMatch", b] =>
		      setBool'' (!Control.warnMatchAnn, warnMatch, b)
		 | Ast.Ann.Ann ["warnUnused", b] =>
		      setBool'' (!Control.warnUnusedAnn, warnUnused, b)
		 | _ => (warn (); restore)
	     end)
		   
      in
	 DynamicWind.wind (f, restore)
      end
      
end



1.1                  mlton/mlton/elaborate/elaborate-controls.sig

Index: elaborate-controls.sig
===================================================================
(* Copyright (C) 1999-2004 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 ELABORATE_CONTROLS_STRUCTS = 
   sig
      structure Ast: AST
      structure ConstType: CONST_TYPE
      structure CoreML: CORE_ML
   end

signature ELABORATE_CONTROLS = 
   sig
      include ELABORATE_CONTROLS_STRUCTS

      val allowConstant: bool ref
      val allowExport: bool ref
      val allowImport: bool ref
      val allowOverload: bool ref
      val allowPrim: bool ref
      val allowRebindEquals: bool ref
      val deadCode: bool ref
      val forceUsed: int ref
      val lookupConstant: (string * ConstType.t -> CoreML.Const.t) ref
      val sequenceUnit: bool ref
      val warnMatch: bool ref
      val warnUnused: bool ref

      val withDefault: (unit -> 'a) -> 'a
      val withAnns: Ast.Ann.t list * (unit -> 'a) -> 'a
   end



1.1                  mlton/mlton/elaborate/elaborate-mlbs.fun

Index: elaborate-mlbs.fun
===================================================================
(* Copyright (C) 1999-2004 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 ElaborateMLBs (S: ELABORATE_MLBS_STRUCTS): ELABORATE_MLBS = 
struct

open S

local
   open Ast
in
   structure Basid = Basid
   structure Basexp = Basexp
   structure Basdec = Basdec
   structure ModIdBind = ModIdBind
end

local
   open Env
in
   structure Decs = Decs
end

structure ElaboratePrograms = ElaboratePrograms (structure Ast = Ast
						 structure ConstType = ConstType
						 structure CoreML = CoreML
						 structure Ctrls = Ctrls
						 structure Decs = Decs
						 structure Env = Env)

local
   open ElaboratePrograms
in
   structure ConstType = ConstType
   structure Decs = Decs
   structure Env = Env
end

fun elaborateMLB (mlb : Basdec.t, {addPrim}) =
   let
      val decs = Buffer.new {dummy = (Decs.empty, false)}

      val E = Env.empty ()
      val emptySnapshot : (unit -> Env.Basis.t) -> Env.Basis.t = 
	 Env.snapshot E
      val emptySnapshot = fn f =>
	 emptySnapshot (fn () => Ctrls.withDefault f)
	 
      val primBasis =
	 emptySnapshot
	 (fn () =>
	  (#2 o Env.makeBasis)
	  (E, fn () =>
	   let val primDecs = addPrim E
	   in Buffer.add(decs, (primDecs, false))
	   end))

      fun elabProg p = ElaboratePrograms.elaborateProgram (p, {env = E})

      val psi : (OS.FileSys.file_id * Env.Basis.t) HashSet.t =
	 HashSet.new {hash = OS.FileSys.hash o #1}

      val elabBasexpInfo = Trace.info "elabBasexp"
      val elabBasdecInfo = Trace.info "elabBasdec"

      fun elabBasexp (basexp: Basexp.t) : Env.Basis.t option =
	 Trace.traceInfo' (elabBasexpInfo,
			   Basexp.layout,
			   Layout.ignore)
	 (fn (basexp: Basexp.t) =>
	 case Basexp.node basexp of
	    Basexp.Bas basdec => 
	       let
		  val ((), B) =
		     Env.makeBasis (E, fn () => elabBasdec basdec)
       in
		  SOME B
	       end
	  | Basexp.Var basid => Env.lookupBasid (E, basid)
	  | Basexp.Let (basdec, basexp) => 
	       Env.scopeAll
	       (E, fn () =>
		(elabBasdec basdec
		 ; elabBasexp basexp))) basexp
      and elabBasdec (basdec: Basdec.t) : unit =
	 Trace.traceInfo' (elabBasdecInfo,
			   Basdec.layout,
			   Layout.ignore)
	 (fn (basdec: Basdec.t) =>
	 case Basdec.node basdec of
	    Basdec.Defs def =>
	       let
		  fun doit (lookup, extend, bnds) =
		     Vector.foreach
		     (Vector.map
		      (bnds, fn {lhs, rhs} =>
		       {lhs = lhs, rhs = lookup (E, rhs)}),
		      fn {lhs, rhs} =>
		      Option.app (rhs, fn z => extend (E, lhs, z)))
	       in
		  case ModIdBind.node def of
		     ModIdBind.Fct bnds => 
			doit (Env.lookupFctid, Env.extendFctid, bnds)
		   | ModIdBind.Sig bnds => 
			doit (Env.lookupSigid, Env.extendSigid, bnds)
		   | ModIdBind.Str bnds => 
			doit (Env.lookupStrid, Env.extendStrid, bnds)
	       end
	  | Basdec.Basis basbinds => 
	       let
		  val basbinds =
		     Vector.map
		     (basbinds, fn {name, def} =>
		      let
			 val B = elabBasexp def
		      in
			 {B = B, name = name}
		      end)
	       in
		  Vector.foreach
		  (basbinds, fn {name, B, ...} =>
		   Option.app (B, fn B => Env.extendBasid (E, name, B)))
	       end
	  | Basdec.Local (basdec1, basdec2) =>
	       Env.localAll (E,
			     fn () => elabBasdec basdec1,
			     fn () => elabBasdec basdec2)
	  | Basdec.Seq basdecs =>
	       List.foreach(basdecs, elabBasdec)
	  | Basdec.Open basids => 
	       Vector.foreach
	       (Vector.map (basids, fn basid => Env.lookupBasid (E, basid)),
		fn bo => Option.app (bo, fn b => Env.openBasis (E, b)))
	  | Basdec.Prog (_, prog) =>
	       Buffer.add (decs, (elabProg prog, !Ctrls.deadCode))
	  | Basdec.MLB (_, fid, basdec) =>
	       let
		  val fid = valOf fid
		  val (_, B) =
		     HashSet.lookupOrInsert
		     (psi, OS.FileSys.hash fid, fn (fid', _) => 
		      OS.FileSys.compare (fid, fid') = EQUAL, fn () =>
		      let
			 val B =
			    emptySnapshot
			    (fn () =>
			     (#2 o Env.makeBasis) 
			     (E, fn () => elabBasdec basdec))
		      in
			 (fid, B)
		      end)
	       in
		  Env.openBasis (E, B)
	       end
	  | Basdec.Prim => 
	       (if not (!Ctrls.allowPrim)
		   then let open Layout
			in Control.error (Basdec.region basdec, str "_prim disallowed", empty)
			end
		   else ()
		; Env.openBasis (E, primBasis))
	  | Basdec.Ann (anns, basdec) =>
	       let
		  val old = !Ctrls.forceUsed
	       in
		  Ctrls.withAnns 
		  (anns, fn () => 
		   (elabBasdec basdec
		    ; if !Ctrls.forceUsed <> old
			 then Env.forceUsed E
			 else ()))
	       end) basdec
      val _ = Ctrls.withDefault (fn () => elabBasdec mlb)
   in
      (E, Buffer.toVector decs)
   end

end



1.1                  mlton/mlton/elaborate/elaborate-mlbs.sig

Index: elaborate-mlbs.sig
===================================================================
(* Copyright (C) 1999-2004 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 ELABORATE_MLBS_STRUCTS = 
   sig
      structure Ast: AST
      structure ConstType: CONST_TYPE
      structure CoreML: CORE_ML
      structure Ctrls: ELABORATE_CONTROLS
      structure Decs: DECS
      structure Env: ELABORATE_ENV
      sharing Ast = Ctrls.Ast = Env.Ast
      sharing Ast.Tyvar = CoreML.Tyvar
      sharing ConstType = Ctrls.ConstType
      sharing CoreML = Ctrls.CoreML = Decs.CoreML = Env.CoreML
      sharing Decs = Env.Decs
   end

signature ELABORATE_MLBS = 
   sig
      include ELABORATE_MLBS_STRUCTS

      val elaborateMLB:
	 Ast.Basdec.t * {addPrim: Env.t -> Decs.t} -> Env.t * (Decs.t * bool) vector
   end



1.1                  mlton/mlton/elaborate/elaborate-modules.fun

Index: elaborate-modules.fun
===================================================================
(* Copyright (C) 1999-2004 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 ElaborateModules (S: ELABORATE_MODULES_STRUCTS): ELABORATE_MODULES = 
struct

open S

local
   open Ast
in
   structure FctArg = FctArg
   structure Fctid = Fctid
   structure Longstrid = Longstrid
   structure SigConst = SigConst
   structure Sigexp = Sigexp
   structure Strdec = Strdec
   structure Strexp = Strexp
   structure Strid = Strid
   structure Symbol = Symbol
   structure Topdec = Topdec
end

local
   open Env
in
   structure Decs = Decs
   structure FunctorClosure = FunctorClosure
   structure Structure = Structure
end

structure ElaborateSigexp = ElaborateSigexp (structure Ast = Ast
					     structure Env = Env)

structure ElaborateCore = ElaborateCore (structure Ast = Ast
					 structure ConstType = ConstType
					 structure CoreML = CoreML
					 structure Ctrls = Ctrls
					 structure Decs = Decs
					 structure Env = Env)

val elabStrdecInfo = Trace.info "elabStrdec"
val elabTopdecInfo = Trace.info "elabTopdec"

fun elaborateTopdec (topdec, {env = E: Env.t}) =
   let
      fun elabSigexp s = ElaborateSigexp.elaborateSigexp (s, {env = E})
      fun elabSigexpConstraint (cons: SigConst.t,
				S: Structure.t option,
				nest: string list)
	 : Decs.t * Structure.t option =
	 let
	    fun s (sigexp, opaque) =
	       let
		  val prefix =
		     case nest of
			[] => ""
		      | _ => concat (List.fold (nest, [], fn (s, ac) =>
						s :: "." :: ac))
	       in
		  case S of
		     NONE => (Decs.empty, NONE)
		   | SOME S => 
			let
			   val (S, decs) =
			      case elabSigexp sigexp of
				 NONE => (S, Decs.empty)
			       | SOME I => 
				    Env.cut (E, S, I,
					     {isFunctor = false,
					      opaque = opaque,
					      prefix = prefix},
					     Sigexp.region sigexp)
			in
			   (decs, SOME S)
			end
	       end
	 in
	    case cons of
	       SigConst.None => (Decs.empty, S)
	     | SigConst.Opaque sigexp => s (sigexp, true)
	     | SigConst.Transparent sigexp => s (sigexp, false)
	 end	 
      fun elabStrdec (arg: Strdec.t * string list): Decs.t =
	 Trace.traceInfo' (elabStrdecInfo,
			   Layout.tuple2 (Strdec.layout,
					  List.layout String.layout),
			   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, {env = E, nest = nest})
	      | Strdec.Local (d, d') => (* rule 58 *)
		   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) =>
		    Decs.append (decs, elabStrdec d))
	      | Strdec.Structure strbinds => (* rules 57, 61 *)
		   let
		      val strbinds =
			 Vector.map
			 (strbinds, fn {name, def, constraint} =>
			  let
			     val nest = Strid.toString name :: nest
			     val (decs', S) = elabStrexp (def, nest)
			     val (decs'', S) =
				elabSigexpConstraint (constraint, S, nest)
			  in
			     {decs = Decs.append (decs', decs''),
			      name = name,
			      S = S}
			  end)
		      val () =
			 Vector.foreach
			 (strbinds, fn {name, S, ...} =>
			  Option.app (S, fn S => Env.extendStrid (E, name, S)))
		    in
		       Decs.appendsV (Vector.map (strbinds, #decs))
		    end
	  end) arg
      and elabStrexp (e: Strexp.t, nest: string list)
	 : Decs.t * Structure.t option =
	 let
	    val elabStrexp = fn e => elabStrexp (e, nest)
	 in
	    case Strexp.node e of
	       Strexp.App (fctid, strexp) => (* rules 54, 154 *)
		  let
		     val (decs, S) = elabStrexp strexp
		  in
		     case S of
			NONE => (decs, NONE)
		      | SOME S =>
			   case Env.lookupFctid (E, fctid) of
			      NONE => (decs, NONE)
			    | SOME fct  =>
				 let
				    val (S, decs') =
				       Env.cut
				       (E, S,
					FunctorClosure.argInterface fct,
					{isFunctor = true,
					 opaque = false,
					 prefix = ""},
					Strexp.region strexp)
				    val (decs'', S) =
				       FunctorClosure.apply
				       (fct, S, [Fctid.toString fctid])
			   in
			      (Decs.appends [decs, decs', decs''], S)
			   end
		  end
	     | Strexp.Constrained (e, c) => (* rules 52, 53 *)
		  let
		     val (decs, S) = elabStrexp e
		     val (decs', S) = elabSigexpConstraint (c, S, nest)
		  in
		     (Decs.append (decs, decs'), S)
		  end
	     | Strexp.Let (d, e) => (* rule 55 *)
		  Env.scope
		  (E, fn () =>
		   let
		      val decs = elabStrdec (d, nest)
		      val (decs', S) = elabStrexp e
		   in
		      (Decs.append (decs, decs'), S)
		   end)
	     | Strexp.Struct d => (* rule 50 *)
		  let
		     val (decs, S) =
			Env.makeStructure (E, fn () => elabStrdec (d, nest))
		  in
		     (decs, SOME S)
		  end
	     | Strexp.Var p => (* rule 51 *)
		  (Decs.empty, Env.lookupLongstrid (E, p))
	 end
      fun elabFunctor {arg, result, body}: FunctorClosure.t option =
	 let
	    val body = Strexp.constrained (body, result)
	    val (arg, argSig, body, prefix) =
	       case FctArg.node arg of
		  FctArg.Structure (arg, argSig) =>
		     (arg, argSig, body, concat [Strid.toString arg, "."])
		| FctArg.Spec spec =>
		     let
			val strid =
			   Strid.fromSymbol (Symbol.fromString "ZZZNewStridZZZ",
					     Region.bogus)
		     in
			(strid,
			 Sigexp.spec spec,
			 Strexp.lett (Strdec.openn (Vector.new1
						    (Longstrid.short strid)),
				      body),
			 "")
		     end
	 in
	    Option.map (elabSigexp argSig, fn argInt =>
			Env.functorClosure
			(E, prefix, argInt,
			 fn (formal, nest) =>
			 Env.scope (E, fn () =>
				    (Env.extendStrid (E, arg, formal)
				     ; elabStrexp (body, nest)))))
	 end
      fun elabTopdec arg: Decs.t =
	 Trace.traceInfo' (elabTopdecInfo, 
			   Topdec.layout, 
			   Decs.layout)
	 (fn (d: Topdec.t) =>
	  case Topdec.node d of
	     Topdec.BasisDone {ffi} =>
		let
		   val _ =
		      Option.app
		      (Env.lookupLongstrid (E, ffi), fn S =>
		       (Env.Structure.ffi := SOME S
			; Env.Structure.forceUsed S))
		in
		   Decs.empty
		end
	   | Topdec.Signature sigbinds =>
		let
		   val sigbinds =
		      Vector.map
		      (sigbinds, fn (sigid, sigexp) =>
		       (sigid, elabSigexp sigexp))
		   val () =
		      Vector.foreach
		      (sigbinds, fn (sigid, I) =>
		       Option.app (I, fn I => Env.extendSigid (E, sigid, I)))
		in
		   Decs.empty
		end
	   | Topdec.Strdec d => elabStrdec (d, [])
	   | Topdec.Functor funbinds =>
		(* Rules 85, 86. Appendix A, p.58 *)
		let
		   val funbinds =
		      Vector.map
		      (funbinds, fn {arg, body, name, result} =>
		       {closure = elabFunctor {arg = arg,
					       body = body,
					       result = result},
			name = name})
		   val () =
		      Vector.foreach (funbinds, fn {closure, name} =>
				      Option.app
				      (closure, fn closure =>
				       Env.extendFctid (E, name, closure)))
		   (* Check for errors here so that we don't report duplicate
		    * errors when re-elaborating the functor body.
		    *)
		   val () = Control.checkForErrors "elaborate"
		in
		   Decs.empty
		end
		) arg
      val elabTopdec =
	 fn d =>
	 let
	    val res = elabTopdec d
	    val _ = ElaborateCore.reportUndeterminedTypes ()
	 in
	    res
	 end
   in
      elabTopdec topdec
   end
end



1.1                  mlton/mlton/elaborate/elaborate-modules.sig

Index: elaborate-modules.sig
===================================================================
(* Copyright (C) 1999-2004 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 ELABORATE_MODULES_STRUCTS = 
   sig
      structure Ast: AST
      structure ConstType: CONST_TYPE
      structure CoreML: CORE_ML
      structure Ctrls: ELABORATE_CONTROLS
      structure Decs: DECS
      structure Env: ELABORATE_ENV
      sharing Ast = Ctrls.Ast = Env.Ast
      sharing Ast.Tyvar = CoreML.Tyvar
      sharing ConstType = Ctrls.ConstType
      sharing CoreML = Ctrls.CoreML = Decs.CoreML = Env.CoreML
      sharing Decs = Env.Decs
   end

signature ELABORATE_MODULES = 
   sig
      include ELABORATE_MODULES_STRUCTS

      val elaborateTopdec:
	 Ast.Topdec.t * {env: Env.t} -> Decs.t
   end



1.1                  mlton/mlton/elaborate/elaborate-programs.fun

Index: elaborate-programs.fun
===================================================================
(* Copyright (C) 1999-2004 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 ElaboratePrograms (S: ELABORATE_PROGRAMS_STRUCTS): ELABORATE_PROGRAMS = 
struct

open S

structure ElaborateModules = ElaborateModules (structure Ast = Ast
					       structure ConstType = ConstType
					       structure CoreML = CoreML
					       structure Ctrls = Ctrls
					       structure Decs = Decs
					       structure Env = Env)

fun elaborateProgram (program, {env = E: Env.t}) =
   let
      val Ast.Program.T decs = Ast.Program.coalesce program 
      fun elabTopdec d = ElaborateModules.elaborateTopdec (d, {env = E})
   in
      List.fold (decs, Decs.empty, fn (ds, decs) =>
		 List.fold (ds, decs, fn (d, decs) =>
			    Decs.append (decs, elabTopdec d)))
   end

end



1.1                  mlton/mlton/elaborate/elaborate-programs.sig

Index: elaborate-programs.sig
===================================================================
(* Copyright (C) 1999-2004 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 ELABORATE_PROGRAMS_STRUCTS = 
   sig
      structure Ast: AST
      structure ConstType: CONST_TYPE
      structure CoreML: CORE_ML
      structure Ctrls: ELABORATE_CONTROLS
      structure Decs: DECS
      structure Env: ELABORATE_ENV
      sharing Ast = Ctrls.Ast = Env.Ast
      sharing Ast.Tyvar = CoreML.Tyvar
      sharing ConstType = Ctrls.ConstType
      sharing CoreML = Ctrls.CoreML = Decs.CoreML = Env.CoreML
      sharing Decs = Env.Decs
   end

signature ELABORATE_PROGRAMS = 
   sig
      include ELABORATE_PROGRAMS_STRUCTS

      val elaborateProgram:
	 Ast.Program.t * {env: Env.t} -> Decs.t
   end



1.3       +4 -0      mlton/mlton/front-end/.cvsignore

Index: .cvsignore
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/.cvsignore,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- .cvsignore	24 Aug 2001 03:04:32 -0000	1.2
+++ .cvsignore	28 Jul 2004 21:05:14 -0000	1.3
@@ -2,3 +2,7 @@
 ml.grm.sig
 ml.grm.sml
 ml.lex.sml
+mlb.grm.desc
+mlb.grm.sig
+mlb.grm.sml
+mlb.lex.sml



1.2       +11 -1     mlton/mlton/front-end/Makefile

Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/Makefile,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- Makefile	28 Jan 2004 19:24:31 -0000	1.1
+++ Makefile	28 Jul 2004 21:05:14 -0000	1.2
@@ -1,5 +1,5 @@
 .PHONY: all
-all: ml.lex.sml ml.grm.sig ml.grm.sml
+all: ml.lex.sml ml.grm.sig ml.grm.sml mlb.lex.sml mlb.grm.sig mlb.grm.sml
 
 .PHONY: clean
 clean:
@@ -14,3 +14,13 @@
 	rm -f ml.grm.*
 	mlyacc ml.grm
 	chmod -w ml.grm.*
+
+mlb.lex.sml: mlb.lex
+	rm -f mlb.lex.sml
+	mllex mlb.lex
+	chmod -w mlb.lex.sml
+
+mlb.grm.sig mlb.grm.sml: mlb.grm
+	rm -f mlb.grm.*
+	mlyacc mlb.grm
+	chmod -w mlb.grm.*



1.6       +30 -29    mlton/mlton/front-end/front-end.fun

Index: front-end.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/front-end.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- front-end.fun	13 Oct 2003 22:03:06 -0000	1.5
+++ front-end.fun	28 Jul 2004 21:05:14 -0000	1.6
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-1999 NEC Research Institute.
  *
@@ -17,35 +17,36 @@
 			       structure Lex = Lex
 			       structure LrParser = LrParser)
    
-fun lexAndParse (f: File.t) =
+fun lexAndParse (source: Source.t, ins: In.t) =
+   let
+      val stream =
+	 Parse.makeLexer (fn n => In.inputN (ins, n))
+	 {source = source}
+      val lookahead = 30
+      val result =
+	 (#1 (Parse.parse (lookahead, stream, fn (s, left, right) =>
+			   Control.errorStr (Region.make {left = left,
+							  right = right},
+					     s),
+			   ())))
+	 handle _ =>
+	    let
+	       val i = Source.lineStart source
+	       val _ = 
+		  Control.errorStr (Region.make {left = i, right = i},
+				    "parse error")
+	    in
+	       Ast.Program.T []
+	    end
+   in result
+   end
+   
+fun lexAndParseFile (f: File.t) =
    File.withIn
-   (f, fn ins =>
-    let
-       val source = Source.new f
-       val stream =
-	  Parse.makeLexer (fn n => In.inputN (ins, n))
-	  {source = source}
-       val lookahead = 30
-       val result =
-	  (#1 (Parse.parse (lookahead, stream, fn (s, left, right) =>
-			    Control.errorStr (Region.make {left = left,
-							   right = right},
-					      s),
-			    ())))
-	  handle _ =>
-	     let
-		val i = Source.lineStart source
-		val _ = 
-		   Control.errorStr (Region.make {left = i, right = i},
-				     "parse error")
-	     in
-		Ast.Program.T []
-	     end
-    in result
-    end)
+   (f, fn ins => lexAndParse (Source.new f, ins))
 
-val lexAndParse =
-    Trace.trace ("lexAndParse", Layout.ignore, Ast.Program.layout)
-    lexAndParse
+val lexAndParseFile =
+    Trace.trace ("FrontEnd.lexAndParseFile", File.layout, Ast.Program.layout)
+    lexAndParseFile
 
 end



1.4       +2 -2      mlton/mlton/front-end/front-end.sig

Index: front-end.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/front-end.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- front-end.sig	10 Apr 2002 07:02:20 -0000	1.3
+++ front-end.sig	28 Jul 2004 21:05:14 -0000	1.4
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-1999 NEC Research Institute.
  *
@@ -14,5 +14,5 @@
    sig
       include FRONT_END_STRUCTS
 	 
-      val lexAndParse: File.t -> Ast.Program.t
+      val lexAndParseFile: File.t -> Ast.Program.t
    end



1.6       +5 -1      mlton/mlton/front-end/import.cm

Index: import.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/import.cm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- import.cm	23 Jun 2003 04:58:58 -0000	1.5
+++ import.cm	28 Jul 2004 21:05:14 -0000	1.6
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-1999 NEC Research Institute.
  *
@@ -11,14 +11,18 @@
 structure Char
 structure Error
 structure Exn
+structure Dir
 structure File
+structure HashSet
 structure In
 structure Int
 structure IntInf
 structure Layout
 structure List
+structure OS
 structure Out
 structure Pervasive
+structure Promise
 structure Ref
 structure String
 structure StringCvt



1.4       +8 -1      mlton/mlton/front-end/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/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	28 Jul 2004 21:05:15 -0000	1.4
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-1999 NEC Research Institute.
  *
@@ -8,6 +8,7 @@
 Group
 
 functor FrontEnd
+functor MLBFrontEnd
    
 is
 
@@ -24,3 +25,9 @@
 ml.lex.sml
 front-end.sig
 front-end.fun
+
+mlb.grm.sig
+mlb.grm.sml
+mlb.lex.sml
+mlb-front-end.sig
+mlb-front-end.fun



1.1                  mlton/mlton/front-end/mlb-front-end.fun

Index: mlb-front-end.fun
===================================================================
(* Copyright (C) 1999-2004 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 MLBFrontEnd (S: MLB_FRONT_END_STRUCTS): MLB_FRONT_END = 
struct

open S

local
   val lexAndParseProgFail = fn _ => Error.bug "lexAndParseProg"
   val lexAndParseMLBFail = fn _ => Error.bug "lexAndParseMLB"

   val lexAndParseProgRef : (File.t * Region.t -> 
			     File.t * Ast.Program.t) list ref =
      ref [lexAndParseProgFail]
   val lexAndParseMLBRef : (File.t * Region.t -> 
			    File.t * OS.FileSys.file_id option * Ast.Basdec.t) list ref =
      ref [lexAndParseMLBFail]
in
   fun pushLexAndParse (prog, mlb) = 
      (List.push (lexAndParseProgRef, prog)
       ; List.push (lexAndParseMLBRef, mlb))
   fun popLexAndParse () = 
      (ignore (List.pop lexAndParseProgRef)
       ; ignore (List.pop lexAndParseMLBRef))

   val lexAndParseProg = fn f => List.first (!lexAndParseProgRef) f
   val lexAndParseMLB = fn f => List.first (!lexAndParseMLBRef) f
end

structure LrVals = MLBLrValsFun (structure Token = LrParser.Token
			 	 structure Ast = Ast
				 val lexAndParseProg = lexAndParseProg
				 val lexAndParseMLB = lexAndParseMLB)
structure Lex = MLBLexFun (structure Tokens = LrVals.Tokens)
structure Parse = JoinWithArg (structure ParserData = LrVals.ParserData
			       structure Lex = Lex
			       structure LrParser = LrParser)

fun lexAndParse (source: Source.t, ins: In.t) =
   let
      val stream =
	 Parse.makeLexer (fn n => In.inputN (ins, n))
	 {source = source}
      val lookahead = 30
      val result =
	 (#1 (Parse.parse (lookahead, stream, fn (s, left, right) =>
			   Control.errorStr (Region.make {left = left,
							  right = right},
					     s),
			   ())))
	 handle _ =>
	    let
	       val i = Source.lineStart source
	       val _ = 
		  Control.errorStr (Region.make {left = i, right = i},
				    "parse error")
	    in
	       Ast.Basdec.empty
	    end
   in result
   end

fun lexAndParseFile (f: File.t) =
   File.withIn
   (f, fn ins => lexAndParse (Source.new f, ins))

val lexAndParseFile =
    Trace.trace ("MLBFrontEnd.lexAndParseFile", File.layout, Ast.Basdec.layout)
    lexAndParseFile

fun lexAndParseString (s: String.t) =
   let 
      val source = Source.new "<string>"
      val ins = In.openString s
   in lexAndParse (source, ins)
   end

val lexAndParseString =
    Trace.trace ("MLBFrontEnd.lexAndParseString", String.layout, Ast.Basdec.layout)
    lexAndParseString

fun mkLexAndParse () =
   let
      val psi : (OS.FileSys.file_id * Ast.Basdec.t) HashSet.t =
	 HashSet.new {hash = OS.FileSys.hash o #1}

      fun regularize (cwd, relativize, f) =
	 let
	    val f = 
	       let
		  fun loop (s, acc, accs) =
		     case s of
			[] => String.concat (List.rev ((String.fromListRev acc)::accs))
		      | (#"$")::(#"(")::s => 
			   let
			      val accs = (String.fromListRev acc)::accs
			      fun loopVar (s, acc) =
				 case s of
				    [] => Error.bug "regularize"
				  | (#")")::s => (s, String.fromListRev acc)
				  | c::s => loopVar (s, c::acc)
			      val (s, var) = loopVar (s, [])
			   in
			      loop (s, [],
				    case OS.Process.getEnv var of
				       NONE => accs
				     | SOME p => p::accs)
			   end
		      | c::s => loop (s, c::acc, accs)
	       in
		  loop (String.explode f, [], [])
	       end
	    val fa = OS.Path.mkAbsolute {path = f, relativeTo = cwd}
	    val relativize =
	       if OS.Path.isAbsolute f
		  then NONE
		  else relativize
	    val f =
	       case relativize of
		  NONE => fa
		| SOME d => OS.Path.mkRelative {path = fa, relativeTo = d}
	 in
	    (fa, relativize, f)
	 end

      fun lexAndParseProg (cwd: Dir.t, relativize: Dir.t option) 
	                  (f: File.t, r: Region.t) =
	 let
	    val (fa, _, f) = regularize (cwd, relativize, f)
	    fun fail msg =
	       (Control.error
		(r, Layout.seq [Layout.str "file ", Layout.str msg], Layout.empty)
		; (fa, Ast.Program.empty))
	 in
	    if not (File.doesExist f)
	       then fail (concat [f, " does not exist"])
	    else if not (File.canRead f)
	       then fail (concat [f, " cannot be read"])
	    else (fa, FrontEnd.lexAndParseFile f)
	 end

      fun lexAndParseMLB (cwd: Dir.t, 
			  relativize: Dir.t option,
			  seen: (OS.FileSys.file_id * File.t * Region.t) list) 
                         (f: File.t, r: Region.t) =
	 let
	    val (fa, relativize, f) = regularize (cwd, relativize, f)
	    fun fail msg =
	       (Control.error
		(r, Layout.seq [Layout.str "file ", Layout.str msg], Layout.empty)
		; (fa, NONE, Ast.Basdec.empty))
	 in
	    if not (File.doesExist f)
	       then fail (concat [f, " does not exist"])
	    else if not (File.canRead f)
	       then fail (concat [f, " cannot be read"])
            else 
	       let
		  val fid = OS.FileSys.fileId fa
		  val seen' = (fid, f, r)::seen
	       in
		  if List.exists (seen, fn (fid', _, _) => OS.FileSys.compare (fid, fid') = EQUAL)
		     then (let open Layout
			   in 
			      Control.error 
			      (r, seq [str "Basis forms a cycle with ", File.layout f],
			       align (List.map (seen', fn (_, f, r) => 
						seq [Region.layout r, str ": ", File.layout f])))
			      ; (fa, SOME fid, Ast.Basdec.empty)
			   end)
		     else 
			let
			   val (_, basdec) =
			      HashSet.lookupOrInsert
			      (psi, OS.FileSys.hash fid, fn (fid', _) => 
			       OS.FileSys.compare (fid, fid') = EQUAL, fn () =>
			       let
				  val cwd = OS.Path.dir fa
				  val basdec =
				     wrapLexAndParse
				     (cwd, relativize, seen')
				     (lexAndParseFile, f)
			       in
				  (fid, basdec)
			       end)
			in
			   (fa, SOME fid, basdec)
			end
	       end
	 end

      and wrapLexAndParse (cwd, relativize, seen) (lexAndParse, arg) =
	 let
	    val () = 
	       pushLexAndParse 
	       (lexAndParseProg (cwd, relativize),
		lexAndParseMLB (cwd, relativize, seen))
	    val basdec = lexAndParse arg
	    val () = popLexAndParse ()
	 in
	    basdec
	 end

      val cwd = Dir.current ()
      val relativize = SOME cwd
      val lexAndParseFile = fn (f: File.t) =>
	 #3 (lexAndParseMLB (cwd, relativize, []) (f, Region.bogus))
      val lexAndParseString = fn (s: String.t) => 
	 wrapLexAndParse (cwd, relativize, []) (lexAndParseString, s)
   in
      (lexAndParseFile, lexAndParseString)
   end

val lexAndParseFile = fn (f: File.t) =>
   (#1 (mkLexAndParse ())) f
val lexAndParseString = fn (s: String.t) =>
   (#2 (mkLexAndParse ())) s

end



1.1                  mlton/mlton/front-end/mlb-front-end.sig

Index: mlb-front-end.sig
===================================================================
(* Copyright (C) 1999-2004 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 MLB_FRONT_END_STRUCTS = 
   sig
      structure Ast: AST
      structure FrontEnd: FRONT_END
      sharing Ast = FrontEnd.Ast
   end

signature MLB_FRONT_END = 
   sig
      include MLB_FRONT_END_STRUCTS
	 
      val lexAndParseFile: File.t -> Ast.Basdec.t
      val lexAndParseString: String.t -> Ast.Basdec.t
   end



1.1                  mlton/mlton/front-end/mlb.grm

Index: mlb.grm
===================================================================
(* Copyright (C) 1999-2004 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

fun reg (left, right) = Region.make {left = left, right = right}
fun error (reg, msg) = Control.error (reg, Layout.str msg, Layout.empty)

open Ast

fun reportDuplicates (v: 'a vector,
		      name: string,
		      equals: 'a * 'a -> bool,
		      layout: 'a -> Layout.t,
		      region: 'a -> Region.t) =
   Vector.foreachi
   (v, fn (i, a) =>
    let
       fun loop i' =
	  if i = i'
	     then ()
	  else if equals (a, Vector.sub (v, i'))
		  then 
		     let
			open Layout
		     in
			Control.error
			(region a,
			 seq [str (concat ["duplicate ", name, ": "]), layout a],
			 empty)
		     end
	       else loop (i' + 1)
    in
       loop 0
    end)

type fctbinds = {lhs: Fctid.t, rhs: Fctid.t} list
type sigbinds = {lhs: Sigid.t, rhs: Sigid.t} list
type strbinds = {lhs: Strid.t, rhs: Strid.t} list

type basbinds = {name: Basid.t, def: Basexp.t} list

  %%
%term
      ID of string | COMMA | SEMICOLON | EOF
    | AND | BAS | BASIS | END | EQUALOP | FUNCTOR | IN | LET 
    | LOCAL | OPEN | SIGNATURE | STRUCTURE
    | ANN | PRIM | FILE of string

%nonterm
	 ann of string list
       | anns of Ann.t list
       | anns' of Ann.t list
       | basbinds of basbinds
       | basbinds' of Basexp.t * basbinds
       | basbinds'' of basbinds
       | basdec of Basdec.t
       | basdecnode of Basdec.node
       | basdecs of Basdec.t
       | basdecsnode of Basdec.node 
       | basexp of Basexp.t
       | basexpnode of Basexp.node
       | basid of Basid.t
       | basids of Basid.t list
       | fctbinds of fctbinds
       | fctbinds' of Fctid.t * fctbinds
       | fctbinds'' of fctbinds
       | fctid of Fctid.t
       | id of Symbol.t * Region.t
       | mlb of Basdec.t
       | sigbinds of sigbinds
       | sigbinds' of Sigid.t * sigbinds
       | sigbinds'' of sigbinds
       | sigid of Sigid.t
       | strbinds of strbinds
       | strbinds' of Strid.t * strbinds
       | strbinds'' of strbinds
       | strid of Strid.t

%verbose
%pos SourcePos.t
%eop EOF
%noshift EOF

%header (functor MLBLrValsFun (structure Token: TOKEN
                               structure Ast: AST
			       val lexAndParseProg: File.t * Region.t -> 
                                                    File.t * Ast.Program.t
			       val lexAndParseMLB: File.t * Region.t -> 
                                                   File.t * OS.FileSys.file_id option * Ast.Basdec.t))

%right AND

%name MLB

%keyword AND BAS BASIS END FUNCTOR IN LET LOCAL OPEN SIGNATURE STRUCTURE ANN PRIM

%change -> SEMICOLON | -> IN ID END

%value ID ("bogus")

%%

mlb : basdecs (basdecs)


basdecs : basdecsnode (Basdec.makeRegion' 
                       (basdecsnode, basdecsnodeleft, basdecsnoderight))

basdecsnode :                    (Basdec.Seq [])
            | SEMICOLON basdecs  (Basdec.Seq [basdecs])
            | basdec basdecs     (Basdec.Seq [basdec, basdecs])

basdec : basdecnode (Basdec.makeRegion'
                     (basdecnode, basdecnodeleft, basdecnoderight))

basdecnode
   : FUNCTOR fctbinds
     (let
         val fctbinds = Vector.fromList fctbinds
         val _ =
            reportDuplicates
            (fctbinds,
             "functor definition",
             fn ({lhs = n, ...}, {lhs = n', ...}) => Fctid.equals (n, n'),
             Fctid.layout o #lhs,
             Fctid.region o #lhs)
      in
         Basdec.Defs (ModIdBind.makeRegion' (ModIdBind.Fct fctbinds, FUNCTORleft, fctbindsright))
      end)
   | SIGNATURE sigbinds
     (let
         val sigbinds = Vector.fromList sigbinds
         val _ =
            reportDuplicates
            (sigbinds,
             "signature definition",
             fn ({lhs = n, ...}, {lhs = n', ...}) => Sigid.equals (n, n'),
             Sigid.layout o #lhs,
             Sigid.region o #lhs)
      in
         Basdec.Defs (ModIdBind.makeRegion' (ModIdBind.Sig sigbinds, SIGNATUREleft, sigbindsright))
      end)
   | STRUCTURE strbinds
     (let
         val strbinds = Vector.fromList strbinds
         val _ =
            reportDuplicates
            (strbinds,
             "structure definition",
             fn ({lhs = n, ...}, {lhs = n', ...}) => Strid.equals (n, n'),
             Strid.layout o #lhs,
             Strid.region o #lhs)
      in
         Basdec.Defs (ModIdBind.makeRegion' (ModIdBind.Str strbinds, STRUCTUREleft, strbindsright))
      end)
   | BASIS basbinds
     (let
         val basbinds = Vector.fromList basbinds
         val _ =
            reportDuplicates
            (basbinds,
             "basis definition",
             fn ({name = n, ...}, {name = n', ...}) => Basid.equals (n, n'),
             Basid.layout o #name,
             Basid.region o #name)
      in
         Basdec.Basis basbinds
      end)
   | LOCAL basdecs IN basdecs END  (Basdec.Local (basdecs1, basdecs2))
   | OPEN basids  (Basdec.Open (Vector.fromList basids))
   | FILE
     (let
	 val reg = reg (FILEleft, FILEright)
         fun err () =
	    (error (reg, "MLton can't process")
             ; Basdec.Seq [])
         val mlbExts = ["mlb"]
         val progExts = ["ML","fun","sig","sml"]
      in
         case File.extension FILE of
	    SOME s =>
	       if List.contains (mlbExts, s, String.equals)
		  then Basdec.MLB (lexAndParseMLB (FILE, reg))
	       else if List.contains (progExts, s, String.equals)
		  then Basdec.Prog (lexAndParseProg (FILE, reg))
	       else err ()
	  | NONE => err ()
      end)
   | PRIM (Basdec.Prim)
   | ANN anns IN basdecs END  (Basdec.Ann (anns, basdecs))

fctbinds : fctid EQUALOP fctbinds'
           (let val (def, fctbinds) = fctbinds'
            in {lhs = fctid, rhs = def}
               :: fctbinds
            end)
         | fctid fctbinds''
           ({lhs = fctid, rhs = fctid} :: fctbinds'')

fctbinds' : fctid fctbinds''  (fctid, fctbinds'')

fctbinds'' :               ([])
           | AND fctbinds  (fctbinds)

sigbinds : sigid EQUALOP sigbinds'
           (let val (def, sigbinds) = sigbinds'
            in {lhs = sigid, rhs = def}
               :: sigbinds
            end)
         | sigid sigbinds''
           ({lhs = sigid, rhs = sigid} :: sigbinds'')

sigbinds' : sigid sigbinds''  (sigid, sigbinds'')

sigbinds'' :               ([])
           | AND sigbinds  (sigbinds)

strbinds : strid EQUALOP strbinds'
           (let val (def, strbinds) = strbinds'
            in {lhs = strid, rhs = def}
               :: strbinds
            end)
         | strid strbinds''
           ({lhs = strid, rhs = strid} :: strbinds'')

strbinds' : strid strbinds''  (strid, strbinds'')

strbinds'' :               ([])
           | AND strbinds  (strbinds)

basbinds : basid EQUALOP basbinds'
           (let val (def, basbinds) = basbinds'
            in {name = basid, def = def}
               :: basbinds
            end)

basbinds' : basexp basbinds''  (basexp, basbinds'')

basbinds'' :               ([])
           | AND basbinds  (basbinds)


basexp : basexpnode (Basexp.makeRegion'
                     (basexpnode, basexpnodeleft, basexpnoderight))

basexpnode : BAS basdecs END           (Basexp.Bas basdecs)
           | basid                     (Basexp.Var basid)
           | LET basdec IN basexp END  (Basexp.Let (basdec, basexp))

basid : id  (Basid.fromSymbol id)
basids : basid ([basid])
       | basid basids (basid :: basids)
fctid : id  (Fctid.fromSymbol id)
sigid : id  (Sigid.fromSymbol id)
strid : id  (Strid.fromSymbol id)
id : ID     (Symbol.fromString ID, reg (IDleft, IDright))

anns : ann anns'  ((Ann.makeRegion' (Ann.Ann ann, annleft, annright))::anns')

anns' :             ([])
      | COMMA anns  (anns)

ann :         ([]) 
    | ID ann  (ID::ann)


1.1                  mlton/mlton/front-end/mlb.lex

Index: mlb.lex
===================================================================
type int = Int.t
   
type svalue = Tokens.svalue
type pos = SourcePos.t
type lexresult = (svalue, pos) Tokens.token
type lexarg = {source: Source.t}
type arg = lexarg
type ('a,'b) token = ('a,'b) Tokens.token

val charlist: string list ref = ref []
val colNum: int ref = ref 0
val commentLevel: int ref = ref 0
val commentStart = ref SourcePos.bogus
val lineFile: File.t ref = ref ""
val lineNum: int ref = ref 0

fun lineDirective (source, file, yypos) =
   Source.lineDirective (source, file,
			 {lineNum = !lineNum,
			  lineStart = yypos - !colNum})

fun inc (ri as ref (i: int)) = (ri := i + 1)
fun dec (ri as ref (i: int)) = (ri := i-1)

fun error (source, left, right, msg) = 
   Control.errorStr (Region.make {left = Source.getPos (source, left),
				  right = Source.getPos (source, right)},
		     msg)

val eof: lexarg -> lexresult =
   fn {source, ...} =>
   let
      val pos = Source.lineStart source
      val _ =
	 if !commentLevel > 0
	    then Control.errorStr (Region.make {left = !commentStart,
						right = pos},
				   "unclosed comment")
	 else ()
   in
      Tokens.EOF (pos, pos)
   end

val size = String.size

fun tok (t, s, l, r) =
   let
      val l = Source.getPos (s, l)
      val r = Source.getPos (s, r)
      val _ =
	 if true
	    then ()
	 else
	    print (concat ["tok (",
			   SourcePos.toString l,
			   ", " ,
			   SourcePos.toString r,
			   ")\n"])
   in
      t (l, r)
   end

fun tok' (t, x, s, l) = tok (fn (l, r) => t (x, l, r), s, l, l + size x)

%% 
%reject
%s A L LL LLC LLCQ;
%header (functor MLBLexFun (structure Tokens : MLB_TOKENS));
%arg ({source});
alphanum=[A-Za-z'_0-9]*;
alphanumId=[A-Za-z]{alphanum};
id={alphanumId};
envvar="$("([A-Z_]+)")";
filebase=[-A-Za-z_0-9]+;
fileext=[-A-Za-z_0-9]+;
filename={filebase}("."{fileext})*;
arc=({envvar}|{filename}|"."|"..");
relpath=({arc}"/")*;
abspath="/"{relpath};
path={relpath}|{abspath};
file={path}{filename};
ws=("\012"|[\t\ ])*;
nrws=("\012"|[\t\ ])+;
cr="\013";
nl="\010";
eol=({cr}{nl}|{nl}|{cr});

%%
<INITIAL>{ws}	=> (continue ());
<INITIAL>{eol}	=> (Source.newline (source, yypos); continue ());

<INITIAL>","	=> (tok (Tokens.COMMA, source, yypos, yypos + 1));
<INITIAL>";"	=> (tok (Tokens.SEMICOLON, source, yypos, yypos + 1));
<INITIAL>"=" => (tok (Tokens.EQUALOP, source, yypos, yypos + 1));
<INITIAL>"ann" => (tok (Tokens.ANN, source, yypos, yypos + 3));
<INITIAL>"and" => (tok (Tokens.AND, source, yypos, yypos + 3));
<INITIAL>"bas" => (tok (Tokens.BAS, source, yypos, yypos + 3));
<INITIAL>"basis" => (tok (Tokens.BASIS, source, yypos, yypos + 5));
<INITIAL>"end" => (tok (Tokens.END, source, yypos, yypos + 3));
<INITIAL>"functor" => (tok (Tokens.FUNCTOR, source, yypos, yypos + 7));
<INITIAL>"in" => (tok (Tokens.IN, source, yypos, yypos + 2));
<INITIAL>"let" => (tok (Tokens.LET, source, yypos, yypos + 3));
<INITIAL>"local" => (tok (Tokens.LOCAL, source, yypos, yypos + 5));
<INITIAL>"open" => (tok (Tokens.OPEN, source, yypos, yypos + 4));
<INITIAL>"_prim" => (tok (Tokens.PRIM, source, yypos, yypos + 4));
<INITIAL>"signature" => (tok (Tokens.SIGNATURE, source, yypos, yypos + 9));
<INITIAL>"structure" => (tok (Tokens.STRUCTURE, source, yypos, yypos + 9));
<INITIAL>{id} => (tok' (Tokens.ID, yytext, source, yypos));
<INITIAL>{file} => (tok' (Tokens.FILE, yytext, source, yypos));

<INITIAL>"(*#line"{nrws}
                => (YYBEGIN L
		    ; commentStart := Source.getPos (source, yypos)
		    ; commentLevel := 1
		    ; continue ());
<INITIAL>"(*"	=> (YYBEGIN A
                    ; commentLevel := 1
                    ; commentStart := Source.getPos (source, yypos)
                    ; continue ());
<INITIAL>.	=> (error (source, yypos, yypos + 1, "illegal token") ;
		    continue ());

<L>[0-9]+       => (YYBEGIN LL
                    ; (lineNum := valOf (Int.fromString yytext)
                       ; colNum := 1)
                      handle Overflow => YYBEGIN A
                    ; continue ());
<LL>\.          => ((* cheat: take n > 0 dots *) continue ());
<LL>[0-9]+      => (YYBEGIN LLC
		    ; (colNum := valOf (Int.fromString yytext))
		      handle Overflow => YYBEGIN A
	            ; continue ());
<LL>.          => (YYBEGIN LLC; continue ()
		(* note hack, since ml-lex chokes on the empty string for 0* *));
<LLC>"*)"       => (YYBEGIN INITIAL
		    ; lineDirective (source, NONE, yypos + 2)
		    ; commentLevel := 0; charlist := []; continue ());
<LLC>{ws}\"	=> (YYBEGIN LLCQ; continue ());
<LLCQ>[^\"]*    => (lineFile := yytext; continue ());
<LLCQ>\""*)"    => (YYBEGIN INITIAL
                    ; lineDirective (source, SOME (!lineFile), yypos + 3)
                    ; commentLevel := 0; charlist := []; continue ());
<L,LLC,LLCQ>"*)" => (YYBEGIN INITIAL; commentLevel := 0; charlist := []; continue ());
<L,LLC,LLCQ>.   => (YYBEGIN A; continue ());

<A>"(*"		=> (inc commentLevel; continue ());
<A>\n		=> (Source.newline (source, yypos) ; continue ());
<A>"*)"         => (dec commentLevel
		    ; if 0 = !commentLevel then YYBEGIN INITIAL else ()
		    ; continue ());
<A>.		=> (continue ());



1.35      +154 -209  mlton/mlton/main/compile.fun

Index: compile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.fun,v
retrieving revision 1.34
retrieving revision 1.35
diff -u -r1.34 -r1.35
--- compile.fun	11 Jun 2004 02:48:56 -0000	1.34
+++ compile.fun	28 Jul 2004 21:05:15 -0000	1.35
@@ -78,6 +78,8 @@
 (*---------------------------------------------------*)
 
 structure FrontEnd = FrontEnd (structure Ast = Ast)
+structure MLBFrontEnd = MLBFrontEnd (structure Ast = Ast
+				     structure FrontEnd = FrontEnd)
 structure DeadCode = DeadCode (structure CoreML = CoreML)
 structure Defunctorize = Defunctorize (structure CoreML = CoreML
 				       structure Xml = Xml)
@@ -89,6 +91,7 @@
 in
    structure ConstType = ConstType
    structure Env = Env
+   structure Decs = Decs
 end
 structure LookupConstant = LookupConstant (structure Const = Const
 					   structure ConstType = ConstType
@@ -109,59 +112,31 @@
 structure x86Codegen = x86Codegen (structure CCodegen = CCodegen
 				   structure Machine = Machine)
 
-local
-   open Elaborate
-in 
-   structure Decs = Decs
-end
-   
+
 (* ------------------------------------------------- *)
-(*                 parseAndElaborate                 *)
+(*                 Lookup Constant                   *)
 (* ------------------------------------------------- *)
 
-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 =
+val allConstants: (string * ConstType.t) list ref = ref []
+val amBuildingConstants: bool ref = ref false
+   
+val lookupConstant =
    let
-      val decs = elaborate z
-      val _ = Control.checkForErrors "elaborate"
+      val zero = Const.word (WordX.fromIntInf (0, WordSize.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
-      decs
+      fn z => f () z
    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                   *)
@@ -172,7 +147,7 @@
    structure Tycon = TypeEnv.Tycon
    structure Type = TypeEnv.Type
    structure Tyvar = TypeEnv.Tyvar
-in
+
    val primitiveDatatypes =
       Vector.new3
       ({tycon = Tycon.bool,
@@ -283,180 +258,115 @@
 	       ()
 	    end
       end
+
+   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
+
+in
+
+   fun addPrim E =
+      (Env.addPrim E
+       ; Decs.fromVector primitiveDecs)
 end
 
+
 (* ------------------------------------------------- *)
-(*                   Basis Library                   *)
+(*                 parseAndElaborateMLB              *)
 (* ------------------------------------------------- *)
 
-val basisEnv = Env.empty ()
-
-val allConstants: (string * ConstType.t) list ref = ref []
-
-val amBuildingConstants: bool ref = ref false
-   
-val lookupConstant =
-   let
-      val zero = Const.word (WordX.fromIntInf (0, WordSize.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
+datatype input = File of File.t | String of String.t
 
 local
-   val dir = ref NONE
+   val (lexAndParseMLBFile, lexAndParseMLBFileMsg) =
+      Control.traceBatch (Control.Pass, "lex and parse (mlb)") MLBFrontEnd.lexAndParseFile
+   val (lexAndParseMLBString, lexAndParseMLBStringMsg) =
+      Control.traceBatch (Control.Pass, "lex and parse (mlb)") MLBFrontEnd.lexAndParseString
+      
+   val lexAndParseMLBMsgRef = ref lexAndParseMLBFileMsg
 in
-   fun setBasisLibraryDir (d: Dir.t): unit =
-      dir := SOME d
-   fun basisLibrary ()
-      : {build: Decs.t,
-	 localTopFinish: (unit -> Decs.t) -> Decs.t,
-	 libs: {name: string,
-		bind: 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))))
-	  fun doit name =
-	    let
-	      fun libFile f = libsFile (String./ (name, f))
-	      val bind = withFiles (libFile "bind", lexAndParseFiles)
-	    in
-	      {name = name,
-	       bind = bind}
-	    end
-       in
-	  {build = build,
-	   localTopFinish = localTopFinish,
-	   libs = List.map (Control.basisLibs, doit)}
-       end
+   fun lexAndParseMLB fs =
+      case fs of
+	 File f => (lexAndParseMLBMsgRef := lexAndParseMLBFileMsg
+		    ; lexAndParseMLBFile f)
+       | String s => (lexAndParseMLBMsgRef := lexAndParseMLBStringMsg
+		      ; lexAndParseMLBString s)
+   fun lexAndParseMLBMsg () =
+      (!lexAndParseMLBMsgRef) ()
 end
 
-val basisLibrary = Promise.lazy basisLibrary
-    
-fun forceBasisLibrary d =
-   (setBasisLibraryDir d
-    ; ignore (basisLibrary ())
-    ; ())
-
-val primitiveDecs: CoreML.Dec.t vector =
+val lexAndParseMLB : input -> Ast.Basdec.t = fn (fs: input) => 
    let
-      open CoreML.Dec
-   in
-      Vector.concat [Vector.new1 (Datatype primitiveDatatypes),
-		     Vector.fromListMap
-		     (primitiveExcons, fn c =>
-		      Exception {con = c, arg = NONE})]
+      val ast = lexAndParseMLB fs
+      val _ = Control.checkForErrors "parse"
+   in ast
    end
 
+val (elaborateMLB, elaborateMLBMsg) =
+   Control.traceBatch (Control.Pass, "elaborate") Elaborate.elaborateMLB
+
+val displayEnvDecs =
+   Control.Layout
+   (fn (_, ds) => 
+    Vector.layout
+    (fn (d, b) =>
+     Layout.record
+     [("deadCode", Bool.layout b),
+      ("decs", Decs.layout d)])
+    ds)
+fun parseAndElaborateMLB (fs: input): Env.t * (Decs.t * bool) vector =
+   Control.pass
+   {name = "parseAndElaborate",
+    suffix = "core-ml",
+    style = Control.ML,
+    thunk = fn () => 
+    Ref.fluidLet
+    (Elaborate.Ctrls.lookupConstant, lookupConstant, fn () =>
+     elaborateMLB (lexAndParseMLB fs, {addPrim = addPrim})),
+    display = displayEnvDecs}
+   
+(* ------------------------------------------------- *)
+(*                   Basis Library                   *)
+(* ------------------------------------------------- *)
+
 fun outputBasisConstants (out: Out.t): unit =
    let
       val _ = amBuildingConstants := true
-      val {build, ...} = basisLibrary ()
+      val (_, decs) = parseAndElaborateMLB (File "$(SML_LIB)/basis/libs/primitive.mlb")
+      val decs = Vector.map (decs, fn (decs, _) => Decs.toList decs)
+      val decs = Vector.concatV (Vector.map (decs, Vector.fromList))
       (* Need to defunctorize so the constants are forced. *)
       val _ =
 	 Defunctorize.defunctorize
-	 (CoreML.Program.T {decs = Vector.concat [primitiveDecs,
-						  Decs.toVector build]})
+	 (CoreML.Program.T {decs = decs})
       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, ...} =>
-	   let
-	     val bind = 
-	        localTopFinish 
-		(fn () =>
-		 elaborateProg (bind, basisEnv, lookupConstantError))
-	   in
-	     {basis = Decs.append (build, bind)}
-	   end
-   end
-
 (* ------------------------------------------------- *)
 (*                      compile                      *)
 (* ------------------------------------------------- *)
 
 exception Done
 
-fun elaborate {input: File.t list}: Xml.Program.t =
+fun elaborate {input: input}: Xml.Program.t =
    let
-      val {basis, ...} = selectBasisLibrary ()
+      val (E, decs) = parseAndElaborateMLB input
       val _ =
-	 if List.isEmpty input
-	    then ()
-	 else Env.clearDefUses basisEnv
-      val input =
-	 Env.scopeAll
-	 (basisEnv, fn () =>
-	  let
-	     val res = parseAndElaborateFiles (input, basisEnv,
-					       lookupConstantError)
-	     val _ =
-		case !Control.showBasis of
-		   NONE => ()
-		 | SOME f => 
-		      let
-			 val lay =
-			    if List.isEmpty input
-			       then Env.layout basisEnv
-			    else Env.layoutCurrentScope basisEnv
-		      in
-			 File.withOut (f, fn out => Layout.outputl (lay, out))
-		      end
-	     val _ =
-		if isSome (!Control.showDefUse) orelse !Control.warnUnused
-		   then Env.processDefUse basisEnv
-		else ()
-	  in
-	     res
-	  end)
-      val _ = 
-	 case !Control.showBasisUsed of
+	 case !Control.showBasis of
 	    NONE => ()
-	  | SOME f => 
-	       File.withOut (f, fn out =>
-			     Layout.outputl (Env.layoutUsed basisEnv, out))
+	  | SOME f =>
+	       File.withOut
+	       (f, fn out =>
+		Layout.outputl (Env.layoutCurrentScope E, out))
+      val _ = Env.processDefUse E
       val _ =
 	 case !Control.exportHeader of
 	    NONE => ()
@@ -473,25 +383,25 @@
 		in
 		   ()
 		end)
-      val _ = (lexAndParseMsg (); elaborateMsg ())
+      val _ = (lexAndParseMLBMsg (); elaborateMLBMsg ())
       val _ = if !Control.elaborateOnly then raise Done else ()
-      val user = Decs.toList input
-      val basis = Decs.toList basis
-      val basis =
-	 if !Control.deadCode
-	    then
-	       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)}
-	 else basis
+
       val decs =
-	 Vector.concat [primitiveDecs,
-			Vector.fromList basis,
-			Vector.fromList user]
+	 Control.pass
+	 {name = "deadCode",
+	  suffix = "basis",
+	  style = Control.ML,
+	  thunk = fn () => let
+			      val decs = 
+				 Vector.map (decs, fn (decs, b) => 
+					     (Decs.toList decs, b))
+			      val {prog = decs} =
+				 DeadCode.deadCode {prog = decs}
+			   in
+			      decs
+			   end,
+	  display = Control.Layout (Vector.layout (List.layout CoreML.Dec.layout))}
+      val decs = Vector.concatV (Vector.map (decs, Vector.fromList))
       val coreML = CoreML.Program.T {decs = decs}
 (*
       val _ = Control.message (Control.Detail, fn () =>
@@ -620,7 +530,7 @@
       machine
    end
  
-fun compile {input: File.t list, outputC, outputS}: unit =
+fun compile {input: input, outputC, outputS}: unit =
    let
       val machine =
 	 Control.trace (Control.Top, "pre codegen")
@@ -648,9 +558,44 @@
       ()
    end handle Done => ()
 
-val elaborate =
-   fn {input: File.t list} =>
-   (ignore (elaborate {input = input}))
+fun compileMLB {input: File.t, outputC, outputS}: unit =
+   compile {input = File input,
+	    outputC = outputC,
+	    outputS = outputS}
+
+val elaborateMLB =
+   fn {input: File.t} =>
+   (ignore (elaborate {input = File input}))
    handle Done => ()
+
+local
+   fun genMLB {input: File.t list} =
+      let
+	 val basis =
+	    String.concat
+	    ["$(SML_LIB)/basis/",!Control.basisLibrary,".mlb\n"]
+	 val s =
+	    if List.length input = 0
+	       then basis
+	       else 
+		  String.concat
+		  ["local\n",
+		   basis,
+		   "in\n",
+		   String.concat (List.separate(input, "\n")), "\n",
+		   "end\n"]
+      in
+	 String s
+      end
+in
+   fun compileSML {input: File.t list, outputC, outputS}: unit =
+      compile {input = genMLB {input = input},
+	       outputC = outputC,
+	       outputS = outputS}
+   val elaborateSML =
+      fn {input: File.t list} =>
+      (ignore (elaborate {input = genMLB {input = input}}))
+      handle Done => ()
+end
 
 end



1.14      +17 -11    mlton/mlton/main/compile.sig

Index: compile.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.sig,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- compile.sig	28 Apr 2004 03:17:06 -0000	1.13
+++ compile.sig	28 Jul 2004 21:05:15 -0000	1.14
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-1999 NEC Research Institute.
  *
@@ -14,16 +14,22 @@
    sig
       include COMPILE_STRUCTS
 
-      val compile: {input: File.t list,
-		    outputC: unit -> {file: File.t,
-				      print: string -> unit,
-				      done: unit -> unit},
-		    outputS: unit -> {file: File.t,
-				      print: string -> unit,
-				      done: unit -> unit}} -> unit
-      val elaborate: {input: File.t list} -> unit
-      val forceBasisLibrary: Dir.t -> unit
+      val compileMLB: {input: File.t,
+		       outputC: unit -> {file: File.t,
+					 print: string -> unit,
+					 done: unit -> unit},
+		       outputS: unit -> {file: File.t,
+					 print: string -> unit,
+					 done: unit -> unit}} -> unit
+      val compileSML: {input: File.t list,
+		       outputC: unit -> {file: File.t,
+					 print: string -> unit,
+					 done: unit -> unit},
+		       outputS: unit -> {file: File.t,
+					 print: string -> unit,
+					 done: unit -> unit}} -> unit
+      val elaborateMLB: {input: File.t} -> unit
+      val elaborateSML: {input: File.t list} -> unit
       (* output a C file to print out the basis constants. *)
       val outputBasisConstants: Out.t -> unit
-      val setBasisLibraryDir: Dir.t -> unit
    end



1.47      +112 -49   mlton/mlton/main/main.fun

Index: main.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.fun,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -r1.46 -r1.47
--- main.fun	8 Jul 2004 17:51:45 -0000	1.46
+++ main.fun	28 Jul 2004 21:05:15 -0000	1.47
@@ -15,21 +15,23 @@
 
 structure Place =
    struct
-      datatype t = CM | Files | Generated | O | OUT | SML | TypeCheck
+      datatype t = CM | Files | Generated | MLB | O | OUT | SML | TypeCheck
 
       val toInt: t -> int =
 	 fn CM => 0
-	  | Files => 1
-	  | SML => 2
-	  | TypeCheck => 3
-	  | Generated => 4
-	  | O => 5
-	  | OUT => 6
+	  | MLB => 1
+	  | Files => 2
+	  | SML => 3
+	  | TypeCheck => 4
+	  | Generated => 5
+	  | O => 6
+	  | OUT => 7
 
       val toString =
 	 fn CM => "cm"
 	  | Files => "files"
 	  | SML => "sml"
+	  | MLB => "mlb"
 	  | Generated => "g"
 	  | O => "o"
 	  | OUT => "out"
@@ -58,7 +60,6 @@
 val profileSet: bool ref = ref false
 val runtimeArgs: string list ref = ref ["@MLton"]
 val stop = ref Place.OUT
-val warnMatch = ref true
 
 val targetMap: unit -> {arch: MLton.Platform.Arch.t,
 			os: MLton.Platform.OS.t,
@@ -161,22 +162,34 @@
 	"contify functions into main",
 	boolRef contifyIntoMain),
        (Expert, "dead-code", " {true|false}",
-	"basis library dead code elimination",
-	boolRef deadCode),
+	"annotated dead code elimination",
+	Bool (fn b =>
+	      (warnDeprecated "dead-code"
+	       ; deadCodeAnn := b))),
        (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 (diagPasses, re)
-					   ; List.push (keepPasses, re)
-					end
-		       | NONE => usage (concat ["invalid -diag-pass flag: ", s])))),
+	SpaceString 
+	(fn s =>
+	 (case Regexp.fromString s of
+	     SOME (re,_) => let val re = Regexp.compileDFA re
+			    in 
+			       List.push (diagPasses, re)
+			       ; List.push (keepPasses, re)
+			    end
+	   | NONE => usage (concat ["invalid -diag-pass flag: ", s])))),
+       (Expert, "disable-ann", " <ann>", "globally disable annotation",
+	SpaceString 
+	(fn s =>
+	 (case s of
+	     "deadCode" => deadCodeAnn := false
+	   | "sequenceUnit" => sequenceUnitAnn := false
+	   | "warnMatch" => warnMatchAnn := false
+	   | "warnUnused" => warnUnusedAnn := false
+	   | _ => usage (concat ["invalid -disable-ann flag: ", s])))),
        (Expert, "drop-pass", " <pass>", "omit optimization pass",
 	SpaceString
 	(fn s => (case Regexp.fromString s of
@@ -187,6 +200,15 @@
        (Expert, "eliminate-overflow", " {true|false}",
 	"eliminate useless overflow tests",
 	boolRef eliminateOverflow),
+       (Expert, "enable-ann", " <ann>", "globally enable annotation",
+	SpaceString 
+	(fn s =>
+	 (case s of
+	     "deadCode" => deadCodeAnn := true
+	   | "sequenceUnit" => sequenceUnitAnn := true
+	   | "warnMatch" => warnMatchAnn := true
+	   | "warnUnused" => warnUnusedAnn := true
+	   | _ => usage (concat ["invalid -enable-ann flag: ", s])))),
        (Expert, "error-threshhold", " 20", "error threshhold",
 	intRef errorThreshhold),
        (Normal, "exn-history", " {false|true}", "enable Exn.history",
@@ -353,12 +375,9 @@
 	boolRef safe),
        (Normal, "sequence-unit", " {false|true}",
 	"in (e1; e2), require e1: unit",
-	boolRef sequenceUnit),
-       (Normal, "show-basis", " <file>", "write out the basis library",
+	boolRef sequenceUnitDef),
+       (Normal, "show-basis", " <file>", "write out the final basis environment",
 	SpaceString (fn s => showBasis := SOME s)),
-       (Normal, "show-basis-used", " <file>",
-	"write the basis library used by the program",
-	SpaceString (fn s => showBasisUsed := SOME s)),
        (Normal, "show-def-use", " <file>", "write def-use information",
 	SpaceString (fn s => showDefUse := SOME s)),
        (Expert, "show-types", " {false|true}", "show types in ILs",
@@ -427,12 +446,15 @@
 			| "2" => Pass
 			| "3" =>  Detail
 			| _ => usage (concat ["invalid -verbose arg: ", s])))),
+       (Normal, "warn-ann", " {true|false}",
+	"unrecognized annotation warnings",
+	boolRef warnAnn),
        (Normal, "warn-match", " {true|false}",
 	"nonexhaustive and redundant match warnings",
-	boolRef warnMatch),
+	boolRef warnMatchDef),
        (Normal, "warn-unused", " {false|true}",
 	"unused identifier warnings",
-	boolRef warnUnused),
+	boolRef warnUnusedDef),
        (Expert, "xml-passes", " <passes>", "xml optimization passes",
 	SpaceString
 	(fn s =>
@@ -463,7 +485,6 @@
 	 case args of
 	    lib :: args =>
 	       (libDir := lib
-		; Compile.setBasisLibraryDir (concat [lib, "/sml/basis-library"])
 		; args)
 	  | _ => Error.bug "incorrect args from shell script"
       val _ = setTargetType ("self", usage)
@@ -557,19 +578,10 @@
 	 if !keepDot andalso List.isEmpty (!keepPasses)
 	    then keepSSA := true
 	 else ()
-      val _ =
-	 let
-	    val b = !warnMatch
-	 in
-	    (warnNonExhaustive := b; warnRedundant := b)
-	 end
-      val _ =
-	 keepDefUse := (isSome (!showDefUse)
-			orelse isSome (!showBasisUsed)
-			orelse !warnUnused)
+      val keepDefUse = (isSome (!showDefUse) orelse !warnUnusedAnn)
       val _ = elaborateOnly := (stop = Place.TypeCheck
-				andalso not (!warnMatch)
-				andalso not (!keepDefUse))
+				andalso not (!Control.warnMatchAnn)
+				andalso not (keepDefUse))
       val _ =
 	 case targetOS of
 	    FreeBSD => ()
@@ -588,11 +600,7 @@
       Result.No msg => usage msg
     | Result.Yes [] =>
 	 (inputFile := "<none>"
-	  ; if isSome (!showDefUse) orelse isSome (!showBasis) orelse !warnUnused
-	       then
-		  trace (Top, "Type Check Basis")
-		  Compile.elaborate {input = []}
-	    else if !buildConstants
+	  ; if !buildConstants
                then Compile.outputBasisConstants Out.standard
 	    else if !verbosity = Silent orelse !verbosity = Top
                then printVersion Out.standard
@@ -617,7 +625,8 @@
 			   else loop sufs
 		  datatype z = datatype Place.t
 	       in
-		  loop [(".cm", CM, false),
+		  loop [(".mlb", MLB, false),
+			(".cm", CM, false),
 			(".sml", SML, false),
 			(".c", Generated, true),
 			(".o", O, true)]
@@ -817,10 +826,10 @@
 			   case stop of
 			      Place.TypeCheck =>
 				 trace (Top, "Type Check SML")
-				 Compile.elaborate {input = files}
+				 Compile.elaborateSML {input = files}
 			    | _ => 
 				 trace (Top, "Compile SML")
-				 Compile.compile
+				 Compile.compileSML
 				 {input = files,
 				  outputC = make (Control.C, ".c"),
 				  outputS = make (Control.Assembly,
@@ -858,10 +867,65 @@
 			       else ()
 				  ; compileSml files)
 		     end
+		  fun compileMLB file =
+		     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 _ =
+			   case stop of
+			      Place.TypeCheck =>
+				 trace (Top, "Type Check SML")
+				 Compile.elaborateMLB {input = file}
+			    | _ => 
+				 trace (Top, "Compile SML")
+				 Compile.compileMLB
+				 {input = file,
+				  outputC = make (Control.C, ".c"),
+				  outputS = make (Control.Assembly,
+						  if !debug then ".s" else ".S")}
+		     in
+			case stop of
+			   Place.Generated => ()
+			 | Place.TypeCheck => ()
+			 | _ =>
+			      (* Shrink the heap before calling gcc. *)
+			      (MLton.GC.pack ()
+			       ; compileCSO (List.concat [!outputs, csoFiles]))
+		     end
 		  fun compile () =
 		     case start of
 			Place.CM => compileCM input
 		      | Place.SML => compileSml [input]
+		      | Place.MLB => compileMLB input
 		      | Place.Generated => compileCSO (input :: csoFiles)
 		      | Place.O => compileCSO (input :: csoFiles)
 		      | _ => Error.bug "invalid start"
@@ -878,9 +942,8 @@
 
 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 exportNJ (file: File.t): unit =
+   SMLofNJ.exportFn (file, fn (_, args) => commandLine args)
    
 fun exportMLton (): unit =
    case CommandLine.arguments () of



1.6       +2 -2      mlton/mlton/main/main.sig

Index: main.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- main.sig	16 Oct 2003 22:37:12 -0000	1.5
+++ main.sig	28 Jul 2004 21:05:15 -0000	1.6
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-1999 NEC Research Institute.
  *
@@ -18,5 +18,5 @@
 	 
       val commandLine: string list -> OS.Process.status
       val exportMLton: unit -> unit
-      val exportNJ: Dir.t * File.t -> unit
+      val exportNJ: File.t -> unit
    end



1.3       +3 -4      mlton/mlton/xml/implement-suffix.fun

Index: implement-suffix.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/implement-suffix.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- implement-suffix.fun	30 Jun 2004 19:08:12 -0000	1.2
+++ implement-suffix.fun	28 Jul 2004 21:05:15 -0000	1.3
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-1999 NEC Research Institute.
  *
@@ -39,13 +39,12 @@
 				       {var = var,
 					ty = ty,
 					lambda = loopLambda lambda})}
-	  | Exception {con, arg} => dec
+	  | Exception {...} => dec
 	  | _ => Error.bug "implement suffix saw unexpected dec"
       and loopMonoVal {var, ty, exp} : Dec.t =
 	 let
 	    fun primExp e = MonoVal {var = var, ty = ty, exp = e}
 	    fun keep () = primExp exp
-	    fun makeExp e = Dexp.vall {var = var, exp = e}
 	 in
 	    case exp of
 	       Case {test, cases, default} =>
@@ -54,7 +53,7 @@
 					    (default, fn (e, r) =>
 					     (loop e, r))),
 				 test = test})
-	     | ConApp {con, arg, ...} => keep ()
+	     | ConApp {...} => keep ()
 	     | Handle {try, catch = (catch, ty), handler} =>
 		  primExp (Handle {try = loop try,
 				   catch = (catch, ty),