[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),