[57694] trunk/dports/lang/polyml
mww at macports.org
mww at macports.org
Tue Sep 15 00:27:38 PDT 2009
Revision: 57694
http://trac.macports.org/changeset/57694
Author: mww at macports.org
Date: 2009-09-15 00:27:34 -0700 (Tue, 15 Sep 2009)
Log Message:
-----------
add patch from svn to make x86_64 work
Modified Paths:
--------------
trunk/dports/lang/polyml/Portfile
Added Paths:
-----------
trunk/dports/lang/polyml/files/
trunk/dports/lang/polyml/files/patch-svn-Sep-15-2009.diff
Modified: trunk/dports/lang/polyml/Portfile
===================================================================
--- trunk/dports/lang/polyml/Portfile 2009-09-15 06:53:34 UTC (rev 57693)
+++ trunk/dports/lang/polyml/Portfile 2009-09-15 07:27:34 UTC (rev 57694)
@@ -21,14 +21,19 @@
distname ${name}.${version}
checksums sha1 39cc9451113d41ca9c491167cf3973dfd55b7446
-#post-extract { system "chmod 755 ${worksrcpath}/install-sh" }
-
configure.ldflags
configure.cppflags
configure.args --mandir=${prefix}/share/man
+# for darwin/x64 builds, patch to a recent svn snapshot -- darwin 10/i386 fails with and without the patch
+if {${build_arch} == "x86_64"} {
+ patchfiles patch-svn-Sep-15-2009.diff
+ configure.args-append --build=${build_arch}-apple-darwin${os.major}
+}
+
post-destroot {
xinstall -m 555 -d ${destroot}${prefix}/share/doc/${name}
xinstall -m 444 -W ${worksrcpath} COPYING \
${destroot}${prefix}/share/doc/${name}
}
+
Added: trunk/dports/lang/polyml/files/patch-svn-Sep-15-2009.diff
===================================================================
--- trunk/dports/lang/polyml/files/patch-svn-Sep-15-2009.diff (rev 0)
+++ trunk/dports/lang/polyml/files/patch-svn-Sep-15-2009.diff 2009-09-15 07:27:34 UTC (rev 57694)
@@ -0,0 +1,54720 @@
+diff -u -r Makefile.am Makefile.am
+--- Makefile.am 2007-11-28 14:55:12.000000000 +0100
++++ Makefile.am 2009-09-15 08:56:48.000000000 +0200
+@@ -14,22 +14,22 @@
+
+ # Select the architecture-specific modules
+ if ARCHI386
+-POLYIMPORT = imports/polymli386.txt
++POLYIMPORT = $(srcdir)/imports/polymli386.txt
+ else
+ if ARCHPPC
+-POLYIMPORT = imports/polymlppc.txt
++POLYIMPORT = $(srcdir)/imports/polymlppc.txt
+ else
+ if ARCHSPARC
+-POLYIMPORT = imports/polymlsparc.txt
++POLYIMPORT = $(srcdir)/imports/polymlsparc.txt
+ else
+ if ARCHINTERPRET
+-POLYIMPORT = imports/polymlint.txt
++POLYIMPORT = $(srcdir)/imports/polymlint.txt
+ else
+ if ARCHINTERPRET64
+-POLYIMPORT = imports/polymlint64.txt
++POLYIMPORT = $(srcdir)/imports/polymlint64.txt
+ else
+ if ARCHX86_64
+-POLYIMPORT = imports/polymlx86_64.txt
++POLYIMPORT = $(srcdir)/imports/polymlx86_64.txt
+ else
+ endif
+ endif
+@@ -51,34 +51,43 @@
+ POLYOBJECTFILE = polyexport.o
+ endif
+
++# The Darwin linker loses execute access to the Poly segment unless this is given.
++if EXPMACHO
++poly_LDFLAGS += -Wl,-segprot,POLY,rwx,rwx
++endif
++
+ poly_SOURCES =
+ poly_LDADD = $(POLYOBJECTFILE) $(POLYRESOURCES) libpolymain/libpolymain.la libpolyml/libpolyml.la
+
+ polyimport_SOURCES = polyimport.c
+ polyimport_LDADD = $(POLYRESOURCES) libpolyml/libpolyml.la
+
+-#
++# Unix.
+ polyexport.o: polyimport exportPoly.sml polytemp.txt
+- ./polyimport $(POLYIMPORT_OPTIONS) polytemp.txt < exportPoly.sml > /dev/null
++ ./polyimport $(POLYIMPORT_OPTIONS) polytemp.txt -I $(srcdir) < $(srcdir)/exportPoly.sml
+
++# Windows. When building on Windows make sure that we provide both stdin and stdout to suppress the GUI.
+ polyexport.obj: polyimport exportPoly.sml polytemp.txt
+- ./polyimport $(POLYIMPORT_OPTIONS) polytemp.txt < exportPoly.sml > /dev/null
++ ./polyimport $(POLYIMPORT_OPTIONS) polytemp.txt -I $(srcdir) < $(srcdir)/exportPoly.sml | cat
+
+ polyresource.o: PolyML.rc poly.ico
+- windres -o polyresource.o PolyML.rc
++ windres -o polyresource.o $(srcdir)/PolyML.rc
+
+ polytemp.txt: $(POLYIMPORT)
+ cp $(POLYIMPORT) polytemp.txt
+
+ # This builds the compiler but does not update the files in the imports directory.
+ # It then builds a version of poly containing the new compiler.
+-cvs: all
++compiler: all
+ ./poly $(BOOTSTRAP_OPTIONS) < mlsource/BuildExport.sml
+ $(MAKE)
+
+ reboot: cvs
+ cp polytemp.txt $(POLYIMPORT)
+
++# Retain this target for backwards compatibility.
++cvs: compiler
++
+ clean-local:
+ rm -f *.obj polytemp.txt
+
+diff -u -r Makefile.in Makefile.in
+--- Makefile.in 2007-11-28 14:55:12.000000000 +0100
++++ Makefile.in 2009-09-15 08:56:48.000000000 +0200
+@@ -1,8 +1,8 @@
+-# Makefile.in generated by automake 1.10 from Makefile.am.
++# Makefile.in generated by automake 1.10.1 from Makefile.am.
+ # @configure_input@
+
+ # Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+-# 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
++# 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+ # This Makefile.in is free software; the Free Software Foundation
+ # gives unlimited permission to copy and/or distribute it,
+ # with or without modifications, as long as this notice is preserved.
+@@ -36,6 +36,9 @@
+ @NATIVE_WINDOWS_TRUE at am__append_1 = -mwindows -Wl,-u,_WinMain at 16
+ @NATIVE_WINDOWS_TRUE at am__append_2 = -mwindows
+ @NATIVE_WINDOWS_TRUE at am__append_3 = polyresource.o
++
++# The Darwin linker loses execute access to the Poly segment unless this is given.
++ at EXPMACHO_TRUE@am__append_4 = -Wl,-segprot,POLY,rwx,rwx
+ subdir = .
+ DIST_COMMON = $(am__configure_deps) $(srcdir)/Makefile.am \
+ $(srcdir)/Makefile.in $(srcdir)/config.h.in \
+@@ -131,6 +134,7 @@
+ DEFS = @DEFS@
+ DEPDIR = @DEPDIR@
+ DLLTOOL = @DLLTOOL@
++DSYMUTIL = @DSYMUTIL@
+ ECHO = @ECHO@
+ ECHO_C = @ECHO_C@
+ ECHO_N = @ECHO_N@
+@@ -154,6 +158,7 @@
+ MAINT = @MAINT@
+ MAKEINFO = @MAKEINFO@
+ MKDIR_P = @MKDIR_P@
++NMEDIT = @NMEDIT@
+ OBJDUMP = @OBJDUMP@
+ OBJEXT = @OBJEXT@
+ OSFLAG = @OSFLAG@
+@@ -166,6 +171,7 @@
+ PATH_SEPARATOR = @PATH_SEPARATOR@
+ POW_LIB = @POW_LIB@
+ RANLIB = @RANLIB@
++SED = @SED@
+ SET_MAKE = @SET_MAKE@
+ SHELL = @SHELL@
+ STRIP = @STRIP@
+@@ -190,6 +196,7 @@
+ build_os = @build_os@
+ build_vendor = @build_vendor@
+ builddir = @builddir@
++check_cpp = @check_cpp@
+ datadir = @datadir@
+ datarootdir = @datarootdir@
+ docdir = @docdir@
+@@ -229,15 +236,15 @@
+ BOOTSTRAP_OPTIONS = -H 10
+ SUBDIRS = libpolyml libpolymain
+ man_MANS = poly.1 polyimport.1
+- at ARCHI386_FALSE@@ARCHINTERPRET64_FALSE@@ARCHINTERPRET_FALSE@@ARCHPPC_FALSE@@ARCHSPARC_FALSE@@ARCHX86_64_TRUE at POLYIMPORT = imports/polymlx86_64.txt
+- at ARCHI386_FALSE@@ARCHINTERPRET64_TRUE@@ARCHINTERPRET_FALSE@@ARCHPPC_FALSE@@ARCHSPARC_FALSE at POLYIMPORT = imports/polymlint64.txt
+- at ARCHI386_FALSE@@ARCHINTERPRET_TRUE@@ARCHPPC_FALSE@@ARCHSPARC_FALSE at POLYIMPORT = imports/polymlint.txt
+- at ARCHI386_FALSE@@ARCHPPC_FALSE@@ARCHSPARC_TRUE at POLYIMPORT = imports/polymlsparc.txt
+- at ARCHI386_FALSE@@ARCHPPC_TRUE at POLYIMPORT = imports/polymlppc.txt
++ at ARCHI386_FALSE@@ARCHINTERPRET64_FALSE@@ARCHINTERPRET_FALSE@@ARCHPPC_FALSE@@ARCHSPARC_FALSE@@ARCHX86_64_TRUE at POLYIMPORT = $(srcdir)/imports/polymlx86_64.txt
++ at ARCHI386_FALSE@@ARCHINTERPRET64_TRUE@@ARCHINTERPRET_FALSE@@ARCHPPC_FALSE@@ARCHSPARC_FALSE at POLYIMPORT = $(srcdir)/imports/polymlint64.txt
++ at ARCHI386_FALSE@@ARCHINTERPRET_TRUE@@ARCHPPC_FALSE@@ARCHSPARC_FALSE at POLYIMPORT = $(srcdir)/imports/polymlint.txt
++ at ARCHI386_FALSE@@ARCHPPC_FALSE@@ARCHSPARC_TRUE at POLYIMPORT = $(srcdir)/imports/polymlsparc.txt
++ at ARCHI386_FALSE@@ARCHPPC_TRUE at POLYIMPORT = $(srcdir)/imports/polymlppc.txt
+
+ # Select the architecture-specific modules
+- at ARCHI386_TRUE@POLYIMPORT = imports/polymli386.txt
+-poly_LDFLAGS = $(am__append_1)
++ at ARCHI386_TRUE@POLYIMPORT = $(srcdir)/imports/polymli386.txt
++poly_LDFLAGS = $(am__append_1) $(am__append_4)
+ polyimport_LDFLAGS = $(am__append_2)
+ POLYRESOURCES = $(am__append_3)
+ @NATIVE_WINDOWS_FALSE at POLYOBJECTFILE = polyexport.o
+@@ -310,8 +317,8 @@
+ || test -f $$p1 \
+ ; then \
+ f=`echo "$$p1" | sed 's,^.*/,,;$(transform);s/$$/$(EXEEXT)/'`; \
+- echo " $(INSTALL_PROGRAM_ENV) $(LIBTOOL) --mode=install $(binPROGRAMS_INSTALL) '$$p' '$(DESTDIR)$(bindir)/$$f'"; \
+- $(INSTALL_PROGRAM_ENV) $(LIBTOOL) --mode=install $(binPROGRAMS_INSTALL) "$$p" "$(DESTDIR)$(bindir)/$$f" || exit 1; \
++ echo " $(INSTALL_PROGRAM_ENV) $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(binPROGRAMS_INSTALL) '$$p' '$(DESTDIR)$(bindir)/$$f'"; \
++ $(INSTALL_PROGRAM_ENV) $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(binPROGRAMS_INSTALL) "$$p" "$(DESTDIR)$(bindir)/$$f" || exit 1; \
+ else :; fi; \
+ done
+
+@@ -494,8 +501,8 @@
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+- $(AWK) ' { files[$$0] = 1; } \
+- END { for (i in files) print i; }'`; \
++ $(AWK) '{ files[$$0] = 1; nonemtpy = 1; } \
++ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ mkid -fID $$unique
+ tags: TAGS
+
+@@ -520,8 +527,8 @@
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+- $(AWK) ' { files[$$0] = 1; } \
+- END { for (i in files) print i; }'`; \
++ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
++ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ if test -z "$(ETAGS_ARGS)$$tags$$unique"; then :; else \
+ test -n "$$unique" || unique=$$empty_fix; \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+@@ -531,13 +538,12 @@
+ CTAGS: ctags-recursive $(HEADERS) $(SOURCES) config.h.in $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ tags=; \
+- here=`pwd`; \
+ list='$(SOURCES) $(HEADERS) config.h.in $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+- $(AWK) ' { files[$$0] = 1; } \
+- END { for (i in files) print i; }'`; \
++ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
++ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ test -z "$(CTAGS_ARGS)$$tags$$unique" \
+ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \
+ $$tags $$unique
+@@ -608,6 +614,10 @@
+ tardir=$(distdir) && $(am__tar) | bzip2 -9 -c >$(distdir).tar.bz2
+ $(am__remove_distdir)
+
++dist-lzma: distdir
++ tardir=$(distdir) && $(am__tar) | lzma -9 -c >$(distdir).tar.lzma
++ $(am__remove_distdir)
++
+ dist-tarZ: distdir
+ tardir=$(distdir) && $(am__tar) | compress -c >$(distdir).tar.Z
+ $(am__remove_distdir)
+@@ -634,6 +644,8 @@
+ GZIP=$(GZIP_ENV) gunzip -c $(distdir).tar.gz | $(am__untar) ;;\
+ *.tar.bz2*) \
+ bunzip2 -c $(distdir).tar.bz2 | $(am__untar) ;;\
++ *.tar.lzma*) \
++ unlzma -c $(distdir).tar.lzma | $(am__untar) ;;\
+ *.tar.Z*) \
+ uncompress -c $(distdir).tar.Z | $(am__untar) ;;\
+ *.shar.gz*) \
+@@ -794,8 +806,8 @@
+ .PHONY: $(RECURSIVE_CLEAN_TARGETS) $(RECURSIVE_TARGETS) CTAGS GTAGS \
+ all all-am am--refresh check check-am clean clean-binPROGRAMS \
+ clean-generic clean-libtool clean-local ctags ctags-recursive \
+- dist dist-all dist-bzip2 dist-gzip dist-shar dist-tarZ \
+- dist-zip distcheck distclean distclean-compile \
++ dist dist-all dist-bzip2 dist-gzip dist-lzma dist-shar \
++ dist-tarZ dist-zip distcheck distclean distclean-compile \
+ distclean-generic distclean-hdr distclean-libtool \
+ distclean-tags distcleancheck distdir distuninstallcheck dvi \
+ dvi-am html html-am info info-am install install-am \
+@@ -811,28 +823,32 @@
+ uninstall-binPROGRAMS uninstall-man uninstall-man1
+
+
+-#
++# Unix.
+ polyexport.o: polyimport exportPoly.sml polytemp.txt
+- ./polyimport $(POLYIMPORT_OPTIONS) polytemp.txt < exportPoly.sml > /dev/null
++ ./polyimport $(POLYIMPORT_OPTIONS) polytemp.txt -I $(srcdir) < $(srcdir)/exportPoly.sml
+
++# Windows. When building on Windows make sure that we provide both stdin and stdout to suppress the GUI.
+ polyexport.obj: polyimport exportPoly.sml polytemp.txt
+- ./polyimport $(POLYIMPORT_OPTIONS) polytemp.txt < exportPoly.sml > /dev/null
++ ./polyimport $(POLYIMPORT_OPTIONS) polytemp.txt -I $(srcdir) < $(srcdir)/exportPoly.sml | cat
+
+ polyresource.o: PolyML.rc poly.ico
+- windres -o polyresource.o PolyML.rc
++ windres -o polyresource.o $(srcdir)/PolyML.rc
+
+ polytemp.txt: $(POLYIMPORT)
+ cp $(POLYIMPORT) polytemp.txt
+
+ # This builds the compiler but does not update the files in the imports directory.
+ # It then builds a version of poly containing the new compiler.
+-cvs: all
++compiler: all
+ ./poly $(BOOTSTRAP_OPTIONS) < mlsource/BuildExport.sml
+ $(MAKE)
+
+ reboot: cvs
+ cp polytemp.txt $(POLYIMPORT)
+
++# Retain this target for backwards compatibility.
++cvs: compiler
++
+ clean-local:
+ rm -f *.obj polytemp.txt
+ # Tell versions [3.59,3.63) of GNU make to not export all variables.
+diff -u -r PolyML.dsp PolyML.dsp
+--- PolyML.dsp 2007-09-27 17:46:11.000000000 +0200
++++ PolyML.dsp 2009-09-15 08:56:48.000000000 +0200
+@@ -152,22 +152,20 @@
+ !IF "$(CFG)" == "PolyML - Win32 Release"
+
+ # Begin Custom Build
+-IntDir=.\Release
+ InputPath=.\imports\polymli386.txt
+
+-"$(IntDir)\polyexport.obj" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
+- $(IntDir)\PolyImport.exe $(InputPath) -o $(IntDir)\polyexport.obj < exportPoly.sml
++"polytemp.txt" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
++ copy $(InputPath) polytemp.txt
+
+ # End Custom Build
+
+ !ELSEIF "$(CFG)" == "PolyML - Win32 Debug"
+
+ # Begin Custom Build
+-IntDir=.\Debug
+ InputPath=.\imports\polymli386.txt
+
+-"$(IntDir)\polyexport.obj" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
+- $(IntDir)\PolyImport.exe $(InputPath) -o $(IntDir)\polyexport.obj < exportPoly.sml
++"polytemp.txt" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
++ copy $(InputPath) polytemp.txt
+
+ # End Custom Build
+
+@@ -197,11 +195,60 @@
+ !ELSEIF "$(CFG)" == "PolyML - Win32 IntDebug"
+
+ # Begin Custom Build
+-IntDir=.\IntDebug
+ InputPath=.\imports\polymlint.txt
+
++"polytemp.txt" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
++ copy $(InputPath) polytemp.txt
++
++# End Custom Build
++
++!ELSEIF "$(CFG)" == "PolyML - Win32 IntRelease"
++
++# Begin Custom Build
++InputPath=.\imports\polymlint.txt
++
++"polytemp.txt" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
++ copy $(InputPath) polytemp.txt
++
++# End Custom Build
++
++!ENDIF
++
++# End Source File
++# Begin Source File
++
++SOURCE=.\polytemp.txt
++
++!IF "$(CFG)" == "PolyML - Win32 Release"
++
++# Begin Custom Build
++IntDir=.\Release
++InputPath=.\polytemp.txt
++
+ "$(IntDir)\polyexport.obj" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
+- $(IntDir)\PolyImport.exe $(InputPath) -o $(IntDir)\polyexport.obj < exportPoly.sml
++ $(IntDir)\PolyImport.exe -H 32 $(InputPath) -o $(IntDir)\polyexport.obj < exportPoly.sml
++
++# End Custom Build
++
++!ELSEIF "$(CFG)" == "PolyML - Win32 Debug"
++
++# Begin Custom Build
++IntDir=.\Debug
++InputPath=.\polytemp.txt
++
++"$(IntDir)\polyexport.obj" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
++ $(IntDir)\PolyImport.exe -H 32 $(InputPath) -o $(IntDir)\polyexport.obj < exportPoly.sml
++
++# End Custom Build
++
++!ELSEIF "$(CFG)" == "PolyML - Win32 IntDebug"
++
++# Begin Custom Build
++IntDir=.\IntDebug
++InputPath=.\polytemp.txt
++
++"$(IntDir)\polyexport.obj" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
++ $(IntDir)\PolyImport.exe -H 32 $(InputPath) -o $(IntDir)\polyexport.obj < exportPoly.sml
+
+ # End Custom Build
+
+@@ -209,10 +256,10 @@
+
+ # Begin Custom Build
+ IntDir=.\IntRelease
+-InputPath=.\imports\polymlint.txt
++InputPath=.\polytemp.txt
+
+ "$(IntDir)\polyexport.obj" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
+- $(IntDir)\PolyImport.exe $(InputPath) -o $(IntDir)\polyexport.obj < exportPoly.sml
++ $(IntDir)\PolyImport.exe -H 32 $(InputPath) -o $(IntDir)\polyexport.obj < exportPoly.sml
+
+ # End Custom Build
+
+diff -u -r PolyML.rc PolyML.rc
+--- PolyML.rc 2008-10-17 15:27:53.000000000 +0200
++++ PolyML.rc 2009-09-15 08:56:47.000000000 +0200
+@@ -84,8 +84,8 @@
+ FONT 8, "MS Sans Serif"
+ BEGIN
+ DEFPUSHBUTTON "OK",IDOK,7,92,50,14
+- LTEXT "Poly/ML Copyright David C.J. Matthews, Cambridge University Technical Services and contributors 2000-8.\n\nThis is free software and released under the GNU Lesser General Public License.",
+- IDC_STATIC,24,30,141,47
++ LTEXT "Poly/ML v 5.2.1 Copyright David C.J. Matthews, Cambridge University Technical Services and contributors 2000-8.\n\nThis is free software and released under the GNU Lesser General Public License.",
++ IDC_STATIC,24,30,167,47
+ ICON IDI_ICON,IDC_STATIC,7,7,20,20
+ END
+
+Only in src/polyml/polyml: Root.ML
+Only in src/polyml/polyml: TODO.txt
+Only in basis: Array.530.sml
+Only in basis: Array2.530.sml
+Only in basis: BasicStreamIO.530.sml
+Only in basis: BinIO.530.sml
+diff -u -r basis/Bool.sml basis/Bool.sml
+--- basis/Bool.sml 2005-09-17 18:39:47.000000000 +0200
++++ basis/Bool.sml 2009-09-15 08:56:42.000000000 +0200
+@@ -44,7 +44,7 @@
+ (* Skip leading white space. *)
+ val strm = StringCvt.skipWS getc str
+ (* Test for a match between a reader and a list of lower case chars. *)
+- fun matchNC getc strm [] = (strm, true )(* Reached end of list - succeeded *)
++ fun matchNC _ strm [] = (strm, true )(* Reached end of list - succeeded *)
+ | matchNC getc strm (ch::rest) =
+ case getc strm of
+ NONE => (strm, false) (* Couldn't read it - fail. *)
+Only in basis: BoolArray.530.sml
+Only in basis: Byte.530.sml
+Only in basis: Date.530.sml
+Only in basis: ExnPrinter.sml
+Only in basis: FinalPolyML.530.sml
+diff -u -r basis/FinalPolyML.sml basis/FinalPolyML.sml
+--- basis/FinalPolyML.sml 2008-09-12 15:25:20.000000000 +0200
++++ basis/FinalPolyML.sml 2009-09-15 08:56:42.000000000 +0200
+@@ -308,8 +308,8 @@
+ (* To allow for the possibility of changing the representation we don't make Universal
+ be the same as Bootstrap.Universal. *)
+ (* Default error message function. *)
+- fun defaultErrorProc fileName (message: string, hard: bool, line: int) =
+- printOut(concat
++ fun defaultErrorProc fileName printFn (message: string, hard: bool, line: int) =
++ printFn(concat
+ ( (if hard then ["Error-"] else ["Warning-"]) @
+ (if fileName = "" then [] else [" in '", fileName, "',"]) @
+ (if line = 0 then [] else [" line ", Int.toString line]) @
+@@ -423,7 +423,7 @@
+ val printString = find (fn CPPrintStream s => SOME s | _ => NONE) outstream parameters
+ val printenv = find (fn CPPrinterNameSpace s => SOME s | _ => NONE) nameSpace parameters
+ val errorProc = find (fn CPErrorMessageProc f => SOME f | _ => NONE)
+- (defaultErrorProc fileName) parameters
++ (defaultErrorProc fileName printString) parameters
+ val debugging = find (fn CPDebug t => SOME t | _ => NONE) (! debug) parameters
+
+ (* Pass all the settings. Some of these aren't included in the parameters datatype (yet?). *)
+Only in basis: General.530.sml
+diff -u -r basis/HashArray.ML basis/HashArray.ML
+--- basis/HashArray.ML 2008-03-14 08:56:56.000000000 +0100
++++ basis/HashArray.ML 2009-09-15 08:56:42.000000000 +0200
+@@ -107,7 +107,7 @@
+ open Array
+ (* Enters the value at the first free entry at or after the
+ one pointed to by the hash value. *)
+- fun enterTab (A : '_a namedOption array, i : int, None : '_a namedOption) = ()
++ fun enterTab (_ : '_a namedOption array, _ : int, None : '_a namedOption) = ()
+ | enterTab (A, i, entry as Some (name,_)) =
+ let
+ fun enter (i : int) : unit =
+@@ -127,8 +127,8 @@
+ val N : int = length A;
+ val hashN : string -> int = !hash
+
+- val U : unit = enterTab (A, hashN name, Some (name, value));
+- val U : unit = used := !used + 1;
++ val () = enterTab (A, hashN name, Some (name, value));
++ val () = used := !used + 1;
+ in
+ (* Do we need to rehash ? *)
+ if !used * 5 > N * 4 (* More than 80% full so rehash *)
+@@ -150,8 +150,8 @@
+ copyOver (index - 1)
+ );
+
+- val U : unit = entries := newA;
+- val U : unit = hash := hashNewN;
++ val () = entries := newA;
++ val () = hash := hashNewN;
+ in
+ copyOver (length A - 1)
+ end
+diff -u -r basis/IEEEReal.sml basis/IEEEReal.sml
+--- basis/IEEEReal.sml 2005-09-17 18:39:48.000000000 +0200
++++ basis/IEEEReal.sml 2009-09-15 08:56:42.000000000 +0200
+@@ -114,7 +114,7 @@
+ fun getExponent src =
+ case getc src of
+ NONE => NONE
+- | SOME(ch, src') =>
++ | SOME(ch, _) =>
+ if Char.isSpace ch
+ then NONE
+ else Int.scan StringCvt.DEC getc src
+Only in basis: ImperativeIO.530.sml
+Only in basis: InitialBasis.530.ML
+Only in basis: InitialPolyML.530.ML
+Only in basis: Int.530.sml
+Only in basis: Int32.530.sml
+diff -u -r basis/IntInf.sml basis/IntInf.sml
+--- basis/IntInf.sml 2005-09-17 18:39:48.000000000 +0200
++++ basis/IntInf.sml 2009-09-15 08:56:42.000000000 +0200
+@@ -104,7 +104,7 @@
+
+ fun pow(i, j) =
+ let
+- fun power(acc, n, 0) = acc
++ fun power(acc, _, 0) = acc
+ | power(acc, n, i) =
+ power(if andb(i, 1) = 1 then acc*n else acc, n*n, Int.quot(i, 2))
+ in
+@@ -114,7 +114,7 @@
+ if i = 0 then raise Div
+ else if i = 1 then 1
+ else if i = ~1
+- then if Int.quot(j, 2) = 0 then (*even*) 1 else (*odd*) ~1
++ then if andb(j, 1) = 0 then (*even*) 1 else (*odd*) ~1
+ else 0
+ )
+ else power(1, i, j)
+Only in basis: LargeWord.530.sml
+Only in basis: LibraryIOSupport.530.sml
+Only in basis: LibrarySupport.530.sml
+diff -u -r basis/List.sml basis/List.sml
+--- basis/List.sml 2005-09-17 18:39:48.000000000 +0200
++++ basis/List.sml 2009-09-15 08:56:43.000000000 +0200
+@@ -120,29 +120,29 @@
+ fun concat [] = []
+ | concat (a::b) = a @ concat b
+
+- fun app f [] = ()
++ fun app _ [] = ()
+ | app f (h::t) = (f h; app f t)
+
+- fun map f [] = []
++ fun map _ [] = []
+ | map f (a::b) = f a :: map f b;
+
+- fun mapPartial f [] = []
++ fun mapPartial _ [] = []
+ | mapPartial f (a::b) =
+ case f a of
+ SOME r => r :: mapPartial f b
+ | NONE => mapPartial f b
+
+- fun find f [] = NONE
++ fun find _ [] = NONE
+ | find f (a::b) = if f a then SOME a else find f b
+
+- fun filter f [] = []
++ fun filter _ [] = []
+ | filter f (a::b) = if f a then a :: filter f b else filter f b
+
+ (* This is defined to evaluate f from left to right. *)
+ (* TODO: This involves returning a pair and creating new pairs
+ which allocates storage in Poly/ML. Is there a more efficient
+ implementation? e.g. recurse down the list and then reverse it. *)
+- fun partition f [] = ([], [])
++ fun partition _ [] = ([], [])
+ | partition f (a::b) =
+ let
+ val test = f a
+@@ -151,16 +151,16 @@
+ if test then (a::x, y) else (x, a::y)
+ end
+
+- fun foldl f b [] = b
++ fun foldl _ b [] = b
+ | foldl f b (x::y) = foldl f (f(x, b)) y
+
+- fun foldr f b [] = b
++ fun foldr _ b [] = b
+ | foldr f b (x::y) = f(x, foldr f b y)
+
+- fun exists f [] = false
++ fun exists _ [] = false
+ | exists f (a::b) = if f a then true else exists f b
+
+- fun all f [] = true
++ fun all _ [] = true
+ | all f (a::b) = if f a then all f b else false
+
+ (* tabulate a function. Rewritten again this time using an array. *)
+@@ -172,9 +172,9 @@
+ end
+
+ (* Lexicographic comparison. *)
+- fun collate cmp ([], []) = General.EQUAL
+- | collate cmp ([], _) = General.LESS
+- | collate cmp (_, []) = General.GREATER
++ fun collate _ ([], []) = General.EQUAL
++ | collate _ ([], _) = General.LESS
++ | collate _ (_, []) = General.GREATER
+ | collate cmp (a::b, c::d) =
+ (case cmp (a, c) of General.EQUAL => collate cmp (b, d) | notEqual => notEqual)
+ end;
+diff -u -r basis/ListPair.sml basis/ListPair.sml
+--- basis/ListPair.sml 2005-09-17 18:39:48.000000000 +0200
++++ basis/ListPair.sml 2009-09-15 08:56:43.000000000 +0200
+@@ -61,45 +61,45 @@
+ | unzip [] = ([], [])
+
+ fun map f (h::t, h'::t') = f(h, h') :: map f (t, t')
+- | map f _ = []
++ | map _ _ = []
+
+ fun mapEq f (h::t, h'::t') = f(h, h') :: mapEq f (t, t')
+- | mapEq f ([], []) = []
+- | mapEq f _ = raise UnequalLengths
++ | mapEq _ ([], []) = []
++ | mapEq _ _ = raise UnequalLengths
+
+ fun app f (h::t, h'::t') = (f(h, h'); app f (t, t'))
+- | app f _ = ()
++ | app _ _ = ()
+
+ fun appEq f (h::t, h'::t') = (f(h, h'); appEq f (t, t'))
+- | appEq f ([], []) = ()
+- | appEq f _ = raise UnequalLengths
++ | appEq _ ([], []) = ()
++ | appEq _ _ = raise UnequalLengths
+
+ fun foldl f b (h::t, h'::t') = foldl f (f(h, h', b)) (t, t')
+- | foldl f b _ = b
++ | foldl _ b _ = b
+
+ fun foldr f b (h::t, h'::t') = f(h, h', foldr f b (t, t'))
+- | foldr f b _ = b
++ | foldr _ b _ = b
+
+ fun foldlEq f b (h::t, h'::t') = foldlEq f (f(h, h', b)) (t, t')
+- | foldlEq f b ([], []) = b
+- | foldlEq f _ _ = raise UnequalLengths
++ | foldlEq _ b ([], []) = b
++ | foldlEq _ _ _ = raise UnequalLengths
+
+ fun foldrEq f b (h::t, h'::t') = f(h, h', foldrEq f b (t, t'))
+- | foldrEq f b ([], []) = b
+- | foldrEq f _ _ = raise UnequalLengths
++ | foldrEq _ b ([], []) = b
++ | foldrEq _ _ _ = raise UnequalLengths
+
+ fun exists f (h::t, h'::t') = if f(h, h') then true else exists f (t, t')
+- | exists f _ = false
++ | exists _ _ = false
+
+ (* all and allEq differ in the way they handle lists of different lengths.
+ all returns true if the predicate holds up to the shorter of the lists whereas
+ allEq returns false if the lists have different lengths. *)
+ fun all f (h::t, h'::t') = if f(h, h') then all f (t, t') else false
+- | all f _ = true
++ | all _ _ = true
+
+ (* Is it better to check the lengths first? *)
+ fun allEq f (h::t, h'::t') = if f(h, h') then allEq f (t, t') else false
+- | allEq f ([], []) = true
+- | allEq f _ = false
++ | allEq _ ([], []) = true
++ | allEq _ _ = false
+
+ end;
+Only in basis: NetHostDB.530.sml
+Only in basis: OS.530.sml
+diff -u -r basis/Option.sml basis/Option.sml
+--- basis/Option.sml 2005-09-17 18:39:49.000000000 +0200
++++ basis/Option.sml 2009-09-15 08:56:42.000000000 +0200
+@@ -60,10 +60,10 @@
+ | app _ NONE = ()
+
+ fun map f (SOME v) = SOME (f v)
+- | map f NONE = NONE
++ | map _ NONE = NONE
+
+ fun mapPartial f (SOME v) = f v
+- | mapPartial f NONE = NONE
++ | mapPartial _ NONE = NONE
+
+
+ fun compose (f, g) a =
+Only in basis: PackRealBig.530.sml
+Only in basis: Posix.530.sml
+Only in basis: PrettyPrinter.sml
+Only in basis: Real.530.sml
+Only in basis: SML90.530.sml
+Only in basis: Socket.530.sml
+Only in basis: String.530.sml
+diff -u -r basis/StringCvt.sml basis/StringCvt.sml
+--- basis/StringCvt.sml 2005-09-17 18:39:51.000000000 +0200
++++ basis/StringCvt.sml 2009-09-15 08:56:43.000000000 +0200
+@@ -55,8 +55,6 @@
+ and stringToCh: string->char = RunCall.unsafeCast
+
+ val System_lock: string -> unit = RunCall.run_call1 POLY_SYS_lockseg;
+- val System_lock: string -> unit = RunCall.run_call1 POLY_SYS_lockseg;
+- val System_loadb: string*word->char = RunCall.run_call2 POLY_SYS_load_byte;
+ val System_setb: string * word * char -> unit = RunCall.run_call3 POLY_SYS_assign_byte;
+ val mem_move: string*word*string*word*word -> unit =
+ RunCall.run_call5 POLY_SYS_move_bytes
+@@ -114,7 +112,6 @@
+ then chToString c (* return single character string. *)
+ else
+ let
+- val extra = iW - len
+ val str = allocString iW
+ fun setCh n =
+ if n = iW then ()
+@@ -192,7 +189,7 @@
+ in
+ case cvt rdr (Index 0w0) of
+ NONE => NONE
+- | SOME(res, strm') => SOME res
++ | SOME(res, _) => SOME res
+ end
+
+ end;
+Only in basis: TextIO.530.sml
+Only in basis: Thread.530.sml
+Only in basis: Time.530.sml
+diff -u -r basis/Timer.sml basis/Timer.sml
+--- basis/Timer.sml 2008-02-16 13:59:01.000000000 +0100
++++ basis/Timer.sml 2009-09-15 08:56:43.000000000 +0200
+@@ -63,7 +63,7 @@
+ and totalCPUTimer () =
+ { userTime=Time.zeroTime, sysTime=Time.zeroTime, gcUTime=Time.zeroTime, gcSTime=Time.zeroTime }
+
+- fun checkCPUTimes (timer as { userTime, sysTime, gcUTime, gcSTime }) =
++ fun checkCPUTimes (timer as { gcUTime, gcSTime, ... }) =
+ let
+ val { usr, sys } = checkCPUTimer timer
+ val gc_usr = getGCUTime() - gcUTime and gc_sys = getGCSTime() - gcSTime
+Only in basis: TopLevelPolyML.sml
+Only in basis: Universal.530.ML
+diff -u -r basis/Unix.sml basis/Unix.sml
+--- basis/Unix.sml 2008-05-20 13:42:58.000000000 +0200
++++ basis/Unix.sml 2009-09-15 08:56:43.000000000 +0200
+@@ -142,7 +142,7 @@
+ fun sys_get_buffsize (strm: OS.IO.iodesc): int = doIo(15, strm, 0)
+ end
+
+- fun textInstreamOf {pid, infd, ...} =
++ fun textInstreamOf {infd, ...} =
+ let
+ val n = Posix.FileSys.fdToIOD infd
+ val textPrimRd =
+@@ -153,7 +153,7 @@
+ TextIO.mkInstream streamIo
+ end
+
+- fun textOutstreamOf {pid, outfd, ...} =
++ fun textOutstreamOf {outfd, ...} =
+ let
+ val n = Posix.FileSys.fdToIOD outfd
+ val buffSize = sys_get_buffsize n
+@@ -166,7 +166,7 @@
+ TextIO.mkOutstream streamIo
+ end
+
+- fun binInstreamOf {pid, infd, ...} =
++ fun binInstreamOf {infd, ...} =
+ let
+ val n = Posix.FileSys.fdToIOD infd
+ val binPrimRd =
+@@ -177,7 +177,7 @@
+ BinIO.mkInstream streamIo
+ end
+
+- fun binOutstreamOf {pid, outfd, ...} =
++ fun binOutstreamOf {outfd, ...} =
+ let
+ val n = Posix.FileSys.fdToIOD outfd
+ val buffSize = sys_get_buffsize n
+@@ -207,8 +207,8 @@
+ fun reap {result = ref(SOME r), ...} = r
+ | reap(p as {pid, infd, outfd, result}) =
+ let
+- val u = Posix.IO.close infd;
+- val u = Posix.IO.close outfd;
++ val () = Posix.IO.close infd;
++ val () = Posix.IO.close outfd;
+ val (_, status) =
+ Posix.Process.waitpid(Posix.Process.W_CHILD pid, [])
+ in
+Only in basis: Vector.530.sml
+diff -u -r basis/VectorSliceOperations.sml basis/VectorSliceOperations.sml
+--- basis/VectorSliceOperations.sml 2005-09-17 18:39:52.000000000 +0200
++++ basis/VectorSliceOperations.sml 2009-09-15 08:56:43.000000000 +0200
+@@ -60,7 +60,6 @@
+ end =
+ struct
+ val wordAsInt: word -> int = RunCall.unsafeCast
+- val intAsWord: int -> word = RunCall.unsafeCast
+
+ type elem = elem
+ type vector = vector
+diff -u -r basis/Windows.sml basis/Windows.sml
+--- basis/Windows.sml 2005-09-17 18:39:52.000000000 +0200
++++ basis/Windows.sml 2009-09-15 08:56:42.000000000 +0200
+@@ -251,7 +251,7 @@
+ (* TODO: We wouldn't normally expect to close a
+ predefined key but it looks as though we might
+ have to be able to close HKEY_PERFORMANCE_DATA. *)
+- fun closeKey(PREDEFINED i) = ()
++ fun closeKey(PREDEFINED _) = ()
+ | closeKey(SUBKEY i) =
+ winCall(1011, i)
+ end
+@@ -327,7 +327,7 @@
+ | totalSize n (s::sl) = totalSize (n + String.size s + 1) sl
+ val len = totalSize 1 sl
+ val arr = Word8Array.array(len, 0w0)
+- fun pack n [] = ()
++ fun pack _ [] = ()
+ | pack n (s::sl) =
+ (
+ Byte.packString(arr, n, Substring.full s);
+@@ -444,13 +444,14 @@
+ end
+ end (* DDE *)
+
+-
++ (* No (longer?) in Basis library
+ local
+ val winCall = RunCall.run_call2 POLY_SYS_os_specific
+ in
+ fun fileTimeToLocalFileTime t = winCall(1030, t)
+ fun localFileTimeToFileTime t = winCall(1031, t)
+ end
++ *)
+
+ local
+ val winCall = RunCall.run_call2 POLY_SYS_os_specific
+Only in basis: Word32.530.sml
+Only in basis: Word32.x86_64.sml
+Only in basis: Word8.530.sml
+diff -u -r basis/Word8.sml basis/Word8.sml
+--- basis/Word8.sml 2008-03-14 08:51:37.000000000 +0100
++++ basis/Word8.sml 2009-09-15 08:56:42.000000000 +0200
+@@ -135,6 +135,8 @@
+ and op - (a, b) = fromWord(Word.-(a, b))
+ and op * (a, b) = fromWord(Word.*(a, b))
+
++ fun ~ x = 0w0 - x
++
+ end;
+
+ (* Because we are using opaque signature matching we have to install
+@@ -168,6 +170,7 @@
+ end;
+
+ (* Add the overloaded operators. *)
++RunCall.addOverload Word8.~ "~";
+ RunCall.addOverload Word8.+ "+";
+ RunCall.addOverload Word8.- "-";
+ RunCall.addOverload Word8.* "*";
+Only in basis: Word8Array.530.sml
+Only in basis: build.530.sml
+diff -u -r basis/processes.ML basis/processes.ML
+--- basis/processes.ML 2008-03-14 08:56:01.000000000 +0100
++++ basis/processes.ML 2009-09-15 08:56:43.000000000 +0200
+@@ -206,7 +206,7 @@
+ (* Find a process that matches and return the new list of partners
+ and the new list of runnable processes. *)
+ (* No match *) ([], NoMatch)
+- | findAProcess((entry as (p,d,v)) :: t) =
++ | findAProcess((entry as (_,d,_)) :: t) =
+ case getMatchingSynchs d of
+ MrTaken =>
+ (* This process is a committed choice in a different direction. Drop
+@@ -220,7 +220,7 @@
+ in
+ (entry :: clist, result)
+ end
+- | MrOK synchs =>
++ | MrOK _ =>
+ (t, FoundMatch entry) (* Return the new list. *)
+
+ in
+@@ -261,7 +261,7 @@
+ end
+ end
+
+- fun send (ch: 'a channel as CHAN {senders, receivers, chanLock, ...}, v:'a) =
++ fun send (CHAN {senders, receivers, chanLock, ...}, v:'a) =
+ blockInterrupt(fn () =>
+ let
+ val () = lock chanLock;
+@@ -293,7 +293,7 @@
+ end
+ )
+
+- fun receive (ch: 'a channel as CHAN {senders, receivers, chanLock, ...}): 'a =
++ fun receive (CHAN {senders, receivers, chanLock, ...}): 'a =
+ blockInterrupt(fn () =>
+ let
+ val () = lock chanLock;
+@@ -350,7 +350,7 @@
+ let
+ (* Get the parent's synchroniser and remove any redundant entries. *)
+ val synch = getActiveSynchroniser(get_process_data(), true)
+- val threadId =
++ val _ =
+ new_process f synch (* Share the parent's synchroniser. *)
+ [EnableBroadcastInterrupt false] (* Does not accept broadcasts. *)
+ in
+diff -u -r config.guess config.guess
+--- config.guess 2006-09-26 15:38:28.000000000 +0200
++++ config.guess 2009-09-15 08:56:48.000000000 +0200
+@@ -1,9 +1,10 @@
+ #! /bin/sh
+ # Attempt to guess a canonical system name.
+ # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+-# 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
++# 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
++# Free Software Foundation, Inc.
+
+-timestamp='2003-06-17'
++timestamp='2009-08-19'
+
+ # This file is free software; you can redistribute it and/or modify it
+ # under the terms of the GNU General Public License as published by
+@@ -17,23 +18,25 @@
+ #
+ # You should have received a copy of the GNU General Public License
+ # along with this program; if not, write to the Free Software
+-# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
++# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA
++# 02110-1301, USA.
+ #
+ # As a special exception to the GNU General Public License, if you
+ # distribute this file as part of a program that contains a
+ # configuration script generated by Autoconf, you may include it under
+ # the same distribution terms that you use for the rest of that program.
+
+-# Originally written by Per Bothner <per at bothner.com>.
+-# Please send patches to <config-patches at gnu.org>. Submit a context
+-# diff and a properly formatted ChangeLog entry.
++
++# Originally written by Per Bothner. Please send patches (context
++# diff format) to <config-patches at gnu.org> and include a ChangeLog
++# entry.
+ #
+ # This script attempts to guess a canonical system name similar to
+ # config.sub. If it succeeds, it prints the system name on stdout, and
+ # exits with 0. Otherwise, it exits with 1.
+ #
+-# The plan is that this can be called by configure scripts if you
+-# don't specify an explicit build system type.
++# You can get the latest version of this script from:
++# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD
+
+ me=`echo "$0" | sed -e 's,.*/,,'`
+
+@@ -53,8 +56,8 @@
+ GNU config.guess ($timestamp)
+
+ Originally written by Per Bothner.
+-Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
+-Free Software Foundation, Inc.
++Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
++2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+
+ This is free software; see the source for copying conditions. There is NO
+ warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
+@@ -66,11 +69,11 @@
+ while test $# -gt 0 ; do
+ case $1 in
+ --time-stamp | --time* | -t )
+- echo "$timestamp" ; exit 0 ;;
++ echo "$timestamp" ; exit ;;
+ --version | -v )
+- echo "$version" ; exit 0 ;;
++ echo "$version" ; exit ;;
+ --help | --h* | -h )
+- echo "$usage"; exit 0 ;;
++ echo "$usage"; exit ;;
+ -- ) # Stop option processing
+ shift; break ;;
+ - ) # Use stdin as input.
+@@ -104,7 +107,7 @@
+ trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ;
+ trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ;
+ : ${TMPDIR=/tmp} ;
+- { tmp=`(umask 077 && mktemp -d -q "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } ||
++ { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } ||
+ { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } ||
+ { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } ||
+ { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ;
+@@ -123,7 +126,7 @@
+ ;;
+ ,,*) CC_FOR_BUILD=$CC ;;
+ ,*,*) CC_FOR_BUILD=$HOST_CC ;;
+-esac ;'
++esac ; set_cc_for_build= ;'
+
+ # This is needed to find uname on a Pyramid OSx when run in the BSD universe.
+ # (ghazi at noc.rutgers.edu 1994-08-24)
+@@ -136,13 +139,6 @@
+ UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown
+ UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown
+
+-## for Red Hat Linux
+-if test -f /etc/redhat-release ; then
+- VENDOR=redhat ;
+-else
+- VENDOR= ;
+-fi
+-
+ # Note: order is significant - the case branches are not exclusive.
+
+ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
+@@ -165,6 +161,7 @@
+ arm*) machine=arm-unknown ;;
+ sh3el) machine=shl-unknown ;;
+ sh3eb) machine=sh-unknown ;;
++ sh5el) machine=sh5le-unknown ;;
+ *) machine=${UNAME_MACHINE_ARCH}-unknown ;;
+ esac
+ # The Operating System including object format, if it has switched
+@@ -173,7 +170,7 @@
+ arm*|i386|m68k|ns32k|sh3*|sparc|vax)
+ eval $set_cc_for_build
+ if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \
+- | grep __ELF__ >/dev/null
++ | grep -q __ELF__
+ then
+ # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout).
+ # Return netbsd for either. FIX?
+@@ -203,50 +200,32 @@
+ # contains redundant information, the shorter form:
+ # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used.
+ echo "${machine}-${os}${release}"
+- exit 0 ;;
+- amiga:OpenBSD:*:*)
+- echo m68k-unknown-openbsd${UNAME_RELEASE}
+- exit 0 ;;
+- arc:OpenBSD:*:*)
+- echo mipsel-unknown-openbsd${UNAME_RELEASE}
+- exit 0 ;;
+- hp300:OpenBSD:*:*)
+- echo m68k-unknown-openbsd${UNAME_RELEASE}
+- exit 0 ;;
+- mac68k:OpenBSD:*:*)
+- echo m68k-unknown-openbsd${UNAME_RELEASE}
+- exit 0 ;;
+- macppc:OpenBSD:*:*)
+- echo powerpc-unknown-openbsd${UNAME_RELEASE}
+- exit 0 ;;
+- mvme68k:OpenBSD:*:*)
+- echo m68k-unknown-openbsd${UNAME_RELEASE}
+- exit 0 ;;
+- mvme88k:OpenBSD:*:*)
+- echo m88k-unknown-openbsd${UNAME_RELEASE}
+- exit 0 ;;
+- mvmeppc:OpenBSD:*:*)
+- echo powerpc-unknown-openbsd${UNAME_RELEASE}
+- exit 0 ;;
+- pmax:OpenBSD:*:*)
+- echo mipsel-unknown-openbsd${UNAME_RELEASE}
+- exit 0 ;;
+- sgi:OpenBSD:*:*)
+- echo mipseb-unknown-openbsd${UNAME_RELEASE}
+- exit 0 ;;
+- sun3:OpenBSD:*:*)
+- echo m68k-unknown-openbsd${UNAME_RELEASE}
+- exit 0 ;;
+- wgrisc:OpenBSD:*:*)
+- echo mipsel-unknown-openbsd${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ *:OpenBSD:*:*)
+- echo ${UNAME_MACHINE}-unknown-openbsd${UNAME_RELEASE}
+- exit 0 ;;
++ UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'`
++ echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE}
++ exit ;;
++ *:ekkoBSD:*:*)
++ echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE}
++ exit ;;
++ *:SolidBSD:*:*)
++ echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE}
++ exit ;;
++ macppc:MirBSD:*:*)
++ echo powerpc-unknown-mirbsd${UNAME_RELEASE}
++ exit ;;
++ *:MirBSD:*:*)
++ echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE}
++ exit ;;
+ alpha:OSF1:*:*)
+- if test $UNAME_RELEASE = "V4.0"; then
++ case $UNAME_RELEASE in
++ *4.0)
+ UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'`
+- fi
++ ;;
++ *5.*)
++ UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'`
++ ;;
++ esac
+ # According to Compaq, /usr/sbin/psrinfo has been available on
+ # OSF/1 and Tru64 systems produced since 1995. I hope that
+ # covers most systems running today. This code pipes the CPU
+@@ -284,42 +263,49 @@
+ "EV7.9 (21364A)")
+ UNAME_MACHINE="alphaev79" ;;
+ esac
++ # A Pn.n version is a patched version.
+ # A Vn.n version is a released version.
+ # A Tn.n version is a released field test version.
+ # A Xn.n version is an unreleased experimental baselevel.
+ # 1.2 uses "1.2" for uname -r.
+- echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[VTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'`
+- exit 0 ;;
+- Alpha*:OpenVMS:*:*)
+- echo alpha-hp-vms
+- exit 0 ;;
++ echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'`
++ exit ;;
+ Alpha\ *:Windows_NT*:*)
+ # How do we know it's Interix rather than the generic POSIX subsystem?
+ # Should we change UNAME_MACHINE based on the output of uname instead
+ # of the specific Alpha model?
+ echo alpha-pc-interix
+- exit 0 ;;
++ exit ;;
+ 21064:Windows_NT:50:3)
+ echo alpha-dec-winnt3.5
+- exit 0 ;;
++ exit ;;
+ Amiga*:UNIX_System_V:4.0:*)
+ echo m68k-unknown-sysv4
+- exit 0;;
++ exit ;;
+ *:[Aa]miga[Oo][Ss]:*:*)
+ echo ${UNAME_MACHINE}-unknown-amigaos
+- exit 0 ;;
++ exit ;;
+ *:[Mm]orph[Oo][Ss]:*:*)
+ echo ${UNAME_MACHINE}-unknown-morphos
+- exit 0 ;;
++ exit ;;
+ *:OS/390:*:*)
+ echo i370-ibm-openedition
+- exit 0 ;;
++ exit ;;
++ *:z/VM:*:*)
++ echo s390-ibm-zvmoe
++ exit ;;
++ *:OS400:*:*)
++ echo powerpc-ibm-os400
++ exit ;;
+ arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*)
+ echo arm-acorn-riscix${UNAME_RELEASE}
+- exit 0;;
++ exit ;;
++ arm:riscos:*:*|arm:RISCOS:*:*)
++ echo arm-unknown-riscos
++ exit ;;
+ SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*)
+ echo hppa1.1-hitachi-hiuxmpp
+- exit 0;;
++ exit ;;
+ Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*)
+ # akee at wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE.
+ if test "`(/bin/universe) 2>/dev/null`" = att ; then
+@@ -327,32 +313,48 @@
+ else
+ echo pyramid-pyramid-bsd
+ fi
+- exit 0 ;;
++ exit ;;
+ NILE*:*:*:dcosx)
+ echo pyramid-pyramid-svr4
+- exit 0 ;;
++ exit ;;
+ DRS?6000:unix:4.0:6*)
+ echo sparc-icl-nx6
+- exit 0 ;;
+- DRS?6000:UNIX_SV:4.2*:7*)
++ exit ;;
++ DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*)
+ case `/usr/bin/uname -p` in
+- sparc) echo sparc-icl-nx7 && exit 0 ;;
++ sparc) echo sparc-icl-nx7; exit ;;
+ esac ;;
++ s390x:SunOS:*:*)
++ echo ${UNAME_MACHINE}-ibm-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
++ exit ;;
+ sun4H:SunOS:5.*:*)
+ echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+- exit 0 ;;
++ exit ;;
+ sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*)
+ echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+- exit 0 ;;
+- i86pc:SunOS:5.*:*)
+- echo i386-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+- exit 0 ;;
++ exit ;;
++ i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*)
++ eval $set_cc_for_build
++ SUN_ARCH="i386"
++ # If there is a compiler, see if it is configured for 64-bit objects.
++ # Note that the Sun cc does not turn __LP64__ into 1 like gcc does.
++ # This test works for both compilers.
++ if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then
++ if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \
++ (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \
++ grep IS_64BIT_ARCH >/dev/null
++ then
++ SUN_ARCH="x86_64"
++ fi
++ fi
++ echo ${SUN_ARCH}-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
++ exit ;;
+ sun4*:SunOS:6*:*)
+ # According to config.sub, this is the proper way to canonicalize
+ # SunOS6. Hard to guess exactly what SunOS6 will be like, but
+ # it's likely to be more like Solaris than SunOS4.
+ echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+- exit 0 ;;
++ exit ;;
+ sun4*:SunOS:*:*)
+ case "`/usr/bin/arch -k`" in
+ Series*|S4*)
+@@ -361,10 +363,10 @@
+ esac
+ # Japanese Language versions have a version number like `4.1.3-JL'.
+ echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'`
+- exit 0 ;;
++ exit ;;
+ sun3*:SunOS:*:*)
+ echo m68k-sun-sunos${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ sun*:*:4.2BSD:*)
+ UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null`
+ test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3
+@@ -376,10 +378,10 @@
+ echo sparc-sun-sunos${UNAME_RELEASE}
+ ;;
+ esac
+- exit 0 ;;
++ exit ;;
+ aushp:SunOS:*:*)
+ echo sparc-auspex-sunos${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ # The situation for MiNT is a little confusing. The machine name
+ # can be virtually everything (everything which is not
+ # "atarist" or "atariste" at least should have a processor
+@@ -390,37 +392,40 @@
+ # be no problem.
+ atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*)
+ echo m68k-atari-mint${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*)
+ echo m68k-atari-mint${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*)
+ echo m68k-atari-mint${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*)
+ echo m68k-milan-mint${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*)
+ echo m68k-hades-mint${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*)
+ echo m68k-unknown-mint${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
++ m68k:machten:*:*)
++ echo m68k-apple-machten${UNAME_RELEASE}
++ exit ;;
+ powerpc:machten:*:*)
+ echo powerpc-apple-machten${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ RISC*:Mach:*:*)
+ echo mips-dec-mach_bsd4.3
+- exit 0 ;;
++ exit ;;
+ RISC*:ULTRIX:*:*)
+ echo mips-dec-ultrix${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ VAX*:ULTRIX*:*:*)
+ echo vax-dec-ultrix${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ 2020:CLIX:*:* | 2430:CLIX:*:*)
+ echo clipper-intergraph-clix${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ mips:*:*:UMIPS | mips:*:*:RISCos)
+ eval $set_cc_for_build
+ sed 's/^ //' << EOF >$dummy.c
+@@ -444,32 +449,33 @@
+ exit (-1);
+ }
+ EOF
+- $CC_FOR_BUILD -o $dummy $dummy.c \
+- && $dummy `echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` \
+- && exit 0
++ $CC_FOR_BUILD -o $dummy $dummy.c &&
++ dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` &&
++ SYSTEM_NAME=`$dummy $dummyarg` &&
++ { echo "$SYSTEM_NAME"; exit; }
+ echo mips-mips-riscos${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ Motorola:PowerMAX_OS:*:*)
+ echo powerpc-motorola-powermax
+- exit 0 ;;
++ exit ;;
+ Motorola:*:4.3:PL8-*)
+ echo powerpc-harris-powermax
+- exit 0 ;;
++ exit ;;
+ Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*)
+ echo powerpc-harris-powermax
+- exit 0 ;;
++ exit ;;
+ Night_Hawk:Power_UNIX:*:*)
+ echo powerpc-harris-powerunix
+- exit 0 ;;
++ exit ;;
+ m88k:CX/UX:7*:*)
+ echo m88k-harris-cxux7
+- exit 0 ;;
++ exit ;;
+ m88k:*:4*:R4*)
+ echo m88k-motorola-sysv4
+- exit 0 ;;
++ exit ;;
+ m88k:*:3*:R3*)
+ echo m88k-motorola-sysv3
+- exit 0 ;;
++ exit ;;
+ AViiON:dgux:*:*)
+ # DG/UX returns AViiON for all architectures
+ UNAME_PROCESSOR=`/usr/bin/uname -p`
+@@ -485,29 +491,29 @@
+ else
+ echo i586-dg-dgux${UNAME_RELEASE}
+ fi
+- exit 0 ;;
++ exit ;;
+ M88*:DolphinOS:*:*) # DolphinOS (SVR3)
+ echo m88k-dolphin-sysv3
+- exit 0 ;;
++ exit ;;
+ M88*:*:R3*:*)
+ # Delta 88k system running SVR3
+ echo m88k-motorola-sysv3
+- exit 0 ;;
++ exit ;;
+ XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3)
+ echo m88k-tektronix-sysv3
+- exit 0 ;;
++ exit ;;
+ Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD)
+ echo m68k-tektronix-bsd
+- exit 0 ;;
++ exit ;;
+ *:IRIX*:*:*)
+ echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'`
+- exit 0 ;;
++ exit ;;
+ ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX.
+- echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id
+- exit 0 ;; # Note that: echo "'`uname -s`'" gives 'AIX '
++ echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id
++ exit ;; # Note that: echo "'`uname -s`'" gives 'AIX '
+ i*86:AIX:*:*)
+ echo i386-ibm-aix
+- exit 0 ;;
++ exit ;;
+ ia64:AIX:*:*)
+ if [ -x /usr/bin/oslevel ] ; then
+ IBM_REV=`/usr/bin/oslevel`
+@@ -515,7 +521,7 @@
+ IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE}
+ fi
+ echo ${UNAME_MACHINE}-ibm-aix${IBM_REV}
+- exit 0 ;;
++ exit ;;
+ *:AIX:2:3)
+ if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then
+ eval $set_cc_for_build
+@@ -530,15 +536,19 @@
+ exit(0);
+ }
+ EOF
+- $CC_FOR_BUILD -o $dummy $dummy.c && $dummy && exit 0
+- echo rs6000-ibm-aix3.2.5
++ if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy`
++ then
++ echo "$SYSTEM_NAME"
++ else
++ echo rs6000-ibm-aix3.2.5
++ fi
+ elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then
+ echo rs6000-ibm-aix3.2.4
+ else
+ echo rs6000-ibm-aix3.2
+ fi
+- exit 0 ;;
+- *:AIX:*:[45])
++ exit ;;
++ *:AIX:*:[456])
+ IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'`
+ if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then
+ IBM_ARCH=rs6000
+@@ -551,28 +561,28 @@
+ IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE}
+ fi
+ echo ${IBM_ARCH}-ibm-aix${IBM_REV}
+- exit 0 ;;
++ exit ;;
+ *:AIX:*:*)
+ echo rs6000-ibm-aix
+- exit 0 ;;
++ exit ;;
+ ibmrt:4.4BSD:*|romp-ibm:BSD:*)
+ echo romp-ibm-bsd4.4
+- exit 0 ;;
++ exit ;;
+ ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and
+ echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to
+- exit 0 ;; # report: romp-ibm BSD 4.3
++ exit ;; # report: romp-ibm BSD 4.3
+ *:BOSX:*:*)
+ echo rs6000-bull-bosx
+- exit 0 ;;
++ exit ;;
+ DPX/2?00:B.O.S.:*:*)
+ echo m68k-bull-sysv3
+- exit 0 ;;
++ exit ;;
+ 9000/[34]??:4.3bsd:1.*:*)
+ echo m68k-hp-bsd
+- exit 0 ;;
++ exit ;;
+ hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*)
+ echo m68k-hp-bsd4.4
+- exit 0 ;;
++ exit ;;
+ 9000/[34678]??:HP-UX:*:*)
+ HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'`
+ case "${UNAME_MACHINE}" in
+@@ -634,9 +644,19 @@
+ esac
+ if [ ${HP_ARCH} = "hppa2.0w" ]
+ then
+- # avoid double evaluation of $set_cc_for_build
+- test -n "$CC_FOR_BUILD" || eval $set_cc_for_build
+- if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E -) | grep __LP64__ >/dev/null
++ eval $set_cc_for_build
++
++ # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating
++ # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler
++ # generating 64-bit code. GNU and HP use different nomenclature:
++ #
++ # $ CC_FOR_BUILD=cc ./config.guess
++ # => hppa2.0w-hp-hpux11.23
++ # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess
++ # => hppa64-hp-hpux11.23
++
++ if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) |
++ grep -q __LP64__
+ then
+ HP_ARCH="hppa2.0w"
+ else
+@@ -644,11 +664,11 @@
+ fi
+ fi
+ echo ${HP_ARCH}-hp-hpux${HPUX_REV}
+- exit 0 ;;
++ exit ;;
+ ia64:HP-UX:*:*)
+ HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'`
+ echo ia64-hp-hpux${HPUX_REV}
+- exit 0 ;;
++ exit ;;
+ 3050*:HI-UX:*:*)
+ eval $set_cc_for_build
+ sed 's/^ //' << EOF >$dummy.c
+@@ -676,194 +696,227 @@
+ exit (0);
+ }
+ EOF
+- $CC_FOR_BUILD -o $dummy $dummy.c && $dummy && exit 0
++ $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` &&
++ { echo "$SYSTEM_NAME"; exit; }
+ echo unknown-hitachi-hiuxwe2
+- exit 0 ;;
++ exit ;;
+ 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* )
+ echo hppa1.1-hp-bsd
+- exit 0 ;;
++ exit ;;
+ 9000/8??:4.3bsd:*:*)
+ echo hppa1.0-hp-bsd
+- exit 0 ;;
++ exit ;;
+ *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*)
+ echo hppa1.0-hp-mpeix
+- exit 0 ;;
++ exit ;;
+ hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* )
+ echo hppa1.1-hp-osf
+- exit 0 ;;
++ exit ;;
+ hp8??:OSF1:*:*)
+ echo hppa1.0-hp-osf
+- exit 0 ;;
++ exit ;;
+ i*86:OSF1:*:*)
+ if [ -x /usr/sbin/sysversion ] ; then
+ echo ${UNAME_MACHINE}-unknown-osf1mk
+ else
+ echo ${UNAME_MACHINE}-unknown-osf1
+ fi
+- exit 0 ;;
++ exit ;;
+ parisc*:Lites*:*:*)
+ echo hppa1.1-hp-lites
+- exit 0 ;;
++ exit ;;
+ C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*)
+ echo c1-convex-bsd
+- exit 0 ;;
++ exit ;;
+ C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*)
+ if getsysinfo -f scalar_acc
+ then echo c32-convex-bsd
+ else echo c2-convex-bsd
+ fi
+- exit 0 ;;
++ exit ;;
+ C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*)
+ echo c34-convex-bsd
+- exit 0 ;;
++ exit ;;
+ C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*)
+ echo c38-convex-bsd
+- exit 0 ;;
++ exit ;;
+ C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*)
+ echo c4-convex-bsd
+- exit 0 ;;
++ exit ;;
+ CRAY*Y-MP:*:*:*)
+ echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+- exit 0 ;;
++ exit ;;
+ CRAY*[A-Z]90:*:*:*)
+ echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \
+ | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \
+ -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \
+ -e 's/\.[^.]*$/.X/'
+- exit 0 ;;
++ exit ;;
+ CRAY*TS:*:*:*)
+ echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+- exit 0 ;;
++ exit ;;
+ CRAY*T3E:*:*:*)
+ echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+- exit 0 ;;
++ exit ;;
+ CRAY*SV1:*:*:*)
+ echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+- exit 0 ;;
++ exit ;;
+ *:UNICOS/mp:*:*)
+- echo nv1-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+- exit 0 ;;
++ echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
++ exit ;;
+ F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*)
+ FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'`
+ FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'`
+ FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'`
+ echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}"
+- exit 0 ;;
++ exit ;;
++ 5000:UNIX_System_V:4.*:*)
++ FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'`
++ FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'`
++ echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}"
++ exit ;;
+ i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*)
+ echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ sparc*:BSD/OS:*:*)
+ echo sparc-unknown-bsdi${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ *:BSD/OS:*:*)
+ echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE}
+- exit 0 ;;
+- *:FreeBSD:*:*|*:GNU/FreeBSD:*:*)
+- # Determine whether the default compiler uses glibc.
+- eval $set_cc_for_build
+- sed 's/^ //' << EOF >$dummy.c
+- #include <features.h>
+- #if __GLIBC__ >= 2
+- LIBC=gnu
+- #else
+- LIBC=
+- #endif
+-EOF
+- eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^LIBC=`
+- echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`${LIBC:+-$LIBC}
+- exit 0 ;;
++ exit ;;
++ *:FreeBSD:*:*)
++ case ${UNAME_MACHINE} in
++ pc98)
++ echo i386-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;;
++ amd64)
++ echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;;
++ *)
++ echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;;
++ esac
++ exit ;;
+ i*:CYGWIN*:*)
+ echo ${UNAME_MACHINE}-pc-cygwin
+- exit 0 ;;
+- i*:MINGW*:*)
++ exit ;;
++ *:MINGW*:*)
+ echo ${UNAME_MACHINE}-pc-mingw32
+- exit 0 ;;
++ exit ;;
++ i*:windows32*:*)
++ # uname -m includes "-pc" on this system.
++ echo ${UNAME_MACHINE}-mingw32
++ exit ;;
+ i*:PW*:*)
+ echo ${UNAME_MACHINE}-pc-pw32
+- exit 0 ;;
+- x86:Interix*:[34]*)
+- echo i586-pc-interix${UNAME_RELEASE}|sed -e 's/\..*//'
+- exit 0 ;;
++ exit ;;
++ *:Interix*:[3456]*)
++ case ${UNAME_MACHINE} in
++ x86)
++ echo i586-pc-interix${UNAME_RELEASE}
++ exit ;;
++ EM64T | authenticamd | genuineintel)
++ echo x86_64-unknown-interix${UNAME_RELEASE}
++ exit ;;
++ IA64)
++ echo ia64-unknown-interix${UNAME_RELEASE}
++ exit ;;
++ esac ;;
+ [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*)
+ echo i${UNAME_MACHINE}-pc-mks
+- exit 0 ;;
++ exit ;;
++ 8664:Windows_NT:*)
++ echo x86_64-pc-mks
++ exit ;;
+ i*:Windows_NT*:* | Pentium*:Windows_NT*:*)
+ # How do we know it's Interix rather than the generic POSIX subsystem?
+ # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we
+ # UNAME_MACHINE based on the output of uname instead of i386?
+ echo i586-pc-interix
+- exit 0 ;;
++ exit ;;
+ i*:UWIN*:*)
+ echo ${UNAME_MACHINE}-pc-uwin
+- exit 0 ;;
++ exit ;;
++ amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*)
++ echo x86_64-unknown-cygwin
++ exit ;;
+ p*:CYGWIN*:*)
+ echo powerpcle-unknown-cygwin
+- exit 0 ;;
++ exit ;;
+ prep*:SunOS:5.*:*)
+ echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+- exit 0 ;;
++ exit ;;
+ *:GNU:*:*)
++ # the GNU system
+ echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'`
+- exit 0 ;;
++ exit ;;
++ *:GNU/*:*:*)
++ # other systems with GNU libc and userland
++ echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-gnu
++ exit ;;
+ i*86:Minix:*:*)
+ echo ${UNAME_MACHINE}-pc-minix
+- exit 0 ;;
++ exit ;;
+ arm*:Linux:*:*)
++ eval $set_cc_for_build
++ if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \
++ | grep -q __ARM_EABI__
++ then
++ echo ${UNAME_MACHINE}-unknown-linux-gnu
++ else
++ echo ${UNAME_MACHINE}-unknown-linux-gnueabi
++ fi
++ exit ;;
++ avr32*:Linux:*:*)
+ echo ${UNAME_MACHINE}-unknown-linux-gnu
+- exit 0 ;;
++ exit ;;
+ cris:Linux:*:*)
+ echo cris-axis-linux-gnu
+- exit 0 ;;
++ exit ;;
++ crisv32:Linux:*:*)
++ echo crisv32-axis-linux-gnu
++ exit ;;
++ frv:Linux:*:*)
++ echo frv-unknown-linux-gnu
++ exit ;;
+ ia64:Linux:*:*)
+- echo ${UNAME_MACHINE}-${VENDOR:-unknown}-linux-gnu
+- exit 0 ;;
++ echo ${UNAME_MACHINE}-unknown-linux-gnu
++ exit ;;
++ m32r*:Linux:*:*)
++ echo ${UNAME_MACHINE}-unknown-linux-gnu
++ exit ;;
+ m68*:Linux:*:*)
+ echo ${UNAME_MACHINE}-unknown-linux-gnu
+- exit 0 ;;
+- mips:Linux:*:*)
+- eval $set_cc_for_build
+- sed 's/^ //' << EOF >$dummy.c
+- #undef CPU
+- #undef mips
+- #undef mipsel
+- #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL)
+- CPU=mipsel
+- #else
+- #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB)
+- CPU=mips
+- #else
+- CPU=
+- #endif
+- #endif
+-EOF
+- eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^CPU=`
+- test x"${CPU}" != x && echo "${CPU}-unknown-linux-gnu" && exit 0
+- ;;
+- mips64:Linux:*:*)
++ exit ;;
++ mips:Linux:*:* | mips64:Linux:*:*)
+ eval $set_cc_for_build
+ sed 's/^ //' << EOF >$dummy.c
+ #undef CPU
+- #undef mips64
+- #undef mips64el
++ #undef ${UNAME_MACHINE}
++ #undef ${UNAME_MACHINE}el
+ #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL)
+- CPU=mips64el
++ CPU=${UNAME_MACHINE}el
+ #else
+ #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB)
+- CPU=mips64
++ CPU=${UNAME_MACHINE}
+ #else
+ CPU=
+ #endif
+ #endif
+ EOF
+- eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^CPU=`
+- test x"${CPU}" != x && echo "${CPU}-unknown-linux-gnu" && exit 0
++ eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n '
++ /^CPU/{
++ s: ::g
++ p
++ }'`"
++ test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; }
+ ;;
++ or32:Linux:*:*)
++ echo or32-unknown-linux-gnu
++ exit ;;
+ ppc:Linux:*:*)
+- echo powerpc-${VENDOR:-unknown}-linux-gnu
+- exit 0 ;;
++ echo powerpc-unknown-linux-gnu
++ exit ;;
+ ppc64:Linux:*:*)
+- echo powerpc64-${VENDOR:-unknown}-linux-gnu
+- exit 0 ;;
++ echo powerpc64-unknown-linux-gnu
++ exit ;;
+ alpha:Linux:*:*)
+ case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in
+ EV5) UNAME_MACHINE=alphaev5 ;;
+@@ -874,10 +927,13 @@
+ EV67) UNAME_MACHINE=alphaev67 ;;
+ EV68*) UNAME_MACHINE=alphaev68 ;;
+ esac
+- objdump --private-headers /bin/sh | grep ld.so.1 >/dev/null
++ objdump --private-headers /bin/sh | grep -q ld.so.1
+ if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi
+ echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC}
+- exit 0 ;;
++ exit ;;
++ padre:Linux:*:*)
++ echo sparc-unknown-linux-gnu
++ exit ;;
+ parisc:Linux:*:* | hppa:Linux:*:*)
+ # Look for CPU level
+ case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in
+@@ -885,25 +941,31 @@
+ PA8*) echo hppa2.0-unknown-linux-gnu ;;
+ *) echo hppa-unknown-linux-gnu ;;
+ esac
+- exit 0 ;;
++ exit ;;
+ parisc64:Linux:*:* | hppa64:Linux:*:*)
+ echo hppa64-unknown-linux-gnu
+- exit 0 ;;
++ exit ;;
+ s390:Linux:*:* | s390x:Linux:*:*)
+- echo ${UNAME_MACHINE}-${VENDOR:-ibm}-linux-gnu
+- exit 0 ;;
++ echo ${UNAME_MACHINE}-ibm-linux
++ exit ;;
+ sh64*:Linux:*:*)
+ echo ${UNAME_MACHINE}-unknown-linux-gnu
+- exit 0 ;;
++ exit ;;
+ sh*:Linux:*:*)
+ echo ${UNAME_MACHINE}-unknown-linux-gnu
+- exit 0 ;;
++ exit ;;
+ sparc:Linux:*:* | sparc64:Linux:*:*)
+ echo ${UNAME_MACHINE}-unknown-linux-gnu
+- exit 0 ;;
++ exit ;;
++ vax:Linux:*:*)
++ echo ${UNAME_MACHINE}-dec-linux-gnu
++ exit ;;
+ x86_64:Linux:*:*)
+- echo x86_64-${VENDOR:-unknown}-linux-gnu
+- exit 0 ;;
++ echo x86_64-unknown-linux-gnu
++ exit ;;
++ xtensa*:Linux:*:*)
++ echo ${UNAME_MACHINE}-unknown-linux-gnu
++ exit ;;
+ i*86:Linux:*:*)
+ # The BFD linker knows what the default object file format is, so
+ # first see if it will tell us. cd to the root directory to prevent
+@@ -919,17 +981,6 @@
+ elf32-i386)
+ TENTATIVE="${UNAME_MACHINE}-pc-linux-gnu"
+ ;;
+- a.out-i386-linux)
+- echo "${UNAME_MACHINE}-pc-linux-gnuaout"
+- exit 0 ;;
+- coff-i386)
+- echo "${UNAME_MACHINE}-pc-linux-gnucoff"
+- exit 0 ;;
+- "")
+- # Either a pre-BFD a.out linker (linux-gnuoldld) or
+- # one that does not give us useful --help.
+- echo "${UNAME_MACHINE}-pc-linux-gnuoldld"
+- exit 0 ;;
+ esac
+ # Determine whether the default compiler is a.out or elf
+ eval $set_cc_for_build
+@@ -946,23 +997,33 @@
+ LIBC=gnulibc1
+ # endif
+ #else
+- #ifdef __INTEL_COMPILER
++ #if defined(__INTEL_COMPILER) || defined(__PGI) || defined(__SUNPRO_C) || defined(__SUNPRO_CC)
+ LIBC=gnu
+ #else
+ LIBC=gnuaout
+ #endif
+ #endif
++ #ifdef __dietlibc__
++ LIBC=dietlibc
++ #endif
+ EOF
+- eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^LIBC=`
+- test x"${LIBC}" != x && echo "${UNAME_MACHINE}-${VENDOR:-pc}-linux-${LIBC}" && exit 0
+- test x"${TENTATIVE}" != x && echo "${TENTATIVE}" && exit 0
++ eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n '
++ /^LIBC/{
++ s: ::g
++ p
++ }'`"
++ test x"${LIBC}" != x && {
++ echo "${UNAME_MACHINE}-pc-linux-${LIBC}"
++ exit
++ }
++ test x"${TENTATIVE}" != x && { echo "${TENTATIVE}"; exit; }
+ ;;
+ i*86:DYNIX/ptx:4*:*)
+ # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there.
+ # earlier versions are messed up and put the nodename in both
+ # sysname and nodename.
+ echo i386-sequent-sysv4
+- exit 0 ;;
++ exit ;;
+ i*86:UNIX_SV:4.2MP:2.*)
+ # Unixware is an offshoot of SVR4, but it has its own version
+ # number series starting with 2...
+@@ -970,24 +1031,27 @@
+ # I just have to hope. -- rms.
+ # Use sysv4.2uw... so that sysv4* matches it.
+ echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION}
+- exit 0 ;;
++ exit ;;
+ i*86:OS/2:*:*)
+ # If we were able to find `uname', then EMX Unix compatibility
+ # is probably installed.
+ echo ${UNAME_MACHINE}-pc-os2-emx
+- exit 0 ;;
++ exit ;;
+ i*86:XTS-300:*:STOP)
+ echo ${UNAME_MACHINE}-unknown-stop
+- exit 0 ;;
++ exit ;;
+ i*86:atheos:*:*)
+ echo ${UNAME_MACHINE}-unknown-atheos
+- exit 0 ;;
+- i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.0*:*)
++ exit ;;
++ i*86:syllable:*:*)
++ echo ${UNAME_MACHINE}-pc-syllable
++ exit ;;
++ i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*)
+ echo i386-unknown-lynxos${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ i*86:*DOS:*:*)
+ echo ${UNAME_MACHINE}-pc-msdosdjgpp
+- exit 0 ;;
++ exit ;;
+ i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*)
+ UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'`
+ if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then
+@@ -995,15 +1059,16 @@
+ else
+ echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL}
+ fi
+- exit 0 ;;
+- i*86:*:5:[78]*)
++ exit ;;
++ i*86:*:5:[678]*)
++ # UnixWare 7.x, OpenUNIX and OpenServer 6.
+ case `/bin/uname -X | grep "^Machine"` in
+ *486*) UNAME_MACHINE=i486 ;;
+ *Pentium) UNAME_MACHINE=i586 ;;
+ *Pent*|*Celeron) UNAME_MACHINE=i686 ;;
+ esac
+ echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION}
+- exit 0 ;;
++ exit ;;
+ i*86:*:3.2:*)
+ if test -f /usr/options/cb.name; then
+ UNAME_REL=`sed -n 's/.*Version //p' </usr/options/cb.name`
+@@ -1021,73 +1086,86 @@
+ else
+ echo ${UNAME_MACHINE}-pc-sysv32
+ fi
+- exit 0 ;;
++ exit ;;
+ pc:*:*:*)
+ # Left here for compatibility:
+ # uname -m prints for DJGPP always 'pc', but it prints nothing about
+- # the processor, so we play safe by assuming i386.
+- echo i386-pc-msdosdjgpp
+- exit 0 ;;
++ # the processor, so we play safe by assuming i586.
++ # Note: whatever this is, it MUST be the same as what config.sub
++ # prints for the "djgpp" host, or else GDB configury will decide that
++ # this is a cross-build.
++ echo i586-pc-msdosdjgpp
++ exit ;;
+ Intel:Mach:3*:*)
+ echo i386-pc-mach3
+- exit 0 ;;
++ exit ;;
+ paragon:*:*:*)
+ echo i860-intel-osf1
+- exit 0 ;;
++ exit ;;
+ i860:*:4.*:*) # i860-SVR4
+ if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then
+ echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4
+ else # Add other i860-SVR4 vendors below as they are discovered.
+ echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4
+ fi
+- exit 0 ;;
++ exit ;;
+ mini*:CTIX:SYS*5:*)
+ # "miniframe"
+ echo m68010-convergent-sysv
+- exit 0 ;;
++ exit ;;
+ mc68k:UNIX:SYSTEM5:3.51m)
+ echo m68k-convergent-sysv
+- exit 0 ;;
++ exit ;;
+ M680?0:D-NIX:5.3:*)
+ echo m68k-diab-dnix
+- exit 0 ;;
+- M68*:*:R3V[567]*:*)
+- test -r /sysV68 && echo 'm68k-motorola-sysv' && exit 0 ;;
+- 3[34]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0)
++ exit ;;
++ M68*:*:R3V[5678]*:*)
++ test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;;
++ 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0)
+ OS_REL=''
+ test -r /etc/.relid \
+ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid`
+ /bin/uname -p 2>/dev/null | grep 86 >/dev/null \
+- && echo i486-ncr-sysv4.3${OS_REL} && exit 0
++ && { echo i486-ncr-sysv4.3${OS_REL}; exit; }
+ /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \
+- && echo i586-ncr-sysv4.3${OS_REL} && exit 0 ;;
++ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;;
+ 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*)
+ /bin/uname -p 2>/dev/null | grep 86 >/dev/null \
+- && echo i486-ncr-sysv4 && exit 0 ;;
++ && { echo i486-ncr-sysv4; exit; } ;;
++ NCR*:*:4.2:* | MPRAS*:*:4.2:*)
++ OS_REL='.3'
++ test -r /etc/.relid \
++ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid`
++ /bin/uname -p 2>/dev/null | grep 86 >/dev/null \
++ && { echo i486-ncr-sysv4.3${OS_REL}; exit; }
++ /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \
++ && { echo i586-ncr-sysv4.3${OS_REL}; exit; }
++ /bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \
++ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;;
+ m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*)
+ echo m68k-unknown-lynxos${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ mc68030:UNIX_System_V:4.*:*)
+ echo m68k-atari-sysv4
+- exit 0 ;;
++ exit ;;
+ TSUNAMI:LynxOS:2.*:*)
+ echo sparc-unknown-lynxos${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ rs6000:LynxOS:2.*:*)
+ echo rs6000-unknown-lynxos${UNAME_RELEASE}
+- exit 0 ;;
+- PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.0*:*)
++ exit ;;
++ PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*)
+ echo powerpc-unknown-lynxos${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ SM[BE]S:UNIX_SV:*:*)
+ echo mips-dde-sysv${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ RM*:ReliantUNIX-*:*:*)
+ echo mips-sni-sysv4
+- exit 0 ;;
++ exit ;;
+ RM*:SINIX-*:*:*)
+ echo mips-sni-sysv4
+- exit 0 ;;
++ exit ;;
+ *:SINIX-*:*:*)
+ if uname -p 2>/dev/null >/dev/null ; then
+ UNAME_MACHINE=`(uname -p) 2>/dev/null`
+@@ -1095,68 +1173,96 @@
+ else
+ echo ns32k-sni-sysv
+ fi
+- exit 0 ;;
++ exit ;;
+ PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort
+ # says <Richard.M.Bartel at ccMail.Census.GOV>
+ echo i586-unisys-sysv4
+- exit 0 ;;
++ exit ;;
+ *:UNIX_System_V:4*:FTX*)
+ # From Gerald Hewes <hewes at openmarket.com>.
+ # How about differentiating between stratus architectures? -djm
+ echo hppa1.1-stratus-sysv4
+- exit 0 ;;
++ exit ;;
+ *:*:*:FTX*)
+ # From seanf at swdc.stratus.com.
+ echo i860-stratus-sysv4
+- exit 0 ;;
++ exit ;;
++ i*86:VOS:*:*)
++ # From Paul.Green at stratus.com.
++ echo ${UNAME_MACHINE}-stratus-vos
++ exit ;;
+ *:VOS:*:*)
+ # From Paul.Green at stratus.com.
+ echo hppa1.1-stratus-vos
+- exit 0 ;;
++ exit ;;
+ mc68*:A/UX:*:*)
+ echo m68k-apple-aux${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ news*:NEWS-OS:6*:*)
+ echo mips-sony-newsos6
+- exit 0 ;;
++ exit ;;
+ R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*)
+ if [ -d /usr/nec ]; then
+ echo mips-nec-sysv${UNAME_RELEASE}
+ else
+ echo mips-unknown-sysv${UNAME_RELEASE}
+ fi
+- exit 0 ;;
++ exit ;;
+ BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only.
+ echo powerpc-be-beos
+- exit 0 ;;
++ exit ;;
+ BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only.
+ echo powerpc-apple-beos
+- exit 0 ;;
++ exit ;;
+ BePC:BeOS:*:*) # BeOS running on Intel PC compatible.
+ echo i586-pc-beos
+- exit 0 ;;
++ exit ;;
++ BePC:Haiku:*:*) # Haiku running on Intel PC compatible.
++ echo i586-pc-haiku
++ exit ;;
+ SX-4:SUPER-UX:*:*)
+ echo sx4-nec-superux${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ SX-5:SUPER-UX:*:*)
+ echo sx5-nec-superux${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ SX-6:SUPER-UX:*:*)
+ echo sx6-nec-superux${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
++ SX-7:SUPER-UX:*:*)
++ echo sx7-nec-superux${UNAME_RELEASE}
++ exit ;;
++ SX-8:SUPER-UX:*:*)
++ echo sx8-nec-superux${UNAME_RELEASE}
++ exit ;;
++ SX-8R:SUPER-UX:*:*)
++ echo sx8r-nec-superux${UNAME_RELEASE}
++ exit ;;
+ Power*:Rhapsody:*:*)
+ echo powerpc-apple-rhapsody${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ *:Rhapsody:*:*)
+ echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ *:Darwin:*:*)
+- case `uname -p` in
+- *86) UNAME_PROCESSOR=i686 ;;
+- powerpc) UNAME_PROCESSOR=powerpc ;;
++ UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown
++ # The next bit is a patch that appeared on the GCC mailing list.
++ # DCJM 7/9/09
++ eval $set_cc_for_build
++ sed 's/^ //' << EOF >$dummy.c
++ main()
++ {
++ }
++EOF
++ if test "`$CC_FOR_BUILD -o $dummy $dummy.c; file $dummy | grep -c x86_64`" = 1 ; then
++ UNAME_PROCESSOR=x86_64
++ fi
++ # End of patch
++ case $UNAME_PROCESSOR in
++ unknown) UNAME_PROCESSOR=powerpc ;;
+ esac
+ echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ *:procnto*:*:* | *:QNX:[0123456789]*:*)
+ UNAME_PROCESSOR=`uname -p`
+ if test "$UNAME_PROCESSOR" = "x86"; then
+@@ -1164,22 +1270,25 @@
+ UNAME_MACHINE=pc
+ fi
+ echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ *:QNX:*:4*)
+ echo i386-pc-qnx
+- exit 0 ;;
+- NSR-[DGKLNPTVW]:NONSTOP_KERNEL:*:*)
++ exit ;;
++ NSE-?:NONSTOP_KERNEL:*:*)
++ echo nse-tandem-nsk${UNAME_RELEASE}
++ exit ;;
++ NSR-?:NONSTOP_KERNEL:*:*)
+ echo nsr-tandem-nsk${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ *:NonStop-UX:*:*)
+ echo mips-compaq-nonstopux
+- exit 0 ;;
++ exit ;;
+ BS2000:POSIX*:*:*)
+ echo bs2000-siemens-sysv
+- exit 0 ;;
++ exit ;;
+ DS/*:UNIX_System_V:*:*)
+ echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
+ *:Plan9:*:*)
+ # "uname -m" is not consistent, so use $cputype instead. 386
+ # is converted to i386 for consistency with other x86
+@@ -1190,28 +1299,50 @@
+ UNAME_MACHINE="$cputype"
+ fi
+ echo ${UNAME_MACHINE}-unknown-plan9
+- exit 0 ;;
++ exit ;;
+ *:TOPS-10:*:*)
+ echo pdp10-unknown-tops10
+- exit 0 ;;
++ exit ;;
+ *:TENEX:*:*)
+ echo pdp10-unknown-tenex
+- exit 0 ;;
++ exit ;;
+ KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*)
+ echo pdp10-dec-tops20
+- exit 0 ;;
++ exit ;;
+ XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*)
+ echo pdp10-xkl-tops20
+- exit 0 ;;
++ exit ;;
+ *:TOPS-20:*:*)
+ echo pdp10-unknown-tops20
+- exit 0 ;;
++ exit ;;
+ *:ITS:*:*)
+ echo pdp10-unknown-its
+- exit 0 ;;
++ exit ;;
+ SEI:*:*:SEIUX)
+ echo mips-sei-seiux${UNAME_RELEASE}
+- exit 0 ;;
++ exit ;;
++ *:DragonFly:*:*)
++ echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`
++ exit ;;
++ *:*VMS:*:*)
++ UNAME_MACHINE=`(uname -p) 2>/dev/null`
++ case "${UNAME_MACHINE}" in
++ A*) echo alpha-dec-vms ; exit ;;
++ I*) echo ia64-dec-vms ; exit ;;
++ V*) echo vax-dec-vms ; exit ;;
++ esac ;;
++ *:XENIX:*:SysV)
++ echo i386-pc-xenix
++ exit ;;
++ i*86:skyos:*:*)
++ echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//'
++ exit ;;
++ i*86:rdos:*:*)
++ echo ${UNAME_MACHINE}-pc-rdos
++ exit ;;
++ i*86:AROS:*:*)
++ echo ${UNAME_MACHINE}-pc-aros
++ exit ;;
+ esac
+
+ #echo '(No uname command or uname output not recognized.)' 1>&2
+@@ -1243,7 +1374,7 @@
+ #endif
+
+ #if defined (__arm) && defined (__acorn) && defined (__unix)
+- printf ("arm-acorn-riscix"); exit (0);
++ printf ("arm-acorn-riscix\n"); exit (0);
+ #endif
+
+ #if defined (hp300) && !defined (hpux)
+@@ -1332,11 +1463,12 @@
+ }
+ EOF
+
+-$CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && $dummy && exit 0
++$CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && SYSTEM_NAME=`$dummy` &&
++ { echo "$SYSTEM_NAME"; exit; }
+
+ # Apollos put the system type in the environment.
+
+-test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit 0; }
++test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit; }
+
+ # Convex versions that predate uname can use getsysinfo(1)
+
+@@ -1345,22 +1477,22 @@
+ case `getsysinfo -f cpu_type` in
+ c1*)
+ echo c1-convex-bsd
+- exit 0 ;;
++ exit ;;
+ c2*)
+ if getsysinfo -f scalar_acc
+ then echo c32-convex-bsd
+ else echo c2-convex-bsd
+ fi
+- exit 0 ;;
++ exit ;;
+ c34*)
+ echo c34-convex-bsd
+- exit 0 ;;
++ exit ;;
+ c38*)
+ echo c38-convex-bsd
+- exit 0 ;;
++ exit ;;
+ c4*)
+ echo c4-convex-bsd
+- exit 0 ;;
++ exit ;;
+ esac
+ fi
+
+@@ -1371,7 +1503,9 @@
+ the operating system you are using. It is advised that you
+ download the most up to date version of the config scripts from
+
+- ftp://ftp.gnu.org/pub/gnu/config/
++ http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD
++and
++ http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD
+
+ If the version you run ($0) is already up to date, please
+ send the following data and any information you think might be
+diff -u -r config.h.in config.h.in
+--- config.h.in 2008-08-07 09:04:28.000000000 +0200
++++ config.h.in 2009-09-15 08:56:48.000000000 +0200
+@@ -470,6 +470,9 @@
+ /* Define to 1 if you have the <tchar.h> header file. */
+ #undef HAVE_TCHAR_H
+
++/* Define to 1 if you have the <termios.h> header file. */
++#undef HAVE_TERMIOS_H
++
+ /* Define to 1 if you have the <time.h> header file. */
+ #undef HAVE_TIME_H
+
+@@ -601,6 +604,9 @@
+ /* Version number of package */
+ #undef VERSION
+
++/* Define if the X-Windows interface should be built */
++#undef WITH_XWINDOWS
++
+ /* Define like PROTOTYPES; this can be used by system headers. */
+ #undef __PROTOTYPES
+
+diff -u -r config.sub config.sub
+--- config.sub 2006-09-26 15:38:28.000000000 +0200
++++ config.sub 2009-09-15 08:56:48.000000000 +0200
+@@ -1,9 +1,10 @@
+ #! /bin/sh
+ # Configuration validation subroutine script.
+ # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+-# 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
++# 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
++# Free Software Foundation, Inc.
+
+-timestamp='2003-06-18'
++timestamp='2009-08-19'
+
+ # This file is (in principle) common to ALL GNU software.
+ # The presence of a machine in this file suggests that SOME GNU software
+@@ -21,22 +22,26 @@
+ #
+ # You should have received a copy of the GNU General Public License
+ # along with this program; if not, write to the Free Software
+-# Foundation, Inc., 59 Temple Place - Suite 330,
+-# Boston, MA 02111-1307, USA.
+-
++# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA
++# 02110-1301, USA.
++#
+ # As a special exception to the GNU General Public License, if you
+ # distribute this file as part of a program that contains a
+ # configuration script generated by Autoconf, you may include it under
+ # the same distribution terms that you use for the rest of that program.
+
++
+ # Please send patches to <config-patches at gnu.org>. Submit a context
+-# diff and a properly formatted ChangeLog entry.
++# diff and a properly formatted GNU ChangeLog entry.
+ #
+ # Configuration subroutine to validate and canonicalize a configuration type.
+ # Supply the specified configuration type as an argument.
+ # If it is invalid, we print an error message on stderr and exit with code 1.
+ # Otherwise, we print the canonical config type on stdout and succeed.
+
++# You can get the latest version of this script from:
++# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD
++
+ # This file is supposed to be the same for all GNU packages
+ # and recognize all the CPU types, system types and aliases
+ # that are meaningful with *any* GNU software.
+@@ -70,8 +75,8 @@
+ version="\
+ GNU config.sub ($timestamp)
+
+-Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
+-Free Software Foundation, Inc.
++Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
++2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+
+ This is free software; see the source for copying conditions. There is NO
+ warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
+@@ -83,11 +88,11 @@
+ while test $# -gt 0 ; do
+ case $1 in
+ --time-stamp | --time* | -t )
+- echo "$timestamp" ; exit 0 ;;
++ echo "$timestamp" ; exit ;;
+ --version | -v )
+- echo "$version" ; exit 0 ;;
++ echo "$version" ; exit ;;
+ --help | --h* | -h )
+- echo "$usage"; exit 0 ;;
++ echo "$usage"; exit ;;
+ -- ) # Stop option processing
+ shift; break ;;
+ - ) # Use stdin as input.
+@@ -99,7 +104,7 @@
+ *local*)
+ # First pass through any local machine types.
+ echo $1
+- exit 0;;
++ exit ;;
+
+ * )
+ break ;;
+@@ -118,7 +123,10 @@
+ # Here we must recognize all the valid KERNEL-OS combinations.
+ maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'`
+ case $maybe_os in
+- nto-qnx* | linux-gnu* | freebsd*-gnu* | netbsd*-gnu* | storm-chaos* | os2-emx* | rtmk-nova*)
++ nto-qnx* | linux-gnu* | linux-dietlibc | linux-newlib* | linux-uclibc* | \
++ uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | knetbsd*-gnu* | netbsd*-gnu* | \
++ kopensolaris*-gnu* | \
++ storm-chaos* | os2-emx* | rtmk-nova*)
+ os=-$maybe_os
+ basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`
+ ;;
+@@ -144,10 +152,13 @@
+ -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\
+ -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \
+ -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \
+- -apple | -axis)
++ -apple | -axis | -knuth | -cray | -microblaze)
+ os=
+ basic_machine=$1
+ ;;
++ -bluegene*)
++ os=-cnk
++ ;;
+ -sim | -cisco | -oki | -wec | -winbond)
+ os=
+ basic_machine=$1
+@@ -169,6 +180,10 @@
+ -hiux*)
+ os=-hiuxwe2
+ ;;
++ -sco6)
++ os=-sco5v6
++ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
++ ;;
+ -sco5)
+ os=-sco3.2v5
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+@@ -185,6 +200,10 @@
+ # Don't forget version if it is 3.2v4 or newer.
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
++ -sco5v6*)
++ # Don't forget version if it is 3.2v4 or newer.
++ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
++ ;;
+ -sco*)
+ os=-sco3.2v2
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+@@ -228,45 +247,57 @@
+ | a29k \
+ | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \
+ | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \
+- | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr \
++ | am33_2.0 \
++ | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr | avr32 \
++ | bfin \
+ | c4x | clipper \
+ | d10v | d30v | dlx | dsp16xx \
+- | fr30 | frv \
++ | fido | fr30 | frv \
+ | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \
+ | i370 | i860 | i960 | ia64 \
+- | ip2k \
+- | m32r | m68000 | m68k | m88k | mcore \
++ | ip2k | iq2000 \
++ | lm32 \
++ | m32c | m32r | m32rle | m68000 | m68k | m88k \
++ | maxq | mb | microblaze | mcore | mep | metag \
+ | mips | mipsbe | mipseb | mipsel | mipsle \
+ | mips16 \
+ | mips64 | mips64el \
+- | mips64vr | mips64vrel \
++ | mips64octeon | mips64octeonel \
+ | mips64orion | mips64orionel \
++ | mips64r5900 | mips64r5900el \
++ | mips64vr | mips64vrel \
+ | mips64vr4100 | mips64vr4100el \
+ | mips64vr4300 | mips64vr4300el \
+ | mips64vr5000 | mips64vr5000el \
++ | mips64vr5900 | mips64vr5900el \
+ | mipsisa32 | mipsisa32el \
+ | mipsisa32r2 | mipsisa32r2el \
+ | mipsisa64 | mipsisa64el \
++ | mipsisa64r2 | mipsisa64r2el \
+ | mipsisa64sb1 | mipsisa64sb1el \
+ | mipsisa64sr71k | mipsisa64sr71kel \
+ | mipstx39 | mipstx39el \
+ | mn10200 | mn10300 \
++ | moxie \
++ | mt \
+ | msp430 \
++ | nios | nios2 \
+ | ns16k | ns32k \
+- | openrisc | or32 \
++ | or32 \
+ | pdp10 | pdp11 | pj | pjl \
+ | powerpc | powerpc64 | powerpc64le | powerpcle | ppcbe \
+ | pyramid \
+- | s390 | s390x \
+- | sh | sh[1234] | sh[23]e | sh[34]eb | shbe | shle | sh[1234]le | sh3ele \
++ | score \
++ | sh | sh[1234] | sh[24]a | sh[24]aeb | sh[23]e | sh[34]eb | sheb | shbe | shle | sh[1234]le | sh3ele \
+ | sh64 | sh64le \
+- | sparc | sparc64 | sparc86x | sparclet | sparclite | sparcv8 | sparcv9 | sparcv9b \
+- | strongarm \
++ | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \
++ | sparcv8 | sparcv9 | sparcv9b | sparcv9v \
++ | spu | strongarm \
+ | tahoe | thumb | tic4x | tic80 | tron \
+ | v850 | v850e \
+ | we32k \
+- | x86 | xscale | xstormy16 | xtensa \
+- | z8k)
++ | x86 | xc16x | xscale | xscalee[bl] | xstormy16 | xtensa \
++ | z8k | z80)
+ basic_machine=$basic_machine-unknown
+ ;;
+ m6811 | m68hc11 | m6812 | m68hc12)
+@@ -276,6 +307,9 @@
+ ;;
+ m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k)
+ ;;
++ ms1)
++ basic_machine=mt-unknown
++ ;;
+
+ # We use `pc' rather than `unknown'
+ # because (1) that's what they normally are, and
+@@ -295,55 +329,67 @@
+ | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \
+ | alphapca5[67]-* | alpha64pca5[67]-* | arc-* \
+ | arm-* | armbe-* | armle-* | armeb-* | armv*-* \
+- | avr-* \
+- | bs2000-* \
++ | avr-* | avr32-* \
++ | bfin-* | bs2000-* \
+ | c[123]* | c30-* | [cjt]90-* | c4x-* | c54x-* | c55x-* | c6x-* \
+- | clipper-* | cydra-* \
++ | clipper-* | craynv-* | cydra-* \
+ | d10v-* | d30v-* | dlx-* \
+ | elxsi-* \
+- | f30[01]-* | f700-* | fr30-* | frv-* | fx80-* \
++ | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \
+ | h8300-* | h8500-* \
+ | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \
+ | i*86-* | i860-* | i960-* | ia64-* \
+- | ip2k-* \
+- | m32r-* \
++ | ip2k-* | iq2000-* \
++ | lm32-* \
++ | m32c-* | m32r-* | m32rle-* \
+ | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \
+- | m88110-* | m88k-* | mcore-* \
++ | m88110-* | m88k-* | maxq-* | mcore-* | metag-* | microblaze-* \
+ | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \
+ | mips16-* \
+ | mips64-* | mips64el-* \
+- | mips64vr-* | mips64vrel-* \
++ | mips64octeon-* | mips64octeonel-* \
+ | mips64orion-* | mips64orionel-* \
++ | mips64r5900-* | mips64r5900el-* \
++ | mips64vr-* | mips64vrel-* \
+ | mips64vr4100-* | mips64vr4100el-* \
+ | mips64vr4300-* | mips64vr4300el-* \
+ | mips64vr5000-* | mips64vr5000el-* \
++ | mips64vr5900-* | mips64vr5900el-* \
+ | mipsisa32-* | mipsisa32el-* \
+ | mipsisa32r2-* | mipsisa32r2el-* \
+ | mipsisa64-* | mipsisa64el-* \
++ | mipsisa64r2-* | mipsisa64r2el-* \
+ | mipsisa64sb1-* | mipsisa64sb1el-* \
+ | mipsisa64sr71k-* | mipsisa64sr71kel-* \
+ | mipstx39-* | mipstx39el-* \
++ | mmix-* \
++ | mt-* \
+ | msp430-* \
+- | none-* | np1-* | nv1-* | ns16k-* | ns32k-* \
++ | nios-* | nios2-* \
++ | none-* | np1-* | ns16k-* | ns32k-* \
+ | orion-* \
+ | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \
+ | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* | ppcbe-* \
+ | pyramid-* \
+ | romp-* | rs6000-* \
+- | s390-* | s390x-* \
+- | sh-* | sh[1234]-* | sh[23]e-* | sh[34]eb-* | shbe-* \
++ | sh-* | sh[1234]-* | sh[24]a-* | sh[24]aeb-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \
+ | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \
+- | sparc-* | sparc64-* | sparc86x-* | sparclet-* | sparclite-* \
+- | sparcv8-* | sparcv9-* | sparcv9b-* | strongarm-* | sv1-* | sx?-* \
++ | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \
++ | sparclite-* \
++ | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | strongarm-* | sv1-* | sx?-* \
+ | tahoe-* | thumb-* \
+- | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \
++ | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* | tile-* \
+ | tron-* \
+ | v850-* | v850e-* | vax-* \
+ | we32k-* \
+- | x86-* | x86_64-* | xps100-* | xscale-* | xstormy16-* \
+- | xtensa-* \
++ | x86-* | x86_64-* | xc16x-* | xps100-* | xscale-* | xscalee[bl]-* \
++ | xstormy16-* | xtensa*-* \
+ | ymp-* \
+- | z8k-*)
++ | z8k-* | z80-*)
++ ;;
++ # Recognize the basic CPU types without company name, with glob match.
++ xtensa*)
++ basic_machine=$basic_machine-unknown
+ ;;
+ # Recognize the various machine names and aliases which stand
+ # for a CPU type and a company and sometimes even an OS.
+@@ -361,6 +407,9 @@
+ basic_machine=a29k-amd
+ os=-udi
+ ;;
++ abacus)
++ basic_machine=abacus-unknown
++ ;;
+ adobe68k)
+ basic_machine=m68010-adobe
+ os=-scout
+@@ -378,6 +427,9 @@
+ amd64)
+ basic_machine=x86_64-pc
+ ;;
++ amd64-*)
++ basic_machine=x86_64-`echo $basic_machine | sed 's/^[^-]*-//'`
++ ;;
+ amdahl)
+ basic_machine=580-amdahl
+ os=-sysv
+@@ -401,6 +453,10 @@
+ basic_machine=m68k-apollo
+ os=-bsd
+ ;;
++ aros)
++ basic_machine=i386-pc
++ os=-aros
++ ;;
+ aux)
+ basic_machine=m68k-apple
+ os=-aux
+@@ -409,10 +465,26 @@
+ basic_machine=ns32k-sequent
+ os=-dynix
+ ;;
++ blackfin)
++ basic_machine=bfin-unknown
++ os=-linux
++ ;;
++ blackfin-*)
++ basic_machine=bfin-`echo $basic_machine | sed 's/^[^-]*-//'`
++ os=-linux
++ ;;
++ bluegene*)
++ basic_machine=powerpc-ibm
++ os=-cnk
++ ;;
+ c90)
+ basic_machine=c90-cray
+ os=-unicos
+ ;;
++ cegcc)
++ basic_machine=arm-unknown
++ os=-cegcc
++ ;;
+ convex-c1)
+ basic_machine=c1-convex
+ os=-bsd
+@@ -437,12 +509,27 @@
+ basic_machine=j90-cray
+ os=-unicos
+ ;;
++ craynv)
++ basic_machine=craynv-cray
++ os=-unicosmp
++ ;;
++ cr16)
++ basic_machine=cr16-unknown
++ os=-elf
++ ;;
+ crds | unos)
+ basic_machine=m68k-crds
+ ;;
++ crisv32 | crisv32-* | etraxfs*)
++ basic_machine=crisv32-axis
++ ;;
+ cris | cris-* | etrax*)
+ basic_machine=cris-axis
+ ;;
++ crx)
++ basic_machine=crx-unknown
++ os=-elf
++ ;;
+ da30 | da30-*)
+ basic_machine=m68k-da30
+ ;;
+@@ -465,6 +552,14 @@
+ basic_machine=m88k-motorola
+ os=-sysv3
+ ;;
++ dicos)
++ basic_machine=i686-pc
++ os=-dicos
++ ;;
++ djgpp)
++ basic_machine=i586-pc
++ os=-msdosdjgpp
++ ;;
+ dpx20 | dpx20-*)
+ basic_machine=rs6000-bull
+ os=-bosx
+@@ -615,6 +710,14 @@
+ basic_machine=m68k-isi
+ os=-sysv
+ ;;
++ m68knommu)
++ basic_machine=m68k-unknown
++ os=-linux
++ ;;
++ m68knommu-*)
++ basic_machine=m68k-`echo $basic_machine | sed 's/^[^-]*-//'`
++ os=-linux
++ ;;
+ m88k-omron*)
+ basic_machine=m88k-omron
+ ;;
+@@ -626,10 +729,17 @@
+ basic_machine=ns32k-utek
+ os=-sysv
+ ;;
++ microblaze)
++ basic_machine=microblaze-xilinx
++ ;;
+ mingw32)
+ basic_machine=i386-pc
+ os=-mingw32
+ ;;
++ mingw32ce)
++ basic_machine=arm-unknown
++ os=-mingw32ce
++ ;;
+ miniframe)
+ basic_machine=m68000-convergent
+ ;;
+@@ -643,10 +753,6 @@
+ mips3*)
+ basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown
+ ;;
+- mmix*)
+- basic_machine=mmix-knuth
+- os=-mmixware
+- ;;
+ monitor)
+ basic_machine=m68k-rom68k
+ os=-coff
+@@ -659,6 +765,9 @@
+ basic_machine=i386-pc
+ os=-msdos
+ ;;
++ ms1-*)
++ basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'`
++ ;;
+ mvs)
+ basic_machine=i370-ibm
+ os=-mvs
+@@ -727,10 +836,6 @@
+ np1)
+ basic_machine=np1-gould
+ ;;
+- nv1)
+- basic_machine=nv1-cray
+- os=-unicosmp
+- ;;
+ nsr-tandem)
+ basic_machine=nsr-tandem
+ ;;
+@@ -738,9 +843,12 @@
+ basic_machine=hppa1.1-oki
+ os=-proelf
+ ;;
+- or32 | or32-*)
++ openrisc | openrisc-*)
+ basic_machine=or32-unknown
+- os=-coff
++ ;;
++ os400)
++ basic_machine=powerpc-ibm
++ os=-os400
+ ;;
+ OSE68000 | ose68000)
+ basic_machine=m68000-ericsson
+@@ -758,6 +866,14 @@
+ basic_machine=i860-intel
+ os=-osf
+ ;;
++ parisc)
++ basic_machine=hppa-unknown
++ os=-linux
++ ;;
++ parisc-*)
++ basic_machine=hppa-`echo $basic_machine | sed 's/^[^-]*-//'`
++ os=-linux
++ ;;
+ pbd)
+ basic_machine=sparc-tti
+ ;;
+@@ -767,6 +883,12 @@
+ pc532 | pc532-*)
+ basic_machine=ns32k-pc532
+ ;;
++ pc98)
++ basic_machine=i386-pc
++ ;;
++ pc98-*)
++ basic_machine=i386-`echo $basic_machine | sed 's/^[^-]*-//'`
++ ;;
+ pentium | p5 | k5 | k6 | nexgen | viac3)
+ basic_machine=i586-pc
+ ;;
+@@ -823,6 +945,10 @@
+ basic_machine=i586-unknown
+ os=-pw32
+ ;;
++ rdos)
++ basic_machine=i386-pc
++ os=-rdos
++ ;;
+ rom68k)
+ basic_machine=m68k-rom68k
+ os=-coff
+@@ -833,6 +959,12 @@
+ rtpc | rtpc-*)
+ basic_machine=romp-ibm
+ ;;
++ s390 | s390-*)
++ basic_machine=s390-ibm
++ ;;
++ s390x | s390x-*)
++ basic_machine=s390x-ibm
++ ;;
+ sa29200)
+ basic_machine=a29k-amd
+ os=-udi
+@@ -843,6 +975,10 @@
+ sb1el)
+ basic_machine=mipsisa64sb1el-unknown
+ ;;
++ sde)
++ basic_machine=mipsisa32-sde
++ os=-elf
++ ;;
+ sei)
+ basic_machine=mips-sei
+ os=-seiux
+@@ -854,6 +990,9 @@
+ basic_machine=sh-hitachi
+ os=-hms
+ ;;
++ sh5el)
++ basic_machine=sh5le-unknown
++ ;;
+ sh64)
+ basic_machine=sh64-unknown
+ ;;
+@@ -943,6 +1082,10 @@
+ basic_machine=tic6x-unknown
+ os=-coff
+ ;;
++ tile*)
++ basic_machine=tile-unknown
++ os=-linux-gnu
++ ;;
+ tx39)
+ basic_machine=mipstx39-unknown
+ ;;
+@@ -956,6 +1099,10 @@
+ tower | tower-32)
+ basic_machine=m68k-ncr
+ ;;
++ tpf)
++ basic_machine=s390x-ibm
++ os=-tpf
++ ;;
+ udi29k)
+ basic_machine=a29k-amd
+ os=-udi
+@@ -999,6 +1146,10 @@
+ basic_machine=hppa1.1-winbond
+ os=-proelf
+ ;;
++ xbox)
++ basic_machine=i686-pc
++ os=-mingw32
++ ;;
+ xps | xps100)
+ basic_machine=xps100-honeywell
+ ;;
+@@ -1010,6 +1161,10 @@
+ basic_machine=z8k-unknown
+ os=-sim
+ ;;
++ z80-*-coff)
++ basic_machine=z80-unknown
++ os=-sim
++ ;;
+ none)
+ basic_machine=none-none
+ os=-none
+@@ -1029,6 +1184,9 @@
+ romp)
+ basic_machine=romp-ibm
+ ;;
++ mmix)
++ basic_machine=mmix-knuth
++ ;;
+ rs6000)
+ basic_machine=rs6000-ibm
+ ;;
+@@ -1045,13 +1203,10 @@
+ we32k)
+ basic_machine=we32k-att
+ ;;
+- sh3 | sh4 | sh[34]eb | sh[1234]le | sh[23]ele)
++ sh[1234] | sh[24]a | sh[24]aeb | sh[34]eb | sh[1234]le | sh[23]ele)
+ basic_machine=sh-unknown
+ ;;
+- sh64)
+- basic_machine=sh64-unknown
+- ;;
+- sparc | sparcv8 | sparcv9 | sparcv9b)
++ sparc | sparcv8 | sparcv9 | sparcv9b | sparcv9v)
+ basic_machine=sparc-sun
+ ;;
+ cydra)
+@@ -1118,25 +1273,30 @@
+ # Each alternative MUST END IN A *, to match a version number.
+ # -sysv* is not here because it comes later, after sysvr4.
+ -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \
+- | -*vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[34]*\
++ | -*vms* | -sco* | -esix* | -isc* | -aix* | -cnk* | -sunos | -sunos[34]*\
+ | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \
++ | -kopensolaris* \
+ | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \
+- | -aos* \
++ | -aos* | -aros* \
+ | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \
+ | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \
+- | -hiux* | -386bsd* | -netbsd* | -openbsd* | -freebsd* | -riscix* \
+- | -lynxos* | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \
++ | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \
++ | -openbsd* | -solidbsd* \
++ | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \
++ | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \
+ | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \
+ | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \
+- | -chorusos* | -chorusrdb* \
++ | -chorusos* | -chorusrdb* | -cegcc* \
+ | -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \
+- | -mingw32* | -linux-gnu* | -uxpv* | -beos* | -mpeix* | -udk* \
++ | -mingw32* | -linux-gnu* | -linux-newlib* | -linux-uclibc* \
++ | -uxpv* | -beos* | -mpeix* | -udk* \
+ | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \
+ | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \
+ | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \
+ | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \
+ | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \
+- | -powermax* | -dnix* | -nx6 | -nx7 | -sei*)
++ | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \
++ | -skyos* | -haiku* | -rdos* | -toppers* | -drops*)
+ # Remember, each alternative MUST END IN *, to match a version number.
+ ;;
+ -qnx*)
+@@ -1154,12 +1314,15 @@
+ os=`echo $os | sed -e 's|nto|nto-qnx|'`
+ ;;
+ -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \
+- | -windows* | -osx | -abug | -netware* | -os9* | -beos* \
++ | -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \
+ | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*)
+ ;;
+ -mac*)
+ os=`echo $os | sed -e 's|mac|macos|'`
+ ;;
++ -linux-dietlibc)
++ os=-linux-dietlibc
++ ;;
+ -linux*)
+ os=`echo $os | sed -e 's|linux|linux-gnu|'`
+ ;;
+@@ -1172,6 +1335,9 @@
+ -opened*)
+ os=-openedition
+ ;;
++ -os400*)
++ os=-os400
++ ;;
+ -wince*)
+ os=-wince
+ ;;
+@@ -1193,6 +1359,9 @@
+ -atheos*)
+ os=-atheos
+ ;;
++ -syllable*)
++ os=-syllable
++ ;;
+ -386bsd)
+ os=-bsd
+ ;;
+@@ -1215,6 +1384,9 @@
+ -sinix*)
+ os=-sysv4
+ ;;
++ -tpf*)
++ os=-tpf
++ ;;
+ -triton*)
+ os=-sysv3
+ ;;
+@@ -1251,6 +1423,12 @@
+ -kaos*)
+ os=-kaos
+ ;;
++ -zvmoe)
++ os=-zvmoe
++ ;;
++ -dicos*)
++ os=-dicos
++ ;;
+ -none)
+ ;;
+ *)
+@@ -1273,6 +1451,12 @@
+ # system, and we'll never get to this point.
+
+ case $basic_machine in
++ score-*)
++ os=-elf
++ ;;
++ spu-*)
++ os=-elf
++ ;;
+ *-acorn)
+ os=-riscix1.2
+ ;;
+@@ -1282,8 +1466,8 @@
+ arm*-semi)
+ os=-aout
+ ;;
+- c4x-* | tic4x-*)
+- os=-coff
++ c4x-* | tic4x-*)
++ os=-coff
+ ;;
+ # This must come before the *-dec entry.
+ pdp10-*)
+@@ -1310,6 +1494,9 @@
+ m68*-cisco)
+ os=-aout
+ ;;
++ mep-*)
++ os=-elf
++ ;;
+ mips*-cisco)
+ os=-elf
+ ;;
+@@ -1328,9 +1515,15 @@
+ *-be)
+ os=-beos
+ ;;
++ *-haiku)
++ os=-haiku
++ ;;
+ *-ibm)
+ os=-aix
+ ;;
++ *-knuth)
++ os=-mmixware
++ ;;
+ *-wec)
+ os=-proelf
+ ;;
+@@ -1433,7 +1626,7 @@
+ -sunos*)
+ vendor=sun
+ ;;
+- -aix*)
++ -cnk*|-aix*)
+ vendor=ibm
+ ;;
+ -beos*)
+@@ -1463,9 +1656,15 @@
+ -mvs* | -opened*)
+ vendor=ibm
+ ;;
++ -os400*)
++ vendor=ibm
++ ;;
+ -ptx*)
+ vendor=sequent
+ ;;
++ -tpf*)
++ vendor=ibm
++ ;;
+ -vxsim* | -vxworks* | -windiss*)
+ vendor=wrs
+ ;;
+@@ -1490,7 +1689,7 @@
+ esac
+
+ echo $basic_machine$os
+-exit 0
++exit
+
+ # Local variables:
+ # eval: (add-hook 'write-file-hooks 'time-stamp)
+diff -u -r configure configure
+--- configure 2008-10-17 14:55:23.000000000 +0200
++++ configure 2009-09-15 08:56:48.000000000 +0200
+@@ -877,6 +877,7 @@
+ MAINTAINER_MODE_TRUE
+ MAINTAINER_MODE_FALSE
+ MAINT
++check_cpp
+ CCAS
+ CCASFLAGS
+ CCASDEPMODE
+@@ -4415,7 +4416,7 @@
+ ;;
+ *-*-irix6*)
+ # Find out which ABI we are using.
+- echo '#line 4418 "configure"' > conftest.$ac_ext
++ echo '#line 4419 "configure"' > conftest.$ac_ext
+ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
+ (eval $ac_compile) 2>&5
+ ac_status=$?
+@@ -7436,11 +7437,11 @@
+ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \
+ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \
+ -e 's:$: $lt_compiler_flag:'`
+- (eval echo "\"\$as_me:7439: $lt_compile\"" >&5)
++ (eval echo "\"\$as_me:7440: $lt_compile\"" >&5)
+ (eval "$lt_compile" 2>conftest.err)
+ ac_status=$?
+ cat conftest.err >&5
+- echo "$as_me:7443: \$? = $ac_status" >&5
++ echo "$as_me:7444: \$? = $ac_status" >&5
+ if (exit $ac_status) && test -s "$ac_outfile"; then
+ # The compiler can only warn and ignore the option if not recognized
+ # So say no if there are warnings other than the usual output.
+@@ -7704,11 +7705,11 @@
+ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \
+ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \
+ -e 's:$: $lt_compiler_flag:'`
+- (eval echo "\"\$as_me:7707: $lt_compile\"" >&5)
++ (eval echo "\"\$as_me:7708: $lt_compile\"" >&5)
+ (eval "$lt_compile" 2>conftest.err)
+ ac_status=$?
+ cat conftest.err >&5
+- echo "$as_me:7711: \$? = $ac_status" >&5
++ echo "$as_me:7712: \$? = $ac_status" >&5
+ if (exit $ac_status) && test -s "$ac_outfile"; then
+ # The compiler can only warn and ignore the option if not recognized
+ # So say no if there are warnings other than the usual output.
+@@ -7808,11 +7809,11 @@
+ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \
+ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \
+ -e 's:$: $lt_compiler_flag:'`
+- (eval echo "\"\$as_me:7811: $lt_compile\"" >&5)
++ (eval echo "\"\$as_me:7812: $lt_compile\"" >&5)
+ (eval "$lt_compile" 2>out/conftest.err)
+ ac_status=$?
+ cat out/conftest.err >&5
+- echo "$as_me:7815: \$? = $ac_status" >&5
++ echo "$as_me:7816: \$? = $ac_status" >&5
+ if (exit $ac_status) && test -s out/conftest2.$ac_objext
+ then
+ # The compiler can only warn and ignore the option if not recognized
+@@ -10105,7 +10106,7 @@
+ lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
+ lt_status=$lt_dlunknown
+ cat > conftest.$ac_ext <<EOF
+-#line 10108 "configure"
++#line 10109 "configure"
+ #include "confdefs.h"
+
+ #if HAVE_DLFCN_H
+@@ -10205,7 +10206,7 @@
+ lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
+ lt_status=$lt_dlunknown
+ cat > conftest.$ac_ext <<EOF
+-#line 10208 "configure"
++#line 10209 "configure"
+ #include "confdefs.h"
+
+ #if HAVE_DLFCN_H
+@@ -12541,11 +12542,11 @@
+ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \
+ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \
+ -e 's:$: $lt_compiler_flag:'`
+- (eval echo "\"\$as_me:12544: $lt_compile\"" >&5)
++ (eval echo "\"\$as_me:12545: $lt_compile\"" >&5)
+ (eval "$lt_compile" 2>conftest.err)
+ ac_status=$?
+ cat conftest.err >&5
+- echo "$as_me:12548: \$? = $ac_status" >&5
++ echo "$as_me:12549: \$? = $ac_status" >&5
+ if (exit $ac_status) && test -s "$ac_outfile"; then
+ # The compiler can only warn and ignore the option if not recognized
+ # So say no if there are warnings other than the usual output.
+@@ -12645,11 +12646,11 @@
+ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \
+ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \
+ -e 's:$: $lt_compiler_flag:'`
+- (eval echo "\"\$as_me:12648: $lt_compile\"" >&5)
++ (eval echo "\"\$as_me:12649: $lt_compile\"" >&5)
+ (eval "$lt_compile" 2>out/conftest.err)
+ ac_status=$?
+ cat out/conftest.err >&5
+- echo "$as_me:12652: \$? = $ac_status" >&5
++ echo "$as_me:12653: \$? = $ac_status" >&5
+ if (exit $ac_status) && test -s out/conftest2.$ac_objext
+ then
+ # The compiler can only warn and ignore the option if not recognized
+@@ -14206,11 +14207,11 @@
+ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \
+ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \
+ -e 's:$: $lt_compiler_flag:'`
+- (eval echo "\"\$as_me:14209: $lt_compile\"" >&5)
++ (eval echo "\"\$as_me:14210: $lt_compile\"" >&5)
+ (eval "$lt_compile" 2>conftest.err)
+ ac_status=$?
+ cat conftest.err >&5
+- echo "$as_me:14213: \$? = $ac_status" >&5
++ echo "$as_me:14214: \$? = $ac_status" >&5
+ if (exit $ac_status) && test -s "$ac_outfile"; then
+ # The compiler can only warn and ignore the option if not recognized
+ # So say no if there are warnings other than the usual output.
+@@ -14310,11 +14311,11 @@
+ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \
+ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \
+ -e 's:$: $lt_compiler_flag:'`
+- (eval echo "\"\$as_me:14313: $lt_compile\"" >&5)
++ (eval echo "\"\$as_me:14314: $lt_compile\"" >&5)
+ (eval "$lt_compile" 2>out/conftest.err)
+ ac_status=$?
+ cat out/conftest.err >&5
+- echo "$as_me:14317: \$? = $ac_status" >&5
++ echo "$as_me:14318: \$? = $ac_status" >&5
+ if (exit $ac_status) && test -s out/conftest2.$ac_objext
+ then
+ # The compiler can only warn and ignore the option if not recognized
+@@ -16497,11 +16498,11 @@
+ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \
+ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \
+ -e 's:$: $lt_compiler_flag:'`
+- (eval echo "\"\$as_me:16500: $lt_compile\"" >&5)
++ (eval echo "\"\$as_me:16501: $lt_compile\"" >&5)
+ (eval "$lt_compile" 2>conftest.err)
+ ac_status=$?
+ cat conftest.err >&5
+- echo "$as_me:16504: \$? = $ac_status" >&5
++ echo "$as_me:16505: \$? = $ac_status" >&5
+ if (exit $ac_status) && test -s "$ac_outfile"; then
+ # The compiler can only warn and ignore the option if not recognized
+ # So say no if there are warnings other than the usual output.
+@@ -16765,11 +16766,11 @@
+ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \
+ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \
+ -e 's:$: $lt_compiler_flag:'`
+- (eval echo "\"\$as_me:16768: $lt_compile\"" >&5)
++ (eval echo "\"\$as_me:16769: $lt_compile\"" >&5)
+ (eval "$lt_compile" 2>conftest.err)
+ ac_status=$?
+ cat conftest.err >&5
+- echo "$as_me:16772: \$? = $ac_status" >&5
++ echo "$as_me:16773: \$? = $ac_status" >&5
+ if (exit $ac_status) && test -s "$ac_outfile"; then
+ # The compiler can only warn and ignore the option if not recognized
+ # So say no if there are warnings other than the usual output.
+@@ -16869,11 +16870,11 @@
+ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \
+ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \
+ -e 's:$: $lt_compiler_flag:'`
+- (eval echo "\"\$as_me:16872: $lt_compile\"" >&5)
++ (eval echo "\"\$as_me:16873: $lt_compile\"" >&5)
+ (eval "$lt_compile" 2>out/conftest.err)
+ ac_status=$?
+ cat out/conftest.err >&5
+- echo "$as_me:16876: \$? = $ac_status" >&5
++ echo "$as_me:16877: \$? = $ac_status" >&5
+ if (exit $ac_status) && test -s out/conftest2.$ac_objext
+ then
+ # The compiler can only warn and ignore the option if not recognized
+@@ -20024,6 +20025,50 @@
+ fi
+
+
++# Extract the first word of "$CXX", so it can be a program name with args.
++set dummy $CXX; ac_word=$2
++{ echo "$as_me:$LINENO: checking for $ac_word" >&5
++echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }
++if test "${ac_cv_prog_check_cpp+set}" = set; then
++ echo $ECHO_N "(cached) $ECHO_C" >&6
++else
++ if test -n "$check_cpp"; then
++ ac_cv_prog_check_cpp="$check_cpp" # Let the user override the test.
++else
++as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
++for as_dir in $PATH
++do
++ IFS=$as_save_IFS
++ test -z "$as_dir" && as_dir=.
++ for ac_exec_ext in '' $ac_executable_extensions; do
++ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
++ ac_cv_prog_check_cpp=""yes""
++ echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
++ break 2
++ fi
++done
++done
++IFS=$as_save_IFS
++
++ test -z "$ac_cv_prog_check_cpp" && ac_cv_prog_check_cpp=""no""
++fi
++fi
++check_cpp=$ac_cv_prog_check_cpp
++if test -n "$check_cpp"; then
++ { echo "$as_me:$LINENO: result: $check_cpp" >&5
++echo "${ECHO_T}$check_cpp" >&6; }
++else
++ { echo "$as_me:$LINENO: result: no" >&5
++echo "${ECHO_T}no" >&6; }
++fi
++
++
++if false; then
++ { { echo "$as_me:$LINENO: error: No C++ compiler found. Unable to build Poly/ML." >&5
++echo "$as_me: error: No C++ compiler found. Unable to build Poly/ML." >&2;}
++ { (exit 1); exit 1; }; }
++fi
++
+ ac_ext=c
+ ac_cpp='$CPP $CPPFLAGS'
+ ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
+@@ -22441,7 +22486,13 @@
+ fi
+
+
+-if test "${with_x+set}" = set; then
++if test "x${with_x}" = "xyes"; then
++
++
++cat >>confdefs.h <<\_ACEOF
++#define WITH_XWINDOWS 1
++_ACEOF
++
+
+ if test "$x_includes" != "" ; then
+ if test "$x_includes" != "NONE" ; then
+@@ -24513,7 +24564,8 @@
+
+
+
+-for ac_header in sys/signal.h sys/sockio.h sys/stat.h sys/termios.h sys/times.h
++
++for ac_header in sys/signal.h sys/sockio.h sys/stat.h termios.h sys/termios.h sys/times.h
+ do
+ as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`
+ if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then
+@@ -32155,6 +32207,25 @@
+ polyarch=interpret
+ fi
+
++# Put this test at the end where it's less likely to be missed.
++# If we're compiling on Cygwin (and mingw?) and /usr/bin/file is not present
++# the link step will produce some strange warning messages of the form:
++# "Warning: linker path does not have real file for library -lXXX". I think
++# that's really a bug in autoconf but to explain what's happening to the user
++# add a test here.
++if test "$lt_cv_file_magic_cmd" = "func_win32_libid";
++then
++ if test \! -x /usr/bin/file;
++ then
++ echo ""
++ echo "*** Warning: You are building Poly/ML on Cygwin/Mingw but '/usr/bin/file' cannot be found."
++ echo "*** You can still go ahead and build Poly/ML but libpolyml will not be built as a"
++ echo "*** shared library and you may get strange warning messages from the linker step."
++ echo "*** Install the 'file' package to correct this problem."
++ echo ""
++ fi
++fi
++
+ if test "$polyarch" = i386; then
+ ARCHI386_TRUE=
+ ARCHI386_FALSE='#'
+@@ -33133,6 +33204,7 @@
+ MAINTAINER_MODE_TRUE!$MAINTAINER_MODE_TRUE$ac_delim
+ MAINTAINER_MODE_FALSE!$MAINTAINER_MODE_FALSE$ac_delim
+ MAINT!$MAINT$ac_delim
++check_cpp!$check_cpp$ac_delim
+ CCAS!$CCAS$ac_delim
+ CCASFLAGS!$CCASFLAGS$ac_delim
+ CCASDEPMODE!$CCASDEPMODE$ac_delim
+@@ -33167,7 +33239,7 @@
+ LTLIBOBJS!$LTLIBOBJS$ac_delim
+ _ACEOF
+
+- if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 43; then
++ if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 44; then
+ break
+ elif $ac_last_try; then
+ { { echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5
+diff -u -r configure.ac configure.ac
+--- configure.ac 2008-10-17 14:55:23.000000000 +0200
++++ configure.ac 2009-09-15 08:56:48.000000000 +0200
+@@ -75,6 +75,11 @@
+
+ # Checks for programs.
+ AC_PROG_CXX
++AC_CHECK_PROG(check_cpp, $CXX, "yes", "no")
++if test "$check_cpp" != "yes"; then
++ AC_MSG_ERROR([No C++ compiler found. Unable to build Poly/ML.])
++fi
++
+ AC_PROG_CC
+ AC_PROG_MAKE_SET
+ AC_PROG_CPP
+@@ -101,7 +106,9 @@
+ # Check for X and Motif headers and libraries
+ AC_PATH_X
+
+-if test "${with_x+set}" = set; then
++if test "x${with_x}" = "xyes"; then
++
++ AC_DEFINE([WITH_XWINDOWS], [1], [Define if the X-Windows interface should be built])
+
+ if test "$x_includes" != "" ; then
+ if test "$x_includes" != "NONE" ; then
+@@ -149,7 +156,7 @@
+ AC_CHECK_HEADERS([assert.h ctype.h direct.h errno.h excpt.h fenv.h fpu_control.h grp.h])
+ AC_CHECK_HEADERS([ieeefp.h io.h math.h memory.h netinet/tcp.h poll.h pwd.h siginfo.h])
+ AC_CHECK_HEADERS([stdarg.h sys/errno.h sys/filio.h sys/mman.h sys/resource.h])
+-AC_CHECK_HEADERS([sys/signal.h sys/sockio.h sys/stat.h sys/termios.h sys/times.h])
++AC_CHECK_HEADERS([sys/signal.h sys/sockio.h sys/stat.h termios.h sys/termios.h sys/times.h])
+ AC_CHECK_HEADERS([sys/types.h sys/uio.h sys/un.h sys/utsname.h sys/select.h sys/sysctl.h])
+ AC_CHECK_HEADERS([sys/elf_SPARC.h sys/elf_386.h])
+ AC_CHECK_HEADERS([windows.h tchar.h pthread.h semaphore.h])
+@@ -283,6 +290,25 @@
+ polyarch=interpret
+ fi
+
++# Put this test at the end where it's less likely to be missed.
++# If we're compiling on Cygwin (and mingw?) and /usr/bin/file is not present
++# the link step will produce some strange warning messages of the form:
++# "Warning: linker path does not have real file for library -lXXX". I think
++# that's really a bug in autoconf but to explain what's happening to the user
++# add a test here.
++if test "$lt_cv_file_magic_cmd" = "func_win32_libid";
++then
++ if test \! -x /usr/bin/file;
++ then
++ echo ""
++ echo "*** Warning: You are building Poly/ML on Cygwin/Mingw but '/usr/bin/file' cannot be found."
++ echo "*** You can still go ahead and build Poly/ML but libpolyml will not be built as a"
++ echo "*** shared library and you may get strange warning messages from the linker step."
++ echo "*** Install the 'file' package to correct this problem."
++ echo ""
++ fi
++fi
++
+ AM_CONDITIONAL([ARCHI386], [test "$polyarch" = i386])
+ AM_CONDITIONAL([ARCHPPC], [test "$polyarch" = ppc])
+ AM_CONDITIONAL([ARCHSPARC], [test "$polyarch" = sparc])
+diff -u -r exportPoly.sml exportPoly.sml
+--- exportPoly.sml 2008-03-28 11:54:41.000000000 +0100
++++ exportPoly.sml 2009-09-15 08:56:47.000000000 +0200
+@@ -27,34 +27,42 @@
+ (* We've now set up the new name space so everything has to be
+ compiled into that rather than the old space. *)
+
+-(* FFI. *)
+-PolyML.make "mlsource/extra/CInterface";
+-PolyML.use "mlsource/extra/CInterface/clean";
+-
+-(* XWindows/Motif *)
+ let
+- val xcall: int*int->int*int =
+- RunCall.run_call1 RuntimeCalls.POLY_SYS_XWindows;
+- (* See if the RTS supports the X GetTimeOfDay call. *)
+- val isX = (xcall(30, 0); true) handle _ => false
++ (* Bootstrap.use adds the path given as -I path but PolyML.make and PolyML.use
++ don't. Add the path explicitly. *)
++ val args = CommandLine.arguments();
++ fun getPath [] = "." (* Default path *)
++ | getPath ("-I" :: outFile :: _) = outFile
++ | getPath (_::tl) = getPath tl
++ val path = getPath args
+ in
+- if isX
+- then
+- (
+- PolyML.make "mlsource/extra/XWindows";
+- PolyML.make "mlsource/extra/Motif"
+- )
+- else ()
++ (* FFI. *)
++ PolyML.make (OS.Path.concat(path, "mlsource/extra/CInterface"));
++ PolyML.use (OS.Path.concat(path, "mlsource/extra/CInterface/clean"));
++
++ (* XWindows/Motif *)
++ let
++ val xcall: int*int->int*int =
++ RunCall.run_call1 RuntimeCalls.POLY_SYS_XWindows;
++ (* See if the RTS supports the X GetTimeOfDay call. *)
++ val isX = (xcall(30, 0); true) handle _ => false
++ in
++ if isX
++ then
++ (
++ PolyML.make "mlsource/extra/XWindows";
++ PolyML.make "mlsource/extra/Motif"
++ )
++ else ()
++ end
+ end;
+
+-PolyML.print_depth 100;
++PolyML.print_depth 10;
+
+ (* Set the inline level to 40 which seems optimal. *)
+ PolyML.Compiler.maxInlineSize := 40;
+
+-(* Do this last. There's a problem that replacing the standard input
+- loses any buffering in the previous input which includes any commands
+- after the one that does the replacing. *)
++(* Write out the result as an export file. *)
+ let
+ val args = CommandLine.arguments();
+ (* If we have -o filename use that as the output name.
+diff -u -r libpolymain/Makefile.in libpolymain/Makefile.in
+--- libpolymain/Makefile.in 2007-10-05 14:31:37.000000000 +0200
++++ libpolymain/Makefile.in 2009-09-15 08:56:36.000000000 +0200
+@@ -1,8 +1,8 @@
+-# Makefile.in generated by automake 1.10 from Makefile.am.
++# Makefile.in generated by automake 1.10.1 from Makefile.am.
+ # @configure_input@
+
+ # Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+-# 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
++# 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+ # This Makefile.in is free software; the Free Software Foundation
+ # gives unlimited permission to copy and/or distribute it,
+ # with or without modifications, as long as this notice is preserved.
+@@ -56,7 +56,7 @@
+ libpolymain_la_LINK = $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) \
+ $(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \
+ $(libpolymain_la_LDFLAGS) $(LDFLAGS) -o $@
+-DEFAULT_INCLUDES = -I. -I$(top_builddir)@am__isrc@
++DEFAULT_INCLUDES = -I. at am__isrc@ -I$(top_builddir)
+ depcomp = $(SHELL) $(top_srcdir)/depcomp
+ am__depfiles_maybe = depfiles
+ COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \
+@@ -98,6 +98,7 @@
+ DEFS = @DEFS@
+ DEPDIR = @DEPDIR@
+ DLLTOOL = @DLLTOOL@
++DSYMUTIL = @DSYMUTIL@
+ ECHO = @ECHO@
+ ECHO_C = @ECHO_C@
+ ECHO_N = @ECHO_N@
+@@ -121,6 +122,7 @@
+ MAINT = @MAINT@
+ MAKEINFO = @MAKEINFO@
+ MKDIR_P = @MKDIR_P@
++NMEDIT = @NMEDIT@
+ OBJDUMP = @OBJDUMP@
+ OBJEXT = @OBJEXT@
+ OSFLAG = @OSFLAG@
+@@ -133,6 +135,7 @@
+ PATH_SEPARATOR = @PATH_SEPARATOR@
+ POW_LIB = @POW_LIB@
+ RANLIB = @RANLIB@
++SED = @SED@
+ SET_MAKE = @SET_MAKE@
+ SHELL = @SHELL@
+ STRIP = @STRIP@
+@@ -157,6 +160,7 @@
+ build_os = @build_os@
+ build_vendor = @build_vendor@
+ builddir = @builddir@
++check_cpp = @check_cpp@
+ datadir = @datadir@
+ datarootdir = @datarootdir@
+ docdir = @docdir@
+@@ -234,8 +238,8 @@
+ @list='$(lib_LTLIBRARIES)'; for p in $$list; do \
+ if test -f $$p; then \
+ f=$(am__strip_dir) \
+- echo " $(LIBTOOL) --mode=install $(libLTLIBRARIES_INSTALL) $(INSTALL_STRIP_FLAG) '$$p' '$(DESTDIR)$(libdir)/$$f'"; \
+- $(LIBTOOL) --mode=install $(libLTLIBRARIES_INSTALL) $(INSTALL_STRIP_FLAG) "$$p" "$(DESTDIR)$(libdir)/$$f"; \
++ echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(libLTLIBRARIES_INSTALL) $(INSTALL_STRIP_FLAG) '$$p' '$(DESTDIR)$(libdir)/$$f'"; \
++ $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(libLTLIBRARIES_INSTALL) $(INSTALL_STRIP_FLAG) "$$p" "$(DESTDIR)$(libdir)/$$f"; \
+ else :; fi; \
+ done
+
+@@ -243,8 +247,8 @@
+ @$(NORMAL_UNINSTALL)
+ @list='$(lib_LTLIBRARIES)'; for p in $$list; do \
+ p=$(am__strip_dir) \
+- echo " $(LIBTOOL) --mode=uninstall rm -f '$(DESTDIR)$(libdir)/$$p'"; \
+- $(LIBTOOL) --mode=uninstall rm -f "$(DESTDIR)$(libdir)/$$p"; \
++ echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f '$(DESTDIR)$(libdir)/$$p'"; \
++ $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f "$(DESTDIR)$(libdir)/$$p"; \
+ done
+
+ clean-libLTLIBRARIES:
+@@ -298,8 +302,8 @@
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+- $(AWK) ' { files[$$0] = 1; } \
+- END { for (i in files) print i; }'`; \
++ $(AWK) '{ files[$$0] = 1; nonemtpy = 1; } \
++ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ mkid -fID $$unique
+ tags: TAGS
+
+@@ -311,8 +315,8 @@
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+- $(AWK) ' { files[$$0] = 1; } \
+- END { for (i in files) print i; }'`; \
++ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
++ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ if test -z "$(ETAGS_ARGS)$$tags$$unique"; then :; else \
+ test -n "$$unique" || unique=$$empty_fix; \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+@@ -322,13 +326,12 @@
+ CTAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ tags=; \
+- here=`pwd`; \
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+- $(AWK) ' { files[$$0] = 1; } \
+- END { for (i in files) print i; }'`; \
++ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
++ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ test -z "$(CTAGS_ARGS)$$tags$$unique" \
+ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \
+ $$tags $$unique
+diff -u -r libpolymain/polystub.c libpolymain/polystub.c
+--- libpolymain/polystub.c 2007-09-16 13:20:56.000000000 +0200
++++ libpolymain/polystub.c 2009-09-15 08:56:36.000000000 +0200
+@@ -29,7 +29,7 @@
+ #error "No configuration file"
+ #endif
+
+-#include "polyexports.h"
++#include "../polyexports.h"
+
+ #ifdef WINDOWS_PC
+ int WINAPI WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPTSTR lpCmdLine, int nCmdShow)
+diff -u -r libpolyml/Console.cpp libpolyml/Console.cpp
+--- libpolyml/Console.cpp 2007-09-16 13:13:30.000000000 +0200
++++ libpolyml/Console.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -58,7 +58,7 @@
+ #define ASSERT(x)
+ #endif
+
+-#include "resource.h"
++#include "../resource.h"
+ #include "mpoly.h"
+ #include "PolyControl.h"
+ #include "diagnostics.h"
+@@ -66,7 +66,7 @@
+ #include "run_time.h"
+ #include "sighandler.h"
+ #include "console.h"
+-#include "polyexports.h"
++#include "../polyexports.h"
+ #include "processes.h"
+
+ /*
+@@ -83,7 +83,7 @@
+
+ HANDLE hMainThread = NULL; // Handle to ML thread.
+ HWND hMainWindow = NULL; // Main window - exported.
+-int useConsole; // Zero if callers should read from stdin.
++bool useConsole; // False if callers should read from stdin.
+ HINSTANCE hApplicationInstance; // Application instance (exported)
+ static HANDLE hReadFromML; // Handles to pipe from ML thread
+ static WNDPROC wpOrigEditProc; // Saved window proc.
+@@ -94,9 +94,8 @@
+ static int nNextPosn; // Position to add input. (<= nBuffLen)
+ static int nAvailable; // Position of "committed" input (<= nNextPosn)
+ static int nReadPosn; // Position of last read (<= nAvailable)
+-static BOOL fCtrlC; // TRUE if we have just pressed ctrl-C.
+ static CRITICAL_SECTION csIOInterlock;
+-static HANDLE hInputEvent; // Signalled when input is available.
++HANDLE hInputEvent; // Signalled when input is available.
+ static HWND hDDEWindow; // Window to handle DDE requests from ML thread.
+
+ static char *lpszServiceName;
+@@ -122,34 +121,23 @@
+
+ /* These functions are called by the I/O routines to test for input and
+ to read from the keyboard. */
+-int isConsoleInput(void)
++bool isConsoleInput(void)
+ {
+- int nRes;
+ if (! isActive) { ShowWindow(hMainWindow, nInitialShow); isActive = true; }
+ EnterCriticalSection(&csIOInterlock);
+- nRes = (nAvailable != nReadPosn) || fCtrlC;
++ bool nRes = nAvailable != nReadPosn;
+ LeaveCriticalSection(&csIOInterlock);
+ return nRes;
+ }
+
+ /* Read characters from the input. Only returns zero on EOF. */
+-int getConsoleInput(char *buff, int nChars)
++unsigned getConsoleInput(char *buff, int nChars)
+ {
+- int nRes = 0;
++ unsigned nRes = 0;
+ if (! isActive) { ShowWindow(hMainWindow, nInitialShow); isActive = true; }
+ EnterCriticalSection(&csIOInterlock);
+- while (nAvailable == nReadPosn || fCtrlC)
++ while (nAvailable == nReadPosn)
+ {
+- if (fCtrlC)
+- {
+- // If we had a control-C we treat it much as an interrupted
+- // system call in Unix.
+- fCtrlC = FALSE;
+- if (nAvailable == nReadPosn) ResetEvent(hInputEvent);
+- LeaveCriticalSection(&csIOInterlock);
+- errno = EINTR;
+- return -1;
+- }
+ ResetEvent(hInputEvent);
+ /* Must block until there is input.
+ This will only actually happen when called from HandleINT
+@@ -423,10 +411,6 @@
+ // Discard any type-ahead.
+ nNextPosn = nAvailable = nReadPosn = 0;
+ RequestConsoleInterrupt();
+- // Set the ctrl-C flag and make sure the ML thread
+- // is unblocked.
+- fCtrlC = TRUE;
+- SetEvent(hInputEvent);
+ }
+ }
+ else if (wParam >= ' ' || wParam == '\r' || wParam == '\t' ||
+@@ -512,7 +496,11 @@
+ if (wParam == IDOK)
+ {
+ EndDialog(hwndDlg, IDOK);
++ return 1;
+ }
++ case WM_CLOSE:
++ EndDialog(hwndDlg, IDOK);
++ return 1;
+ default: return 0;
+ }
+ }
+@@ -647,10 +635,6 @@
+ // Discard any type-ahead.
+ nNextPosn = nAvailable = nReadPosn = 0;
+ RequestConsoleInterrupt();
+- // Set the ctrl-C flag and make sure the ML thread
+- // is unblocked.
+- fCtrlC = TRUE;
+- SetEvent(hInputEvent);
+ return 0;
+
+ default: return DefWindowProc(hwnd, uMsg, wParam, lParam);
+@@ -714,6 +698,7 @@
+ return polymain(nArgs, lpArgs, exports);
+ }
+
++
+ int PolyWinMain(
+ HINSTANCE hInstance,
+ HINSTANCE hPrevInstance,
+@@ -791,6 +776,7 @@
+
+ // Create a thread to manage the output from ML.
+ HANDLE hInThread = CreateThread(NULL, 0, InThrdProc, 0, 0, &dwInId);
++ if (hInThread == NULL) return 1;
+ CloseHandle(hInThread);
+ wndClass.cbSize = sizeof(wndClass);
+ wndClass.style = 0;
+@@ -835,14 +821,30 @@
+ // read from or write to the main window. That way if we are
+ // actually using another window this will never get displayed.
+ nInitialShow = nCmdShow;
+- useConsole = 1;
++ useConsole = true;
+ }
+ else {
+- // If we're not creating a window it's possible that we could still
+- // call getConsoleInput if the handle underlying stdin is closed for
+- // some reason. Set the event so that we return EOF in that case.
+- SetEvent(hInputEvent);
+- useConsole = 0;
++ // We're using the stdin passed in by the caller. This may well
++ // be a pipe and in order to get reasonable performance we need
++ // to interpose a thread. This is the only way to be able to have
++ // something we can pass to MsgWaitForMultipleObjects, in this case
++ // hInputEvent, which will indicate the input is available.
++ HANDLE hOldStdin;
++ // Duplicate the handle because we're going to close this.
++ if (! DuplicateHandle(GetCurrentProcess(), GetStdHandle(STD_INPUT_HANDLE),
++ GetCurrentProcess(), &hOldStdin, 0, TRUE, // inheritable
++ DUPLICATE_SAME_ACCESS ))
++ return 1;
++
++ HANDLE hNewStdin = CreateCopyPipe(hOldStdin, hInputEvent);
++ if (hNewStdin == NULL) return 1;
++
++ // Replace the current stdin with the output from the pipe.
++ fclose(stdin);
++ int newstdin = _open_osfhandle ((INT_PTR)hNewStdin, _O_RDONLY | _O_TEXT);
++ if (newstdin != 0) _dup2(newstdin, 0);
++ fdopen(0, "rt");
++ useConsole = false;
+ }
+
+ // Convert the command line into Unix-style arguments.
+@@ -1004,3 +1006,109 @@
+ // Unitialise DDE.
+ DdeUninitialize(dwDDEInstance);
+ }
++
++// We want copyThread to be static but also a friend of CopyPipe
++// GCC requires it to be declared static first otherwise it creates it
++// extern when it sees it as a friend then complains when it's static.
++static DWORD WINAPI copyThread(LPVOID lpParameter);
++
++class CopyPipe {
++public:
++ CopyPipe():
++ hOriginal(NULL), hOutput(NULL), hEvent(NULL) {}
++
++ HANDLE RunPipe(HANDLE hIn, HANDLE hEv);
++private:
++ ~CopyPipe();
++
++ void threadFunction(void);
++
++ HANDLE hOriginal;
++ HANDLE hOutput;
++ HANDLE hEvent;
++
++ friend DWORD WINAPI copyThread(LPVOID lpParameter);
++};
++
++CopyPipe::~CopyPipe()
++{
++ if (hOutput) CloseHandle(hOutput);
++ if (hOriginal) CloseHandle(hOriginal);
++ if (hEvent) CloseHandle(hEvent);
++}
++
++static DWORD WINAPI copyThread(LPVOID lpParameter)
++{
++ CopyPipe *cp = (CopyPipe *)lpParameter;
++ cp->threadFunction();
++ delete cp;
++ return 0;
++}
++
++// This thread is used when the caller has provided a standard input
++// stream and we're using that and not out console. It copies the
++// standard input to a pipe and the ML code uses that as its input.
++// This way we can set hInputEvent whenever input is available.
++void CopyPipe::threadFunction()
++{
++ // Duplicate the event handle so that we can close it when we've finished
++ char buffer[4096];
++
++ while (true) {
++ DWORD dwRead;
++ if (! ReadFile(hOriginal, buffer, sizeof(buffer), &dwRead, NULL))
++ {
++ SetEvent(hEvent);
++ return;
++ }
++
++ if (dwRead == 0) // End-of-stream
++ {
++ // Normal exit. Indicate EOF
++ SetEvent(hEvent);
++ return;
++ }
++
++ SetEvent(hEvent); // Signal input has arrived
++ char *b = buffer;
++ do {
++ DWORD dwWritten;
++ if (! WriteFile(hOutput, b, dwRead, &dwWritten, NULL))
++ {
++ SetEvent(hEvent);
++ return;
++ }
++ b += dwWritten;
++ dwRead -= dwWritten;
++ } while (dwRead != 0);
++ }
++}
++
++HANDLE CopyPipe::RunPipe(HANDLE hIn, HANDLE hEv)
++{
++ HANDLE hNewInput = NULL;
++ hOriginal = hIn;
++
++ if (!CreatePipe(&hNewInput, &hOutput, NULL, 0)) return NULL;
++
++ if (! DuplicateHandle(GetCurrentProcess(), hEv, GetCurrentProcess(),
++ &hEvent, 0, FALSE, DUPLICATE_SAME_ACCESS))
++ return NULL;
++
++ DWORD dwInId;
++ HANDLE hInThread = CreateThread(NULL, 0, copyThread, this, 0, &dwInId);
++ if (hInThread == NULL) return NULL;
++ CloseHandle(hInThread);
++
++ return hNewInput;
++}
++
++// Create a pipe and a thread to read the input thread and signal the
++// event when input is available. Returns a handle to a pipe that
++// supplies a copy of the original input.
++HANDLE CreateCopyPipe(HANDLE hInput, HANDLE hEvent)
++{
++ CopyPipe *cp = new CopyPipe();
++ return cp->RunPipe(hInput, hEvent);
++}
++
+diff -u -r libpolyml/Console.h libpolyml/Console.h
+--- libpolyml/Console.h 2007-08-25 09:35:19.000000000 +0200
++++ libpolyml/Console.h 2009-09-15 08:56:44.000000000 +0200
+@@ -25,12 +25,16 @@
+ #include <windows.h>
+
+ /* Test whether input is available. */
+-extern int isConsoleInput(void);
++extern bool isConsoleInput(void);
+ /* Read characters from the input. Only returns zero on EOF. */
+-extern int getConsoleInput(char *buff, int nChars);
++extern unsigned getConsoleInput(char *buff, int nChars);
++
++// Create a copying thread that can also signal an event.
++// This is used both in stdin and also in Windows.execute.
++extern HANDLE CreateCopyPipe(HANDLE hInput, HANDLE hEvent);
+
+ extern HWND hMainWindow; /* Handle to main window - NULL if none. */
+-extern int useConsole; /* non-zero if we should use the console for input. */
++extern bool useConsole; /* non-zero if we should use the console for input. */
+ extern HINSTANCE hApplicationInstance; /* Application instance */
+
+ /* DDE requests. */
+@@ -39,5 +43,6 @@
+ extern LRESULT ExecuteDDE(char *command, HCONV hConv);
+
+ extern HANDLE hMainThread; /* Handle to main thread. */
++extern HANDLE hInputEvent; // Handle to console input event
+
+ #endif
+diff -u -r libpolyml/Makefile.am libpolyml/Makefile.am
+--- libpolyml/Makefile.am 2008-10-17 14:53:35.000000000 +0200
++++ libpolyml/Makefile.am 2009-09-15 08:56:44.000000000 +0200
+@@ -75,7 +75,7 @@
+
+ # Special rule for x86 assembly code.
+ x86asmtemp.S: x86asm.asm
+- sed -f masm2gas < x86asm.asm > x86asmtemp.S
++ sed -f $(srcdir)/masm2gas < $(srcdir)/x86asm.asm > x86asmtemp.S
+
+ # Special rule for Power PC. This is needed because of pecularities with MAC OS X.
+ ppcasmtemp.s: power_assembly.S
+diff -u -r libpolyml/Makefile.in libpolyml/Makefile.in
+--- libpolyml/Makefile.in 2008-10-17 14:53:35.000000000 +0200
++++ libpolyml/Makefile.in 2009-09-15 08:56:44.000000000 +0200
+@@ -1,8 +1,8 @@
+-# Makefile.in generated by automake 1.10 from Makefile.am.
++# Makefile.in generated by automake 1.10.1 from Makefile.am.
+ # @configure_input@
+
+ # Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+-# 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
++# 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+ # This Makefile.in is free software; the Free Software Foundation
+ # gives unlimited permission to copy and/or distribute it,
+ # with or without modifications, as long as this notice is preserved.
+@@ -93,7 +93,7 @@
+ libpolyml_la_LINK = $(LIBTOOL) --tag=CXX $(AM_LIBTOOLFLAGS) \
+ $(LIBTOOLFLAGS) --mode=link $(CXXLD) $(AM_CXXFLAGS) \
+ $(CXXFLAGS) $(libpolyml_la_LDFLAGS) $(LDFLAGS) -o $@
+-DEFAULT_INCLUDES = -I. -I$(top_builddir)@am__isrc@
++DEFAULT_INCLUDES = -I. at am__isrc@ -I$(top_builddir)
+ depcomp = $(SHELL) $(top_srcdir)/depcomp
+ am__depfiles_maybe = depfiles
+ CPPASCOMPILE = $(CCAS) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) \
+@@ -152,6 +152,7 @@
+ DEFS = @DEFS@
+ DEPDIR = @DEPDIR@
+ DLLTOOL = @DLLTOOL@
++DSYMUTIL = @DSYMUTIL@
+ ECHO = @ECHO@
+ ECHO_C = @ECHO_C@
+ ECHO_N = @ECHO_N@
+@@ -175,6 +176,7 @@
+ MAINT = @MAINT@
+ MAKEINFO = @MAKEINFO@
+ MKDIR_P = @MKDIR_P@
++NMEDIT = @NMEDIT@
+ OBJDUMP = @OBJDUMP@
+ OBJEXT = @OBJEXT@
+ OSFLAG = @OSFLAG@
+@@ -187,6 +189,7 @@
+ PATH_SEPARATOR = @PATH_SEPARATOR@
+ POW_LIB = @POW_LIB@
+ RANLIB = @RANLIB@
++SED = @SED@
+ SET_MAKE = @SET_MAKE@
+ SHELL = @SHELL@
+ STRIP = @STRIP@
+@@ -211,6 +214,7 @@
+ build_os = @build_os@
+ build_vendor = @build_vendor@
+ builddir = @builddir@
++check_cpp = @check_cpp@
+ datadir = @datadir@
+ datarootdir = @datarootdir@
+ docdir = @docdir@
+@@ -315,8 +319,8 @@
+ @list='$(lib_LTLIBRARIES)'; for p in $$list; do \
+ if test -f $$p; then \
+ f=$(am__strip_dir) \
+- echo " $(LIBTOOL) --mode=install $(libLTLIBRARIES_INSTALL) $(INSTALL_STRIP_FLAG) '$$p' '$(DESTDIR)$(libdir)/$$f'"; \
+- $(LIBTOOL) --mode=install $(libLTLIBRARIES_INSTALL) $(INSTALL_STRIP_FLAG) "$$p" "$(DESTDIR)$(libdir)/$$f"; \
++ echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(libLTLIBRARIES_INSTALL) $(INSTALL_STRIP_FLAG) '$$p' '$(DESTDIR)$(libdir)/$$f'"; \
++ $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(libLTLIBRARIES_INSTALL) $(INSTALL_STRIP_FLAG) "$$p" "$(DESTDIR)$(libdir)/$$f"; \
+ else :; fi; \
+ done
+
+@@ -324,8 +328,8 @@
+ @$(NORMAL_UNINSTALL)
+ @list='$(lib_LTLIBRARIES)'; for p in $$list; do \
+ p=$(am__strip_dir) \
+- echo " $(LIBTOOL) --mode=uninstall rm -f '$(DESTDIR)$(libdir)/$$p'"; \
+- $(LIBTOOL) --mode=uninstall rm -f "$(DESTDIR)$(libdir)/$$p"; \
++ echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f '$(DESTDIR)$(libdir)/$$p'"; \
++ $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f "$(DESTDIR)$(libdir)/$$p"; \
+ done
+
+ clean-libLTLIBRARIES:
+@@ -452,8 +456,8 @@
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+- $(AWK) ' { files[$$0] = 1; } \
+- END { for (i in files) print i; }'`; \
++ $(AWK) '{ files[$$0] = 1; nonemtpy = 1; } \
++ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ mkid -fID $$unique
+ tags: TAGS
+
+@@ -465,8 +469,8 @@
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+- $(AWK) ' { files[$$0] = 1; } \
+- END { for (i in files) print i; }'`; \
++ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
++ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ if test -z "$(ETAGS_ARGS)$$tags$$unique"; then :; else \
+ test -n "$$unique" || unique=$$empty_fix; \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+@@ -476,13 +480,12 @@
+ CTAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ tags=; \
+- here=`pwd`; \
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+- $(AWK) ' { files[$$0] = 1; } \
+- END { for (i in files) print i; }'`; \
++ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
++ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ test -z "$(CTAGS_ARGS)$$tags$$unique" \
+ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \
+ $$tags $$unique
+@@ -634,7 +637,7 @@
+
+ # Special rule for x86 assembly code.
+ x86asmtemp.S: x86asm.asm
+- sed -f masm2gas < x86asm.asm > x86asmtemp.S
++ sed -f $(srcdir)/masm2gas < $(srcdir)/x86asm.asm > x86asmtemp.S
+
+ # Special rule for Power PC. This is needed because of pecularities with MAC OS X.
+ ppcasmtemp.s: power_assembly.S
+diff -u -r libpolyml/PolyLib.dsp libpolyml/PolyLib.dsp
+--- libpolyml/PolyLib.dsp 2007-10-02 11:13:04.000000000 +0200
++++ libpolyml/PolyLib.dsp 2009-09-15 08:56:44.000000000 +0200
+@@ -558,7 +558,7 @@
+ # End Source File
+ # Begin Source File
+
+-SOURCE=.\winconfig.h
++SOURCE=..\winconfig.h
+ # End Source File
+ # Begin Source File
+
+diff -u -r libpolyml/arb.cpp libpolyml/arb.cpp
+--- libpolyml/arb.cpp 2008-03-25 12:23:08.000000000 +0100
++++ libpolyml/arb.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -51,10 +51,12 @@
+ canonical representation. That is required for structure equality to work.
+ */
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_STDIO_H
+diff -u -r libpolyml/basicio.cpp libpolyml/basicio.cpp
+--- libpolyml/basicio.cpp 2008-03-25 12:23:08.000000000 +0100
++++ libpolyml/basicio.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -31,10 +31,12 @@
+ Directory operations are also included in here.
+ DCJM May 2000.
+ */
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_FCNTL_H
+@@ -187,45 +189,55 @@
+ PLock ioLock; // Currently this just protects against two threads using the same entry
+
+ #ifdef WINDOWS_PC
++class WaitStream: public WaitHandle
++{
++public:
++ WaitStream(PIOSTRUCT strm): WaitHandle(strm == NULL ? NULL : strm->hAvailable) {}
++};
++
++#else
++
++class WaitStream: public WaitInputFD
++{
++public:
++ WaitStream(PIOSTRUCT strm): WaitInputFD(strm == NULL ? -1 : strm->device.ioDesc) {}
++};
++#endif
++
++#ifdef WINDOWS_PC
+
+ /* Deal with the various cases to see if input is available. */
+-static int isAvailable(TaskData *taskData, PIOSTRUCT strm)
++static bool isAvailable(TaskData *taskData, PIOSTRUCT strm)
+ {
+ HANDLE hFile = (HANDLE)_get_osfhandle(strm->device.ioDesc);
++
+ if (isPipe(strm))
+ {
+ DWORD dwAvail;
+ int err;
+ if (PeekNamedPipe(hFile, NULL, 0, NULL, &dwAvail, NULL))
+- {
+- return (dwAvail == 0 ? 0 : 1);
+- }
++ return dwAvail != 0;
+ err = GetLastError();
+ /* Windows returns ERROR_BROKEN_PIPE on input whereas Unix
+ only returns it on output and treats it as EOF. We
+ follow Unix here. */
+ if (err == ERROR_BROKEN_PIPE)
+- return 1; /* At EOF - will not block. */
++ return true; /* At EOF - will not block. */
+ else raise_syscall(taskData, "PeekNamedPipe failed", -err);
+ /*NOTREACHED*/
+ }
++
+ else if (isConsole(strm)) return isConsoleInput();
++
+ else if (isDevice(strm))
+- {
+- if (WaitForSingleObject(hFile, 0) == WAIT_OBJECT_0)
+- return 1;
+- else return 0;
+- }
++ return WaitForSingleObject(hFile, 0) == WAIT_OBJECT_0;
+ else
+ /* File - We may be at end-of-file but we won't block. */
+- return 1;
++ return true;
+ }
+
+ #else
+-// Test whether input is available and block if it is not.
+-// This is also used in xwindows.cpp
+-// N.B. There may be a GC while in here.
+-void process_may_block(TaskData *taskData, int fd, int/* ioCall*/)
++static bool isAvailable(TaskData *taskData, PIOSTRUCT strm)
+ {
+ #ifdef __CYGWIN__
+ static struct timeval poll = {0,1};
+@@ -234,21 +246,15 @@
+ #endif
+ fd_set read_fds;
+ int selRes;
++ FD_ZERO(&read_fds);
++ FD_SET((int)strm->device.ioDesc, &read_fds);
+
+- while (1)
+- {
+-
+- FD_ZERO(&read_fds);
+- FD_SET((int)fd,&read_fds);
+-
+- /* If there is something there we can return. */
+- selRes = select(FD_SETSIZE, &read_fds, NULL, NULL, &poll);
+- if (selRes > 0) return; /* Something waiting. */
+- else if (selRes < 0 && errno != EINTR) // Maybe another thread closed descr
+- raise_syscall(taskData, "select failed %d\n", errno);
+- // Wait for activity.
+- processes->ThreadPauseForIO(taskData, fd);
+- }
++ /* If there is something there we can return. */
++ selRes = select(FD_SETSIZE, &read_fds, NULL, NULL, &poll);
++ if (selRes > 0) return true; /* Something waiting. */
++ else if (selRes < 0 && errno != EINTR) // Maybe another thread closed descr
++ raise_syscall(taskData, "select failed %d\n", errno);
++ else return false;
+ }
+
+ #endif
+@@ -287,6 +293,10 @@
+ str->ioBits = 0;
+ str->token = 0;
+ emfileFlag = false;
++#ifdef WINDOWS_PC
++ if (str->hAvailable) CloseHandle(str->hAvailable);
++ str->hAvailable = NULL;
++#endif
+ }
+
+
+@@ -489,6 +499,8 @@
+ } /* close_file */
+
+ /* Read into an array. */
++// We can't combine readArray and readString because we mustn't compute the
++// destination of the data in readArray until after any GC.
+ static Handle readArray(TaskData *taskData, Handle stream, Handle args, bool/*isText*/)
+ {
+ /* The isText argument is ignored in both Unix and Windows but
+@@ -499,33 +511,30 @@
+ {
+ // First test to see if we have input available.
+ // These tests may result in a GC if another thread is running.
+- PIOSTRUCT strm = get_stream(DEREFHANDLE(stream));
+- /* Raise an exception if the stream has been closed. */
+- if (strm == NULL) raise_syscall(taskData, "Stream is closed", EBADF);
+- int fd = strm->device.ioDesc;
+-#ifdef WINDOWS_PC
+- if (isConsole(strm))
+- {
+- while (! isConsoleInput())
+- processes->ThreadPause(taskData);
+- }
+- else
+- {
+- while (! isAvailable(taskData, strm))
+- {
+- processes->ThreadPauseForIO(taskData, strm->device.ioDesc);
+- strm = get_stream(DEREFHANDLE(stream)); // Could have been closed.
+- }
++ // First test to see if we have input available.
++ // These tests may result in a GC if another thread is running.
++ PIOSTRUCT strm;
++
++ while (true) {
++ strm = get_stream(DEREFHANDLE(stream));
++ /* Raise an exception if the stream has been closed. */
++ if (strm == NULL) raise_syscall(taskData, "Stream is closed", EBADF);
++ if (isAvailable(taskData, strm))
++ break;
++ WaitStream waiter(strm);
++ processes->ThreadPauseForIO(taskData, &waiter);
+ }
+-#else
+- /* Unix. */
+- process_may_block(taskData, fd, POLY_SYS_io_dispatch);
++
++#ifdef WINDOWS_PC
++ if (strm->hAvailable != NULL) ResetEvent(strm->hAvailable);
+ #endif
+ // We can now try to read without blocking.
+- strm = get_stream(DEREFHANDLE(stream));
+- /* Raise an exception if the stream has been closed. */
+- if (strm == NULL) raise_syscall(taskData, "Stream is closed", EBADF);
+- fd = strm->device.ioDesc;
++ // Actually there's a race here in the unlikely situation that there
++ // are multiple threads sharing the same low-level reader. They could
++ // both detect that input is available but only one may succeed in
++ // reading without blocking. This doesn't apply where the threads use
++ // the higher-level IO interfaces in ML which have their own mutexes.
++ int fd = strm->device.ioDesc;
+ byte *base = DEREFHANDLE(args)->Get(0).AsObjPtr()->AsBytePtr();
+ POLYUNSIGNED offset = get_C_ulong(taskData, DEREFWORDHANDLE(args)->Get(1));
+ POLYUNSIGNED length = get_C_ulong(taskData, DEREFWORDHANDLE(args)->Get(2));
+@@ -563,31 +572,24 @@
+ {
+ // First test to see if we have input available.
+ // These tests may result in a GC if another thread is running.
+- PIOSTRUCT strm = get_stream(DEREFHANDLE(stream));
+- /* Raise an exception if the stream has been closed. */
+- if (strm == NULL) raise_syscall(taskData, "Stream is closed", EBADF);
+- int fd = strm->device.ioDesc;
+-#ifdef WINDOWS_PC
+- if (isConsole(strm))
+- {
+- while (! isConsoleInput())
+- processes->ThreadPause(taskData);
+- }
+- else
+- {
+- while (! isAvailable(taskData, strm))
+- {
+- processes->ThreadPauseForIO(taskData, strm->device.ioDesc);
+- strm = get_stream(DEREFHANDLE(stream)); // Could have been closed.
+- }
++ PIOSTRUCT strm;
++
++ while (true) {
++ strm = get_stream(DEREFHANDLE(stream));
++ /* Raise an exception if the stream has been closed. */
++ if (strm == NULL) raise_syscall(taskData, "Stream is closed", EBADF);
++ if (isAvailable(taskData, strm))
++ break;
++ WaitStream waiter(strm);
++ processes->ThreadPauseForIO(taskData, &waiter);
+ }
+-#else
+- /* Unix. */
+- process_may_block(taskData, fd, POLY_SYS_io_dispatch);
++
++#ifdef WINDOWS_PC
++ if (strm->hAvailable != NULL) ResetEvent(strm->hAvailable);
+ #endif
++
+ // We can now try to read without blocking.
+- strm = get_stream(DEREFHANDLE(stream));
+- fd = strm->device.ioDesc;
++ int fd = strm->device.ioDesc;
+ // We previously allocated the buffer on the stack but that caused
+ // problems with multi-threading at least on Mac OS X because of
+ // stack exhaustion. We limit the space to 100k. */
+@@ -637,7 +639,6 @@
+ if (strm == NULL) raise_syscall(taskData, "Stream is closed", EBADF);
+
+ /* We don't actually handle cases of blocking on output. */
+- /* process_may_block(strm); */
+ byte *toWrite;
+ if (IS_INT(base))
+ {
+@@ -656,59 +657,33 @@
+ return Make_arbitrary_precision(taskData, haveWritten);
+ }
+
+-
+-/* Test whether we can read without blocking. Returns 0 if it will block,
+- 1 if it will not. */
+-static int canInput(TaskData *taskData, Handle stream)
+-{
+- PIOSTRUCT strm = get_stream(stream->WordP());
+- if (strm == NULL) raise_syscall(taskData, "Stream is closed", EBADF);
+-
+-#ifdef WINDOWS_PC
+- return isAvailable(taskData, strm);
+-#else
+- {
+- /* Unix - use "select" to find out if there is input available. */
+- struct timeval delay = { 0, 0 };
+- fd_set read_fds;
+- int sel;
+- FD_ZERO(&read_fds);
+- FD_SET(strm->device.ioDesc, &read_fds);
+- sel = select(FD_SETSIZE, &read_fds, NULL, NULL, &delay);
+- if (sel < 0 && errno != EINTR)
+- raise_syscall(taskData, "select failed", errno);
+- else if (sel > 0) return 1;
+- else return 0;
+- }
+-#endif
+-}
+-
+-/* Test whether we can write without blocking. Returns 0 if it will block,
+- 1 if it will not. */
+-static int canOutput(TaskData *taskData, Handle stream)
++// Test whether we can write without blocking. Returns false if it will block,
++// true if it will not.
++static bool canOutput(TaskData *taskData, Handle stream)
+ {
+ PIOSTRUCT strm = get_stream(stream->WordP());
+ if (strm == NULL) raise_syscall(taskData, "Stream is closed", EBADF);
+
+ #ifdef WINDOWS_PC
+ /* There's no way I can see of doing this in Windows. */
+- return 1;
++ return true;
+ #else
+- {
+- /* Unix - use "select" to find out if output is possible. */
+- struct timeval delay = { 0, 0 };
+- fd_set read_fds, write_fds, except_fds;
+- int sel;
+- FD_ZERO(&read_fds);
+- FD_ZERO(&write_fds);
+- FD_ZERO(&except_fds);
+- FD_SET(strm->device.ioDesc, &write_fds);
+- sel = select(FD_SETSIZE,&read_fds,&write_fds,&except_fds,&delay);
+- if (sel < 0 && errno != EINTR)
+- raise_syscall(taskData, "select failed", errno);
+- else if (sel > 0) return 1;
+- else return 0;
+- }
++ /* Unix - use "select" to find out if output is possible. */
++#ifdef __CYGWIN__
++ static struct timeval poll = {0,1};
++#else
++ static struct timeval poll = {0,0};
++#endif
++ fd_set read_fds, write_fds, except_fds;
++ int sel;
++ FD_ZERO(&read_fds);
++ FD_ZERO(&write_fds);
++ FD_ZERO(&except_fds);
++ FD_SET(strm->device.ioDesc, &write_fds);
++ sel = select(FD_SETSIZE,&read_fds,&write_fds,&except_fds,&poll);
++ if (sel < 0 && errno != EINTR)
++ raise_syscall(taskData, "select failed", errno);
++ return sel > 0;
+ #endif
+ }
+
+@@ -910,7 +885,7 @@
+ /* else drop through and block. */
+ }
+ case 1: /* Block until one of the descriptors is ready. */
+- processes->BlockAndRestart(taskData, -1, false, POLY_SYS_io_dispatch);
++ processes->BlockAndRestart(taskData, NULL, false, POLY_SYS_io_dispatch);
+ /*NOTREACHED*/
+ case 2: /* Just a simple poll - drop through. */
+ break;
+@@ -968,7 +943,7 @@
+ /* else block. */
+ }
+ case 1: /* Block until one of the descriptors is ready. */
+- processes->BlockAndRestart(taskData, -1, false, POLY_SYS_io_dispatch);
++ processes->BlockAndRestart(taskData, NULL, false, POLY_SYS_io_dispatch);
+ /*NOTREACHED*/
+ case 2: /* Just a simple poll - drop through. */
+ break;
+@@ -1039,7 +1014,7 @@
+ /* else block. */
+ }
+ case 1: /* Block until one of the descriptors is ready. */
+- processes->BlockAndRestart(taskData, -1, false, POLY_SYS_io_dispatch);
++ processes->BlockAndRestart(taskData, NULL, false, POLY_SYS_io_dispatch);
+ /*NOTREACHED*/
+ case 2: /* Just a simple poll - drop through. */
+ break;
+@@ -1431,7 +1406,7 @@
+ if (dwErr != /* ERROR_FILE_EXISTS */ ERROR_ALREADY_EXISTS)
+ raise_syscall(taskData, "MoveFile failed", -(int)dwErr);
+ /* Failed because destination file exists. */
+- if (_osver & 0x8000)
++ if (GetVersion() & 0x80000000)
+ {
+ /* Windows 95 - must use delete. */
+ if (!DeleteFile(newName))
+@@ -1545,8 +1520,14 @@
+ the moment. */
+ /* Try increasing to 4k. */
+ return Make_arbitrary_precision(taskData, /*1024*/4096);
++
+ case 16: /* See if we can get some input. */
+- return Make_arbitrary_precision(taskData, canInput(taskData, strm));
++ {
++ PIOSTRUCT str = get_stream(strm->WordP());
++ if (str == NULL) raise_syscall(taskData, "Stream is closed", EBADF);
++ return Make_arbitrary_precision(taskData, isAvailable(taskData, str) ? 1 : 0);
++ }
++
+ case 17: /* Return the number of bytes available. */
+ return bytesAvailable(taskData, strm);
+
+@@ -1602,22 +1583,26 @@
+ return readString(taskData, strm, args, false);
+
+ case 27: /* Block until input is available. */
+- {
++ while (true) {
+ PIOSTRUCT str = get_stream(strm->WordP());
+ if (str == NULL) raise_syscall(taskData, "Stream is closed", EBADF);
+- if (canInput(taskData, strm) == 0)
+- processes->BlockAndRestart(taskData, str->device.ioDesc, false, POLY_SYS_io_dispatch);
+- return Make_arbitrary_precision(taskData, 0);
++ if (isAvailable(taskData, str))
++ Make_arbitrary_precision(taskData, 0);
++ WaitStream waiter(str);
++ processes->ThreadPauseForIO(taskData, &waiter);
+ }
+
+ case 28: /* Test whether output is possible. */
+- return Make_arbitrary_precision(taskData, canOutput(taskData, strm));
++ return Make_arbitrary_precision(taskData, canOutput(taskData, strm) ? 1:0);
+
+ case 29: /* Block until output is possible. */
+- if (canOutput(taskData, strm) == 0)
+- processes->BlockAndRestart(taskData, -1, false, POLY_SYS_io_dispatch);
+- return Make_arbitrary_precision(taskData, 0);
+-
++ while (true) {
++ if (canOutput(taskData, strm))
++ return Make_arbitrary_precision(taskData, 0);
++ // Use the default waiter for the moment since we don't have
++ // one to test for output.
++ processes->ThreadPauseForIO(taskData, Waiter::defaultWaiter);
++ }
+
+ /* Functions added for Posix structure. */
+ case 30: /* Return underlying file descriptor. */
+@@ -1691,8 +1676,8 @@
+ raise_syscall(taskData, "CreateDirectory failed", -(int)GetLastError());
+ #else
+ if (mkdir(string_buffer, 0777) != 0)
+-#endif
+ raise_syscall(taskData, "mkdir failed", errno);
++#endif
+
+ return Make_arbitrary_precision(taskData, 0);
+ }
+@@ -1895,13 +1880,17 @@
+
+ void BasicIO::Reinit(void)
+ {
+- /* The interface map is recreated after the database
+- is committed. */
+ basic_io_vector[0].token = (PolyObject*)IoEntry(POLY_SYS_stdin);
+ basic_io_vector[0].device.ioDesc = 0;
+ basic_io_vector[0].ioBits = IO_BIT_OPEN | IO_BIT_READ;
+ #ifdef WINDOWS_PC
+ basic_io_vector[0].ioBits |= getFileType(0);
++ // Set this to a duplicate of the handle so it can be closed when we
++ // close the stream.
++ HANDLE hDup;
++ if (DuplicateHandle(GetCurrentProcess(), hInputEvent, GetCurrentProcess(),
++ &hDup, 0, FALSE, DUPLICATE_SAME_ACCESS))
++ basic_io_vector[0].hAvailable = hDup;
+ #endif
+
+ basic_io_vector[1].token = (PolyObject*)IoEntry(POLY_SYS_stdout);
+diff -u -r libpolyml/basicio.h libpolyml/basicio.h
+--- libpolyml/basicio.h 2007-03-29 08:52:29.000000000 +0200
++++ libpolyml/basicio.h 2009-09-15 08:56:44.000000000 +0200
+@@ -29,8 +29,4 @@
+ extern Handle IO_dispatch_c(TaskData *mdTaskData, Handle args, Handle strm, Handle code);
+ extern Handle change_dirc(TaskData *mdTaskData, Handle name);
+
+-#ifndef WINDOWS_PC
+-extern void process_may_block(TaskData *taskData, int fd, int ioCall);
+-#endif
+-
+ #endif /* BASICIO_H */
+diff -u -r libpolyml/bitmap.cpp libpolyml/bitmap.cpp
+--- libpolyml/bitmap.cpp 2007-03-29 08:52:29.000000000 +0200
++++ libpolyml/bitmap.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -26,10 +26,12 @@
+ collector.
+ */
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_ASSERT_H
+diff -u -r libpolyml/check_objects.cpp libpolyml/check_objects.cpp
+--- libpolyml/check_objects.cpp 2008-03-25 12:23:08.000000000 +0100
++++ libpolyml/check_objects.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -19,10 +19,12 @@
+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+ */
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_ASSERT_H
+diff -u -r libpolyml/diagnostics.cpp libpolyml/diagnostics.cpp
+--- libpolyml/diagnostics.cpp 2007-09-13 18:38:45.000000000 +0200
++++ libpolyml/diagnostics.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -19,10 +19,12 @@
+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+ */
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_STDIO_H
+diff -u -r libpolyml/exporter.cpp libpolyml/exporter.cpp
+--- libpolyml/exporter.cpp 2008-08-13 20:05:23.000000000 +0200
++++ libpolyml/exporter.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -19,10 +19,12 @@
+
+ */
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_ASSERT_H
+@@ -60,6 +62,7 @@
+ #include "diagnostics.h"
+ #include "memmgr.h"
+ #include "processes.h" // For IO_SPACING
++#include "sys.h" // For EXC_Fail
+
+ #include "pexport.h"
+
+@@ -84,37 +87,54 @@
+ words.
+ */
+
+-CopyScan::CopyScan(unsigned h): hierarchy(h)
++CopyScan::CopyScan(bool isExport/*=true*/, unsigned h/*=0*/): hierarchy(h)
+ {
+ ASSERT(gMem.neSpaces == 0);
+- // Set the space sizes to a quarter the space currently in use. Making
+- // the spaces too large may be a problem if we're very close to the maximum
+- // address space. Making them too small may increase the cost of linking.
++ // Set the space sizes to a proportion of the space currently in use.
++ // Computing these sizes is not obvious because CopyScan is used both
++ // for export and for saved states. For saved states in particular we
++ // want to use a smaller size because they are retained after we save
++ // the state and if we have many child saved states its important not
++ // to waste memory.
+ defaultImmSize = defaultMutSize = 0;
+ defaultNoOverSize = 4096; // This can be small.
+ unsigned i;
+ for (i = 0; i < gMem.npSpaces; i++)
+ {
+- MemSpace *space = gMem.pSpaces[i];
+- POLYUNSIGNED size = (space->top-space->bottom)/4;
+- if (space->isMutable)
+- defaultMutSize += size;
+- else
+- defaultImmSize += size;
++ PermanentMemSpace *space = gMem.pSpaces[i];
++ if (space->hierarchy >= h) {
++ // Include this if we're exporting (h=0) or if we're saving a state
++ // and will include this in the new state.
++ POLYUNSIGNED size = (space->top-space->bottom)/4;
++ if (space->isMutable)
++ defaultMutSize += size;
++ else
++ defaultImmSize += size;
++ }
+ }
+ for (i = 0; i < gMem.nlSpaces; i++)
+ {
+ LocalMemSpace *space = gMem.lSpaces[i];
+- POLYUNSIGNED size = (space->top-space->pointer)/4;
++ POLYUNSIGNED size = space->top-space->pointer;
++ // It looks as though the mutable size generally gets
++ // overestimated while the immutable size is correct.
+ if (space->isMutable)
+- defaultMutSize += size;
++ defaultMutSize += size/4;
+ else
+- defaultImmSize += size;
++ defaultImmSize += size/2;
++ }
++ if (isExport)
++ {
++ // Minimum 1M words.
++ if (defaultMutSize < 1024*1024) defaultMutSize = 1024*1024;
++ if (defaultImmSize < 1024*1024) defaultImmSize = 1024*1024;
++ }
++ else
++ {
++ // Much smaller minimum sizes for saved states.
++ if (defaultMutSize < 1024) defaultMutSize = 1024;
++ if (defaultImmSize < 4096) defaultImmSize = 4096;
+ }
+- if (defaultMutSize < 1024*1024)
+- defaultMutSize = 1024*1024;
+- if (defaultImmSize < 1024*1024)
+- defaultImmSize = 1024*1024;
+ }
+
+ CopyScan::~CopyScan()
+diff -u -r libpolyml/exporter.h libpolyml/exporter.h
+--- libpolyml/exporter.h 2008-03-25 12:23:08.000000000 +0100
++++ libpolyml/exporter.h 2009-09-15 08:56:44.000000000 +0200
+@@ -23,7 +23,7 @@
+ #define EXPORTER_H_INCLUDED
+
+ #include "globals.h" // For PolyWord
+-#include "polyexports.h" // For struct _memTableEntry
++#include "../polyexports.h" // For struct _memTableEntry
+
+ #ifdef HAVE_STDIO_H
+ #include <stdio.h> // For FILE
+@@ -84,7 +84,7 @@
+ class CopyScan: public ScanAddress
+ {
+ public:
+- CopyScan(unsigned h=0);
++ CopyScan(bool isExport=true, unsigned h=0);
+ ~CopyScan();
+ protected:
+ virtual POLYUNSIGNED ScanAddressAt(PolyWord *pt);
+diff -u -r libpolyml/foreign.cpp libpolyml/foreign.cpp
+--- libpolyml/foreign.cpp 2008-03-25 12:23:08.000000000 +0100
++++ libpolyml/foreign.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -21,10 +21,12 @@
+
+ */
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #if (defined(WIN32) || (defined(HAVE_DLOPEN)))
+@@ -223,15 +225,13 @@
+
+ #define INITIAL_NUM_VOLS 200
+
+-/*typedef enum {False,True} Bool;*/
+-typedef int Bool; /* record size for malloc/free wrappers */
+-
+ class PolyVolData;
+
+ typedef struct {
+ PolyVolData* ML_pointer; /* Pointer to ML token object. */
+ void* C_pointer; /* Pointer to C storage. */
+- Bool Own_C_space; /* Size if this is the owner of storage. */
++ POLYUNSIGNED Own_C_space; /* Size if this is the owner of storage. */
++ void (*C_finaliser)(void*); // Pointer to finalisation function.
+ } Volatile;
+
+
+@@ -301,6 +301,7 @@
+ #define ML_POINTER(v) (vols[V_INDEX(v)].ML_pointer)
+ #define C_POINTER(v) (vols[V_INDEX(v)].C_pointer)
+ #define OWN_C_SPACE(v) (vols[V_INDEX(v)].Own_C_space)
++#define FINALISER(v) (vols[V_INDEX(v)].C_finaliser)
+
+ #define UNVOLHANDLE(_x) ((PolyVolData*)DEREFHANDLE(_x))
+
+@@ -326,7 +327,8 @@
+ MakeVolMagic(v);
+ ML_POINTER(v) = v;
+ C_POINTER(v) = NULL;
+- OWN_C_SPACE(v) = /*False*/0;
++ OWN_C_SPACE(v) = 0; /* Does not own it. */
++ FINALISER(v) = 0; /* None installed yet. */
+
+ return result;
+ }
+@@ -338,7 +340,7 @@
+ Handle res = vol_alloc(taskData);
+ trace(("size= %lu\n",size));
+ Vmalloc( C_POINTER(UNVOLHANDLE(res)), size );
+- OWN_C_SPACE(UNVOLHANDLE(res)) = /*True*/size;
++ OWN_C_SPACE(UNVOLHANDLE(res)) = size; /* Size of owned space. */
+ return res;
+ }
+
+@@ -471,7 +473,7 @@
+ void *dest = C_POINTER(left);
+ memcpy(dest, source, size);
+
+- return h; /* to be ignored */
++ return SAVE(TAGGED(0));
+ }}
+
+
+@@ -621,12 +623,15 @@
+ vols[from].ML_pointer = (PolyVolData*)p;
+
+ if (vols[from].ML_pointer == NULL) { /* It's no longer reachable. */
++ if (vols[from].C_finaliser) {
++ trace(("Calling finaliser on <%lu>\n",from));
++ vols[from].C_finaliser(*(void**)vols[from].C_pointer);
++ }
++
+ if (vols[from].Own_C_space) {
+
+ mes(("Trashing malloc space of <%lu>\n",from));
+- {int i; for (i=0; i<vols[from].Own_C_space; i++) {
+- ((char*)vols[from].C_pointer)[i] = 0;
+- }}
++ memset(vols[from].C_pointer, 0, vols[from].Own_C_space);
+
+ trace(("Freeing malloc space of <%lu>\n",from));
+ Vfree(vols[from].C_pointer);
+@@ -1306,7 +1311,7 @@
+ Poly_string_to_C(str, (char*)DEREFVOL(taskData, cArg), size);
+ PLocker plocker(&volLock);
+ mes(("<%s>\n", (char*)C_POINTER(cArg)));
+- return h; /* to be ignored */
++ return SAVE(TAGGED(0));
+ }}
+
+
+@@ -1821,6 +1826,21 @@
+ return DEREFVOL(taskData, resultWord);
+ }
+
++typedef void (*finalType)(void*);
++
++// Set a finalisation function: A C function that is called when the Vol is freed by
++// the GC.
++static Handle set_final (TaskData *taskData, Handle pair)
++{
++ Handle symH = TUPLE_GET1(pair);
++ Handle volH = TUPLE_GET2(pair);
++ PolyVolData *vol = (PolyVolData*)(UNHANDLE(volH));
++ finalType f = *(finalType*)DEREFVOL(taskData, symH->Word());
++ FINALISER(vol) = f;
++ return SAVE(TAGGED(0));
++}
++
++
+ /**********************************************************************
+ *
+ * Foreign Dispatch
+@@ -1875,7 +1895,9 @@
+ fromCbytes,
+
+ toCfunction, /* Added DCJM 7/4/04. */
+- toPascalfunction /* Added DCJM 7/4/04. */
++ toPascalfunction, /* Added DCJM 7/4/04. */
++
++ set_final /* Added DCJM 2/8/09. */
+ };
+
+ #define NUM_HANDLERS ((int)(sizeof(handlers)/sizeof(type_hh_fun)))
+diff -u -r libpolyml/gc.cpp libpolyml/gc.cpp
+--- libpolyml/gc.cpp 2008-05-28 14:30:15.000000000 +0200
++++ libpolyml/gc.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -19,10 +19,12 @@
+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+ */
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_ASSERT_H
+@@ -62,6 +64,13 @@
+ #include "rts_module.h"
+ #include "memmgr.h"
+
++// Settings moved from userOptions.
++static unsigned long heapSize, immutableSegSize, mutableSegSize;
++static unsigned long immutableFreeSpace, mutableFreeSpace;
++static unsigned long immutableMinFree, mutableMinFree; // Probably remove
++
++static POLYUNSIGNED GetPhysicalMemorySize(void);
++
+ unsigned gc_phase = 0; // Tells the profiler whether we're in the gc
+
+ // If the GC converts a weak ref from SOME to NONE it sets this ref. It can be
+@@ -69,10 +78,54 @@
+ // is only set during GC and only cleared when not GCing.
+ bool convertedWeak = false;
+
+-/* zero the memory - the "standard" way */
+-#define wzero(start,word_count) do { memset(start, 0, (word_count)*sizeof(POLYUNSIGNED)); } while (0)
++/*
++ How the garbage collector works.
++ The GC is generational. There are two modes: minor and full. Most of the
++ code is the same for both. There are two types of local heap: mutable and
++ immutable. ML and RTS code always allocate new objects in a mutable heap.
++ Note allocation is from the top of the area down.
++ Originally, there were just two areas but now there may be multiple
++ heap segments of each type. The GC has three phases:
++
++ 1. Mark phase.
++ Working from the roots; which are the the permanent mutable segments, the RTS
++ roots (e.g. thread stacks) and, if this is a minor collection, mutable objects
++ collected in previous collections ("gen_top" to "top"), mark all reachable cells.
++ Marking involves setting bits in the bitmap for reachable words. If this is a
++ minor collection we only follow cells that are in the current generation
++ ("gen_bottom" to "gen_top").
++
++ 2. Compact phase.
++ Marked objects are copied to try to compact, upwards, the heap segments. When
++ an object is moved the length word of the object in the old location is set as
++ a tombstone that points to its new location. In particular this means that we
++ cannot reuse the space where an object previously was during the compaction phase.
++ Immutable objects are moved into immutable segments. When an object is moved
++ to a new location the bits are set in the bitmap as though the object had been
++ marked at that location.
++
++ 3. Update phase.
++ The roots and objects marked during the first two phases are scanned and any
++ addresses for moved objects are updated. The lowest address used in the area
++ then becomes the base of the area for future allocations.
++
++ Typically, a minor GC moves immutable data into the immutable area and leaves
++ mutable data behind. The immutable data moved is considered "old" and not
++ scanned until a major collection. However, if a collection finds that there
++ are significant holes in the heap (these holes must be in the mutable area)
++ it is better to try to recollect the current generation. In this case the
++ immutable data moved during this collection are considered as "new" in the
++ next minor collection. Even though we're only concerned there with compacting
++ the mutable area we have to process immutable objects that may contain their
++ addresses.
++ DCJM 27/6/09
++*/
+
+ /*
++ The comments below may still be relevant. I've left them in because they
++ contain notes about optimisations that were tried in the past and no longer
++ apply.
++
+ How the garbage collector works.
+
+ Phase 1: Starting from the roots in the old mutable area, and
+@@ -727,14 +780,15 @@
+ // or an immutable space if it's immutable.
+ LocalMemSpace *dst = 0; /* New object allocation area */
+ // Find a mutable space for the mutable objects and an immutable space for
+- // the immutables. We are copying objects starting from the first space
+- // and working upwards so to avoid copying the same object multiple times
+- // we must allocate from the last space first. We may copy an object within
+- // its own space but we don't copy an object into an earlier space of the
+- // same type.
+- for (unsigned i = gMem.nlSpaces; i > 0; i--)
++ // the immutables. We copy objects into earlier spaces or within its own
++ // space but we don't copy an object to a later space. This avoids the
++ // risk of copying an object multiple times. Previously this copied objects
++ // into later spaces but that doesn't work well if we have converted old
++ // saved state segments into local areas. It's much better to delete them
++ // if possible.
++ for (unsigned i = 0; i < gMem.nlSpaces; i++)
+ {
+- dst = gMem.lSpaces[i-1];
++ dst = gMem.lSpaces[i];
+ if (OBJ_IS_MUTABLE_OBJECT(L))
+ {
+ // Mutable object
+@@ -1031,18 +1085,18 @@
+ }
+ }
+
+- if (userOptions.immutableFreeSpace + wordsNeeded > currentSize) // need to get some more space
++ if (immutableFreeSpace + wordsNeeded > currentSize) // need to get some more space
+ {
+ // We want to ensure that we have immutableFreeSpace free after this
+ // collection. We allocate in units of immutableSegSize so as not to
+ // have too many small segments.
+- POLYUNSIGNED requestedGrowth = userOptions.immutableFreeSpace + wordsNeeded - currentSize;
+- if (requestedGrowth < userOptions.immutableSegSize)
+- requestedGrowth = userOptions.immutableSegSize;
++ POLYUNSIGNED requestedGrowth = immutableFreeSpace + wordsNeeded - currentSize;
++ if (requestedGrowth < immutableSegSize)
++ requestedGrowth = immutableSegSize;
+ // Make the segments larger if we have already allocated several.
+ // The factors here are a guess. Maybe tune them more carefully
+ unsigned spaceFactor = nISpaces / 3;
+- while (spaceFactor > 0) { requestedGrowth += userOptions.immutableSegSize; spaceFactor--; }
++ while (spaceFactor > 0) { requestedGrowth += immutableSegSize; spaceFactor--; }
+
+ POLYUNSIGNED chunks = ROUNDUP_UNITS(requestedGrowth, BITSPERWORD);
+ POLYUNSIGNED words = chunks * BITSPERWORD;
+@@ -1062,10 +1116,10 @@
+ // out of the mutable area so doesn't need to be contiguous.
+ POLYUNSIGNED requiredFree;
+ if (mutableRegion)
+- requiredFree = fullGC ? userOptions.mutableFreeSpace: userOptions.mutableMinFree;
++ requiredFree = fullGC ? mutableFreeSpace: mutableMinFree;
+ else
+ {
+- requiredFree = fullGC ? userOptions.immutableFreeSpace: userOptions.immutableMinFree;
++ requiredFree = fullGC ? immutableFreeSpace: immutableMinFree;
+ requiredFree += wordsNeeded;
+ wordsNeeded = 0;
+ }
+@@ -1090,9 +1144,8 @@
+ }
+
+ // AFTER a full GC, make sure we have a full buffer's worth of free space available.
+-static bool AdjustHeapSize(bool isMutableSpace, POLYUNSIGNED wordsRequired)
++static void AdjustHeapSize(bool isMutableSpace, POLYUNSIGNED wordsRequired)
+ {
+- bool sizeChanged = false;
+ POLYUNSIGNED currentSize = 0, currentlyFree = 0;
+ unsigned nSpaces = 0;
+ POLYUNSIGNED largestFree = 0;
+@@ -1111,7 +1164,7 @@
+ }
+
+ const POLYUNSIGNED requiredFree = wordsRequired +
+- (isMutableSpace ? userOptions.mutableFreeSpace : userOptions.immutableFreeSpace);
++ (isMutableSpace ? mutableFreeSpace : immutableFreeSpace);
+
+ /* Basic sanity checks. */
+ ASSERT(0 <= wordsRequired);
+@@ -1124,7 +1177,7 @@
+ { // expand the heap.
+ POLYUNSIGNED requestedGrowth = requiredFree - currentlyFree;
+ const POLYUNSIGNED segSize =
+- isMutableSpace ? userOptions.mutableSegSize : userOptions.immutableSegSize;
++ isMutableSpace ? mutableSegSize : immutableSegSize;
+ if (requestedGrowth < segSize)
+ requestedGrowth = segSize;
+ // Make the segments larger if we have already allocated several.
+@@ -1136,8 +1189,7 @@
+ POLYUNSIGNED chunks = ROUNDUP_UNITS(requestedGrowth, BITSPERWORD);
+ POLYUNSIGNED words = chunks * BITSPERWORD;
+
+- if (TryMoreHeap(words, isMutableSpace)) // If this fails just carry on with what we have.
+- sizeChanged = true;
++ (void)TryMoreHeap(words, isMutableSpace); // If this fails just carry on with what we have.
+ }
+ else // currentlyFree >= requiredFree
+ {
+@@ -1146,6 +1198,11 @@
+ // we have finished building a large data structure and now want to
+ // export it. The export code requires buffer space and may need the
+ // space we're using.
++ // Another reason is to get rid of old saved state areas that have been
++ // converted into local areas. These are likely to be small compared with the
++ // heap and result in fragmentation of the address space.
++ // TODO: We should perhaps deallocate small areas even if that would bring
++ // us under the limit because it would be better to reallocate a larger area.
+ POLYUNSIGNED requestedShrink = currentlyFree - requiredFree;
+ // Delete the most recent space first.
+ for (unsigned k = gMem.nlSpaces; k > 0; k--)
+@@ -1158,11 +1215,9 @@
+ // We can free this space without going under our limit
+ requestedShrink -= space->top - space->bottom;
+ gMem.DeleteLocalSpace(space);
+- sizeChanged = true;
+ }
+ }
+ }
+- return sizeChanged;
+ }
+
+
+@@ -1185,22 +1240,19 @@
+ }
+ if (total == 0)
+ return false;
++ /* I think the idea here is that if we have a significant number of
++ objects in the current generation which have not actually been
++ visited to have their addresses updated we should not merge
++ this generation with the old data and treat them as "old" but
++ instead treat them as "new".
++ If we have allocated a large object in the mutable area we
++ may not have a gap big enough to move it to. We may though
++ have created enough space in this minor GC to move it next time.
++ That's because if we have moved an object we can't use the space
++ until after the update phase has finished with the tombstone.
++ DCJM 27/6/09. */
+ return updated * 2 < total; // Less than 50% updated
+ }
+-
+-// Called when Poly/ML starts up.
+-void CreateHeap(void)
+-{
+- // Immutable space
+- POLYUNSIGNED immutSize = ROUNDDOWN(userOptions.immutableSegSize, BITSPERWORD);
+- if (gMem.NewLocalSpace(immutSize, false) == 0)
+- Exit("Unable to allocate immutable area");
+-
+- // Mutable space
+- POLYUNSIGNED mutSize = ROUNDDOWN(userOptions.mutableSegSize, BITSPERWORD);
+- if (gMem.NewLocalSpace(mutSize, true) == 0)
+- Exit("Unable to allocate mutable area");
+-}
+
+ static bool doGC(bool doFullGC, const POLYUNSIGNED wordsRequiredToAllocate)
+ {
+@@ -1344,6 +1396,8 @@
+ // First, process the mutable areas, copying immutable data into the immutable areas
+ // and compacting mutable objects within the area.
+ POLYUNSIGNED immutable_overflow = 0; // The immutable space we couldn't copy out.
++ // I think immutable overflow was a problem in the old version of the GC with only
++ // a single segment. It ought to be possible to change this so it doesn't happen now.
+ {
+ POLYUNSIGNED immutableFree = 0, immutableNeeded = 0;
+ for(j = 0; j < gMem.nlSpaces; j++)
+@@ -1376,9 +1430,9 @@
+ }
+
+ /* Invariant: there are no objects below A.M.gen_bottom. */
+- for(j = 0; j < gMem.nlSpaces; j++)
++ for(j = gMem.nlSpaces; j > 0; j--)
+ {
+- LocalMemSpace *lSpace = gMem.lSpaces[j];
++ LocalMemSpace *lSpace = gMem.lSpaces[j-1];
+ if (lSpace->isMutable)
+ CopyObjectsInArea(lSpace, compressImmutables);
+ }
+@@ -1461,9 +1515,9 @@
+ POLYUNSIGNED immutable_free = immutable_space - immutable_used;
+ bool compressImmutables = immutable_needed / 4 < immutable_free ; /* Needs tuning!!! */
+
+- for(j = 0; j < gMem.nlSpaces; j++)
++ for(j = gMem.nlSpaces; j > 0; j--)
+ {
+- LocalMemSpace *lSpace = gMem.lSpaces[j];
++ LocalMemSpace *lSpace = gMem.lSpaces[j-1];
+ if (! lSpace->isMutable)
+ {
+ if (lSpace->gen_bottom <= lSpace->pointer)
+@@ -1599,9 +1653,13 @@
+ }
+ }
+
+-
++
+ if (RecollectThisGeneration(this_generation))
+ {
++ /* Generally we treat all the objects we have left after this GC as "old" for
++ the purposes of subsequent minor GCs. If, though, a collection has left us
++ with significant gaps we don't do that merge and instead on the next GC we
++ recollect everything since the last collection. */
+ /* If this was a full GC, make sure the next one is too, as we may
+ need to reconfigure the mutable buffer size. If we only did a
+ partial next, we would still have to mark all the immutables again
+@@ -1714,7 +1772,7 @@
+ #endif
+
+
+-POLYUNSIGNED GetPhysicalMemorySize(void)
++static POLYUNSIGNED GetPhysicalMemorySize(void)
+ {
+ POLYUNSIGNED maxMem = 0-1; // Maximum unsigned value.
+ #if defined(HAVE_WINDOWS_H)
+@@ -1813,6 +1871,81 @@
+ return 0; // Unable to determine
+ }
+
++/* This macro must make a whole number of chunks */
++#define K_to_words(k) ROUNDUP((k) * (1024 / sizeof(PolyWord)),BITSPERWORD)
++
++// Create the initial heap. hsize, isize and msize are the requested heap sizes
++// from the user arguments in units of kbytes.
++// Fills in the defaults and attempts to allocate the heap. If the heap size
++// is too large it allocates as much as it can. The default heap size is half the
++// physical memory.
++void CreateHeap(unsigned hsize, unsigned isize, unsigned msize)
++{
++ // If no -H option was given set the default initial size to half the memory.
++ if (hsize == 0) {
++ POLYUNSIGNED memsize = GetPhysicalMemorySize();
++ if (memsize == 0) // Unable to determine memory size so default to 64M.
++ memsize = 64 * 1024 * 1024;
++ hsize = memsize / 2 / 1024;
++ }
++
++ if (hsize < isize) hsize = isize;
++ if (hsize < msize) hsize = msize;
++
++ if (msize == 0) msize = 4 * 1024 + hsize / 5; /* set default mutable buffer size */
++ if (isize == 0) isize = hsize - msize; /* set default immutable buffer size */
++
++ // Set the heap size and segment sizes. We allocate in units of this size,
++ heapSize = K_to_words(hsize);
++ immutableSegSize = K_to_words(isize);
++ mutableSegSize = K_to_words(msize);
++
++ // Try allocating the space. If it fails try something smaller.
++ LocalMemSpace *iSpace = 0, *mSpace = 0;
++
++ while (iSpace == 0 || mSpace == 0) {
++ if (iSpace != 0) { gMem.DeleteLocalSpace(iSpace); iSpace = 0; }
++ if (mSpace != 0) { gMem.DeleteLocalSpace(mSpace); mSpace = 0; }
++
++ // Immutable space
++ POLYUNSIGNED immutSize = ROUNDDOWN(immutableSegSize, BITSPERWORD);
++ iSpace = gMem.NewLocalSpace(immutSize, false);
++ // Mutable space
++ POLYUNSIGNED mutSize = ROUNDDOWN(mutableSegSize, BITSPERWORD);
++ mSpace = gMem.NewLocalSpace(mutSize, true);
++
++ if (iSpace == 0 || mSpace == 0)
++ {
++ if (immutableSegSize < 1024 || mutableSegSize < 512) {
++ // Too small to be able to run.
++ Exit("Insufficient memory to allocate the heap");
++ }
++ // Make both spaces smaller. It may be that there's space for one but not both.
++ immutableSegSize = immutableSegSize/2;
++ mutableSegSize = mutableSegSize/2;
++ }
++ }
++ // Heap allocation has succeeded.
++
++ // The space we need to have free at the end of a partial collection. If we have less
++ // than this we do a full GC.
++ // For an immutable area this is zero. For the mutable area, though, this is 80% of the
++ // mutable segment size since we allocate new objects in the mutable area and this
++ // determines how soon we will need to do another GC.
++ immutableMinFree = 0;
++ mutableMinFree = mutableSegSize - mutableSegSize / 5;
++
++ // This is the space we try to have free at the end of a major collection. If
++ // we have less than this we allocate another segment.
++ immutableFreeSpace = immutableSegSize/2; // 50% full
++ if (immutableFreeSpace < immutableMinFree)
++ immutableFreeSpace = immutableMinFree;
++ // For the mutable area it is 90% of the segment size.
++ mutableFreeSpace = mutableSegSize - mutableSegSize/10;
++ if (mutableFreeSpace < mutableMinFree)
++ mutableFreeSpace = mutableMinFree;
++}
++
+ class FullGCRequest: public MainThreadRequest
+ {
+ public:
+diff -u -r libpolyml/gc.h libpolyml/gc.h
+--- libpolyml/gc.h 2008-02-25 13:52:34.000000000 +0100
++++ libpolyml/gc.h 2009-09-15 08:56:44.000000000 +0200
+@@ -34,8 +34,7 @@
+ extern void FullGC(TaskData *taskData);
+ // Make a request for a partial garbage collection.
+ extern bool QuickGC(TaskData *taskData, POLYUNSIGNED words_needed);
+-extern void CreateHeap(void);
+-extern POLYUNSIGNED GetPhysicalMemorySize(void);
++extern void CreateHeap(unsigned hsize, unsigned isize, unsigned msize);
+
+ extern unsigned gc_phase;
+ extern bool convertedWeak;
+diff -u -r libpolyml/globals.h libpolyml/globals.h
+--- libpolyml/globals.h 2008-03-25 12:23:08.000000000 +0100
++++ libpolyml/globals.h 2009-09-15 08:56:44.000000000 +0200
+@@ -367,6 +367,7 @@
+ PolyWord ex_id; /* Exc identifier */
+ PolyWord ex_name;/* Exc name */
+ PolyWord arg; /* Exc arguments */
++ PolyWord ex_location; // Location of "raise". Always zero for RTS exceptions.
+ };
+
+ typedef PolyException poly_exn;
+diff -u -r libpolyml/interpret.cpp libpolyml/interpret.cpp
+--- libpolyml/interpret.cpp 2008-03-15 15:22:49.000000000 +0100
++++ libpolyml/interpret.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -21,10 +21,12 @@
+
+ */
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_STDIO_H
+diff -u -r libpolyml/io_internal.h libpolyml/io_internal.h
+--- libpolyml/io_internal.h 2007-08-24 16:15:30.000000000 +0200
++++ libpolyml/io_internal.h 2009-09-15 08:56:44.000000000 +0200
+@@ -87,8 +87,9 @@
+ DIR *ioDir; /* Directory entry. */
+ #endif
+ } device;
+- char lookAheadChar; /* Temporarily. This is needed for
+- the old IO functions. */
++#ifdef WINDOWS_PC
++ HANDLE hAvailable; // Used to signal available data
++#endif
+ } IOSTRUCT, *PIOSTRUCT;
+
+ class TaskData;
+diff -u -r libpolyml/locking.cpp libpolyml/locking.cpp
+--- libpolyml/locking.cpp 2008-03-25 12:23:08.000000000 +0100
++++ libpolyml/locking.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -22,13 +22,18 @@
+
+ */
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+-#ifdef HAVE_WINDOWS_H
++#if ((!defined(WIN32) || defined(__CYGWIN__)) && defined(HAVE_PTHREAD_H))
++#define HAVE_PTHREAD 1
++#include <pthread.h>
++#elif (defined(HAVE_WINDOWS_H))
+ // We need the next define since TryEnterCriticalSection is only
+ // defined in Win NT. This could mean that this code won't run under
+ // Windows 95 or 98.
+@@ -36,11 +41,6 @@
+ #include <windows.h>
+ #endif
+
+-#if (defined(HAVE_LIBPTHREAD) && defined(HAVE_PTHREAD_H))
+-#define HAVE_PTHREAD 1
+-#include <pthread.h>
+-#endif
+-
+ #ifdef HAVE_ERRNO_H
+ #include <errno.h>
+ #endif
+diff -u -r libpolyml/locking.h libpolyml/locking.h
+--- libpolyml/locking.h 2007-09-27 17:02:57.000000000 +0200
++++ libpolyml/locking.h 2009-09-15 08:56:44.000000000 +0200
+@@ -25,18 +25,20 @@
+ #ifndef LOCKING_H_DEFINED
+ #define LOCKING_H_DEFINED
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+-
+ #ifdef HAVE_WINDOWS_H
+ #include <windows.h>
+ #endif
+
+-#ifdef HAVE_PTHREAD_H
++#if ((!defined(WIN32) || defined(__CYGWIN__)) && defined(HAVE_PTHREAD_H))
++// Don't include pthread if this is native Windows and not Cygwin
+ #include <pthread.h>
+ #endif
+
+@@ -50,7 +52,7 @@
+ bool Trylock(void); // Try to lock the mutex - returns true if succeeded
+
+ private:
+-#if (defined(HAVE_LIBPTHREAD) && defined(HAVE_PTHREAD_H))
++#if ((!defined(WIN32) || defined(__CYGWIN__)) && defined(HAVE_PTHREAD_H))
+ pthread_mutex_t lock;
+ #elif defined(HAVE_WINDOWS_H)
+ CRITICAL_SECTION lock;
+@@ -83,7 +85,7 @@
+ bool WaitFor(PLock *pLock, unsigned milliseconds);
+ void Signal(void); // Wake up the waiting thread.
+ private:
+-#if (defined(HAVE_LIBPTHREAD) && defined(HAVE_PTHREAD_H))
++#if ((!defined(WIN32) || defined(__CYGWIN__)) && defined(HAVE_PTHREAD_H))
+ pthread_cond_t cond;
+ pthread_mutex_t *plock;
+ #elif defined(HAVE_WINDOWS_H)
+diff -u -r libpolyml/machoexport.cpp libpolyml/machoexport.cpp
+--- libpolyml/machoexport.cpp 2007-11-19 19:39:13.000000000 +0100
++++ libpolyml/machoexport.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -57,6 +57,7 @@
+ #include <mach-o/reloc.h>
+ #include <mach-o/nlist.h>
+ #include <mach-o/ppc/reloc.h>
++#include <mach-o/x86_64/reloc.h>
+
+ #ifdef HAVE_STRING_H
+ #include <string.h>
+@@ -83,7 +84,7 @@
+ // offsets to match that.
+ void MachoExport::adjustOffset(unsigned area, POLYUNSIGNED &offset)
+ {
+- // Add in the offset. If sect is memTableEntries it's actually the
++ // Add in the offset. If sect is memTableEntries it's actually the
+ // descriptors so doesn't have any additional offset.
+ if (area != memTableEntries)
+ {
+@@ -116,8 +117,13 @@
+ setRelocationAddress(relocAddr, &relInfo.r_address);
+ relInfo.r_symbolnum = 1; // Section numbers start at 1
+ relInfo.r_pcrel = 0;
++#if (SIZEOF_VOIDP == 8)
++ relInfo.r_length = 3; // 8 bytes
++ relInfo.r_type = X86_64_RELOC_UNSIGNED;
++#else
+ relInfo.r_length = 2; // 4 bytes
+ relInfo.r_type = GENERIC_RELOC_VANILLA;
++#endif
+ relInfo.r_extern = 0; // r_symbolnum is a section number. It should be 1 if we make the IO area a common.
+
+ fwrite(&relInfo, sizeof(relInfo), 1, exportFile);
+@@ -150,8 +156,13 @@
+ setRelocationAddress(addr, &reloc.r_address);
+ reloc.r_symbolnum = 1; // Section numbers start at 1
+ reloc.r_pcrel = 0;
++#if (defined(HOSTARCHITECTURE_X86_64))
++ reloc.r_length = 3; // 8 bytes
++ reloc.r_type = X86_64_RELOC_UNSIGNED;
++#else
+ reloc.r_length = 2; // 4 bytes
+ reloc.r_type = GENERIC_RELOC_VANILLA;
++#endif
+ reloc.r_extern = 0; // r_symbolnum is a section number. It should be 1 if we make the IO area a common.
+
+ for (unsigned i = 0; i < sizeof(PolyWord); i++)
+@@ -163,7 +174,7 @@
+ relocationCount++;
+ }
+ break;
+-#if(defined(HOSTARCHITECTURE_X86) || defined(HOSTARCHITECTURE_X86_64))
++#if (defined(HOSTARCHITECTURE_X86))
+ case PROCESS_RELOC_I386RELATIVE: // 32 bit relative address
+ {
+ // We don't need a relocation since everything is in the same segment
+@@ -244,7 +255,11 @@
+
+ void MachoExport::writeSymbol(const char *symbolName, unsigned char nType, unsigned char nSect, unsigned long offset)
+ {
++#if (SIZEOF_VOIDP == 8)
++ struct nlist_64 symbol;
++#else
+ struct nlist symbol;
++#endif
+ memset(&symbol, 0, sizeof(symbol)); // Zero unused fields
+ symbol.n_un.n_strx = stringTable.makeEntry(symbolName);
+ symbol.n_type = nType;
+@@ -272,8 +287,13 @@
+ reloc.r_address = offset;
+ reloc.r_symbolnum = 1; // Section numbers start at 1
+ reloc.r_pcrel = 0;
++#if (SIZEOF_VOIDP == 8)
++ reloc.r_length = 3; // 8 bytes
++ reloc.r_type = X86_64_RELOC_UNSIGNED;
++#else
+ reloc.r_length = 2; // 4 bytes
+ reloc.r_type = GENERIC_RELOC_VANILLA;
++#endif
+ reloc.r_extern = 0; // r_symbolnum is a section number.
+
+ fwrite(&reloc, sizeof(reloc), 1, exportFile);
+@@ -283,39 +303,55 @@
+ void MachoExport::exportStore(void)
+ {
+ PolyWord *p;
++#if (SIZEOF_VOIDP == 8)
++ struct mach_header_64 fhdr;
++ struct segment_command_64 sHdr;
++ struct section_64 theSection;
++#else
+ struct mach_header fhdr;
+ struct segment_command sHdr;
+- struct symtab_command symTab;
+ struct section theSection;
++#endif
++ struct symtab_command symTab;
+ unsigned i;
+
+ // Write out initial values for the headers. These are overwritten at the end.
+ // File header
+ memset(&fhdr, 0, sizeof(fhdr));
+- fhdr.magic = MH_MAGIC; // Feed Face (0xfeedface)
+ fhdr.filetype = MH_OBJECT;
+ fhdr.ncmds = 2; // One for the segment and one for the symbol table.
+- fhdr.sizeofcmds = sizeof(struct segment_command) + sizeof(struct section)*(memTableEntries+1)
+- + sizeof(struct symtab_command);
++ fhdr.sizeofcmds = sizeof(sHdr) + sizeof(theSection) + sizeof(symTab);
+ fhdr.flags = 0;
+ // The machine needs to match the machine we're compiling for
+ // even if this is actually portable code.
++#if (SIZEOF_VOIDP == 8)
++ fhdr.magic = MH_MAGIC_64; // (0xfeedfacf) 64-bit magic number
++#else
++ fhdr.magic = MH_MAGIC; // Feed Face (0xfeedface)
++#endif
+ #if defined(HOSTARCHITECTURE_X86)
+ fhdr.cputype = CPU_TYPE_I386;
+ fhdr.cpusubtype = CPU_SUBTYPE_I386_ALL;
+ #elif defined(HOSTARCHITECTURE_PPC)
+ fhdr.cputype = CPU_TYPE_POWERPC;
+ fhdr.cpusubtype = CPU_SUBTYPE_POWERPC_ALL;
++#elif defined(HOSTARCHITECTURE_X86_64)
++ fhdr.cputype = CPU_TYPE_X86_64;
++ fhdr.cpusubtype = CPU_SUBTYPE_X86_64_ALL;
+ #else
+ #error "No support for exporting on this architecture"
+ #endif
+ fwrite(&fhdr, sizeof(fhdr), 1, exportFile); // Write it for the moment.
+
+ // Segment header.
+- memset(&sHdr, 0, sizeof(struct segment_command));
++ memset(&sHdr, 0, sizeof(sHdr));
++#if (SIZEOF_VOIDP == 8)
++ sHdr.cmd = LC_SEGMENT_64;
++#else
+ sHdr.cmd = LC_SEGMENT;
++#endif
+ sHdr.nsects = 1;
+- sHdr.cmdsize = sizeof(struct segment_command) + sizeof(struct section) * sHdr.nsects;
++ sHdr.cmdsize = sizeof(sHdr) + sizeof(theSection) * sHdr.nsects;
+ // Add up the sections to give the file size
+ sHdr.filesize = 0;
+ for (i = 0; i < memTableEntries; i++)
+@@ -331,7 +367,7 @@
+ fwrite(&sHdr, sizeof(sHdr), 1, exportFile);
+
+ // Section header.
+- memset(&theSection, 0, sizeof(struct section));
++ memset(&theSection, 0, sizeof(theSection));
+ sprintf(theSection.sectname, "poly");
+ sprintf(theSection.segname, "POLY");
+ //theSection.offset is set later
+@@ -342,17 +378,17 @@
+ theSection.flags = S_ATTR_LOC_RELOC | S_ATTR_SOME_INSTRUCTIONS | S_REGULAR; //
+
+ // Write it out for the moment.
+- fwrite(&theSection, sizeof(struct section), 1, exportFile);
++ fwrite(&theSection, sizeof(theSection), 1, exportFile);
+
+ // Symbol table header.
+- memset(&symTab, 0, sizeof(struct symtab_command));
++ memset(&symTab, 0, sizeof(symTab));
+ symTab.cmd = LC_SYMTAB;
+- symTab.cmdsize = sizeof(struct symtab_command);
++ symTab.cmdsize = sizeof(symTab);
+ //symTab.symoff is set later
+ //symTab.nsyms is set later
+ //symTab.stroff is set later
+ //symTab.strsize is set later
+- fwrite(&symTab, sizeof(struct symtab_command), 1, exportFile);
++ fwrite(&symTab, sizeof(symTab), 1, exportFile);
+
+ // Create the symbol table first before we mess up the addresses by turning them
+ // into relocations.
+@@ -474,12 +510,11 @@
+ {
+ fwrite(memTable[i].mtAddr, 1, memTable[i].mtLength, exportFile);
+ }
+-
+ // Rewind to rewrite the headers with the actual offsets.
+ rewind(exportFile);
+ fwrite(&fhdr, sizeof(fhdr), 1, exportFile); // File header
+ fwrite(&sHdr, sizeof(sHdr), 1, exportFile); // Segment header
+- fwrite(&theSection, sizeof(struct section), 1, exportFile); // Section headers
+- fwrite(&symTab, sizeof(struct symtab_command), 1, exportFile); // Symbol table header
++ fwrite(&theSection, sizeof(theSection), 1, exportFile); // Section headers
++ fwrite(&symTab, sizeof(symTab), 1, exportFile); // Symbol table header
+ fclose(exportFile); exportFile = NULL;
+ }
+diff -u -r libpolyml/masm2gas libpolyml/masm2gas
+--- libpolyml/masm2gas 2006-09-26 15:38:30.000000000 +0200
++++ libpolyml/masm2gas 2009-09-15 08:56:44.000000000 +0200
+@@ -1,5 +1,6 @@
+ #! /usr/bin/sed -f
+-s/
+//g
++# N.B. This is used only with GCC. There's a bug in sed under MinGW which means
++# that CRNL line endings don't work so this file must be marked as binary.
+ s/;#.*//
+ s/^IFDEF/#ifdef/
+ s/^ELSE/#else/
+diff -u -r libpolyml/memmgr.cpp libpolyml/memmgr.cpp
+--- libpolyml/memmgr.cpp 2008-03-25 12:23:08.000000000 +0100
++++ libpolyml/memmgr.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -18,10 +18,12 @@
+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+ */
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_ASSERT_H
+@@ -321,8 +323,10 @@
+ {
+ // Turn this into a local space.
+ LocalMemSpace *space = new LocalMemSpace;
+- space->top = space->gen_top = space->gen_bottom = pSpace->top;
+- space->bottom = space->pointer = pSpace->bottom;
++ space->top = pSpace->top;
++ // Space is allocated in local areas from the top down. This area is full and
++ // all data is in the old generation. The area can be recovered by a full GC.
++ space->bottom = space->pointer = space->gen_top = space->gen_bottom = pSpace->bottom;
+ space->isMutable = pSpace->isMutable;
+ space->isOwnSpace = true;
+ if (! space->bitmap.Create(space->top-space->bottom) || ! AddLocalSpace(space))
+diff -u -r libpolyml/mpoly.cpp libpolyml/mpoly.cpp
+--- libpolyml/mpoly.cpp 2008-03-25 12:23:08.000000000 +0100
++++ libpolyml/mpoly.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -20,10 +20,12 @@
+
+ */
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_STDIO_H
+@@ -60,7 +62,7 @@
+ #include "mpoly.h"
+ #include "scanaddrs.h"
+ #include "save_vec.h"
+-#include "polyexports.h"
++#include "../polyexports.h"
+ #include "memmgr.h"
+ #include "pexport.h"
+
+@@ -78,14 +80,11 @@
+ return space->bottom + sysOp * IO_SPACING;
+ }
+
+-/* This macro must make a whole number of chunks */
+-#define K_to_words(k) ROUNDUP((k) * (1024 / sizeof(PolyWord)),BITSPERWORD)
+-
+ struct _userOptions userOptions;
+
+ UNSIGNEDADDR exportTimeStamp;
+
+-unsigned hsize, isize, msize;
++static unsigned hsize, isize, msize;
+
+ struct __argtab {
+ const char *argName, *argHelp;
+@@ -102,16 +101,6 @@
+ /* In the Windows version this is called from WinMain in Console.c */
+ int polymain(int argc, char **argv, exportDescription *exports)
+ {
+-
+- POLYUNSIGNED memsize = GetPhysicalMemorySize();
+- if (memsize == 0) // Unable to determine memory size so default to 64M.
+- memsize = 64 * 1024 * 1024;
+-
+- // Set the default initial size to half the memory.
+- hsize = memsize / 2 / 1024;
+- isize = 0; /* use standard default */
+- msize = 0; /* use standard default */
+-
+ /* Get arguments. */
+ memset(&userOptions, 0, sizeof(userOptions)); /* Reset it */
+
+@@ -171,42 +160,11 @@
+
+ if (exports == 0 && importFileName == 0)
+ Usage("Missing import file name");
+-
+- if (hsize < 500) Usage ("Invalid heap-size value");
+-
+- if (hsize < isize) hsize = isize;
+- if (hsize < msize) hsize = msize;
+-
+- if (msize == 0) msize = 4 * 1024 + hsize / 5; /* set default mutable buffer size */
+- if (isize == 0) isize = hsize - msize; /* set default immutable buffer size */
+-
+- // Set the heap size and segment sizes. We allocate in units of this size,
+- userOptions.heapSize = K_to_words(hsize);
+- userOptions.immutableSegSize = K_to_words(isize);
+- userOptions.mutableSegSize = K_to_words(msize);
+-
+- // The space we need to have free at the end of a partial collection. If we have less
+- // than this we do a full GC.
+- // For an immutable area this is zero. For the mutable area, though, this is 80% of the
+- // mutable segment size since we allocate new objects in the mutable area and this
+- // determines how soon we will need to do another GC.
+- userOptions.immutableMinFree = 0;
+- userOptions.mutableMinFree = userOptions.mutableSegSize - userOptions.mutableSegSize / 5;
+-
+- // This is the space we try to have free at the end of a major collection. If
+- // we have less than this we allocate another segment.
+- userOptions.immutableFreeSpace = userOptions.immutableSegSize/2; // 50% full
+- if (userOptions.immutableFreeSpace < userOptions.immutableMinFree)
+- userOptions.immutableFreeSpace = userOptions.immutableMinFree;
+- // For the mutable area it is 90% of the segment size.
+- userOptions.mutableFreeSpace = userOptions.mutableSegSize - userOptions.mutableSegSize/10;
+- if (userOptions.mutableFreeSpace < userOptions.mutableMinFree)
+- userOptions.mutableFreeSpace = userOptions.mutableMinFree;
+
+ /* initialise the run-time system before opening the database */
+ init_run_time_system();
+
+- CreateHeap();
++ CreateHeap(hsize, isize, msize);
+
+ PolyObject *rootFunction = 0;
+
+diff -u -r libpolyml/mpoly.h libpolyml/mpoly.h
+--- libpolyml/mpoly.h 2007-10-01 20:01:46.000000000 +0200
++++ libpolyml/mpoly.h 2009-09-15 08:56:44.000000000 +0200
+@@ -23,7 +23,7 @@
+ #define _MPOLY_H_DEFINED
+
+ #include "noreturn.h"
+-#include "polyexports.h"
++#include "../polyexports.h"
+
+ extern struct _userOptions {
+ unsigned user_arg_count;
+@@ -31,10 +31,6 @@
+ const char *programName;
+ unsigned debug; /* debugging flags */
+ bool noDisplay; /* X display flag */
+- // Not all of these can be set any longer.
+- unsigned long heapSize, immutableSegSize, mutableSegSize;
+- unsigned long immutableFreeSpace, mutableFreeSpace;
+- unsigned long immutableMinFree, mutableMinFree; // Probably remove
+ } userOptions;
+
+ // Values for debugging flags
+diff -u -r libpolyml/network.cpp libpolyml/network.cpp
+--- libpolyml/network.cpp 2008-07-29 10:25:03.000000000 +0200
++++ libpolyml/network.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -18,10 +18,12 @@
+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+ */
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_STDIO_H
+@@ -373,6 +375,28 @@
+ #define MAPERROR(x) (x)
+ #endif
+
++class WaitNet: public Waiter {
++public:
++ WaitNet(SOCKET sock, bool isOOB = false) : m_sock(sock), m_isOOB(isOOB) {}
++ void Wait(unsigned maxMillisecs);
++private:
++ SOCKET m_sock;
++ bool m_isOOB;
++};
++
++// Use "select" in both Windows and Unix. In Windows that means we
++// don't watch hWakeupEvent but that's only a hint.
++void WaitNet::Wait(unsigned maxMillisecs)
++{
++ fd_set readFds, writeFds, exceptFds;
++ struct timeval toWait = { 0, 0 };
++ toWait.tv_usec = maxMillisecs * 1000;
++ FD_ZERO(&readFds);
++ FD_ZERO(&writeFds);
++ FD_ZERO(&exceptFds);
++ FD_SET(m_sock, m_isOOB ? &exceptFds : &readFds);
++ select(FD_SETSIZE, &readFds, &writeFds, &exceptFds, &toWait);
++}
+
+ Handle Net_dispatch_c(TaskData *taskData, Handle args, Handle code)
+ {
+@@ -840,8 +864,10 @@
+ /* If the socket is in non-blocking mode we pass
+ this back to the caller. If it is blocking we
+ suspend this process and try again later. */
+- if (c == 46 /* blocking version. */)
+- processes->BlockAndRestart(taskData, strm->device.sock, false, POLY_SYS_network);
++ if (c == 46 /* blocking version. */) {
++ WaitNet waiter(strm->device.sock);
++ processes->BlockAndRestart(taskData, &waiter, false, POLY_SYS_network);
++ }
+ /* else drop through. */
+ default:
+ raise_syscall(taskData, "accept failed", GETERROR);
+@@ -911,7 +937,7 @@
+ else if (sel == 0)
+ {
+ /* Nothing yet */
+- processes->BlockAndRestart(taskData, -1, false, POLY_SYS_network);
++ processes->BlockAndRestart(taskData, NULL, false, POLY_SYS_network);
+ /* -1 => not for reading. */
+ }
+ else /* Definite result. */
+@@ -936,7 +962,7 @@
+ if ((err == EWOULDBLOCK || err == EINPROGRESS) && c == 48 /*blocking version*/)
+ {
+ strm->ioBits |= IO_BIT_INPROGRESS;
+- processes->BlockAndRestart(taskData, -1, false, POLY_SYS_network);
++ processes->BlockAndRestart(taskData, NULL, false, POLY_SYS_network);
+ /* -1 => not for reading. */
+ }
+ else if (err != EINTR)
+@@ -1008,7 +1034,7 @@
+ err = GETERROR;
+ if (err == EWOULDBLOCK && c == 51 /* blocking */)
+ {
+- processes->BlockAndRestart(taskData, -1, false, POLY_SYS_network);
++ processes->BlockAndRestart(taskData, NULL, false, POLY_SYS_network);
+ /* -1 => not for reading */
+ ASSERT(0); /* Must not have returned. */
+ }
+@@ -1056,7 +1082,7 @@
+ err = GETERROR;
+ if (err == EWOULDBLOCK && c == 52 /* blocking */)
+ {
+- processes->BlockAndRestart(taskData, -1, false, POLY_SYS_network);
++ processes->BlockAndRestart(taskData, NULL, false, POLY_SYS_network);
+ ASSERT(0); /* Must not have returned. */
+ }
+ else if (err != EINTR)
+@@ -1092,8 +1118,8 @@
+ if (err == EWOULDBLOCK && c == 53 /* blocking */)
+ {
+ /* Block until something arrives. */
+- processes->BlockAndRestart(taskData, outOfBand ? -1 : strm->device.sock,
+- false, POLY_SYS_network);
++ WaitNet waiter(strm->device.sock, outOfBand != 0);
++ processes->BlockAndRestart(taskData, &waiter, false, POLY_SYS_network);
+ ASSERT(0); /* Must not have returned. */
+ }
+ else if (err != EINTR)
+@@ -1139,8 +1165,8 @@
+ }
+ if (err == EWOULDBLOCK && c == 54 /* blocking */)
+ {
+- processes->BlockAndRestart(taskData, outOfBand ? -1 : strm->device.sock,
+- false, POLY_SYS_network);
++ WaitNet waiter(strm->device.sock, outOfBand != 0);
++ processes->BlockAndRestart(taskData, &waiter, false, POLY_SYS_network);
+ ASSERT(0); /* Must not have returned. */
+ }
+ else if (err != EINTR)
+@@ -1585,7 +1611,7 @@
+ #endif
+ }
+ case 1: /* Block until one of the descriptors is ready. */
+- processes->BlockAndRestart(taskData, -1, false, POLY_SYS_network);
++ processes->BlockAndRestart(taskData, NULL, false, POLY_SYS_network);
+ /*NOTREACHED*/
+ case 2: /* Just a simple poll - drop through. */
+ break;
+diff -u -r libpolyml/objsize.cpp libpolyml/objsize.cpp
+--- libpolyml/objsize.cpp 2007-03-29 08:52:30.000000000 +0200
++++ libpolyml/objsize.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -19,10 +19,12 @@
+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+ */
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_STDIO_H
+diff -u -r libpolyml/osmem.cpp libpolyml/osmem.cpp
+--- libpolyml/osmem.cpp 2007-10-18 15:19:05.000000000 +0200
++++ libpolyml/osmem.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -19,10 +19,12 @@
+
+ */
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_SYS_TYPES_H
+diff -u -r libpolyml/pecoffexport.cpp libpolyml/pecoffexport.cpp
+--- libpolyml/pecoffexport.cpp 2007-03-29 08:52:30.000000000 +0200
++++ libpolyml/pecoffexport.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -19,10 +19,12 @@
+ License along with this library; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #include <stdio.h>
+@@ -51,7 +53,7 @@
+ #include "machine_dep.h"
+ #include "scanaddrs.h"
+ #include "run_time.h"
+-#include "polyexports.h"
++#include "../polyexports.h"
+ #include "version.h"
+ #include "polystring.h"
+
+diff -u -r libpolyml/pexport.cpp libpolyml/pexport.cpp
+--- libpolyml/pexport.cpp 2008-03-25 12:53:50.000000000 +0100
++++ libpolyml/pexport.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -19,10 +19,12 @@
+ License along with this library; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_STDIO_H
+@@ -49,7 +51,7 @@
+ #include "machine_dep.h"
+ #include "scanaddrs.h"
+ #include "run_time.h"
+-#include "polyexports.h"
++#include "../polyexports.h"
+ #include "version.h"
+ #include "sys.h"
+ #include "polystring.h"
+diff -u -r libpolyml/poly_specific.cpp libpolyml/poly_specific.cpp
+--- libpolyml/poly_specific.cpp 2007-10-05 13:37:41.000000000 +0200
++++ libpolyml/poly_specific.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -22,10 +22,12 @@
+ /* This module is used for various run-time calls that are either in the
+ PolyML structure or otherwise specific to Poly/ML. */
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_ASSERT_H
+diff -u -r libpolyml/polystring.cpp libpolyml/polystring.cpp
+--- libpolyml/polystring.cpp 2008-03-25 12:23:08.000000000 +0100
++++ libpolyml/polystring.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -19,10 +19,12 @@
+
+ */
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_STDIO_H
+diff -u -r libpolyml/power_dep.cpp libpolyml/power_dep.cpp
+--- libpolyml/power_dep.cpp 2008-03-25 12:23:08.000000000 +0100
++++ libpolyml/power_dep.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -20,10 +20,12 @@
+
+ */
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_STDLIB_H
+diff -u -r libpolyml/process_env.cpp libpolyml/process_env.cpp
+--- libpolyml/process_env.cpp 2008-02-27 14:12:35.000000000 +0100
++++ libpolyml/process_env.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -18,10 +18,12 @@
+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+ */
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_STDIO_H
+@@ -165,7 +167,7 @@
+ argv[0] = getenv("COMSPEC"); // Default CLI.
+ if (argv[0] == 0)
+ {
+- if (_osver & 0x8000) argv[0] = "command.com"; // Win 95 etc.
++ if (GetVersion() & 0x80000000) argv[0] = "command.com"; // Win 95 etc.
+ else argv[0] = "cmd.exe"; // Win NT etc.
+ }
+ argv[1] = (char*)"/c";
+@@ -236,6 +238,9 @@
+ case WAIT_FAILED:
+ raise_syscall(mdTaskData, "Function system failed", -(int)GetLastError());
+ }
++ // Wait for the process to exit or for the timeout
++ WaitHandle waiter((HANDLE)pid);
++ processes->ThreadPauseForIO(mdTaskData, &waiter);
+ #else
+ int wRes = waitpid(pid, &res, WNOHANG);
+ if (wRes > 0)
+@@ -244,8 +249,12 @@
+ {
+ raise_syscall(mdTaskData, "Function system failed", errno);
+ }
+-#endif
++ // In Unix the best we can do is wait. This may be interrupted
++ // by SIGCHLD depending on where signals are processed.
++ // One possibility is for the main thread to somehow wake-up
++ // the thread when it processes a SIGCHLD.
+ processes->ThreadPause(mdTaskData);
++#endif
+ }
+ catch (...)
+ {
+diff -u -r libpolyml/processes.cpp libpolyml/processes.cpp
+--- libpolyml/processes.cpp 2008-10-07 15:56:27.000000000 +0200
++++ libpolyml/processes.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -20,10 +20,12 @@
+
+ */
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_STDIO_H
+@@ -81,7 +83,7 @@
+ #include <windows.h>
+ #endif
+
+-#if (defined(HAVE_LIBPTHREAD) && defined(HAVE_PTHREAD_H))
++#if ((!defined(WIN32) || defined(__CYGWIN__)) && defined(HAVE_LIBPTHREAD) && defined(HAVE_PTHREAD_H))
+ #define HAVE_PTHREAD 1
+ #include <pthread.h>
+ #endif
+@@ -195,12 +197,10 @@
+ // Called when a thread has completed - doesn't return.
+ virtual NORETURNFN(void ThreadExit(TaskData *taskData));
+
+- void BlockAndRestart(TaskData *taskData, int fd, bool posixInterruptable, int ioCall);
++ void BlockAndRestart(TaskData *taskData, Waiter *pWait, bool posixInterruptable, int ioCall);
+ // Called when a thread may block. Returns some time later when perhaps
+ // the input is available.
+- virtual void ThreadPauseForIO(TaskData *taskData, int fd);
+-
+- void SwitchSubShells(void);
++ virtual void ThreadPauseForIO(TaskData *taskData, Waiter *pWait);
+ // Return the task data for the current thread.
+ virtual TaskData *GetTaskDataForThread(void);
+ // ForkFromRTS. Creates a new thread from within the RTS.
+@@ -280,10 +280,6 @@
+ DWORD tlsId;
+ #endif
+
+-#ifdef HAVE_WINDOWS_H
+- HANDLE hWakeupEvent; // Pulsed to wake up any threads waiting for IO.
+-#endif
+-
+ // We make an exception packet for Interrupt and store it here.
+ // This exception can be raised if we run out of store so we need to
+ // make sure we have the packet before we do.
+@@ -327,7 +323,7 @@
+ crowbarRunning(false), sigTask(0)
+ {
+ #ifdef HAVE_WINDOWS_H
+- hWakeupEvent = NULL;
++ Waiter::hWakeupEvent = NULL;
+ hStopEvent = NULL;
+ profilingHd = NULL;
+ lastCPUTime = 0;
+@@ -752,7 +748,7 @@
+ }
+ #ifdef HAVE_WINDOWS_H
+ // Wake any threads waiting for IO
+- PulseEvent(hWakeupEvent);
++ PulseEvent(Waiter::hWakeupEvent);
+ #endif
+ }
+
+@@ -946,20 +942,52 @@
+ }
+
+ /* Called when a thread is about to block, usually because of IO.
+- fd may be negative if the file descriptor value is not relevant.
+ If this is interruptable (currently only used for Posix functions)
+ the process will be set to raise an exception if any signal is handled.
+ It may also raise an exception if another thread has called
+ broadcastInterrupt. */
+-void Processes::ThreadPauseForIO(TaskData *taskData, int fd)
++void Processes::ThreadPauseForIO(TaskData *taskData, Waiter *pWait)
+ {
+ TestSynchronousRequests(taskData); // Consider this a blocking call that may raise Interrupt
+ ThreadReleaseMLMemory(taskData);
+-#ifdef WINDOWS_PC
+- /* It's too complicated in Windows to try and wait for a stream.
+- We simply wait for half a second or until a Windows message
+- arrives. */
++ pWait->Wait(1000); // Wait up to a second
++ ThreadUseMLMemory(taskData);
++ TestSynchronousRequests(taskData); // Check if we've been interrupted.
++ if (ProcessAsynchRequests(taskData))
++ throw IOException(EXC_EXCEPTION);
++}
++
++// This is largely a legacy of the old single-thread version. In that version there
++// was only a single C thread managing multiple ML threads (processes) so if an ML
++// thread blocked it was necessary to switch the thread and then for the C function
++// call to raise an exception to get back to ML.
++// TODO: There's actually a race here if we have posixInterruptible set. We
++// repeatedly come back here and if a signal happens while we're in
++// ThreadPauseForIO we will raise the exception. If the signal happens at
++// another point we won't.
++void Processes::BlockAndRestart(TaskData *taskData, Waiter *pWait, bool posixInterruptable, int ioCall)
++{
++ if (pWait == NULL) pWait = Waiter::defaultWaiter;
++ machineDependent->SetForRetry(taskData, ioCall);
++ unsigned lastSigCount = receivedSignalCount;
++ ThreadPauseForIO(taskData, pWait);
++ // If this is an interruptible Posix function we raise an exception if
++ // there has been a signal.
++ if (posixInterruptable && lastSigCount != receivedSignalCount)
++ raise_syscall(taskData, "Call interrupted by signal", EINTR);
++ throw IOException(EXC_EXCEPTION);
++ /* NOTREACHED */
++}
+
++// Default waiter: simply wait for the time. In the case of Windows it
++// is also woken up if the event is signalled. In Unix it may be woken
++// up by a signal.
++void Waiter::Wait(unsigned maxMillisecs)
++{
++ // Since this is used only when we can't monitor the source directly
++ // we set this to 100ms so that we're not waiting too long.
++ if (maxMillisecs > 100) maxMillisecs = 100;
++#ifdef WINDOWS_PC
+ /* We seem to need to reset the queue before calling
+ MsgWaitForMultipleObjects otherwise it frequently returns
+ immediately, often saying there is a message with a message ID
+@@ -973,45 +1001,59 @@
+ // could result in a recursive call here if we have installed an ML
+ // window proc.
+ PeekMessage(&msg, 0, 0, 0, PM_NOREMOVE);
+-
+ // Wait until we get input or we're woken up.
+- MsgWaitForMultipleObjects(1, &hWakeupEvent, FALSE, 100, QS_ALLINPUT);
++ MsgWaitForMultipleObjects(1, &hWakeupEvent, FALSE, maxMillisecs, QS_ALLINPUT);
+ #else
++ // Unix
+ fd_set read_fds, write_fds, except_fds;
+- struct timeval toWait = { 0, 100000 }; /* 100ms. */
+-
++ struct timeval toWait = { 0, 0 };
++ toWait.tv_sec = maxMillisecs / 1000;
++ toWait.tv_usec = (maxMillisecs % 1000) * 1000;
+ FD_ZERO(&read_fds);
+- if (fd >= 0) FD_SET(fd, &read_fds);
+ FD_ZERO(&write_fds);
+ FD_ZERO(&except_fds);
+ select(FD_SETSIZE, &read_fds, &write_fds, &except_fds, &toWait);
+ #endif
+- ThreadUseMLMemory(taskData);
+- TestSynchronousRequests(taskData); // Check if we've been interrupted.
+- if (ProcessAsynchRequests(taskData))
+- throw IOException(EXC_EXCEPTION);
+ }
+
+-// This is largely a legacy of the old single-thread version. In that version there
+-// was only a single C thread managing multiple ML threads (processes) so if an ML
+-// thread blocked it was necessary to switch the thread and then for the C function
+-// call to raise an exception to get back to ML.
+-// TODO: There's actually a race here if we have posixInterruptible set. We
+-// repeatedly come back here and if a signal happens while we're in
+-// ThreadPauseForIO we will raise the exception. If the signal happens at
+-// another point we won't.
+-void Processes::BlockAndRestart(TaskData *taskData, int fd, bool posixInterruptable, int ioCall)
++static Waiter defWait;
++Waiter *Waiter::defaultWaiter = &defWait;
++
++#ifdef HAVE_WINDOWS_H
++// Windows and Cygwin
++HANDLE Waiter::hWakeupEvent; // Pulsed to wake up any threads waiting for IO.
++
++// Wait for the specified handle to be signalled.
++void WaitHandle::Wait(unsigned maxMillisecs)
+ {
+- machineDependent->SetForRetry(taskData, ioCall);
+- unsigned lastSigCount = receivedSignalCount;
+- ThreadPauseForIO(taskData, fd);
+- // If this is an interruptible Posix function we raise an exception if
+- // there has been a signal.
+- if (posixInterruptable && lastSigCount != receivedSignalCount)
+- raise_syscall(taskData, "Call interrupted by signal", EINTR);
+- throw IOException(EXC_EXCEPTION);
+- /* NOTREACHED */
++ MSG msg;
++ PeekMessage(&msg, 0, 0, 0, PM_NOREMOVE);
++
++ HANDLE hEvents[2];
++ DWORD dwEvents = 0;
++ hEvents[dwEvents++] = Waiter::hWakeupEvent;
++ if (m_Handle != NULL)
++ hEvents[dwEvents++] = m_Handle;
++ // Wait until we get input or we're woken up.
++ MsgWaitForMultipleObjects(dwEvents, hEvents, FALSE, maxMillisecs, QS_ALLINPUT);
++}
++#endif
++
++#ifndef WINDOWS_PC
++// Unix and Cygwin: Wait for a file descriptor on input.
++void WaitInputFD::Wait(unsigned maxMillisecs)
++{
++ fd_set read_fds, write_fds, except_fds;
++ struct timeval toWait = { 0, 0 };
++ toWait.tv_sec = maxMillisecs / 1000;
++ toWait.tv_usec = (maxMillisecs % 1000) * 1000;
++ FD_ZERO(&read_fds);
++ if (m_waitFD >= 0) FD_SET(m_waitFD, &read_fds);
++ FD_ZERO(&write_fds);
++ FD_ZERO(&except_fds);
++ select(FD_SETSIZE, &read_fds, &write_fds, &except_fds, &toWait);
+ }
++#endif
+
+ // Get the task data for the current thread. This is held in
+ // thread-local storage. Normally this is passed in taskData but
+@@ -1690,7 +1732,7 @@
+ {
+ #ifdef HAVE_WINDOWS_H
+ // Create event to wake up from IO sleeping.
+- hWakeupEvent = CreateEvent(NULL, TRUE, FALSE, NULL);
++ Waiter::hWakeupEvent = CreateEvent(NULL, TRUE, FALSE, NULL);
+ #endif
+
+ #ifdef HAVE_PTHREAD
+@@ -1735,12 +1777,12 @@
+ void Processes::Uninit(void)
+ {
+ #ifdef HAVE_WINDOWS_H
+- if (hWakeupEvent) SetEvent(hWakeupEvent);
++ if (Waiter::hWakeupEvent) SetEvent(Waiter::hWakeupEvent);
+ #endif
+
+ #ifdef HAVE_WINDOWS_H
+- if (hWakeupEvent) CloseHandle(hWakeupEvent);
+- hWakeupEvent = NULL;
++ if (Waiter::hWakeupEvent) CloseHandle(Waiter::hWakeupEvent);
++ Waiter::hWakeupEvent = NULL;
+ #endif
+
+ #ifdef HAVE_PTHREAD
+diff -u -r libpolyml/processes.h libpolyml/processes.h
+--- libpolyml/processes.h 2008-02-26 09:51:12.000000000 +0100
++++ libpolyml/processes.h 2009-09-15 08:56:44.000000000 +0200
+@@ -23,10 +23,12 @@
+ #ifndef _PROCESSES_H_
+ #define _PROCESSES_H_
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #include "globals.h"
+@@ -43,6 +45,10 @@
+ class MDTaskData;
+ class Exporter;
+
++#ifdef HAVE_WINDOWS_H
++typedef void *HANDLE;
++#endif
++
+ #define MIN_HEAP_SIZE 4096 // Minimum and initial heap segment size (words)
+
+ // This is the ML "thread identifier" object. The fields
+@@ -114,6 +120,57 @@
+
+ class PLock;
+
++// Class to wait for a given time or for an event, whichever comes first.
++//
++// A pointer to this class or a subclass is passed to ThreadPauseForIO.
++// Because a thread may be interrupted or killed by another ML thread we
++// don't allow any thread to block indefinitely. Instead whenever a
++// thread wants to do an operation that may block we have it enter a
++// loop that polls for the desired condition and if it is not ready it
++// calls ThreadPauseForIO. The default action is to block for a short
++// period and then return so that the caller can poll again. That can
++// limit performance when, for example, reading from a pipe so where possible
++// we use a sub-class that waits until either input is available or it times
++// out, whichever comes first, using "select" in Unix or MsgWaitForMultipleObjects
++// in Windows.
++// During a call to Waiter::Wait the thread is set as "not using ML memory"
++// so a GC can happen while this thread is blocked.
++class Waiter
++{
++public:
++ Waiter() {}
++ virtual ~Waiter() {}
++ virtual void Wait(unsigned maxMillisecs);
++ static Waiter *defaultWaiter;
++#ifdef HAVE_WINDOWS_H
++ static HANDLE hWakeupEvent;
++#endif
++};
++
++#ifdef HAVE_WINDOWS_H
++class WaitHandle: public Waiter
++{
++public:
++ WaitHandle(HANDLE h): m_Handle(h) {}
++ virtual void Wait(unsigned maxMillisecs);
++private:
++ HANDLE m_Handle;
++};
++#endif
++
++#ifndef WINDOWS_PC
++// Unix: Wait until a file descriptor is available for input
++class WaitInputFD: public Waiter
++{
++public:
++ WaitInputFD(int fd): m_waitFD(fd) {}
++ virtual void Wait(unsigned maxMillisecs);
++private:
++ int m_waitFD;
++};
++#endif
++
++
+ // External interface to the Process module. These functions are all implemented
+ // by the Processes class.
+ class ProcessExternal
+@@ -132,13 +189,13 @@
+
+ virtual void BeginRootThread(PolyObject *rootFunction) = 0;
+ // Called when a thread may block. Never returns. May cause a retry.
+- virtual NORETURNFN(void BlockAndRestart(TaskData *taskData, int fd,
++ virtual NORETURNFN(void BlockAndRestart(TaskData *taskData, Waiter *pWait,
+ bool posixInterruptable, int ioCall)) = 0;
+ // Called when a thread may block. Returns some time later when perhaps
+ // the input is available.
+- virtual void ThreadPauseForIO(TaskData *taskData, int fd) = 0;
+- // As ThreadPauseForIO but when there is no file descriptor
+- virtual void ThreadPause(TaskData *taskData) { ThreadPauseForIO(taskData, -1); }
++ virtual void ThreadPauseForIO(TaskData *taskData, Waiter *pWait) = 0;
++ // As ThreadPauseForIO but when there is no stream
++ virtual void ThreadPause(TaskData *taskData) { ThreadPauseForIO(taskData, Waiter::defaultWaiter); }
+
+ // If a thread is blocking for some time it should release its use
+ // of the ML memory. That allows a GC. ThreadUseMLMemory returns true if
+diff -u -r libpolyml/profiling.cpp libpolyml/profiling.cpp
+--- libpolyml/profiling.cpp 2008-02-02 14:19:59.000000000 +0100
++++ libpolyml/profiling.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -21,10 +21,12 @@
+
+ */
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_STDIO_H
+diff -u -r libpolyml/proper_io.cpp libpolyml/proper_io.cpp
+--- libpolyml/proper_io.cpp 2007-03-29 08:52:30.000000000 +0200
++++ libpolyml/proper_io.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -20,10 +20,12 @@
+
+ */
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_ERRNO_H
+diff -u -r libpolyml/proper_io.h libpolyml/proper_io.h
+--- libpolyml/proper_io.h 2007-03-29 08:52:30.000000000 +0200
++++ libpolyml/proper_io.h 2009-09-15 08:56:44.000000000 +0200
+@@ -23,10 +23,12 @@
+ #ifndef _PROPER_IO_H_DEFINED
+ #define _PROPER_IO_H_DEFINED 1
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_STDIO_H
+diff -u -r libpolyml/realconv.cpp libpolyml/realconv.cpp
+--- libpolyml/realconv.cpp 2007-10-05 14:52:08.000000000 +0200
++++ libpolyml/realconv.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -2,8 +2,10 @@
+ Note: Although strtod and dtoa seem to be present on some systems
+ they are not always included in the headers or in the libraries.
+ DCJM 6/4/00
+-*/
+
++ To simplify all this strtod, dtoa and free_dtoa all have
++ a poly_ prefix.
++*/
+ /****************************************************************
+ *
+ * The author of this software is David M. Gay.
+@@ -78,7 +80,13 @@
+ * #define No_leftright to omit left-right logic in fast floating-point
+ * computation of dtoa.
+ * #define Honor_FLT_ROUNDS if FLT_ROUNDS can assume the values 2 or 3
+- * and strtod and dtoa should round accordingly.
++ * and strtod and dtoa should round accordingly. Unless Trust_FLT_ROUNDS
++ * is also #defined, fegetround() will be queried for the rounding mode.
++ * Note that both FLT_ROUNDS and fegetround() are specified by the C99
++ * standard (and are specified to be consistent, with fesetround()
++ * affecting the value of FLT_ROUNDS), but that some (Linux) systems
++ * do not work correctly in this regard, so using fegetround() is more
++ * portable than using FLT_FOUNDS directly.
+ * #define Check_FLT_ROUNDS if FLT_ROUNDS can assume the values 2 or 3
+ * and Honor_FLT_ROUNDS is not #defined.
+ * #define RND_PRODQUOT to use rnd_prod and rnd_quot (assembly routines
+@@ -103,7 +111,12 @@
+ * #define MALLOC your_malloc, where your_malloc(n) acts like malloc(n)
+ * if memory is available and otherwise does something you deem
+ * appropriate. If MALLOC is undefined, malloc will be invoked
+- * directly -- and assumed always to succeed.
++ * directly -- and assumed always to succeed. Similarly, if you
++ * want something other than the system's free() to be called to
++ * recycle memory acquired from MALLOC, #define FREE to be the
++ * name of the alternate routine. (FREE or free is only called in
++ * pathological cases, e.g., in a dtoa call after a dtoa return in
++ * mode 3 with thousands of digits requested.)
+ * #define Omit_Private_Memory to omit logic (added Jan. 1998) for making
+ * memory allocations from a private pool of memory when possible.
+ * When used, the private pool is PRIVATE_MEM bytes long: 2304 bytes,
+@@ -115,9 +128,11 @@
+ * all dtoa conversions in single-threaded executions with 8-byte
+ * pointers, PRIVATE_MEM >= 7400 appears to suffice; with 4-byte
+ * pointers, PRIVATE_MEM >= 7112 appears adequate.
+- * #define INFNAN_CHECK on IEEE systems to cause strtod to check for
+- * Infinity and NaN (case insensitively). On some systems (e.g.,
+- * some HP systems), it may be necessary to #define NAN_WORD0
++ * #define NO_INFNAN_CHECK if you do not wish to have INFNAN_CHECK
++ * #defined automatically on IEEE systems. On such systems,
++ * when INFNAN_CHECK is #defined, strtod checks
++ * for Infinity and NaN (case insensitively). On some systems
++ * (e.g., some HP systems), it may be necessary to #define NAN_WORD0
+ * appropriately -- to the most significant word of a quiet NaN.
+ * (On HP Series 700/800 machines, -DNAN_WORD0=0x7ff40000 works.)
+ * When INFNAN_CHECK is #defined and No_Hex_NaN is not #defined,
+@@ -145,11 +160,6 @@
+ * floating-point numbers and flushes underflows to zero rather
+ * than implementing gradual underflow, then you must also #define
+ * Sudden_Underflow.
+- * #define YES_ALIAS to permit aliasing certain double values with
+- * arrays of ULongs. This leads to slightly better code with
+- * some compilers and was always used prior to 19990916, but it
+- * is not strictly legal and can cause trouble with aggressively
+- * optimizing compilers (e.g., gcc 2.95.1 under -O2).
+ * #define USE_LOCALE to use the current locale's decimal_point value.
+ * #define SET_INEXACT if IEEE arithmetic is being used and extra
+ * computation should be done to set the inexact flag when the
+@@ -167,12 +177,22 @@
+ * inexact or when it is a numeric value rounded to +-infinity).
+ * #define NO_ERRNO if strtod should not assign errno = ERANGE when
+ * the result overflows to +-Infinity or underflows to 0.
++ * #define NO_HEX_FP to omit recognition of hexadecimal floating-point
++ * values by strtod.
++ * #define NO_STRTOD_BIGCOMP (on IEEE-arithmetic systems only for now)
++ * to disable logic for "fast" testing of very long input strings
++ * to strtod. This testing proceeds by initially truncating the
++ * input string, then if necessary comparing the whole string with
++ * a decimal expansion to decide close cases. This logic is only
++ * used for input more than STRTOD_DIGLIM digits long (default 40).
+ */
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_SYS_PARAM_H
+@@ -193,7 +213,7 @@
+
+ #if !defined(IEEE_8087) && ! defined(IEEE_MC68k)
+ #if defined(WINDOWS_PC) || defined(HOSTARCHITECTURE_X86) || defined (__i386__) || defined (_M_IX86) || \
+- defined (vax) || defined (__alpha)
++ defined (vax) || defined (__alpha) || defined(HOSTARCHITECTURE_X86_64)
+ #define IEEE_8087
+ #else
+ #define IEEE_MC68k
+@@ -203,6 +223,7 @@
+ #if (SIZEOF_LONG == 8)
+ // If "long" is the same size as "double" we need to define this.
+ #define Long int
++#define ULong unsigned
+ #endif
+
+ #ifndef HAVE_LONG_LONG
+@@ -228,6 +249,12 @@
+ #include "locale.h"
+ #endif
+
++#ifdef Honor_FLT_ROUNDS
++#ifndef Trust_FLT_ROUNDS
++#include <fenv.h>
++#endif
++#endif
++
+ #ifdef MALLOC
+ #ifdef KR_headers
+ extern char *MALLOC();
+@@ -255,6 +282,16 @@
+ #define IEEE_Arith
+ #endif
+
++#ifdef IEEE_Arith
++#ifndef NO_INFNAN_CHECK
++#undef INFNAN_CHECK
++#define INFNAN_CHECK
++#endif
++#else
++#undef INFNAN_CHECK
++#define NO_STRTOD_BIGCOMP
++#endif
++
+ #include "errno.h"
+
+ #ifdef Bad_float_h
+@@ -312,24 +349,23 @@
+
+ typedef union { double d; ULong L[2]; } U;
+
+-#ifdef YES_ALIAS
+-#define dval(x) x
+ #ifdef IEEE_8087
+-#define word0(x) ((ULong *)&x)[1]
+-#define word1(x) ((ULong *)&x)[0]
++#define word0(x) (x)->L[1]
++#define word1(x) (x)->L[0]
+ #else
+-#define word0(x) ((ULong *)&x)[0]
+-#define word1(x) ((ULong *)&x)[1]
++#define word0(x) (x)->L[0]
++#define word1(x) (x)->L[1]
+ #endif
+-#else
+-#ifdef IEEE_8087
+-#define word0(x) ((U*)&x)->L[1]
+-#define word1(x) ((U*)&x)->L[0]
+-#else
+-#define word0(x) ((U*)&x)->L[0]
+-#define word1(x) ((U*)&x)->L[1]
++#define dval(x) (x)->d
++
++#ifndef STRTOD_DIGLIM
++#define STRTOD_DIGLIM 40
+ #endif
+-#define dval(x) ((U*)&x)->d
++
++#ifdef DIGLIM_DEBUG
++extern int strtod_diglim;
++#else
++#define strtod_diglim STRTOD_DIGLIM
+ #endif
+
+ /* The following definition of Storeinc is appropriate for MIPS processors.
+@@ -357,7 +393,9 @@
+ #define Exp_msk11 0x100000
+ #define Exp_mask 0x7ff00000
+ #define P 53
++#define Nbits 53
+ #define Bias 1023
++#define Emax 1023
+ #define Emin (-1022)
+ #define Exp_1 0x3ff00000
+ #define Exp_11 0x3ff00000
+@@ -391,7 +429,6 @@
+ #endif /*Flt_Rounds*/
+
+ #ifdef Honor_FLT_ROUNDS
+-#define Rounding rounding
+ #undef Check_FLT_ROUNDS
+ #define Check_FLT_ROUNDS
+ #else
+@@ -413,7 +450,10 @@
+ #define Exp_msk11 0x1000000
+ #define Exp_mask 0x7f000000
+ #define P 14
++#define Nbits 56
+ #define Bias 65
++#define Emax 248
++#define Emin (-260)
+ #define Exp_1 0x41000000
+ #define Exp_11 0x41000000
+ #define Ebits 8 /* exponent has 7 bits, but 8 is the right value in b2d */
+@@ -439,7 +479,10 @@
+ #define Exp_msk11 0x800000
+ #define Exp_mask 0x7f80
+ #define P 56
++#define Nbits 56
+ #define Bias 129
++#define Emax 126
++#define Emin (-129)
+ #define Exp_1 0x40800000
+ #define Exp_11 0x4080
+ #define Ebits 8
+@@ -483,6 +526,10 @@
+ #define Pack_32
+ #endif
+
++typedef struct BCinfo BCinfo;
++ struct
++BCinfo { int dp0, dp1, dplen, dsign, e0, inexact, nd, nd0, rounding, scale, uflchk; };
++
+ #ifdef KR_headers
+ #define FFFFFFFF ((((unsigned long)0xffff)<<16)|(unsigned long)0xffff)
+ #else
+@@ -518,7 +565,7 @@
+ #define FREE_DTOA_LOCK(n) /*nothing*/
+ #endif
+
+-#define Kmax 15
++#define Kmax 7
+
+ #ifdef __cplusplus
+ extern "C" double strtod(const char *s00, char **se);
+@@ -552,9 +599,10 @@
+ #endif
+
+ ACQUIRE_DTOA_LOCK(0);
+- if ((rv = freelist[k])) {
++ /* The k > Kmax case does not need ACQUIRE_DTOA_LOCK(0), */
++ /* but this case seems very unlikely. */
++ if (k <= Kmax && (rv = freelist[k]))
+ freelist[k] = rv->next;
+- }
+ else {
+ x = 1 << k;
+ #ifdef Omit_Private_Memory
+@@ -562,7 +610,7 @@
+ #else
+ len = (sizeof(Bigint) + (x-1)*sizeof(ULong) + sizeof(double) - 1)
+ /sizeof(double);
+- if (pmem_next - private_mem + len <= PRIVATE_mem) {
++ if (k <= Kmax && pmem_next - private_mem + len <= PRIVATE_mem) {
+ rv = (Bigint*)pmem_next;
+ pmem_next += len;
+ }
+@@ -586,10 +634,18 @@
+ #endif
+ {
+ if (v) {
+- ACQUIRE_DTOA_LOCK(0);
+- v->next = freelist[v->k];
+- freelist[v->k] = v;
+- FREE_DTOA_LOCK(0);
++ if (v->k > Kmax)
++#ifdef FREE
++ FREE((void*)v);
++#else
++ free((void*)v);
++#endif
++ else {
++ ACQUIRE_DTOA_LOCK(0);
++ v->next = freelist[v->k];
++ freelist[v->k] = v;
++ FREE_DTOA_LOCK(0);
++ }
+ }
+ }
+
+@@ -653,14 +709,12 @@
+ return b;
+ }
+
+-#ifndef HAVE_STRTOD
+-
+ static Bigint *
+ s2b
+ #ifdef KR_headers
+- (s, nd0, nd, y9) CONST char *s; int nd0, nd; ULong y9;
++ (s, nd0, nd, y9, dplen) CONST char *s; int nd0, nd, dplen; ULong y9;
+ #else
+- (CONST char *s, int nd0, int nd, ULong y9)
++ (CONST char *s, int nd0, int nd, ULong y9, int dplen)
+ #endif
+ {
+ Bigint *b;
+@@ -684,25 +738,24 @@
+ s += 9;
+ do b = multadd(b, 10, *s++ - '0');
+ while(++i < nd0);
+- s++;
++ s += dplen;
+ }
+ else
+- s += 10;
++ s += dplen + 9;
+ for(; i < nd; i++)
+ b = multadd(b, 10, *s++ - '0');
+ return b;
+ }
+-#endif // HAVE_STRTOD
+
+ static int
+ hi0bits
+ #ifdef KR_headers
+- (x) register ULong x;
++ (x) ULong x;
+ #else
+- (register ULong x)
++ (ULong x)
+ #endif
+ {
+- register int k = 0;
++ int k = 0;
+
+ if (!(x & 0xffff0000)) {
+ k = 16;
+@@ -736,8 +789,8 @@
+ (ULong *y)
+ #endif
+ {
+- register int k;
+- register ULong x = *y;
++ int k;
++ ULong x = *y;
+
+ if (x & 7) {
+ if (x & 1)
+@@ -1149,17 +1202,16 @@
+ return c;
+ }
+
+-#ifndef HAVE_STRTOD
+ static double
+ ulp
+ #ifdef KR_headers
+- (x) double x;
++ (x) U *x;
+ #else
+- (double x)
++ (U *x)
+ #endif
+ {
+- register Long L;
+- double a;
++ Long L;
++ U u;
+
+ L = (word0(x) & Exp_mask) - (P-1)*Exp_msk1;
+ #ifndef Avoid_Underflow
+@@ -1170,26 +1222,26 @@
+ #ifdef IBM
+ L |= Exp_msk1 >> 4;
+ #endif
+- word0(a) = L;
+- word1(a) = 0;
++ word0(&u) = L;
++ word1(&u) = 0;
+ #ifndef Avoid_Underflow
+ #ifndef Sudden_Underflow
+ }
+ else {
+ L = -L >> Exp_shift;
+ if (L < Exp_shift) {
+- word0(a) = 0x80000 >> L;
+- word1(a) = 0;
++ word0(&u) = 0x80000 >> L;
++ word1(&u) = 0;
+ }
+ else {
+- word0(a) = 0;
++ word0(&u) = 0;
+ L -= Exp_shift;
+- word1(a) = L >= 31 ? 1 : 1 << 31 - L;
++ word1(&u) = L >= 31 ? 1 : 1 << 31 - L;
+ }
+ }
+ #endif
+ #endif
+- return dval(a);
++ return dval(&u);
+ }
+
+ static double
+@@ -1202,12 +1254,12 @@
+ {
+ ULong *xa, *xa0, w, y, z;
+ int k;
+- double d;
++ U d;
+ #ifdef VAX
+ ULong d0, d1;
+ #else
+-#define d0 word0(d)
+-#define d1 word1(d)
++#define d0 word0(&d)
++#define d1 word1(&d)
+ #endif
+
+ xa0 = a->x;
+@@ -1220,16 +1272,16 @@
+ *e = 32 - k;
+ #ifdef Pack_32
+ if (k < Ebits) {
+- d0 = Exp_1 | y >> Ebits - k;
++ d0 = Exp_1 | y >> (Ebits - k);
+ w = xa > xa0 ? *--xa : 0;
+- d1 = y << (32-Ebits) + k | w >> Ebits - k;
++ d1 = y << ((32-Ebits) + k) | w >> (Ebits - k);
+ goto ret_d;
+ }
+ z = xa > xa0 ? *--xa : 0;
+ if (k -= Ebits) {
+- d0 = Exp_1 | y << k | z >> 32 - k;
++ d0 = Exp_1 | y << k | z >> (32 - k);
+ y = xa > xa0 ? *--xa : 0;
+- d1 = z << k | y >> 32 - k;
++ d1 = z << k | y >> (32 - k);
+ }
+ else {
+ d0 = Exp_1 | y;
+@@ -1253,22 +1305,21 @@
+ #endif
+ ret_d:
+ #ifdef VAX
+- word0(d) = d0 >> 16 | d0 << 16;
+- word1(d) = d1 >> 16 | d1 << 16;
++ word0(&d) = d0 >> 16 | d0 << 16;
++ word1(&d) = d1 >> 16 | d1 << 16;
+ #else
+ #undef d0
+ #undef d1
+ #endif
+- return dval(d);
++ return dval(&d);
+ }
+-#endif // HAVE_STRTOD
+
+ static Bigint *
+ d2b
+ #ifdef KR_headers
+- (d, e, bits) double d; int *e, *bits;
++ (d, e, bits) U *d; int *e, *bits;
+ #else
+- (double d, int *e, int *bits)
++ (U *d, int *e, int *bits)
+ #endif
+ {
+ Bigint *b;
+@@ -1318,10 +1369,6 @@
+ b->wds = (x[1] = z) ? 2 : 1;
+ }
+ else {
+-#ifdef DEBUG
+- if (!z)
+- Bug("Zero passed to d2b");
+-#endif
+ k = lo0bits(&z);
+ x[0] = z;
+ #ifndef Sudden_Underflow
+@@ -1401,7 +1448,6 @@
+ #undef d0
+ #undef d1
+
+-#ifndef HAVE_STRTOD
+ static double
+ ratio
+ #ifdef KR_headers
+@@ -1410,11 +1456,11 @@
+ (Bigint *a, Bigint *b)
+ #endif
+ {
+- double da, db;
++ U da, db;
+ int k, ka, kb;
+
+- dval(da) = b2d(a, &ka);
+- dval(db) = b2d(b, &kb);
++ dval(&da) = b2d(a, &ka);
++ dval(&db) = b2d(b, &kb);
+ #ifdef Pack_32
+ k = ka - kb + 32*(a->wds - b->wds);
+ #else
+@@ -1422,27 +1468,26 @@
+ #endif
+ #ifdef IBM
+ if (k > 0) {
+- word0(da) += (k >> 2)*Exp_msk1;
++ word0(&da) += (k >> 2)*Exp_msk1;
+ if (k &= 3)
+- dval(da) *= 1 << k;
++ dval(&da) *= 1 << k;
+ }
+ else {
+ k = -k;
+- word0(db) += (k >> 2)*Exp_msk1;
++ word0(&db) += (k >> 2)*Exp_msk1;
+ if (k &= 3)
+- dval(db) *= 1 << k;
++ dval(&db) *= 1 << k;
+ }
+ #else
+ if (k > 0)
+- word0(da) += k*Exp_msk1;
++ word0(&da) += k*Exp_msk1;
+ else {
+ k = -k;
+- word0(db) += k*Exp_msk1;
++ word0(&db) += k*Exp_msk1;
+ }
+ #endif
+- return dval(da) / dval(db);
++ return dval(&da) / dval(&db);
+ }
+-#endif // HAVE_STRTOD
+
+ static CONST double
+ tens[] = {
+@@ -1457,16 +1502,14 @@
+ static CONST double
+ #ifdef IEEE_Arith
+ bigtens[] = { 1e16, 1e32, 1e64, 1e128, 1e256 };
+-#ifndef HAVE_STRTOD
+ static CONST double tinytens[] = { 1e-16, 1e-32, 1e-64, 1e-128,
+ #ifdef Avoid_Underflow
+ 9007199254740992.*9007199254740992.e-256
+- /* = 2^106 * 1e-53 */
++ /* = 2^106 * 1e-256 */
+ #else
+ 1e-256
+ #endif
+ };
+-#endif
+ /* The factor of 2^53 in tinytens[4] helps us avoid setting the underflow */
+ /* flag unnecessarily. It leads to a song and dance at the end of strtod. */
+ #define Scale_Bit 0x10
+@@ -1483,9 +1526,47 @@
+ #endif
+ #endif
+
+-#ifndef IEEE_Arith
+-#undef INFNAN_CHECK
++#undef Need_Hexdig
++#ifdef INFNAN_CHECK
++#ifndef No_Hex_NaN
++#define Need_Hexdig
++#endif
++#endif
++
++#ifndef Need_Hexdig
++#ifndef NO_HEX_FP
++#define Need_Hexdig
++#endif
++#endif
++
++#ifdef Need_Hexdig /*{*/
++static unsigned char hexdig[256];
++
++ static void
++#ifdef KR_headers
++htinit(h, s, inc) unsigned char *h; unsigned char *s; int inc;
++#else
++htinit(unsigned char *h, unsigned char *s, int inc)
++#endif
++{
++ int i, j;
++ for(i = 0; (j = s[i]) !=0; i++)
++ h[j] = i + inc;
++ }
++
++ static void
++#ifdef KR_headers
++hexdig_init()
++#else
++hexdig_init(void)
+ #endif
++{
++#define USC (unsigned char *)
++ htinit(hexdig, USC "0123456789", 0x10);
++ htinit(hexdig, USC "abcdef", 0x10 + 10);
++ htinit(hexdig, USC "ABCDEF", 0x10 + 10);
++ }
++#endif /* } Need_Hexdig */
+
+ #ifdef INFNAN_CHECK
+
+@@ -1502,13 +1583,13 @@
+ #ifdef KR_headers
+ (sp, t) char **sp, *t;
+ #else
+- (CONST char **sp, char *t)
++ (CONST char **sp, CONST char *t)
+ #endif
+ {
+ int c, d;
+ CONST char *s = *sp;
+
+- while(d = *t++) {
++ while((d = *t++)) {
+ if ((c = *++s) >= 'A' && c <= 'Z')
+ c += 'a' - 'A';
+ if (c != d)
+@@ -1522,26 +1603,29 @@
+ static void
+ hexnan
+ #ifdef KR_headers
+- (rvp, sp) double *rvp; CONST char **sp;
++ (rvp, sp) U *rvp; CONST char **sp;
+ #else
+- (double *rvp, CONST char **sp)
++ (U *rvp, CONST char **sp)
+ #endif
+ {
+ ULong c, x[2];
+ CONST char *s;
+- int havedig, udx0, xshift;
++ int c1, havedig, udx0, xshift;
+
++ if (!hexdig['0'])
++ hexdig_init();
+ x[0] = x[1] = 0;
+ havedig = xshift = 0;
+ udx0 = 1;
+ s = *sp;
+- while(c = *(CONST unsigned char*)++s) {
+- if (c >= '0' && c <= '9')
+- c -= '0';
+- else if (c >= 'a' && c <= 'f')
+- c += 10 - 'a';
+- else if (c >= 'A' && c <= 'F')
+- c += 10 - 'A';
++ /* allow optional initial 0x or 0X */
++ while((c = *(CONST unsigned char*)(s+1)) && c <= ' ')
++ ++s;
++ if (s[1] == '0' && (s[2] == 'x' || s[2] == 'X'))
++ s += 2;
++ while((c = *(CONST unsigned char*)++s)) {
++ if ((c1 = hexdig[c]))
++ c = c1 & 0xf;
+ else if (c <= ' ') {
+ if (udx0 && havedig) {
+ udx0 = 0;
+@@ -1549,12 +1633,24 @@
+ }
+ continue;
+ }
++#ifdef GDTOA_NON_PEDANTIC_NANCHECK
+ else if (/*(*/ c == ')' && havedig) {
+ *sp = s + 1;
+ break;
+ }
+ else
+ return; /* invalid form: don't change *sp */
++#else
++ else {
++ do {
++ if (/*(*/ c == ')') {
++ *sp = s + 1;
++ break;
++ }
++ } while((c = *++s));
++ break;
++ }
++#endif
+ havedig = 1;
+ if (xshift) {
+ xshift = 0;
+@@ -1566,131 +1662,956 @@
+ x[1] = (x[1] << 4) | c;
+ }
+ if ((x[0] &= 0xfffff) || x[1]) {
+- word0(*rvp) = Exp_mask | x[0];
+- word1(*rvp) = x[1];
++ word0(rvp) = Exp_mask | x[0];
++ word1(rvp) = x[1];
+ }
+ }
+ #endif /*No_Hex_NaN*/
+ #endif /* INFNAN_CHECK */
++#ifdef Pack_32
++#define ULbits 32
++#define kshift 5
++#define kmask 31
++#else
++#define ULbits 16
++#define kshift 4
++#define kmask 15
++#endif
++#ifndef NO_HEX_FP /*{*/
+
+-#ifndef HAVE_STRTOD
++ static void
++#ifdef KR_headers
++rshift(b, k) Bigint *b; int k;
++#else
++rshift(Bigint *b, int k)
++#endif
++{
++ ULong *x, *x1, *xe, y;
++ int n;
+
+- double
+-strtod
++ x = x1 = b->x;
++ n = k >> kshift;
++ if (n < b->wds) {
++ xe = x + b->wds;
++ x += n;
++ if (k &= kmask) {
++ n = 32 - k;
++ y = *x++ >> k;
++ while(x < xe) {
++ *x1++ = (y | (*x << n)) & 0xffffffff;
++ y = *x++ >> k;
++ }
++ if ((*x1 = y) !=0)
++ x1++;
++ }
++ else
++ while(x < xe)
++ *x1++ = *x++;
++ }
++ if ((b->wds = x1 - b->x) == 0)
++ b->x[0] = 0;
++ }
++
++ static ULong
+ #ifdef KR_headers
+- (s00, se) CONST char *s00; char **se;
++any_on(b, k) Bigint *b; int k;
+ #else
+- (CONST char *s00, char **se)
++any_on(Bigint *b, int k)
+ #endif
+ {
+-#ifdef Avoid_Underflow
+- int scale;
++ int n, nwds;
++ ULong *x, *x0, x1, x2;
++
++ x = b->x;
++ nwds = b->wds;
++ n = k >> kshift;
++ if (n > nwds)
++ n = nwds;
++ else if (n < nwds && (k &= kmask)) {
++ x1 = x2 = x[n];
++ x1 >>= k;
++ x1 <<= k;
++ if (x1 != x2)
++ return 1;
++ }
++ x0 = x;
++ x += n;
++ while(x > x0)
++ if (*--x)
++ return 1;
++ return 0;
++ }
++
++enum { /* rounding values: same as FLT_ROUNDS */
++ Round_zero = 0,
++ Round_near = 1,
++ Round_up = 2,
++ Round_down = 3
++ };
++
++ static Bigint *
++#ifdef KR_headers
++increment(b) Bigint *b;
++#else
++increment(Bigint *b)
+ #endif
+- int bb2, bb5, bbe, bd2, bd5, bbbits, bs2, c, dsign,
+- e, e1, esign, i, j, k, nd, nd0, nf, nz, nz0, sign;
+- CONST char *s, *s0, *s1;
+- double aadj, aadj1, adj, rv, rv0;
+- Long L;
+- ULong y, z;
+- Bigint *bb, *bb1, *bd, *bd0, *bs, *delta;
+-#ifdef SET_INEXACT
+- int inexact, oldinexact;
++{
++ ULong *x, *xe;
++ Bigint *b1;
++
++ x = b->x;
++ xe = x + b->wds;
++ do {
++ if (*x < (ULong)0xffffffffL) {
++ ++*x;
++ return b;
++ }
++ *x++ = 0;
++ } while(x < xe);
++ {
++ if (b->wds >= b->maxwds) {
++ b1 = Balloc(b->k+1);
++ Bcopy(b1,b);
++ Bfree(b);
++ b = b1;
++ }
++ b->x[b->wds++] = 1;
++ }
++ return b;
++ }
++
++ void
++#ifdef KR_headers
++gethex(sp, rvp, rounding, sign)
++ CONST char **sp; U *rvp; int rounding, sign;
++#else
++gethex( CONST char **sp, U *rvp, int rounding, int sign)
+ #endif
+-#ifdef Honor_FLT_ROUNDS
+- int rounding;
++{
++ Bigint *b;
++ CONST unsigned char *decpt, *s0, *s, *s1;
++ Long e, e1;
++ ULong L, lostbits, *x;
++ int big, denorm, esign, havedig, k, n, nbits, up, zret;
++#ifdef IBM
++ int j;
++#endif
++ enum {
++#ifdef IEEE_Arith /*{{*/
++ emax = 0x7fe - Bias - P + 1,
++ emin = Emin - P + 1
++#else /*}{*/
++ emin = Emin - P,
++#ifdef VAX
++ emax = 0x7ff - Bias - P + 1
++#endif
++#ifdef IBM
++ emax = 0x7f - Bias - P
+ #endif
++#endif /*}}*/
++ };
+ #ifdef USE_LOCALE
+- CONST char *s2;
++ int i;
++#ifdef NO_LOCALE_CACHE
++ const unsigned char *decimalpoint = (unsigned char*)
++ localeconv()->decimal_point;
++#else
++ const unsigned char *decimalpoint;
++ static unsigned char *decimalpoint_cache;
++ if (!(s0 = decimalpoint_cache)) {
++ s0 = (unsigned char*)localeconv()->decimal_point;
++ if ((decimalpoint_cache = (unsigned char*)
++ MALLOC(strlen((CONST char*)s0) + 1))) {
++ strcpy((char*)decimalpoint_cache, (CONST char*)s0);
++ s0 = decimalpoint_cache;
++ }
++ }
++ decimalpoint = s0;
++#endif
+ #endif
+
+- sign = nz0 = nz = 0;
+- dval(rv) = 0.;
+- for(s = s00;;s++) switch(*s) {
+- case '-':
+- sign = 1;
+- /* no break */
+- case '+':
+- if (*++s)
+- goto break2;
+- /* no break */
+- case 0:
+- goto ret0;
+- case '\t':
+- case '\n':
+- case '\v':
+- case '\f':
+- case '\r':
+- case ' ':
+- continue;
+- default:
+- goto break2;
+- }
+- break2:
+- if (*s == '0') {
+- nz0 = 1;
+- while(*++s == '0') ;
+- if (!*s)
+- goto ret;
++ if (!hexdig['0'])
++ hexdig_init();
++ havedig = 0;
++ s0 = *(CONST unsigned char **)sp + 2;
++ while(s0[havedig] == '0')
++ havedig++;
++ s0 += havedig;
++ s = s0;
++ decpt = 0;
++ zret = 0;
++ e = 0;
++ if (hexdig[*s])
++ havedig++;
++ else {
++ zret = 1;
++#ifdef USE_LOCALE
++ for(i = 0; decimalpoint[i]; ++i) {
++ if (s[i] != decimalpoint[i])
++ goto pcheck;
++ }
++ decpt = s += i;
++#else
++ if (*s != '.')
++ goto pcheck;
++ decpt = ++s;
++#endif
++ if (!hexdig[*s])
++ goto pcheck;
++ while(*s == '0')
++ s++;
++ if (hexdig[*s])
++ zret = 0;
++ havedig = 1;
++ s0 = s;
+ }
+- s0 = s;
+- y = z = 0;
+- for(nd = nf = 0; (c = *s) >= '0' && c <= '9'; nd++, s++)
+- if (nd < 9)
+- y = 10*y + c - '0';
+- else if (nd < 16)
+- z = 10*z + c - '0';
+- nd0 = nd;
++ while(hexdig[*s])
++ s++;
+ #ifdef USE_LOCALE
+- s1 = localeconv()->decimal_point;
+- if (c == *s1) {
+- c = '.';
+- if (*++s1) {
+- s2 = s;
+- for(;;) {
+- if (*++s2 != *s1) {
+- c = 0;
++ if (*s == *decimalpoint && !decpt) {
++ for(i = 1; decimalpoint[i]; ++i) {
++ if (s[i] != decimalpoint[i])
++ goto pcheck;
++ }
++ decpt = s += i;
++#else
++ if (*s == '.' && !decpt) {
++ decpt = ++s;
++#endif
++ while(hexdig[*s])
++ s++;
++ }/*}*/
++ if (decpt)
++ e = -(((Long)(s-decpt)) << 2);
++ pcheck:
++ s1 = s;
++ big = esign = 0;
++ switch(*s) {
++ case 'p':
++ case 'P':
++ switch(*++s) {
++ case '-':
++ esign = 1;
++ /* no break */
++ case '+':
++ s++;
++ }
++ if ((n = hexdig[*s]) == 0 || n > 0x19) {
++ s = s1;
++ break;
++ }
++ e1 = n - 0x10;
++ while((n = hexdig[*++s]) !=0 && n <= 0x19) {
++ if (e1 & 0xf8000000)
++ big = 1;
++ e1 = 10*e1 + n - 0x10;
++ }
++ if (esign)
++ e1 = -e1;
++ e += e1;
++ }
++ *sp = (char*)s;
++ if (!havedig)
++ *sp = (char*)s0 - 1;
++ if (zret)
++ goto retz1;
++ if (big) {
++ if (esign) {
++#ifdef IEEE_Arith
++ switch(rounding) {
++ case Round_up:
++ if (sign)
+ break;
+- }
+- if (!*++s1) {
+- s = s2;
++ goto ret_tiny;
++ case Round_down:
++ if (!sign)
+ break;
+- }
+- }
++ goto ret_tiny;
++ }
++#endif
++ goto retz;
++#ifdef IEEE_Arith
++ ret_tiny:
++#ifndef NO_ERRNO
++ errno = ERANGE;
++#endif
++ word0(rvp) = 0;
++ word1(rvp) = 1;
++ return;
++#endif /* IEEE_Arith */
+ }
++ switch(rounding) {
++ case Round_near:
++ goto ovfl1;
++ case Round_up:
++ if (!sign)
++ goto ovfl1;
++ goto ret_big;
++ case Round_down:
++ if (sign)
++ goto ovfl1;
++ goto ret_big;
++ }
++ ret_big:
++ word0(rvp) = Big0;
++ word1(rvp) = Big1;
++ return;
+ }
++ n = s1 - s0 - 1;
++ for(k = 0; n > (1 << (kshift-2)) - 1; n >>= 1)
++ k++;
++ b = Balloc(k);
++ x = b->x;
++ n = 0;
++ L = 0;
++#ifdef USE_LOCALE
++ for(i = 0; decimalpoint[i+1]; ++i);
+ #endif
+- if (c == '.') {
+- c = *++s;
+- if (!nd) {
+- for(; c == '0'; c = *++s)
+- nz++;
+- if (c > '0' && c <= '9') {
+- s0 = s;
+- nf += nz;
+- nz = 0;
+- goto have_dig;
+- }
+- goto dig_done;
++ while(s1 > s0) {
++#ifdef USE_LOCALE
++ if (*--s1 == decimalpoint[i]) {
++ s1 -= i;
++ continue;
+ }
+- for(; c >= '0' && c <= '9'; c = *++s) {
+- have_dig:
+- nz++;
+- if (c -= '0') {
+- nf += nz;
+- for(i = 1; i < nz; i++)
+- if (nd++ < 9)
+- y *= 10;
+- else if (nd <= DBL_DIG + 1)
+- z *= 10;
+- if (nd++ < 9)
+- y = 10*y + c;
+- else if (nd <= DBL_DIG + 1)
+- z = 10*z + c;
+- nz = 0;
++#else
++ if (*--s1 == '.')
++ continue;
++#endif
++ if (n == ULbits) {
++ *x++ = L;
++ L = 0;
++ n = 0;
++ }
++ L |= (hexdig[*s1] & 0x0f) << n;
++ n += 4;
++ }
++ *x++ = L;
++ b->wds = n = x - b->x;
++ n = ULbits*n - hi0bits(L);
++ nbits = Nbits;
++ lostbits = 0;
++ x = b->x;
++ if (n > nbits) {
++ n -= nbits;
++ if (any_on(b,n)) {
++ lostbits = 1;
++ k = n - 1;
++ if (x[k>>kshift] & 1 << (k & kmask)) {
++ lostbits = 2;
++ if (k > 0 && any_on(b,k))
++ lostbits = 3;
++ }
++ }
++ rshift(b, n);
++ e += n;
++ }
++ else if (n < nbits) {
++ n = nbits - n;
++ b = lshift(b, n);
++ e -= n;
++ x = b->x;
++ }
++ if (e > Emax) {
++ ovfl:
++ Bfree(b);
++ ovfl1:
++#ifndef NO_ERRNO
++ errno = ERANGE;
++#endif
++ word0(rvp) = Exp_mask;
++ word1(rvp) = 0;
++ return;
++ }
++ denorm = 0;
++ if (e < emin) {
++ denorm = 1;
++ n = emin - e;
++ if (n >= nbits) {
++#ifdef IEEE_Arith /*{*/
++ switch (rounding) {
++ case Round_near:
++ if (n == nbits && (n < 2 || any_on(b,n-1)))
++ goto ret_tiny;
++ break;
++ case Round_up:
++ if (!sign)
++ goto ret_tiny;
++ break;
++ case Round_down:
++ if (sign)
++ goto ret_tiny;
++ }
++#endif /* } IEEE_Arith */
++ Bfree(b);
++ retz:
++#ifndef NO_ERRNO
++ errno = ERANGE;
++#endif
++ retz1:
++ rvp->d = 0.;
++ return;
++ }
++ k = n - 1;
++ if (lostbits)
++ lostbits = 1;
++ else if (k > 0)
++ lostbits = any_on(b,k);
++ if (x[k>>kshift] & 1 << (k & kmask))
++ lostbits |= 2;
++ nbits -= n;
++ rshift(b,n);
++ e = emin;
++ }
++ if (lostbits) {
++ up = 0;
++ switch(rounding) {
++ case Round_zero:
++ break;
++ case Round_near:
++ if (lostbits & 2
++ && (lostbits & 1) | (x[0] & 1))
++ up = 1;
++ break;
++ case Round_up:
++ up = 1 - sign;
++ break;
++ case Round_down:
++ up = sign;
++ }
++ if (up) {
++ k = b->wds;
++ b = increment(b);
++ x = b->x;
++ if (denorm) {
++#if 0
++ if (nbits == Nbits - 1
++ && x[nbits >> kshift] & 1 << (nbits & kmask))
++ denorm = 0; /* not currently used */
++#endif
++ }
++ else if (b->wds > k
++ || ((n = nbits & kmask) !=0
++ && hi0bits(x[k-1]) < 32-n)) {
++ rshift(b,1);
++ if (++e > Emax)
++ goto ovfl;
+ }
+ }
+ }
+- dig_done:
++#ifdef IEEE_Arith
++ if (denorm)
++ word0(rvp) = b->wds > 1 ? b->x[1] & ~0x100000 : 0;
++ else
++ word0(rvp) = (b->x[1] & ~0x100000) | ((e + 0x3ff + 52) << 20);
++ word1(rvp) = b->x[0];
++#endif
++#ifdef IBM
++ if ((j = e & 3)) {
++ k = b->x[0] & ((1 << j) - 1);
++ rshift(b,j);
++ if (k) {
++ switch(rounding) {
++ case Round_up:
++ if (!sign)
++ increment(b);
++ break;
++ case Round_down:
++ if (sign)
++ increment(b);
++ break;
++ case Round_near:
++ j = 1 << (j-1);
++ if (k & j && ((k & (j-1)) | lostbits))
++ increment(b);
++ }
++ }
++ }
++ e >>= 2;
++ word0(rvp) = b->x[1] | ((e + 65 + 13) << 24);
++ word1(rvp) = b->x[0];
++#endif
++#ifdef VAX
++ /* The next two lines ignore swap of low- and high-order 2 bytes. */
++ /* word0(rvp) = (b->x[1] & ~0x800000) | ((e + 129 + 55) << 23); */
++ /* word1(rvp) = b->x[0]; */
++ word0(rvp) = ((b->x[1] & ~0x800000) >> 16) | ((e + 129 + 55) << 7) | (b->x[1] << 16);
++ word1(rvp) = (b->x[0] >> 16) | (b->x[0] << 16);
++#endif
++ Bfree(b);
++ }
++#endif /*}!NO_HEX_FP*/
++
++ static int
++#ifdef KR_headers
++dshift(b, p2) Bigint *b; int p2;
++#else
++dshift(Bigint *b, int p2)
++#endif
++{
++ int rv = hi0bits(b->x[b->wds-1]) - 4;
++ if (p2 > 0)
++ rv -= p2;
++ return rv & kmask;
++ }
++
++ static int
++quorem
++#ifdef KR_headers
++ (b, S) Bigint *b, *S;
++#else
++ (Bigint *b, Bigint *S)
++#endif
++{
++ int n;
++ ULong *bx, *bxe, q, *sx, *sxe;
++#ifdef ULLong
++ ULLong borrow, carry, y, ys;
++#else
++ ULong borrow, carry, y, ys;
++#ifdef Pack_32
++ ULong si, z, zs;
++#endif
++#endif
++
++ n = S->wds;
++#ifdef DEBUG
++ /*debug*/ if (b->wds > n)
++ /*debug*/ Bug("oversize b in quorem");
++#endif
++ if (b->wds < n)
++ return 0;
++ sx = S->x;
++ sxe = sx + --n;
++ bx = b->x;
++ bxe = bx + n;
++ q = *bxe / (*sxe + 1); /* ensure q <= true quotient */
++#ifdef DEBUG
++ /*debug*/ if (q > 9)
++ /*debug*/ Bug("oversized quotient in quorem");
++#endif
++ if (q) {
++ borrow = 0;
++ carry = 0;
++ do {
++#ifdef ULLong
++ ys = *sx++ * (ULLong)q + carry;
++ carry = ys >> 32;
++ y = *bx - (ys & FFFFFFFF) - borrow;
++ borrow = y >> 32 & (ULong)1;
++ *bx++ = y & FFFFFFFF;
++#else
++#ifdef Pack_32
++ si = *sx++;
++ ys = (si & 0xffff) * q + carry;
++ zs = (si >> 16) * q + (ys >> 16);
++ carry = zs >> 16;
++ y = (*bx & 0xffff) - (ys & 0xffff) - borrow;
++ borrow = (y & 0x10000) >> 16;
++ z = (*bx >> 16) - (zs & 0xffff) - borrow;
++ borrow = (z & 0x10000) >> 16;
++ Storeinc(bx, z, y);
++#else
++ ys = *sx++ * q + carry;
++ carry = ys >> 16;
++ y = *bx - (ys & 0xffff) - borrow;
++ borrow = (y & 0x10000) >> 16;
++ *bx++ = y & 0xffff;
++#endif
++#endif
++ }
++ while(sx <= sxe);
++ if (!*bxe) {
++ bx = b->x;
++ while(--bxe > bx && !*bxe)
++ --n;
++ b->wds = n;
++ }
++ }
++ if (cmp(b, S) >= 0) {
++ q++;
++ borrow = 0;
++ carry = 0;
++ bx = b->x;
++ sx = S->x;
++ do {
++#ifdef ULLong
++ ys = *sx++ + carry;
++ carry = ys >> 32;
++ y = *bx - (ys & FFFFFFFF) - borrow;
++ borrow = y >> 32 & (ULong)1;
++ *bx++ = y & FFFFFFFF;
++#else
++#ifdef Pack_32
++ si = *sx++;
++ ys = (si & 0xffff) + carry;
++ zs = (si >> 16) + (ys >> 16);
++ carry = zs >> 16;
++ y = (*bx & 0xffff) - (ys & 0xffff) - borrow;
++ borrow = (y & 0x10000) >> 16;
++ z = (*bx >> 16) - (zs & 0xffff) - borrow;
++ borrow = (z & 0x10000) >> 16;
++ Storeinc(bx, z, y);
++#else
++ ys = *sx++ + carry;
++ carry = ys >> 16;
++ y = *bx - (ys & 0xffff) - borrow;
++ borrow = (y & 0x10000) >> 16;
++ *bx++ = y & 0xffff;
++#endif
++#endif
++ }
++ while(sx <= sxe);
++ bx = b->x;
++ bxe = bx + n;
++ if (!*bxe) {
++ while(--bxe > bx && !*bxe)
++ --n;
++ b->wds = n;
++ }
++ }
++ return q;
++ }
++
++#ifndef NO_STRTOD_BIGCOMP
++
++ static void
++bigcomp
++#ifdef KR_headers
++ (rv, s0, bc)
++ U *rv; CONST char *s0; BCinfo *bc;
++#else
++ (U *rv, CONST char *s0, BCinfo *bc)
++#endif
++{
++ Bigint *b, *d;
++ int b2, bbits, d2, dd, dig, dsign, i, j, nd, nd0, p2, p5, speccase;
++
++ dsign = bc->dsign;
++ nd = bc->nd;
++ nd0 = bc->nd0;
++ p5 = nd + bc->e0 - 1;
++ speccase = 0;
++#ifndef Sudden_Underflow
++ if (rv->d == 0.) { /* special case: value near underflow-to-zero */
++ /* threshold was rounded to zero */
++ b = i2b(1);
++ p2 = Emin - P + 1;
++ bbits = 1;
++#ifdef Avoid_Underflow
++ word0(rv) = (P+2) << Exp_shift;
++#else
++ word1(rv) = 1;
++#endif
++ i = 0;
++#ifdef Honor_FLT_ROUNDS
++ if (bc->rounding == 1)
++#endif
++ {
++ speccase = 1;
++ --p2;
++ dsign = 0;
++ goto have_i;
++ }
++ }
++ else
++#endif
++ b = d2b(rv, &p2, &bbits);
++#ifdef Avoid_Underflow
++ p2 -= bc->scale;
++#endif
++ /* floor(log2(rv)) == bbits - 1 + p2 */
++ /* Check for denormal case. */
++ i = P - bbits;
++ if (i > (j = P - Emin - 1 + p2)) {
++#ifdef Sudden_Underflow
++ Bfree(b);
++ b = i2b(1);
++ p2 = Emin;
++ i = P - 1;
++#ifdef Avoid_Underflow
++ word0(rv) = (1 + bc->scale) << Exp_shift;
++#else
++ word0(rv) = Exp_msk1;
++#endif
++ word1(rv) = 0;
++#else
++ i = j;
++#endif
++ }
++#ifdef Honor_FLT_ROUNDS
++ if (bc->rounding != 1) {
++ if (i > 0)
++ b = lshift(b, i);
++ if (dsign)
++ b = increment(b);
++ }
++ else
++#endif
++ {
++ b = lshift(b, ++i);
++ b->x[0] |= 1;
++ }
++#ifndef Sudden_Underflow
++ have_i:
++#endif
++ p2 -= p5 + i;
++ d = i2b(1);
++ /* Arrange for convenient computation of quotients:
++ * shift left if necessary so divisor has 4 leading 0 bits.
++ */
++ if (p5 > 0)
++ d = pow5mult(d, p5);
++ else if (p5 < 0)
++ b = pow5mult(b, -p5);
++ if (p2 > 0) {
++ b2 = p2;
++ d2 = 0;
++ }
++ else {
++ b2 = 0;
++ d2 = -p2;
++ }
++ i = dshift(d, d2);
++ if ((b2 += i) > 0)
++ b = lshift(b, b2);
++ if ((d2 += i) > 0)
++ d = lshift(d, d2);
++
++ /* Now b/d = exactly half-way between the two floating-point values */
++ /* on either side of the input string. Compute first digit of b/d. */
++
++ if (!(dig = quorem(b,d))) {
++ b = multadd(b, 10, 0); /* very unlikely */
++ dig = quorem(b,d);
++ }
++
++ /* Compare b/d with s0 */
++
++ for(i = 0; i < nd0; ) {
++ if ((dd = s0[i++] - '0' - dig))
++ goto ret;
++ if (!b->x[0] && b->wds == 1) {
++ if (i < nd)
++ dd = 1;
++ goto ret;
++ }
++ b = multadd(b, 10, 0);
++ dig = quorem(b,d);
++ }
++ for(j = bc->dp1; i++ < nd;) {
++ if ((dd = s0[j++] - '0' - dig))
++ goto ret;
++ if (!b->x[0] && b->wds == 1) {
++ if (i < nd)
++ dd = 1;
++ goto ret;
++ }
++ b = multadd(b, 10, 0);
++ dig = quorem(b,d);
++ }
++ if (b->x[0] || b->wds > 1)
++ dd = -1;
++ ret:
++ Bfree(b);
++ Bfree(d);
++#ifdef Honor_FLT_ROUNDS
++ if (bc->rounding != 1) {
++ if (dd < 0) {
++ if (bc->rounding == 0) {
++ if (!dsign)
++ goto retlow1;
++ }
++ else if (dsign)
++ goto rethi1;
++ }
++ else if (dd > 0) {
++ if (bc->rounding == 0) {
++ if (dsign)
++ goto rethi1;
++ goto ret1;
++ }
++ if (!dsign)
++ goto rethi1;
++ dval(rv) += 2.*ulp(rv);
++ }
++ else {
++ bc->inexact = 0;
++ if (dsign)
++ goto rethi1;
++ }
++ }
++ else
++#endif
++ if (speccase) {
++ if (dd <= 0)
++ rv->d = 0.;
++ }
++ else if (dd < 0) {
++ if (!dsign) /* does not happen for round-near */
++retlow1:
++ dval(rv) -= ulp(rv);
++ }
++ else if (dd > 0) {
++ if (dsign) {
++ rethi1:
++ dval(rv) += ulp(rv);
++ }
++ }
++ else {
++ /* Exact half-way case: apply round-even rule. */
++ if (word1(rv) & 1) {
++ if (dsign)
++ goto rethi1;
++ goto retlow1;
++ }
++ }
++
++#ifdef Honor_FLT_ROUNDS
++ ret1:
++#endif
++ return;
++ }
++#endif /* NO_STRTOD_BIGCOMP */
++
++ double
++poly_strtod
++#ifdef KR_headers
++ (s00, se) CONST char *s00; char **se;
++#else
++ (CONST char *s00, char **se)
++#endif
++{
++ int bb2, bb5, bbe, bd2, bd5, bbbits, bs2, c, e, e1;
++ int esign, i, j, k, nd, nd0, nf, nz, nz0, sign;
++ CONST char *s, *s0, *s1;
++ double aadj, aadj1;
++ Long L;
++ U aadj2, adj, rv, rv0;
++ ULong y, z;
++ BCinfo bc;
++ Bigint *bb, *bb1, *bd, *bd0, *bs, *delta;
++#ifdef SET_INEXACT
++ int oldinexact;
++#endif
++#ifdef Honor_FLT_ROUNDS /*{*/
++#ifdef Trust_FLT_ROUNDS /*{{ only define this if FLT_ROUNDS really works! */
++ bc.rounding = Flt_Rounds;
++#else /*}{*/
++ bc.rounding = 1;
++ switch(fegetround()) {
++ case FE_TOWARDZERO: bc.rounding = 0; break;
++ case FE_UPWARD: bc.rounding = 2; break;
++ case FE_DOWNWARD: bc.rounding = 3;
++ }
++#endif /*}}*/
++#endif /*}*/
++#ifdef USE_LOCALE
++ CONST char *s2;
++#endif
++
++ sign = nz0 = nz = bc.dplen = bc.uflchk = 0;
++ dval(&rv) = 0.;
++ for(s = s00;;s++) switch(*s) {
++ case '-':
++ sign = 1;
++ /* no break */
++ case '+':
++ if (*++s)
++ goto break2;
++ /* no break */
++ case 0:
++ goto ret0;
++ case '\t':
++ case '\n':
++ case '\v':
++ case '\f':
++ case '\r':
++ case ' ':
++ continue;
++ default:
++ goto break2;
++ }
++ break2:
++ if (*s == '0') {
++#ifndef NO_HEX_FP /*{*/
++ switch(s[1]) {
++ case 'x':
++ case 'X':
++#ifdef Honor_FLT_ROUNDS
++ gethex(&s, &rv, bc.rounding, sign);
++#else
++ gethex(&s, &rv, 1, sign);
++#endif
++ goto ret;
++ }
++#endif /*}*/
++ nz0 = 1;
++ while(*++s == '0') ;
++ if (!*s)
++ goto ret;
++ }
++ s0 = s;
++ y = z = 0;
++ for(nd = nf = 0; (c = *s) >= '0' && c <= '9'; nd++, s++)
++ if (nd < 9)
++ y = 10*y + c - '0';
++ else if (nd < 16)
++ z = 10*z + c - '0';
++ nd0 = nd;
++ bc.dp0 = bc.dp1 = s - s0;
++#ifdef USE_LOCALE
++ s1 = localeconv()->decimal_point;
++ if (c == *s1) {
++ c = '.';
++ if (*++s1) {
++ s2 = s;
++ for(;;) {
++ if (*++s2 != *s1) {
++ c = 0;
++ break;
++ }
++ if (!*++s1) {
++ s = s2;
++ break;
++ }
++ }
++ }
++ }
++#endif
++ if (c == '.') {
++ c = *++s;
++ bc.dp1 = s - s0;
++ bc.dplen = bc.dp1 - bc.dp0;
++ if (!nd) {
++ for(; c == '0'; c = *++s)
++ nz++;
++ if (c > '0' && c <= '9') {
++ s0 = s;
++ nf += nz;
++ nz = 0;
++ goto have_dig;
++ }
++ goto dig_done;
++ }
++ for(; c >= '0' && c <= '9'; c = *++s) {
++ have_dig:
++ nz++;
++ if (c -= '0') {
++ nf += nz;
++ for(i = 1; i < nz; i++)
++ if (nd++ < 9)
++ y *= 10;
++ else if (nd <= DBL_DIG + 1)
++ z *= 10;
++ if (nd++ < 9)
++ y = 10*y + c;
++ else if (nd <= DBL_DIG + 1)
++ z = 10*z + c;
++ nz = 0;
++ }
++ }
++ }
++ dig_done:
+ e = 0;
+ if (c == 'e' || c == 'E') {
+ if (!nd && !nz && !nz0) {
+@@ -1732,23 +2653,24 @@
+ if (!nz && !nz0) {
+ #ifdef INFNAN_CHECK
+ /* Check for Nan and Infinity */
+- switch(c) {
++ if (!bc.dplen)
++ switch(c) {
+ case 'i':
+ case 'I':
+ if (match(&s,"nf")) {
+ --s;
+ if (!match(&s,"inity"))
+ ++s;
+- word0(rv) = 0x7ff00000;
+- word1(rv) = 0;
++ word0(&rv) = 0x7ff00000;
++ word1(&rv) = 0;
+ goto ret;
+ }
+ break;
+ case 'n':
+ case 'N':
+ if (match(&s, "an")) {
+- word0(rv) = NAN_WORD0;
+- word1(rv) = NAN_WORD1;
++ word0(&rv) = NAN_WORD0;
++ word1(&rv) = NAN_WORD1;
+ #ifndef No_Hex_NaN
+ if (*s == '(') /*)*/
+ hexnan(&rv, &s);
+@@ -1763,7 +2685,7 @@
+ }
+ goto ret;
+ }
+- e1 = e -= nf;
++ bc.e0 = e1 = e -= nf;
+
+ /* Now we have nd0 digits, starting at s0, followed by a
+ * decimal point, followed by nd-nd0 digits. The number we're
+@@ -1773,13 +2695,13 @@
+ if (!nd0)
+ nd0 = nd;
+ k = nd < DBL_DIG + 1 ? nd : DBL_DIG + 1;
+- dval(rv) = y;
++ dval(&rv) = y;
+ if (k > 9) {
+ #ifdef SET_INEXACT
+ if (k > DBL_DIG)
+ oldinexact = get_inexact();
+ #endif
+- dval(rv) = tens[k - 9] * dval(rv) + z;
++ dval(&rv) = tens[k - 9] * dval(&rv) + z;
+ }
+ bd0 = 0;
+ if (nd <= DBL_DIG
+@@ -1799,11 +2721,11 @@
+ #ifdef Honor_FLT_ROUNDS
+ /* round correctly FLT_ROUNDS = 2 or 3 */
+ if (sign) {
+- rv = -rv;
++ rv.d = -rv.d;
+ sign = 0;
+ }
+ #endif
+- /* rv = */ rounded_product(dval(rv), tens[e]);
++ /* rv = */ rounded_product(dval(&rv), tens[e]);
+ goto ret;
+ #endif
+ }
+@@ -1815,25 +2737,25 @@
+ #ifdef Honor_FLT_ROUNDS
+ /* round correctly FLT_ROUNDS = 2 or 3 */
+ if (sign) {
+- rv = -rv;
++ rv.d = -rv.d;
+ sign = 0;
+ }
+ #endif
+ e -= i;
+- dval(rv) *= tens[i];
++ dval(&rv) *= tens[i];
+ #ifdef VAX
+ /* VAX exponent range is so narrow we must
+ * worry about overflow here...
+ */
+ vax_ovfl_check:
+- word0(rv) -= P*Exp_msk1;
+- /* rv = */ rounded_product(dval(rv), tens[e]);
+- if ((word0(rv) & Exp_mask)
++ word0(&rv) -= P*Exp_msk1;
++ /* rv = */ rounded_product(dval(&rv), tens[e]);
++ if ((word0(&rv) & Exp_mask)
+ > Exp_msk1*(DBL_MAX_EXP+Bias-1-P))
+ goto ovfl;
+- word0(rv) += P*Exp_msk1;
++ word0(&rv) += P*Exp_msk1;
+ #else
+- /* rv = */ rounded_product(dval(rv), tens[e]);
++ /* rv = */ rounded_product(dval(&rv), tens[e]);
+ #endif
+ goto ret;
+ }
+@@ -1843,11 +2765,11 @@
+ #ifdef Honor_FLT_ROUNDS
+ /* round correctly FLT_ROUNDS = 2 or 3 */
+ if (sign) {
+- rv = -rv;
++ rv.d = -rv.d;
+ sign = 0;
+ }
+ #endif
+- /* rv = */ rounded_quotient(dval(rv), tens[-e]);
++ /* rv = */ rounded_quotient(dval(&rv), tens[-e]);
+ goto ret;
+ }
+ #endif
+@@ -1856,20 +2778,20 @@
+
+ #ifdef IEEE_Arith
+ #ifdef SET_INEXACT
+- inexact = 1;
++ bc.inexact = 1;
+ if (k <= DBL_DIG)
+ oldinexact = get_inexact();
+ #endif
+ #ifdef Avoid_Underflow
+- scale = 0;
++ bc.scale = 0;
+ #endif
+ #ifdef Honor_FLT_ROUNDS
+- if ((rounding = Flt_Rounds) >= 2) {
++ if (bc.rounding >= 2) {
+ if (sign)
+- rounding = rounding == 2 ? 0 : 2;
++ bc.rounding = bc.rounding == 2 ? 0 : 2;
+ else
+- if (rounding != 2)
+- rounding = 0;
++ if (bc.rounding != 2)
++ bc.rounding = 0;
+ }
+ #endif
+ #endif /*IEEE_Arith*/
+@@ -1877,8 +2799,8 @@
+ /* Get starting approximation = rv * 10**e1 */
+
+ if (e1 > 0) {
+- if (i = e1 & 15)
+- dval(rv) *= tens[i];
++ if ((i = e1 & 15))
++ dval(&rv) *= tens[i];
+ if (e1 &= ~15) {
+ if (e1 > DBL_MAX_10_EXP) {
+ ovfl:
+@@ -1888,103 +2810,99 @@
+ /* Can't trust HUGE_VAL */
+ #ifdef IEEE_Arith
+ #ifdef Honor_FLT_ROUNDS
+- switch(rounding) {
++ switch(bc.rounding) {
+ case 0: /* toward 0 */
+ case 3: /* toward -infinity */
+- word0(rv) = Big0;
+- word1(rv) = Big1;
++ word0(&rv) = Big0;
++ word1(&rv) = Big1;
+ break;
+ default:
+- word0(rv) = Exp_mask;
+- word1(rv) = 0;
++ word0(&rv) = Exp_mask;
++ word1(&rv) = 0;
+ }
+ #else /*Honor_FLT_ROUNDS*/
+- word0(rv) = Exp_mask;
+- word1(rv) = 0;
++ word0(&rv) = Exp_mask;
++ word1(&rv) = 0;
+ #endif /*Honor_FLT_ROUNDS*/
+ #ifdef SET_INEXACT
+ /* set overflow bit */
+- dval(rv0) = 1e300;
+- dval(rv0) *= dval(rv0);
++ dval(&rv0) = 1e300;
++ dval(&rv0) *= dval(&rv0);
+ #endif
+ #else /*IEEE_Arith*/
+- word0(rv) = Big0;
+- word1(rv) = Big1;
++ word0(&rv) = Big0;
++ word1(&rv) = Big1;
+ #endif /*IEEE_Arith*/
+- if (bd0)
+- goto retfree;
+ goto ret;
+ }
+ e1 >>= 4;
+ for(j = 0; e1 > 1; j++, e1 >>= 1)
+ if (e1 & 1)
+- dval(rv) *= bigtens[j];
++ dval(&rv) *= bigtens[j];
+ /* The last multiplication could overflow. */
+- word0(rv) -= P*Exp_msk1;
+- dval(rv) *= bigtens[j];
+- if ((z = word0(rv) & Exp_mask)
++ word0(&rv) -= P*Exp_msk1;
++ dval(&rv) *= bigtens[j];
++ if ((z = word0(&rv) & Exp_mask)
+ > Exp_msk1*(DBL_MAX_EXP+Bias-P))
+ goto ovfl;
+ if (z > Exp_msk1*(DBL_MAX_EXP+Bias-1-P)) {
+ /* set to largest number */
+ /* (Can't trust DBL_MAX) */
+- word0(rv) = Big0;
+- word1(rv) = Big1;
++ word0(&rv) = Big0;
++ word1(&rv) = Big1;
+ }
+ else
+- word0(rv) += P*Exp_msk1;
++ word0(&rv) += P*Exp_msk1;
+ }
+ }
+ else if (e1 < 0) {
+ e1 = -e1;
+- if (i = e1 & 15)
+- dval(rv) /= tens[i];
++ if ((i = e1 & 15))
++ dval(&rv) /= tens[i];
+ if (e1 >>= 4) {
+ if (e1 >= 1 << n_bigtens)
+ goto undfl;
+ #ifdef Avoid_Underflow
+ if (e1 & Scale_Bit)
+- scale = 2*P;
++ bc.scale = 2*P;
+ for(j = 0; e1 > 0; j++, e1 >>= 1)
+ if (e1 & 1)
+- dval(rv) *= tinytens[j];
+- if (scale && (j = 2*P + 1 - ((word0(rv) & Exp_mask)
++ dval(&rv) *= tinytens[j];
++ if (bc.scale && (j = 2*P + 1 - ((word0(&rv) & Exp_mask)
+ >> Exp_shift)) > 0) {
+- /* scaled rv is denormal; zap j low bits */
++ /* scaled rv is denormal; clear j low bits */
+ if (j >= 32) {
+- word1(rv) = 0;
++ word1(&rv) = 0;
+ if (j >= 53)
+- word0(rv) = (P+2)*Exp_msk1;
++ word0(&rv) = (P+2)*Exp_msk1;
+ else
+- word0(rv) &= 0xffffffff << j-32;
++ word0(&rv) &= 0xffffffff << (j-32);
+ }
+ else
+- word1(rv) &= 0xffffffff << j;
++ word1(&rv) &= 0xffffffff << j;
+ }
+ #else
+ for(j = 0; e1 > 1; j++, e1 >>= 1)
+ if (e1 & 1)
+- dval(rv) *= tinytens[j];
++ dval(&rv) *= tinytens[j];
+ /* The last multiplication could underflow. */
+- dval(rv0) = dval(rv);
+- dval(rv) *= tinytens[j];
+- if (!dval(rv)) {
+- dval(rv) = 2.*dval(rv0);
+- dval(rv) *= tinytens[j];
++ dval(&rv0) = dval(&rv);
++ dval(&rv) *= tinytens[j];
++ if (!dval(&rv)) {
++ dval(&rv) = 2.*dval(&rv0);
++ dval(&rv) *= tinytens[j];
+ #endif
+- if (!dval(rv)) {
++ if (!dval(&rv)) {
+ undfl:
+- dval(rv) = 0.;
++ dval(&rv) = 0.;
+ #ifndef NO_ERRNO
+ errno = ERANGE;
+ #endif
+- if (bd0)
+- goto retfree;
+ goto ret;
+ }
+ #ifndef Avoid_Underflow
+- word0(rv) = Tiny0;
+- word1(rv) = Tiny1;
++ word0(&rv) = Tiny0;
++ word1(&rv) = Tiny1;
+ /* The refinement below will clean
+ * this approximation up.
+ */
+@@ -1997,12 +2915,44 @@
+
+ /* Put digits into bd: true value = bd * 10^e */
+
+- bd0 = s2b(s0, nd0, nd, y);
++ bc.nd = nd;
++#ifndef NO_STRTOD_BIGCOMP
++ bc.nd0 = nd0; /* Only needed if nd > strtod_diglim, but done here */
++ /* to silence an erroneous warning about bc.nd0 */
++ /* possibly not being initialized. */
++ if (nd > strtod_diglim) {
++ /* ASSERT(strtod_diglim >= 18); 18 == one more than the */
++ /* minimum number of decimal digits to distinguish double values */
++ /* in IEEE arithmetic. */
++ i = j = 18;
++ if (i > nd0)
++ j += bc.dplen;
++ for(;;) {
++ if (--j <= bc.dp1 && j >= bc.dp0)
++ j = bc.dp0 - 1;
++ if (s0[j] != '0')
++ break;
++ --i;
++ }
++ e += nd - i;
++ nd = i;
++ if (nd0 > nd)
++ nd0 = nd;
++ if (nd < 9) { /* must recompute y */
++ y = 0;
++ for(i = 0; i < nd0; ++i)
++ y = 10*y + s0[i] - '0';
++ for(j = bc.dp1; i < nd; ++i)
++ y = 10*y + s0[j++] - '0';
++ }
++ }
++#endif
++ bd0 = s2b(s0, nd0, nd, y, bc.dplen);
+
+ for(;;) {
+ bd = Balloc(bd0->k);
+ Bcopy(bd, bd0);
+- bb = d2b(dval(rv), &bbe, &bbbits); /* rv = bb * 2^bbe */
++ bb = d2b(&rv, &bbe, &bbbits); /* rv = bb * 2^bbe */
+ bs = i2b(1);
+
+ if (e >= 0) {
+@@ -2019,11 +2969,11 @@
+ bd2 -= bbe;
+ bs2 = bb2;
+ #ifdef Honor_FLT_ROUNDS
+- if (rounding != 1)
++ if (bc.rounding != 1)
+ bs2++;
+ #endif
+ #ifdef Avoid_Underflow
+- j = bbe - scale;
++ j = bbe - bc.scale;
+ i = j + bbbits - 1; /* logb(rv) */
+ if (i < Emin) /* denormal */
+ j += P - Emin;
+@@ -2048,7 +2998,7 @@
+ bb2 += j;
+ bd2 += j;
+ #ifdef Avoid_Underflow
+- bd2 += scale;
++ bd2 += bc.scale;
+ #endif
+ i = bb2 < bd2 ? bb2 : bd2;
+ if (i > bs2)
+@@ -2073,96 +3023,116 @@
+ if (bs2 > 0)
+ bs = lshift(bs, bs2);
+ delta = diff(bb, bd);
+- dsign = delta->sign;
++ bc.dsign = delta->sign;
+ delta->sign = 0;
+ i = cmp(delta, bs);
++#ifndef NO_STRTOD_BIGCOMP
++ if (bc.nd > nd && i <= 0) {
++ if (bc.dsign)
++ break; /* Must use bigcomp(). */
+ #ifdef Honor_FLT_ROUNDS
+- if (rounding != 1) {
++ if (bc.rounding != 1) {
++ if (i < 0)
++ break;
++ }
++ else
++#endif
++ {
++ bc.nd = nd;
++ i = -1; /* Discarded digits make delta smaller. */
++ }
++ }
++#endif
++#ifdef Honor_FLT_ROUNDS
++ if (bc.rounding != 1) {
+ if (i < 0) {
+ /* Error is less than an ulp */
+ if (!delta->x[0] && delta->wds <= 1) {
+ /* exact */
+ #ifdef SET_INEXACT
+- inexact = 0;
++ bc.inexact = 0;
+ #endif
+ break;
+ }
+- if (rounding) {
+- if (dsign) {
+- adj = 1.;
++ if (bc.rounding) {
++ if (bc.dsign) {
++ adj.d = 1.;
+ goto apply_adj;
+ }
+ }
+- else if (!dsign) {
+- adj = -1.;
+- if (!word1(rv)
+- && !(word0(rv) & Frac_mask)) {
+- y = word0(rv) & Exp_mask;
++ else if (!bc.dsign) {
++ adj.d = -1.;
++ if (!word1(&rv)
++ && !(word0(&rv) & Frac_mask)) {
++ y = word0(&rv) & Exp_mask;
+ #ifdef Avoid_Underflow
+- if (!scale || y > 2*P*Exp_msk1)
++ if (!bc.scale || y > 2*P*Exp_msk1)
+ #else
+ if (y)
+ #endif
+ {
+ delta = lshift(delta,Log2P);
+ if (cmp(delta, bs) <= 0)
+- adj = -0.5;
++ adj.d = -0.5;
+ }
+ }
+ apply_adj:
+ #ifdef Avoid_Underflow
+- if (scale && (y = word0(rv) & Exp_mask)
++ if (bc.scale && (y = word0(&rv) & Exp_mask)
+ <= 2*P*Exp_msk1)
+- word0(adj) += (2*P+1)*Exp_msk1 - y;
++ word0(&adj) += (2*P+1)*Exp_msk1 - y;
+ #else
+ #ifdef Sudden_Underflow
+- if ((word0(rv) & Exp_mask) <=
++ if ((word0(&rv) & Exp_mask) <=
+ P*Exp_msk1) {
+- word0(rv) += P*Exp_msk1;
+- dval(rv) += adj*ulp(dval(rv));
+- word0(rv) -= P*Exp_msk1;
++ word0(&rv) += P*Exp_msk1;
++ dval(&rv) += adj.d*ulp(dval(&rv));
++ word0(&rv) -= P*Exp_msk1;
+ }
+ else
+ #endif /*Sudden_Underflow*/
+ #endif /*Avoid_Underflow*/
+- dval(rv) += adj*ulp(dval(rv));
++ dval(&rv) += adj.d*ulp(&rv);
+ }
+ break;
+ }
+- adj = ratio(delta, bs);
+- if (adj < 1.)
+- adj = 1.;
+- if (adj <= 0x7ffffffe) {
++ adj.d = ratio(delta, bs);
++ if (adj.d < 1.)
++ adj.d = 1.;
++ if (adj.d <= 0x7ffffffe) {
+ /* adj = rounding ? ceil(adj) : floor(adj); */
+- y = adj;
+- if (y != adj) {
+- if (!((rounding>>1) ^ dsign))
++ y = adj.d;
++ if (y != adj.d) {
++ if (!((bc.rounding>>1) ^ bc.dsign))
+ y++;
+- adj = y;
++ adj.d = y;
+ }
+ }
+ #ifdef Avoid_Underflow
+- if (scale && (y = word0(rv) & Exp_mask) <= 2*P*Exp_msk1)
+- word0(adj) += (2*P+1)*Exp_msk1 - y;
++ if (bc.scale && (y = word0(&rv) & Exp_mask) <= 2*P*Exp_msk1)
++ word0(&adj) += (2*P+1)*Exp_msk1 - y;
+ #else
+ #ifdef Sudden_Underflow
+- if ((word0(rv) & Exp_mask) <= P*Exp_msk1) {
+- word0(rv) += P*Exp_msk1;
+- adj *= ulp(dval(rv));
+- if (dsign)
+- dval(rv) += adj;
++ if ((word0(&rv) & Exp_mask) <= P*Exp_msk1) {
++ word0(&rv) += P*Exp_msk1;
++ adj.d *= ulp(dval(&rv));
++ if (bc.dsign)
++ dval(&rv) += adj.d;
+ else
+- dval(rv) -= adj;
+- word0(rv) -= P*Exp_msk1;
++ dval(&rv) -= adj.d;
++ word0(&rv) -= P*Exp_msk1;
+ goto cont;
+ }
+ #endif /*Sudden_Underflow*/
+ #endif /*Avoid_Underflow*/
+- adj *= ulp(dval(rv));
+- if (dsign)
+- dval(rv) += adj;
++ adj.d *= ulp(&rv);
++ if (bc.dsign) {
++ if (word0(&rv) == Big0 && word1(&rv) == Big1)
++ goto ovfl;
++ dval(&rv) += adj.d;
++ }
+ else
+- dval(rv) -= adj;
++ dval(&rv) -= adj.d;
+ goto cont;
+ }
+ #endif /*Honor_FLT_ROUNDS*/
+@@ -2171,25 +3141,25 @@
+ /* Error is less than half an ulp -- check for
+ * special case of mantissa a power of two.
+ */
+- if (dsign || word1(rv) || word0(rv) & Bndry_mask
++ if (bc.dsign || word1(&rv) || word0(&rv) & Bndry_mask
+ #ifdef IEEE_Arith
+ #ifdef Avoid_Underflow
+- || (word0(rv) & Exp_mask) <= (2*P+1)*Exp_msk1
++ || (word0(&rv) & Exp_mask) <= (2*P+1)*Exp_msk1
+ #else
+- || (word0(rv) & Exp_mask) <= Exp_msk1
++ || (word0(&rv) & Exp_mask) <= Exp_msk1
+ #endif
+ #endif
+ ) {
+ #ifdef SET_INEXACT
+ if (!delta->x[0] && delta->wds <= 1)
+- inexact = 0;
++ bc.inexact = 0;
+ #endif
+ break;
+ }
+ if (!delta->x[0] && delta->wds <= 1) {
+ /* exact result */
+ #ifdef SET_INEXACT
+- inexact = 0;
++ bc.inexact = 0;
+ #endif
+ break;
+ }
+@@ -2200,62 +3170,72 @@
+ }
+ if (i == 0) {
+ /* exactly half-way between */
+- if (dsign) {
+- if ((word0(rv) & Bndry_mask1) == Bndry_mask1
+- && word1(rv) == (
++ if (bc.dsign) {
++ if ((word0(&rv) & Bndry_mask1) == Bndry_mask1
++ && word1(&rv) == (
+ #ifdef Avoid_Underflow
+- (scale && (y = word0(rv) & Exp_mask) <= 2*P*Exp_msk1)
++ (bc.scale && (y = word0(&rv) & Exp_mask) <= 2*P*Exp_msk1)
+ ? (0xffffffff & (0xffffffff << (2*P+1-(y>>Exp_shift)))) :
+ #endif
+ 0xffffffff)) {
+ /*boundary case -- increment exponent*/
+- word0(rv) = (word0(rv) & Exp_mask)
++ word0(&rv) = (word0(&rv) & Exp_mask)
+ + Exp_msk1
+ #ifdef IBM
+ | Exp_msk1 >> 4
+ #endif
+ ;
+- word1(rv) = 0;
++ word1(&rv) = 0;
+ #ifdef Avoid_Underflow
+- dsign = 0;
++ bc.dsign = 0;
+ #endif
+ break;
+ }
+ }
+- else if (!(word0(rv) & Bndry_mask) && !word1(rv)) {
++ else if (!(word0(&rv) & Bndry_mask) && !word1(&rv)) {
+ drop_down:
+ /* boundary case -- decrement exponent */
+ #ifdef Sudden_Underflow /*{{*/
+- L = word0(rv) & Exp_mask;
++ L = word0(&rv) & Exp_mask;
+ #ifdef IBM
+ if (L < Exp_msk1)
+ #else
+ #ifdef Avoid_Underflow
+- if (L <= (scale ? (2*P+1)*Exp_msk1 : Exp_msk1))
++ if (L <= (bc.scale ? (2*P+1)*Exp_msk1 : Exp_msk1))
+ #else
+ if (L <= Exp_msk1)
+ #endif /*Avoid_Underflow*/
+ #endif /*IBM*/
++ {
++ if (bc.nd >nd) {
++ bc.uflchk = 1;
++ break;
++ }
+ goto undfl;
++ }
+ L -= Exp_msk1;
+ #else /*Sudden_Underflow}{*/
+ #ifdef Avoid_Underflow
+- if (scale) {
+- L = word0(rv) & Exp_mask;
++ if (bc.scale) {
++ L = word0(&rv) & Exp_mask;
+ if (L <= (2*P+1)*Exp_msk1) {
+ if (L > (P+2)*Exp_msk1)
+ /* round even ==> */
+ /* accept rv */
+ break;
+ /* rv = smallest denormal */
++ if (bc.nd >nd) {
++ bc.uflchk = 1;
++ break;
++ }
+ goto undfl;
+ }
+ }
+ #endif /*Avoid_Underflow*/
+- L = (word0(rv) & Exp_mask) - Exp_msk1;
++ L = (word0(&rv) & Exp_mask) - Exp_msk1;
+ #endif /*Sudden_Underflow}}*/
+- word0(rv) = L | Bndry_mask1;
+- word1(rv) = 0xffffffff;
++ word0(&rv) = L | Bndry_mask1;
++ word1(&rv) = 0xffffffff;
+ #ifdef IBM
+ goto cont;
+ #else
+@@ -2263,32 +3243,42 @@
+ #endif
+ }
+ #ifndef ROUND_BIASED
+- if (!(word1(rv) & LSB))
++ if (!(word1(&rv) & LSB))
+ break;
+ #endif
+- if (dsign)
+- dval(rv) += ulp(dval(rv));
++ if (bc.dsign)
++ dval(&rv) += ulp(&rv);
+ #ifndef ROUND_BIASED
+ else {
+- dval(rv) -= ulp(dval(rv));
++ dval(&rv) -= ulp(&rv);
+ #ifndef Sudden_Underflow
+- if (!dval(rv))
++ if (!dval(&rv)) {
++ if (bc.nd >nd) {
++ bc.uflchk = 1;
++ break;
++ }
+ goto undfl;
++ }
+ #endif
+ }
+ #ifdef Avoid_Underflow
+- dsign = 1 - dsign;
++ bc.dsign = 1 - bc.dsign;
+ #endif
+ #endif
+ break;
+ }
+ if ((aadj = ratio(delta, bs)) <= 2.) {
+- if (dsign)
++ if (bc.dsign)
+ aadj = aadj1 = 1.;
+- else if (word1(rv) || word0(rv) & Bndry_mask) {
++ else if (word1(&rv) || word0(&rv) & Bndry_mask) {
+ #ifndef Sudden_Underflow
+- if (word1(rv) == Tiny1 && !word0(rv))
++ if (word1(&rv) == Tiny1 && !word0(&rv)) {
++ if (bc.nd >nd) {
++ bc.uflchk = 1;
++ break;
++ }
+ goto undfl;
++ }
+ #endif
+ aadj = 1.;
+ aadj1 = -1.;
+@@ -2306,9 +3296,9 @@
+ }
+ else {
+ aadj *= 0.5;
+- aadj1 = dsign ? aadj : -aadj;
++ aadj1 = bc.dsign ? aadj : -aadj;
+ #ifdef Check_FLT_ROUNDS
+- switch(Rounding) {
++ switch(bc.rounding) {
+ case 2: /* towards +infinity */
+ aadj1 -= 0.5;
+ break;
+@@ -2321,65 +3311,72 @@
+ aadj1 += 0.5;
+ #endif /*Check_FLT_ROUNDS*/
+ }
+- y = word0(rv) & Exp_mask;
++ y = word0(&rv) & Exp_mask;
+
+ /* Check for overflow */
+
+ if (y == Exp_msk1*(DBL_MAX_EXP+Bias-1)) {
+- dval(rv0) = dval(rv);
+- word0(rv) -= P*Exp_msk1;
+- adj = aadj1 * ulp(dval(rv));
+- dval(rv) += adj;
+- if ((word0(rv) & Exp_mask) >=
++ dval(&rv0) = dval(&rv);
++ word0(&rv) -= P*Exp_msk1;
++ adj.d = aadj1 * ulp(&rv);
++ dval(&rv) += adj.d;
++ if ((word0(&rv) & Exp_mask) >=
+ Exp_msk1*(DBL_MAX_EXP+Bias-P)) {
+- if (word0(rv0) == Big0 && word1(rv0) == Big1)
++ if (word0(&rv0) == Big0 && word1(&rv0) == Big1)
+ goto ovfl;
+- word0(rv) = Big0;
+- word1(rv) = Big1;
++ word0(&rv) = Big0;
++ word1(&rv) = Big1;
+ goto cont;
+ }
+ else
+- word0(rv) += P*Exp_msk1;
++ word0(&rv) += P*Exp_msk1;
+ }
+ else {
+ #ifdef Avoid_Underflow
+- if (scale && y <= 2*P*Exp_msk1) {
++ if (bc.scale && y <= 2*P*Exp_msk1) {
+ if (aadj <= 0x7fffffff) {
+ if ((z = aadj) <= 0)
+ z = 1;
+ aadj = z;
+- aadj1 = dsign ? aadj : -aadj;
++ aadj1 = bc.dsign ? aadj : -aadj;
+ }
+- word0(aadj1) += (2*P+1)*Exp_msk1 - y;
++ dval(&aadj2) = aadj1;
++ word0(&aadj2) += (2*P+1)*Exp_msk1 - y;
++ aadj1 = dval(&aadj2);
+ }
+- adj = aadj1 * ulp(dval(rv));
+- dval(rv) += adj;
++ adj.d = aadj1 * ulp(&rv);
++ dval(&rv) += adj.d;
+ #else
+ #ifdef Sudden_Underflow
+- if ((word0(rv) & Exp_mask) <= P*Exp_msk1) {
+- dval(rv0) = dval(rv);
+- word0(rv) += P*Exp_msk1;
+- adj = aadj1 * ulp(dval(rv));
+- dval(rv) += adj;
++ if ((word0(&rv) & Exp_mask) <= P*Exp_msk1) {
++ dval(&rv0) = dval(&rv);
++ word0(&rv) += P*Exp_msk1;
++ adj.d = aadj1 * ulp(&rv);
++ dval(&rv) += adj.d;
+ #ifdef IBM
+- if ((word0(rv) & Exp_mask) < P*Exp_msk1)
++ if ((word0(&rv) & Exp_mask) < P*Exp_msk1)
+ #else
+- if ((word0(rv) & Exp_mask) <= P*Exp_msk1)
++ if ((word0(&rv) & Exp_mask) <= P*Exp_msk1)
+ #endif
+ {
+- if (word0(rv0) == Tiny0
+- && word1(rv0) == Tiny1)
++ if (word0(&rv0) == Tiny0
++ && word1(&rv0) == Tiny1) {
++ if (bc.nd >nd) {
++ bc.uflchk = 1;
++ break;
++ }
+ goto undfl;
+- word0(rv) = Tiny0;
+- word1(rv) = Tiny1;
++ }
++ word0(&rv) = Tiny0;
++ word1(&rv) = Tiny1;
+ goto cont;
+ }
+ else
+- word0(rv) -= P*Exp_msk1;
++ word0(&rv) -= P*Exp_msk1;
+ }
+ else {
+- adj = aadj1 * ulp(dval(rv));
+- dval(rv) += adj;
++ adj.d = aadj1 * ulp(&rv);
++ dval(&rv) += adj.d;
+ }
+ #else /*Sudden_Underflow*/
+ /* Compute adj so that the IEEE rounding rules will
+@@ -2391,31 +3388,33 @@
+ */
+ if (y <= (P-1)*Exp_msk1 && aadj > 1.) {
+ aadj1 = (double)(int)(aadj + 0.5);
+- if (!dsign)
++ if (!bc.dsign)
+ aadj1 = -aadj1;
+ }
+- adj = aadj1 * ulp(dval(rv));
+- dval(rv) += adj;
++ adj.d = aadj1 * ulp(&rv);
++ dval(&rv) += adj.d;
+ #endif /*Sudden_Underflow*/
+ #endif /*Avoid_Underflow*/
+ }
+- z = word0(rv) & Exp_mask;
++ z = word0(&rv) & Exp_mask;
+ #ifndef SET_INEXACT
++ if (bc.nd == nd) {
+ #ifdef Avoid_Underflow
+- if (!scale)
++ if (!bc.scale)
+ #endif
+ if (y == z) {
+ /* Can we stop now? */
+ L = (Long)aadj;
+ aadj -= L;
+ /* The tolerances below are conservative. */
+- if (dsign || word1(rv) || word0(rv) & Bndry_mask) {
++ if (bc.dsign || word1(&rv) || word0(&rv) & Bndry_mask) {
+ if (aadj < .4999999 || aadj > .5000001)
+ break;
+ }
+ else if (aadj < .4999999/FLT_RADIX)
+ break;
+ }
++ }
+ #endif
+ cont:
+ Bfree(bb);
+@@ -2423,168 +3422,53 @@
+ Bfree(bs);
+ Bfree(delta);
+ }
++ Bfree(bb);
++ Bfree(bd);
++ Bfree(bs);
++ Bfree(bd0);
++ Bfree(delta);
++#ifndef NO_STRTOD_BIGCOMP
++ if (bc.nd > nd)
++ bigcomp(&rv, s0, &bc);
++#endif
+ #ifdef SET_INEXACT
+- if (inexact) {
++ if (bc.inexact) {
+ if (!oldinexact) {
+- word0(rv0) = Exp_1 + (70 << Exp_shift);
+- word1(rv0) = 0;
+- dval(rv0) += 1.;
++ word0(&rv0) = Exp_1 + (70 << Exp_shift);
++ word1(&rv0) = 0;
++ dval(&rv0) += 1.;
+ }
+ }
+ else if (!oldinexact)
+ clear_inexact();
+ #endif
+ #ifdef Avoid_Underflow
+- if (scale) {
+- word0(rv0) = Exp_1 - 2*P*Exp_msk1;
+- word1(rv0) = 0;
+- dval(rv) *= dval(rv0);
++ if (bc.scale) {
++ word0(&rv0) = Exp_1 - 2*P*Exp_msk1;
++ word1(&rv0) = 0;
++ dval(&rv) *= dval(&rv0);
+ #ifndef NO_ERRNO
+ /* try to avoid the bug of testing an 8087 register value */
+- if (word0(rv) == 0 && word1(rv) == 0)
++#ifdef IEEE_Arith
++ if (!(word0(&rv) & Exp_mask))
++#else
++ if (word0(&rv) == 0 && word1(&rv) == 0)
++#endif
+ errno = ERANGE;
+ #endif
+ }
+ #endif /* Avoid_Underflow */
+ #ifdef SET_INEXACT
+- if (inexact && !(word0(rv) & Exp_mask)) {
++ if (bc.inexact && !(word0(&rv) & Exp_mask)) {
+ /* set underflow bit */
+- dval(rv0) = 1e-300;
+- dval(rv0) *= dval(rv0);
++ dval(&rv0) = 1e-300;
++ dval(&rv0) *= dval(&rv0);
+ }
+ #endif
+- retfree:
+- Bfree(bb);
+- Bfree(bd);
+- Bfree(bs);
+- Bfree(bd0);
+- Bfree(delta);
+ ret:
+ if (se)
+ *se = (char *)s;
+- return sign ? -dval(rv) : dval(rv);
+- }
+-
+-#endif // HAVE_STRTOD
+-
+-#ifndef HAVE_DTOA
+-
+- static int
+-quorem
+-#ifdef KR_headers
+- (b, S) Bigint *b, *S;
+-#else
+- (Bigint *b, Bigint *S)
+-#endif
+-{
+- int n;
+- ULong *bx, *bxe, q, *sx, *sxe;
+-#ifdef ULLong
+- ULLong borrow, carry, y, ys;
+-#else
+- ULong borrow, carry, y, ys;
+-#ifdef Pack_32
+- ULong si, z, zs;
+-#endif
+-#endif
+-
+- n = S->wds;
+-#ifdef DEBUG
+- /*debug*/ if (b->wds > n)
+- /*debug*/ Bug("oversize b in quorem");
+-#endif
+- if (b->wds < n)
+- return 0;
+- sx = S->x;
+- sxe = sx + --n;
+- bx = b->x;
+- bxe = bx + n;
+- q = *bxe / (*sxe + 1); /* ensure q <= true quotient */
+-#ifdef DEBUG
+- /*debug*/ if (q > 9)
+- /*debug*/ Bug("oversized quotient in quorem");
+-#endif
+- if (q) {
+- borrow = 0;
+- carry = 0;
+- do {
+-#ifdef ULLong
+- ys = *sx++ * (ULLong)q + carry;
+- carry = ys >> 32;
+- y = *bx - (ys & FFFFFFFF) - borrow;
+- borrow = y >> 32 & (ULong)1;
+- *bx++ = y & FFFFFFFF;
+-#else
+-#ifdef Pack_32
+- si = *sx++;
+- ys = (si & 0xffff) * q + carry;
+- zs = (si >> 16) * q + (ys >> 16);
+- carry = zs >> 16;
+- y = (*bx & 0xffff) - (ys & 0xffff) - borrow;
+- borrow = (y & 0x10000) >> 16;
+- z = (*bx >> 16) - (zs & 0xffff) - borrow;
+- borrow = (z & 0x10000) >> 16;
+- Storeinc(bx, z, y);
+-#else
+- ys = *sx++ * q + carry;
+- carry = ys >> 16;
+- y = *bx - (ys & 0xffff) - borrow;
+- borrow = (y & 0x10000) >> 16;
+- *bx++ = y & 0xffff;
+-#endif
+-#endif
+- }
+- while(sx <= sxe);
+- if (!*bxe) {
+- bx = b->x;
+- while(--bxe > bx && !*bxe)
+- --n;
+- b->wds = n;
+- }
+- }
+- if (cmp(b, S) >= 0) {
+- q++;
+- borrow = 0;
+- carry = 0;
+- bx = b->x;
+- sx = S->x;
+- do {
+-#ifdef ULLong
+- ys = *sx++ + carry;
+- carry = ys >> 32;
+- y = *bx - (ys & FFFFFFFF) - borrow;
+- borrow = y >> 32 & (ULong)1;
+- *bx++ = y & FFFFFFFF;
+-#else
+-#ifdef Pack_32
+- si = *sx++;
+- ys = (si & 0xffff) + carry;
+- zs = (si >> 16) + (ys >> 16);
+- carry = zs >> 16;
+- y = (*bx & 0xffff) - (ys & 0xffff) - borrow;
+- borrow = (y & 0x10000) >> 16;
+- z = (*bx >> 16) - (zs & 0xffff) - borrow;
+- borrow = (z & 0x10000) >> 16;
+- Storeinc(bx, z, y);
+-#else
+- ys = *sx++ + carry;
+- carry = ys >> 16;
+- y = *bx - (ys & 0xffff) - borrow;
+- borrow = (y & 0x10000) >> 16;
+- *bx++ = y & 0xffff;
+-#endif
+-#endif
+- }
+- while(sx <= sxe);
+- bx = b->x;
+- bxe = bx + n;
+- if (!*bxe) {
+- while(--bxe > bx && !*bxe)
+- --n;
+- b->wds = n;
+- }
+- }
+- return q;
++ return sign ? -dval(&rv) : dval(&rv);
+ }
+
+ #ifndef MULTIPLE_THREADS
+@@ -2602,7 +3486,7 @@
+
+ j = sizeof(ULong);
+ for(k = 0;
+- (int)(sizeof(Bigint) - sizeof(ULong) - sizeof(int)) + j <= i;
++ sizeof(Bigint) - sizeof(ULong) - sizeof(int) + j <= i;
+ j <<= 1)
+ k++;
+ r = (int*)Balloc(k);
+@@ -2618,7 +3502,7 @@
+ #ifdef KR_headers
+ nrv_alloc(s, rve, n) char *s, **rve; int n;
+ #else
+-nrv_alloc(const char *s, char **rve, int n)
++nrv_alloc(CONST char *s, char **rve, int n)
+ #endif
+ {
+ char *rv, *t;
+@@ -2638,9 +3522,9 @@
+
+ void
+ #ifdef KR_headers
+-freedtoa(s) char *s;
++poly_freedtoa(s) char *s;
+ #else
+-freedtoa(char *s)
++poly_freedtoa(char *s)
+ #endif
+ {
+ Bigint *b = (Bigint *)((int *)s - 1);
+@@ -2687,12 +3571,12 @@
+ */
+
+ char *
+-dtoa
++poly_dtoa
+ #ifdef KR_headers
+- (d, mode, ndigits, decpt, sign, rve)
+- double d; int mode, ndigits, *decpt, *sign; char **rve;
++ (dd, mode, ndigits, decpt, sign, rve)
++ double dd; int mode, ndigits, *decpt, *sign; char **rve;
+ #else
+- (double d, int mode, int ndigits, int *decpt, int *sign, char **rve)
++ (double dd, int mode, int ndigits, int *decpt, int *sign, char **rve)
+ #endif
+ {
+ /* Arguments ndigits, decpt, sign are similar to those
+@@ -2729,7 +3613,7 @@
+ to hold the suppressed trailing zeros.
+ */
+
+- int bbits, b2, b5, be, dig, i, ieps, ilim=0, ilim0, ilim1=0,
++ int bbits, b2, b5, be, dig, i, ieps, ilim, ilim0, ilim1,
+ j, j1, k, k0, k_check, leftright, m2, m5, s2, s5,
+ spec_case, try_quick;
+ Long L;
+@@ -2738,14 +3622,25 @@
+ ULong x;
+ #endif
+ Bigint *b, *b1, *delta, *mlo, *mhi, *S;
+- double d2, ds, eps;
++ U d2, eps, u;
++ double ds;
+ char *s, *s0;
+-#ifdef Honor_FLT_ROUNDS
+- int rounding;
+-#endif
+ #ifdef SET_INEXACT
+ int inexact, oldinexact;
+ #endif
++#ifdef Honor_FLT_ROUNDS /*{*/
++ int Rounding;
++#ifdef Trust_FLT_ROUNDS /*{{ only define this if FLT_ROUNDS really works! */
++ Rounding = Flt_Rounds;
++#else /*}{*/
++ Rounding = 1;
++ switch(fegetround()) {
++ case FE_TOWARDZERO: Rounding = 0; break;
++ case FE_UPWARD: Rounding = 2; break;
++ case FE_DOWNWARD: Rounding = 3;
++ }
++#endif /*}}*/
++#endif /*}*/
+
+ #ifndef MULTIPLE_THREADS
+ if (dtoa_result) {
+@@ -2754,34 +3649,35 @@
+ }
+ #endif
+
+- if (word0(d) & Sign_bit) {
++ u.d = dd;
++ if (word0(&u) & Sign_bit) {
+ /* set sign for everything, including 0's and NaNs */
+ *sign = 1;
+- word0(d) &= ~Sign_bit; /* clear sign bit */
++ word0(&u) &= ~Sign_bit; /* clear sign bit */
+ }
+ else
+ *sign = 0;
+
+ #if defined(IEEE_Arith) + defined(VAX)
+ #ifdef IEEE_Arith
+- if ((word0(d) & Exp_mask) == Exp_mask)
++ if ((word0(&u) & Exp_mask) == Exp_mask)
+ #else
+- if (word0(d) == 0x8000)
++ if (word0(&u) == 0x8000)
+ #endif
+ {
+ /* Infinity or NaN */
+ *decpt = 9999;
+ #ifdef IEEE_Arith
+- if (!word1(d) && !(word0(d) & 0xfffff))
++ if (!word1(&u) && !(word0(&u) & 0xfffff))
+ return nrv_alloc("Infinity", rve, 8);
+ #endif
+ return nrv_alloc("NaN", rve, 3);
+ }
+ #endif
+ #ifdef IBM
+- dval(d) += 0; /* normalize */
++ dval(&u) += 0; /* normalize */
+ #endif
+- if (!dval(d)) {
++ if (!dval(&u)) {
+ *decpt = 1;
+ return nrv_alloc("0", rve, 1);
+ }
+@@ -2791,27 +3687,27 @@
+ inexact = 1;
+ #endif
+ #ifdef Honor_FLT_ROUNDS
+- if ((rounding = Flt_Rounds) >= 2) {
++ if (Rounding >= 2) {
+ if (*sign)
+- rounding = rounding == 2 ? 0 : 2;
++ Rounding = Rounding == 2 ? 0 : 2;
+ else
+- if (rounding != 2)
+- rounding = 0;
++ if (Rounding != 2)
++ Rounding = 0;
+ }
+ #endif
+
+- b = d2b(dval(d), &be, &bbits);
++ b = d2b(&u, &be, &bbits);
+ #ifdef Sudden_Underflow
+- i = (int)(word0(d) >> Exp_shift1 & (Exp_mask>>Exp_shift1));
++ i = (int)(word0(&u) >> Exp_shift1 & (Exp_mask>>Exp_shift1));
+ #else
+- if ((i = (int)(word0(d) >> Exp_shift1 & (Exp_mask>>Exp_shift1)))) {
++ if ((i = (int)(word0(&u) >> Exp_shift1 & (Exp_mask>>Exp_shift1)))) {
+ #endif
+- dval(d2) = dval(d);
+- word0(d2) &= Frac_mask1;
+- word0(d2) |= Exp_11;
++ dval(&d2) = dval(&u);
++ word0(&d2) &= Frac_mask1;
++ word0(&d2) |= Exp_11;
+ #ifdef IBM
+- if (j = 11 - hi0bits(word0(d2) & Frac_mask))
+- dval(d2) /= 1 << j;
++ if (j = 11 - hi0bits(word0(&d2) & Frac_mask))
++ dval(&d2) /= 1 << j;
+ #endif
+
+ /* log(x) ~=~ log(1.5) + (x-1.5)/1.5
+@@ -2848,21 +3744,21 @@
+ /* d is denormalized */
+
+ i = bbits + be + (Bias + (P-1) - 1);
+- x = i > 32 ? word0(d) << (64 - i) | word1(d) >> (i - 32)
+- : word1(d) << (32 - i);
+- dval(d2) = x;
+- word0(d2) -= 31*Exp_msk1; /* adjust exponent */
++ x = i > 32 ? word0(&u) << (64 - i) | word1(&u) >> (i - 32)
++ : word1(&u) << (32 - i);
++ dval(&d2) = x;
++ word0(&d2) -= 31*Exp_msk1; /* adjust exponent */
+ i -= (Bias + (P-1) - 1) + 1;
+ denorm = 1;
+ }
+ #endif
+- ds = (dval(d2)-1.5)*0.289529654602168 + 0.1760912590558 + i*0.301029995663981;
++ ds = (dval(&d2)-1.5)*0.289529654602168 + 0.1760912590558 + i*0.301029995663981;
+ k = (int)ds;
+ if (ds < 0. && ds != k)
+ k--; /* want k = floor(ds) */
+ k_check = 1;
+ if (k >= 0 && k <= Ten_pmax) {
+- if (dval(d) < tens[k])
++ if (dval(&u) < tens[k])
+ k--;
+ k_check = 0;
+ }
+@@ -2901,10 +3797,11 @@
+ try_quick = 0;
+ }
+ leftright = 1;
++ ilim = ilim1 = -1; /* Values for cases 0 and 1; done here to */
++ /* silence erroneous "gcc -Wall" warning. */
+ switch(mode) {
+ case 0:
+ case 1:
+- ilim = ilim1 = -1;
+ i = 18;
+ ndigits = 0;
+ break;
+@@ -2929,7 +3826,7 @@
+ s = s0 = rv_alloc(i);
+
+ #ifdef Honor_FLT_ROUNDS
+- if (mode > 1 && rounding != 1)
++ if (mode > 1 && Rounding != 1)
+ leftright = 0;
+ #endif
+
+@@ -2938,7 +3835,7 @@
+ /* Try to get by with floating-point arithmetic. */
+
+ i = 0;
+- dval(d2) = dval(d);
++ dval(&d2) = dval(&u);
+ k0 = k;
+ ilim0 = ilim;
+ ieps = 2; /* conservative */
+@@ -2948,7 +3845,7 @@
+ if (j & Bletch) {
+ /* prevent overflows */
+ j &= Bletch - 1;
+- dval(d) /= bigtens[n_bigtens-1];
++ dval(&u) /= bigtens[n_bigtens-1];
+ ieps++;
+ }
+ for(; j; j >>= 1, i++)
+@@ -2956,32 +3853,32 @@
+ ieps++;
+ ds *= bigtens[i];
+ }
+- dval(d) /= ds;
++ dval(&u) /= ds;
+ }
+ else if ((j1 = -k)) {
+- dval(d) *= tens[j1 & 0xf];
++ dval(&u) *= tens[j1 & 0xf];
+ for(j = j1 >> 4; j; j >>= 1, i++)
+ if (j & 1) {
+ ieps++;
+- dval(d) *= bigtens[i];
++ dval(&u) *= bigtens[i];
+ }
+ }
+- if (k_check && dval(d) < 1. && ilim > 0) {
++ if (k_check && dval(&u) < 1. && ilim > 0) {
+ if (ilim1 <= 0)
+ goto fast_failed;
+ ilim = ilim1;
+ k--;
+- dval(d) *= 10.;
++ dval(&u) *= 10.;
+ ieps++;
+ }
+- dval(eps) = ieps*dval(d) + 7.;
+- word0(eps) -= (P-1)*Exp_msk1;
++ dval(&eps) = ieps*dval(&u) + 7.;
++ word0(&eps) -= (P-1)*Exp_msk1;
+ if (ilim == 0) {
+ S = mhi = 0;
+- dval(d) -= 5.;
+- if (dval(d) > dval(eps))
++ dval(&u) -= 5.;
++ if (dval(&u) > dval(&eps))
+ goto one_digit;
+- if (dval(d) < -dval(eps))
++ if (dval(&u) < -dval(&eps))
+ goto no_digits;
+ goto fast_failed;
+ }
+@@ -2990,34 +3887,34 @@
+ /* Use Steele & White method of only
+ * generating digits needed.
+ */
+- dval(eps) = 0.5/tens[ilim-1] - dval(eps);
++ dval(&eps) = 0.5/tens[ilim-1] - dval(&eps);
+ for(i = 0;;) {
+- L = dval(d);
+- dval(d) -= L;
++ L = dval(&u);
++ dval(&u) -= L;
+ *s++ = '0' + (int)L;
+- if (dval(d) < dval(eps))
++ if (dval(&u) < dval(&eps))
+ goto ret1;
+- if (1. - dval(d) < dval(eps))
++ if (1. - dval(&u) < dval(&eps))
+ goto bump_up;
+ if (++i >= ilim)
+ break;
+- dval(eps) *= 10.;
+- dval(d) *= 10.;
++ dval(&eps) *= 10.;
++ dval(&u) *= 10.;
+ }
+ }
+ else {
+ #endif
+ /* Generate ilim digits, then fix them up. */
+- dval(eps) *= tens[ilim-1];
+- for(i = 1;; i++, dval(d) *= 10.) {
+- L = (Long)(dval(d));
+- if (!(dval(d) -= L))
++ dval(&eps) *= tens[ilim-1];
++ for(i = 1;; i++, dval(&u) *= 10.) {
++ L = (Long)(dval(&u));
++ if (!(dval(&u) -= L))
+ ilim = i;
+ *s++ = '0' + (int)L;
+ if (i == ilim) {
+- if (dval(d) > 0.5 + dval(eps))
++ if (dval(&u) > 0.5 + dval(&eps))
+ goto bump_up;
+- else if (dval(d) < 0.5 - dval(eps)) {
++ else if (dval(&u) < 0.5 - dval(&eps)) {
+ while(*--s == '0');
+ s++;
+ goto ret1;
+@@ -3030,7 +3927,7 @@
+ #endif
+ fast_failed:
+ s = s0;
+- dval(d) = dval(d2);
++ dval(&u) = dval(&d2);
+ k = k0;
+ ilim = ilim0;
+ }
+@@ -3042,22 +3939,22 @@
+ ds = tens[k];
+ if (ndigits < 0 && ilim <= 0) {
+ S = mhi = 0;
+- if (ilim < 0 || dval(d) <= 5*ds)
++ if (ilim < 0 || dval(&u) <= 5*ds)
+ goto no_digits;
+ goto one_digit;
+ }
+- for(i = 1;; i++, dval(d) *= 10.) {
+- L = (Long)(dval(d) / ds);
+- dval(d) -= L*ds;
++ for(i = 1;; i++, dval(&u) *= 10.) {
++ L = (Long)(dval(&u) / ds);
++ dval(&u) -= L*ds;
+ #ifdef Check_FLT_ROUNDS
+ /* If FLT_ROUNDS == 2, L will usually be high by 1 */
+- if (dval(d) < 0) {
++ if (dval(&u) < 0) {
+ L--;
+- dval(d) += ds;
++ dval(&u) += ds;
+ }
+ #endif
+ *s++ = '0' + (int)L;
+- if (!dval(d)) {
++ if (!dval(&u)) {
+ #ifdef SET_INEXACT
+ inexact = 0;
+ #endif
+@@ -3066,13 +3963,13 @@
+ if (i == ilim) {
+ #ifdef Honor_FLT_ROUNDS
+ if (mode > 1)
+- switch(rounding) {
++ switch(Rounding) {
+ case 0: goto ret1;
+ case 2: goto bump_up;
+ }
+ #endif
+- dval(d) += dval(d);
+- if (dval(d) > ds || (dval(d) == ds && L & 1)) {
++ dval(&u) += dval(&u);
++ if (dval(&u) > ds || (dval(&u) == ds && L & 1)) {
+ bump_up:
+ while(*--s == '9')
+ if (s == s0) {
+@@ -3134,12 +4031,12 @@
+ spec_case = 0;
+ if ((mode < 2 || leftright)
+ #ifdef Honor_FLT_ROUNDS
+- && rounding == 1
++ && Rounding == 1
+ #endif
+ ) {
+- if (!word1(d) && !(word0(d) & Bndry_mask)
++ if (!word1(&u) && !(word0(&u) & Bndry_mask)
+ #ifndef Sudden_Underflow
+- && word0(d) & (Exp_mask & ~Exp_msk1)
++ && word0(&u) & (Exp_mask & ~Exp_msk1)
+ #endif
+ ) {
+ /* The special case */
+@@ -3159,22 +4056,16 @@
+ #ifdef Pack_32
+ if ((i = ((s5 ? 32 - hi0bits(S->x[S->wds-1]) : 1) + s2) & 0x1f))
+ i = 32 - i;
++#define iInc 28
+ #else
+- if ((i = ((s5 ? 32 - hi0bits(S->x[S->wds-1]) : 1) + s2) & 0xf))
++ if (i = ((s5 ? 32 - hi0bits(S->x[S->wds-1]) : 1) + s2) & 0xf)
+ i = 16 - i;
++#define iInc 12
+ #endif
+- if (i > 4) {
+- i -= 4;
+- b2 += i;
+- m2 += i;
+- s2 += i;
+- }
+- else if (i < 4) {
+- i += 28;
+- b2 += i;
+- m2 += i;
+- s2 += i;
+- }
++ i = dshift(S, s2);
++ b2 += i;
++ m2 += i;
++ s2 += i;
+ if (b2 > 0)
+ b = lshift(b, b2);
+ if (s2 > 0)
+@@ -3225,9 +4116,9 @@
+ j1 = delta->sign ? 1 : cmp(b, delta);
+ Bfree(delta);
+ #ifndef ROUND_BIASED
+- if (j1 == 0 && mode != 1 && !(word1(d) & 1)
++ if (j1 == 0 && mode != 1 && !(word1(&u) & 1)
+ #ifdef Honor_FLT_ROUNDS
+- && rounding >= 1
++ && Rounding >= 1
+ #endif
+ ) {
+ if (dig == '9')
+@@ -3244,7 +4135,7 @@
+ #endif
+ if (j < 0 || (j == 0 && mode != 1
+ #ifndef ROUND_BIASED
+- && !(word1(d) & 1)
++ && !(word1(&u) & 1)
+ #endif
+ )) {
+ if (!b->x[0] && b->wds <= 1) {
+@@ -3255,7 +4146,7 @@
+ }
+ #ifdef Honor_FLT_ROUNDS
+ if (mode > 1)
+- switch(rounding) {
++ switch(Rounding) {
+ case 0: goto accept_dig;
+ case 2: goto keep_dig;
+ }
+@@ -3273,7 +4164,7 @@
+ }
+ if (j1 > 0) {
+ #ifdef Honor_FLT_ROUNDS
+- if (!rounding)
++ if (!Rounding)
+ goto accept_dig;
+ #endif
+ if (dig == '9') { /* possible if i == 1 */
+@@ -3316,7 +4207,7 @@
+ /* Round off last digit */
+
+ #ifdef Honor_FLT_ROUNDS
+- switch(rounding) {
++ switch(Rounding) {
+ case 0: goto trimzeros;
+ case 2: goto roundoff;
+ }
+@@ -3351,9 +4242,9 @@
+ #ifdef SET_INEXACT
+ if (inexact) {
+ if (!oldinexact) {
+- word0(d) = Exp_1 + (70 << Exp_shift);
+- word1(d) = 0;
+- dval(d) += 1.;
++ word0(&u) = Exp_1 + (70 << Exp_shift);
++ word1(&u) = 0;
++ dval(&u) += 1.;
+ }
+ }
+ else if (!oldinexact)
+@@ -3366,8 +4257,6 @@
+ *rve = s;
+ return s0;
+ }
+-#endif // HAVE_DTOA
+-
+
+ #ifdef __cplusplus
+ }
+diff -u -r libpolyml/realconv.h libpolyml/realconv.h
+--- libpolyml/realconv.h 2007-03-29 08:52:30.000000000 +0200
++++ libpolyml/realconv.h 2009-09-15 08:56:44.000000000 +0200
+@@ -23,24 +23,23 @@
+ #ifndef REALCONV_H
+ #define REALCONV_H
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef __cplusplus
+ extern "C" {
+ #endif
+
+-#ifndef HAVE_STRTOD
+-extern double strtod(const char *s00, char **se);
+-#endif
++extern double poly_strtod(const char *s00, char **se);
+
+-#ifndef HAVE_DTOA
+-extern char *dtoa(double d, int mode, int ndigits,
++extern char *poly_dtoa(double d, int mode, int ndigits,
+ int *decpt, int *sign, char **rve);
+-#endif
++extern void poly_freedtoa(char *s);
+
+ #ifdef __cplusplus
+ };
+diff -u -r libpolyml/reals.cpp libpolyml/reals.cpp
+--- libpolyml/reals.cpp 2008-06-17 12:07:56.000000000 +0200
++++ libpolyml/reals.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -21,10 +21,12 @@
+
+ */
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_IEEEFP_H
+@@ -361,7 +363,7 @@
+ }
+
+ /* Now convert it */
+- result = strtod(string_buffer, &finish);
++ result = poly_strtod(string_buffer, &finish);
+ bool isError = *finish != '\0'; // Test before deallocating
+ free(string_buffer);
+ // We no longer detect overflow and underflow and instead return
+@@ -577,11 +579,12 @@
+ int mode = get_C_long(mdTaskData, DEREFWORDHANDLE(hMode));
+ int digits = get_C_long(mdTaskData, DEREFWORDHANDLE(hDigits));
+ /* Compute the shortest string which gives the required value. */
+- /* N.B. dtoa uses static buffers and is NOT thread-safe. */
+- char *chars = dtoa(dx, mode, digits, &decpt, &sign, NULL);
++ /* */
++ char *chars = poly_dtoa(dx, mode, digits, &decpt, &sign, NULL);
+ /* We have to be careful in case an allocation causes a
+ garbage collection. */
+ PolyWord pStr = C_string_to_Poly(mdTaskData, chars);
++ poly_freedtoa(chars);
+ Handle ppStr = mdTaskData->saveVec.push(pStr);
+ /* Allocate a triple for the results. */
+ PolyObject *result = alloc(mdTaskData, 3);
+diff -u -r libpolyml/rts_module.cpp libpolyml/rts_module.cpp
+--- libpolyml/rts_module.cpp 2007-09-03 18:16:57.000000000 +0200
++++ libpolyml/rts_module.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -19,10 +19,12 @@
+
+ */
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #include "rts_module.h"
+diff -u -r libpolyml/run_time.cpp libpolyml/run_time.cpp
+--- libpolyml/run_time.cpp 2008-03-25 12:23:08.000000000 +0100
++++ libpolyml/run_time.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -24,10 +24,12 @@
+ /* Contains most of the routines in the interface_map vector. Others are
+ in their own modules e.g. arb.c, reals.c and persistence.c */
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ /************************************************************************
+@@ -246,7 +248,8 @@
+ DEREFEXNHANDLE(exnHandle)->ex_id = TAGGED(id);
+ DEREFEXNHANDLE(exnHandle)->ex_name = DEREFWORD(pushed_name);
+ DEREFEXNHANDLE(exnHandle)->arg = DEREFWORDHANDLE(arg);
+-
++ DEREFEXNHANDLE(exnHandle)->ex_location = TAGGED(0);
++
+ return exnHandle;
+ }
+
+@@ -437,7 +440,22 @@
+ PolyWord *handler = DEREFWORD(handler_handle).AsStackAddr();
+
+ fputs("\nException trace for exception - ", stdout);
+- print_string(((poly_exn *)DEREFHANDLE(exnHandle))->ex_name);
++ print_string((DEREFEXNHANDLE(exnHandle))->ex_name);
++ // For backwards compatibility check the packet length first
++ if (DEREFHANDLE(exnHandle)->Length() == SIZEOF(poly_exn)) {
++ if (DEREFEXNHANDLE(exnHandle)->ex_location.IsDataPtr()) {
++ PolyObject *location = DEREFEXNHANDLE(exnHandle)->ex_location.AsObjPtr();
++ PolyWord fileName = location->Get(0);
++ POLYSIGNED lineNo = get_C_long(taskData, location->Get(1));
++ if (fileName.IsTagged() || ((PolyStringObject *)fileName.AsObjPtr())->length != 0) {
++ printf(" raised in ");
++ print_string(fileName);
++ if (lineNo != 0) printf(" line %ld", lineNo);
++ }
++ else if (lineNo != 0) printf(" raised at line %ld", lineNo);
++ fputs("\n", stdout);
++ }
++ }
+ putc('\n',stdout);
+
+ /* Trace down as far as the dummy handler on the stack. */
+diff -u -r libpolyml/save_vec.cpp libpolyml/save_vec.cpp
+--- libpolyml/save_vec.cpp 2007-09-17 14:56:43.000000000 +0200
++++ libpolyml/save_vec.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -20,10 +20,12 @@
+
+ */
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_ASSERT_H
+diff -u -r libpolyml/savestate.cpp libpolyml/savestate.cpp
+--- libpolyml/savestate.cpp 2008-03-25 12:23:08.000000000 +0100
++++ libpolyml/savestate.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -20,10 +20,12 @@
+ */
+
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_STDIO_H
+@@ -50,6 +52,14 @@
+ #include <sys/types.h>
+ #endif
+
++#ifdef HAVE_SYS_STAT_H
++#include <sys/stat.h>
++#endif
++
++#ifdef HAVE_UNISTD_H
++#include <unistd.h>
++#endif
++
+ #ifdef HAVE_ASSERT_H
+ #include <assert.h>
+ #define ASSERT(x) assert(x)
+@@ -65,11 +75,11 @@
+ #include "scanaddrs.h"
+ #include "arb.h"
+ #include "memmgr.h"
+-#include "polyexports.h"
+ #include "mpoly.h" // For exportTimeStamp
+ #include "exporter.h" // For CopyScan
+ #include "machine_dep.h"
+ #include "osmem.h"
++#include "gc.h" // For FullGC.
+
+ #if(!defined(MAXPATHLEN) && defined(MAX_PATH))
+ #define MAXPATHLEN MAX_PATH
+@@ -198,6 +208,34 @@
+ return true;
+ }
+
++// Test whether we're overwriting a parent of ourself.
++#ifdef HAVE_WINDOWS_H
++static bool sameFile(const char *x, const char *y)
++{
++ // Get the lengths and return if either does not exist.
++ LPSTR filePart;
++ DWORD dwxLen = GetFullPathName(x, 1, 0, 0);
++ if (dwxLen == 0) return false;
++ DWORD dwyLen = GetFullPathName(y, 0, 0, 0);
++ if (dwyLen == 0) return false;
++ if (dwxLen != dwyLen) return false;
++ AutoFree<char*> xName = (char*)malloc(dwxLen+1);
++ GetFullPathName(x, dwxLen+1, xName, &filePart);
++ AutoFree<char*> yName = (char*)malloc(dwyLen+1);
++ GetFullPathName(y, dwyLen+1, yName, &filePart);
++ return strcmpi(xName, yName) == 0;
++}
++#else
++static bool sameFile(const char *x, const char *y)
++{
++ struct stat xStat, yStat;
++ // If either file does not exist that's fine.
++ if (stat(x, &xStat) != 0 || stat(y, &yStat) != 0)
++ return false;
++ return (xStat.st_dev == yStat.st_dev && xStat.st_ino == yStat.st_ino);
++}
++#endif
++
+ /*
+ * Saving state.
+ */
+@@ -351,6 +389,16 @@
+ // Called by the root thread to actually save the state and write the file.
+ void SaveRequest::Perform()
+ {
++ // Check that we aren't overwriting our own parent.
++ for (unsigned q = 0; q < newHierarchy-1; q++) {
++ if (sameFile(hierarchyTable[q]->fileName, fileName))
++ {
++ errorMessage = "File being saved is used as a parent of this file";
++ errCode = 0;
++ return;
++ }
++ }
++
+ SaveStateExport exports;
+ // Open the file. This could quite reasonably fail if the path is wrong.
+ exports.exportFile = fopen(fileName, "wb");
+@@ -363,7 +411,7 @@
+
+ // Scan over the permanent mutable area copying all reachable data that is
+ // not in a lower hierarchy into new permanent segments.
+- CopyScan copyScan(newHierarchy);
++ CopyScan copyScan(false, newHierarchy);
+ bool success = true;
+ try {
+ for (unsigned i = 0; i < gMem.npSpaces; i++)
+@@ -444,7 +492,10 @@
+
+ // Update the global memory space table. Old segments at the same level
+ // or lower are removed. The new segments become permanent.
+- if (! success || ! gMem.PromoteExportSpaces(newHierarchy))
++ // Try to promote the spaces even if we've had a failure because export
++ // spaces are deleted in ~CopyScan and we may have already copied
++ // some objects there.
++ if (! gMem.PromoteExportSpaces(newHierarchy) || ! success)
+ {
+ errorMessage = "Out of Memory";
+ errCode = ENOMEM;
+@@ -568,9 +619,15 @@
+ raise_syscall(taskData, "File name too long", ENAMETOOLONG);
+ // The value of depth is zero for top-level save so we need to add one for hierarchy.
+ unsigned newHierarchy = get_C_ulong(taskData, DEREFHANDLE(args)->Get(1)) + 1;
+- // We don't support hierarchical saving at the moment.
++
+ if (newHierarchy > hierarchyDepth+1)
+ raise_fail(taskData, "Depth must be no more than the current hierarchy plus one");
++
++ // Request a full GC first. The main reason is to avoid running out of memory as a
++ // result of repeated saves. Old export spaces are turned into local spaces and
++ // the GC will delete them if they are completely empty
++ FullGC(taskData);
++
+ SaveRequest request(fileNameBuff, newHierarchy);
+ processes->MakeRootRequest(taskData, &request);
+ if (request.errorMessage)
+@@ -588,7 +645,7 @@
+ StateLoader(const char *file): errorResult(0), errNumber(0) { strcpy(fileName, file); }
+
+ virtual void Perform(void);
+- bool LoadFile(void);
++ bool LoadFile(bool isInitial, UNSIGNEDADDR requiredStamp);
+ const char *errorResult;
+ // The fileName here is the last file loaded. As well as using it
+ // to load the name can also be printed out at the end to identify the
+@@ -600,7 +657,7 @@
+ // Called by the main thread once all the ML threads have stopped.
+ void StateLoader::Perform(void)
+ {
+- (void)LoadFile();
++ (void)LoadFile(true, 0);
+ }
+
+ // This class is used to relocate addresses in areas that have been loaded.
+@@ -721,7 +778,7 @@
+ }
+
+ // Load a saved state file. Calls itself to handle parent files.
+-bool StateLoader::LoadFile()
++bool StateLoader::LoadFile(bool isInitial, UNSIGNEDADDR requiredStamp)
+ {
+ LoadRelocate relocate;
+ AutoFree<char*> thisFile(strdup(fileName));
+@@ -754,6 +811,15 @@
+ return false;
+ }
+
++ // Check that we have the required stamp before loading any children.
++ // If a parent has been overwritten we could get a loop.
++ if (! isInitial && header.timeStamp != requiredStamp)
++ {
++ // Time-stamps don't match.
++ errorResult = "The parent for this saved state does not match or has been changed";
++ return false;
++ }
++
+ // Have verified that this is a reasonable saved state file. If it isn't a
+ // top-level file we have to load the parents first.
+ if (header.parentNameEntry != 0)
+@@ -769,19 +835,12 @@
+ return false;
+ }
+ fileName[toRead] = 0; // Should already be null-terminated, but just in case.
+- if (! LoadFile())
++
++ if (! LoadFile(false, header.parentTimeStamp))
+ return false;
+
+ // Check the parent time stamp.
+ ASSERT(hierarchyDepth > 0 && hierarchyTable[hierarchyDepth-1] != 0);
+-
+- if (header.parentTimeStamp != hierarchyTable[hierarchyDepth-1]->timeStamp)
+- {
+- // Time-stamps don't match.
+- errorResult = "The parent for this saved state does not match or has been changed";
+- return false;
+- }
+-
+ }
+ else // Top-level file
+ {
+diff -u -r libpolyml/scanaddrs.cpp libpolyml/scanaddrs.cpp
+--- libpolyml/scanaddrs.cpp 2008-02-25 13:52:34.000000000 +0100
++++ libpolyml/scanaddrs.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -18,10 +18,12 @@
+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+ */
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_ASSERT_H
+diff -u -r libpolyml/sharedata.cpp libpolyml/sharedata.cpp
+--- libpolyml/sharedata.cpp 2007-10-29 16:53:53.000000000 +0100
++++ libpolyml/sharedata.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -21,10 +21,12 @@
+
+ */
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_STDIO_H
+diff -u -r libpolyml/sighandler.cpp libpolyml/sighandler.cpp
+--- libpolyml/sighandler.cpp 2008-08-07 15:09:17.000000000 +0200
++++ libpolyml/sighandler.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -19,10 +19,12 @@
+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+ */
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_STDIO_H
+@@ -80,7 +82,12 @@
+ #include <fcntl.h>
+ #endif
+
+-
++#if ((!defined(WIN32) || defined(__CYGWIN__)) && defined(HAVE_LIBPTHREAD) && defined(HAVE_PTHREAD_H) && defined(HAVE_SEMAPHORE_H))
++// If we have the pthread library and header and we have semaphores we can use the pthread
++// signalling mechanism. But if this is a native Windows build we don't use semaphores or
++// pthread even if they're provided.
++#define USE_PTHREAD_SIGNALS 1
++#endif
+
+ /*
+ Signal handling is complicated in a multi-threaded environment.
+@@ -133,7 +140,7 @@
+ // not the "handler" field.
+ static PLock sigLock;
+
+-#if (defined(HAVE_LIBPTHREAD) && defined(HAVE_PTHREAD_H) && defined(HAVE_SEMAPHORE_H))
++#ifdef USE_PTHREAD_SIGNALS
+ static pthread_t detectionThreadId; // Thread processing signals.
+ static sem_t *waitSema;
+ static int lastSignals[NSIG];
+@@ -157,7 +164,7 @@
+ void markSignalInuse(int sig)
+ {
+ sigData[sig].nonMaskable = true;
+-#if (defined(HAVE_LIBPTHREAD) && defined(HAVE_PTHREAD_H))
++#ifdef USE_PTHREAD_SIGNALS
+ // Enable this signal.
+ sigset_t sigset;
+ sigemptyset(&sigset);
+@@ -185,7 +192,7 @@
+ }
+ #endif
+
+-#if (defined(HAVE_LIBPTHREAD) && defined(HAVE_PTHREAD_H) && defined(HAVE_SEMAPHORE_H))
++#ifdef USE_PTHREAD_SIGNALS
+ // Request the main thread to change the blocking state of a signal.
+ class SignalRequest: public MainThreadRequest
+ {
+@@ -271,7 +278,7 @@
+ // we affect is SIGINT and that is handled by RequestConsoleInterrupt.
+ if (! sigData[sign].nonMaskable)
+ {
+-#if (defined(HAVE_LIBPTHREAD) && defined(HAVE_PTHREAD_H) && defined(HAVE_SEMAPHORE_H))
++#ifdef USE_PTHREAD_SIGNALS
+ SignalRequest request(sign, action);
+ processes->MakeRootRequest(taskData, &request);
+ #endif
+@@ -368,7 +375,7 @@
+ ASSERT(sigaltstack_result == 0);
+ #endif
+ #endif /* not the PC */
+-#if (defined(HAVE_LIBPTHREAD) && defined(HAVE_PTHREAD_H))
++#ifdef USE_PTHREAD_SIGNALS
+ // Block all signals except those marked as in use by the RTS so
+ // that they will only be picked up by the signal detection thread.
+ // Since the signal mask is inherited we really don't need to do
+@@ -462,7 +469,7 @@
+ // Declare this. It will be automatically added to the table.
+ static SigHandler sighandlerModule;
+
+-#if (defined(HAVE_LIBPTHREAD) && defined(HAVE_PTHREAD_H) && defined(HAVE_SEMAPHORE_H))
++#ifdef USE_PTHREAD_SIGNALS
+ // This thread is really only to convert between POSIX semaphores and
+ // pthread condition variables. It waits for a semphore to be released by the
+ // signal handler running on the main thread and then wakes up the ML handler
+@@ -502,7 +509,7 @@
+ }
+ #endif
+
+-#if (defined(HAVE_SEMAPHORE_H))
++#ifdef USE_PTHREAD_SIGNALS
+ static sem_t waitSemaphore;
+
+ // Initialise a semphore. Tries to create an unnamed semaphore if
+@@ -541,7 +548,7 @@
+ #ifdef SIGILL
+ sigData[SIGILL].nonMaskable = true;
+ #endif
+-#if (defined(HAVE_LIBPTHREAD) && defined(HAVE_PTHREAD_H) && defined(HAVE_SEMAPHORE_H))
++#ifdef USE_PTHREAD_SIGNALS
+ // Initialise the "wait" semaphore so that it blocks immediately.
+ waitSema = init_semaphore(&waitSemaphore, 0);
+ if (waitSema == 0) return;
+diff -u -r libpolyml/timing.cpp libpolyml/timing.cpp
+--- libpolyml/timing.cpp 2007-09-14 13:43:53.000000000 +0200
++++ libpolyml/timing.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -21,10 +21,12 @@
+
+ */
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_STDLIB_H
+diff -u -r libpolyml/unix_specific.cpp libpolyml/unix_specific.cpp
+--- libpolyml/unix_specific.cpp 2008-02-26 09:51:12.000000000 +0100
++++ libpolyml/unix_specific.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -22,10 +22,12 @@
+ */
+
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_STDIO_H
+@@ -94,6 +96,8 @@
+
+ #ifdef HAVE_SYS_TERMIOS_H
+ #include <sys/termios.h>
++#elif (defined(HAVE_TERMIOS_H))
++#include <termios.h>
+ #endif
+
+ #ifdef HAVE_SYS_STAT_H
+@@ -577,7 +581,7 @@
+ {
+ /* This never returns. When a signal is handled it will
+ be interrupted. */
+- processes->BlockAndRestart(taskData, -1, true /* Interruptable. */, POLY_SYS_os_specific);
++ processes->BlockAndRestart(taskData, NULL, true /* Interruptable. */, POLY_SYS_os_specific);
+ }
+
+ case 22: /* Sleep until given time or until a signal. Note: this is called
+@@ -600,7 +604,7 @@
+ by a signal. */
+ if ((unsigned long)tv.tv_sec < secs ||
+ ((unsigned long)tv.tv_sec == secs && (unsigned long)tv.tv_usec < usecs))
+- processes->BlockAndRestart(taskData, -1, true /* Interruptable. */, POLY_SYS_os_specific);
++ processes->BlockAndRestart(taskData, NULL, true /* Interruptable. */, POLY_SYS_os_specific);
+ return Make_arbitrary_precision(taskData, 0);
+ }
+
+@@ -1252,7 +1256,7 @@
+ wasn't a child process waiting we have to block
+ and come back here later. */
+ if (pres == 0 && !(callFlags & WNOHANG))
+- processes->BlockAndRestart(taskData, -1, false, POLY_SYS_os_specific);
++ processes->BlockAndRestart(taskData, NULL, false, POLY_SYS_os_specific);
+
+ /* Construct the result tuple. */
+ {
+diff -u -r libpolyml/version.h libpolyml/version.h
+--- libpolyml/version.h 2008-10-17 15:26:56.000000000 +0200
++++ libpolyml/version.h 2009-09-15 08:56:44.000000000 +0200
+@@ -1,7 +1,7 @@
+ /*
+ Title: version.h
+
+- Copyright (c) 2000-7
++ Copyright (c) 2000-9
+ Cambridge University Technical Services Limited
+
+ This library is free software; you can redistribute it and/or
+@@ -24,15 +24,15 @@
+ #define VERSION_H_INCLUDED
+
+ // Poly/ML system interface level
+-#define POLY_version_number 520
++#define POLY_version_number 530
+ // POLY_version_number is written into all exported files and tested
+ // when we start up. The idea is to ensure that if a file is exported
+ // from one version of the library it will run successfully if linked
+ // with a different version.
+-// We currently export version 5.2 but will support either that or 5.1.
++// We currently export version 5.3 but will support 5.3, 5.2 or 5.1.
+ #define FIRST_supported_version 510
+-#define LAST_supported_version 520
++#define LAST_supported_version 530
+
+-#define TextVersion "5.2.1"
++#define TextVersion "5.3.0"
+
+ #endif
+diff -u -r libpolyml/windows_specific.cpp libpolyml/windows_specific.cpp
+--- libpolyml/windows_specific.cpp 2008-03-25 12:23:08.000000000 +0100
++++ libpolyml/windows_specific.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -18,10 +18,12 @@
+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+ */
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_STDIO_H
+@@ -105,7 +107,7 @@
+
+ struct {
+ /* Process and IO channels. */
+- HANDLE hProcess, hInput, hOutput;
++ HANDLE hProcess, hInput, hOutput, hEvent;
+ PolyObject *readToken, *writeToken;
+ } process;
+ HCONV hcDDEConv; /* DDE Conversation. */
+@@ -133,6 +135,8 @@
+ CloseHandle(pTab->entry.process.hInput);
+ if (pTab->entry.process.hOutput != INVALID_HANDLE_VALUE)
+ CloseHandle(pTab->entry.process.hOutput);
++ if (pTab->entry.process.hEvent)
++ CloseHandle(pTab->entry.process.hEvent);
+ break;
+
+ case HE_DDECONVERSATION:
+@@ -319,7 +323,6 @@
+ case 1005: /* Get result of process. */
+ {
+ PHANDLETAB hnd = get_handle(DEREFWORD(args), HE_PROCESS);
+- DWORD dwResult;
+ if (hnd == 0)
+ raise_syscall(taskData, "Process is closed", EINVAL);
+ // Close the streams. Either of them may have been
+@@ -327,6 +330,9 @@
+ if (hnd->entry.process.hInput != INVALID_HANDLE_VALUE)
+ CloseHandle(hnd->entry.process.hInput);
+ hnd->entry.process.hInput = INVALID_HANDLE_VALUE;
++ if (hnd->entry.process.hEvent)
++ CloseHandle(hnd->entry.process.hEvent);
++ hnd->entry.process.hEvent = NULL;
+ if (hnd->entry.process.readToken)
+ {
+ PIOSTRUCT strm =
+@@ -344,21 +350,25 @@
+ if (strm != NULL) close_stream(strm);
+ }
+ hnd->entry.process.writeToken = 0;
++
+ // See if it's finished.
+- if (GetExitCodeProcess(hnd->entry.process.hProcess,
+- &dwResult) == 0)
+- raise_syscall(taskData, "GetExitCodeProcess failed",
+- -(int)GetLastError());
+- if (dwResult == STILL_ACTIVE)
+- /* Run some other ML processes and come back in at
+- the top some time later*/
+- processes->BlockAndRestart(taskData, -1, false, POLY_SYS_os_specific);
+- /* Finished - return the result. */
+- /* Note: we haven't closed the handle because we might want to ask
+- for the result again. We only close it when we've garbage-collected
+- the token. Doing this runs the risk of running out of handles.
+- Maybe change it and remember the result in ML. */
+- return Make_unsigned(taskData, dwResult);
++ while (true) {
++ DWORD dwResult;
++ if (GetExitCodeProcess(hnd->entry.process.hProcess, &dwResult) == 0)
++ raise_syscall(taskData, "GetExitCodeProcess failed",
++ -(int)GetLastError());
++ if (dwResult != STILL_ACTIVE) {
++ /* Finished - return the result. */
++ /* Note: we haven't closed the handle because we might want to ask
++ for the result again. We only close it when we've garbage-collected
++ the token. Doing this runs the risk of running out of handles.
++ Maybe change it and remember the result in ML. */
++ return Make_unsigned(taskData, dwResult);
++ }
++ // Block and try again.
++ WaitHandle waiter(hnd->entry.process.hProcess);
++ processes->ThreadPauseForIO(taskData, &waiter);
++ }
+ }
+
+ case 1006: /* Return a constant. */
+@@ -526,7 +536,7 @@
+ }
+
+
+- case 1030: // Convert UTC time values to local time.
++ case 1030: // Convert UTC time values to local time. -- No longer used??
+ {
+ FILETIME ftUTC, ftLocal;
+ /* Get the file time. */
+@@ -539,7 +549,7 @@
+ ftLocal.dwLowDateTime);
+ }
+
+- case 1031: // Convert local time values to UTC.
++ case 1031: // Convert local time values to UTC. -- No longer used??
+ {
+ FILETIME ftUTC, ftLocal;
+ /* Get the file time. */
+@@ -790,7 +800,15 @@
+ pipe to the child. The end we pass to the child is "inheritable" (i.e. duplicated
+ in the child as with Unix file descriptors) while the ends we keep in the parent
+ are non-inheritable (i.e. not duplicated in the child).
+-DCJM: December 1999.
++DCJM: December 1999.
++This is now further complicated to improve the performance. In Unix we can pass
++the file ID to "select" which will return immediately when input is available (we
++ignore blocking on output at the moment). That allows the ML process to respond
++immediately. There's no easy way to do that in Windows since the pipe handle is
++signalled whether there is input available or not. One possibility would be to
++use overlapped IO but that requires using the ReadFile call directly and some
++contortions to create a pipe with overlapped IO. The other, taken here, is to
++interpose a thread which can signal an event when input is available.
+ */
+ static Handle execute(TaskData *taskData, Handle args)
+ {
+@@ -800,6 +818,7 @@
+ hReadFromParent = INVALID_HANDLE_VALUE,
+ hWriteToParent = INVALID_HANDLE_VALUE,
+ hReadFromChild = INVALID_HANDLE_VALUE;
++ HANDLE hEvent = CreateEvent(NULL, TRUE, FALSE, NULL);
+ HANDLE hTemp;
+ STARTUPINFO startupInfo;
+ PROCESS_INFORMATION processInfo;
+@@ -823,6 +842,13 @@
+ lpszError = "Could not create pipe";
+ goto error;
+ }
++ // Create the copying thread.
++ hTemp = CreateCopyPipe(hReadFromChild, hEvent);
++ if (hTemp == NULL) {
++ lpszError = "Could not create pipe";
++ goto error;
++ }
++ hReadFromChild = hTemp;
+ // Convert the handles we want to pass to the child into inheritable
+ // handles by duplicating and replacing them with the duplicates.
+ if (! DuplicateHandle(GetCurrentProcess(), hWriteToParent, GetCurrentProcess(),
+@@ -875,6 +901,7 @@
+ pTab->entry.process.hProcess = processInfo.hProcess;
+ pTab->entry.process.hInput = hReadFromChild;
+ pTab->entry.process.hOutput = hWriteToChild;
++ pTab->entry.process.hEvent = hEvent;
+ pTab->entry.process.readToken = 0;
+ pTab->entry.process.writeToken = 0;
+
+@@ -890,6 +917,7 @@
+ if (hReadFromParent != INVALID_HANDLE_VALUE) CloseHandle(hReadFromParent);
+ if (hWriteToParent != INVALID_HANDLE_VALUE) CloseHandle(hWriteToParent);
+ if (hReadFromChild != INVALID_HANDLE_VALUE) CloseHandle(hReadFromChild);
++ if (hEvent) CloseHandle(hEvent);
+ raise_syscall(taskData, lpszError, -err);
+ return NULL; // Never reached.
+ }
+@@ -952,6 +980,7 @@
+ // We only use the process handle entry.
+ pTab->entry.process.hInput = INVALID_HANDLE_VALUE;
+ pTab->entry.process.hOutput = INVALID_HANDLE_VALUE;
++ pTab->entry.process.hEvent = NULL;
+ pTab->entry.process.readToken = 0;
+ pTab->entry.process.writeToken = 0;
+
+@@ -992,6 +1021,7 @@
+ if (strm->device.ioDesc == -1)
+ raise_syscall(taskData, "_open_osfhandle failed", errno);
+ strm->ioBits = ioBits | IO_BIT_OPEN | IO_BIT_PIPE;
++
+ /* The responsibility for closing the handle is passed to
+ the stream package. We need to retain a pointer to the
+ stream entry so that we can close the stream in "reap". */
+@@ -999,6 +1029,9 @@
+ {
+ hnd->entry.process.hInput = INVALID_HANDLE_VALUE;
+ hnd->entry.process.readToken = strm->token;
++ // Pass the "input available" event.
++ strm->hAvailable = hnd->entry.process.hEvent;
++ hnd->entry.process.hEvent = NULL;
+ }
+ else
+ {
+diff -u -r libpolyml/x86_dep.cpp libpolyml/x86_dep.cpp
+--- libpolyml/x86_dep.cpp 2008-03-25 12:23:08.000000000 +0100
++++ libpolyml/x86_dep.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -20,10 +20,12 @@
+
+ */
+
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
++#error "No configuration file"
+ #endif
+
+ #ifdef HAVE_STDLIB_H
+@@ -2021,7 +2023,7 @@
+ cbEntryNo = cbEntryNo >> 8;
+ *p++ = cbEntryNo & 0xff;
+ /* The call is PC relative so we have to subtract the address of the END of the call instruction. */
+- cbAddr -= (int)p + 5; /* The instruction is 5 bytes long. */
++ cbAddr -= (long)p + 5; /* The instruction is 5 bytes long. */
+ *p++ = 0xE8; /* call cbAddr */
+ *p++ = cbAddr & 0xff;
+ cbAddr = cbAddr >> 8;
+diff -u -r libpolyml/x86asm.asm libpolyml/x86asm.asm
+--- libpolyml/x86asm.asm 2008-06-17 12:10:29.000000000 +0200
++++ libpolyml/x86asm.asm 2009-09-15 08:56:44.000000000 +0200
+@@ -2180,11 +2180,7 @@
+ PUBLIC registerMaskVector
+ registerMaskVector dd Mask_all ;# 0 is unused
+ ELSE
+-IFNDEF HOSTARCHITECTURE_X86_64
+ GLOBAL EXTNAME(registerMaskVector)
+-ELSE
+- .global EXTNAME(registerMaskVector)
+-ENDIF
+ EXTNAME(registerMaskVector):
+ #define dd .long
+ dd Mask_all ;# 0 is unused
+diff -u -r libpolyml/xwindows.cpp libpolyml/xwindows.cpp
+--- libpolyml/xwindows.cpp 2008-08-14 13:53:00.000000000 +0200
++++ libpolyml/xwindows.cpp 2009-09-15 08:56:44.000000000 +0200
+@@ -20,18 +20,16 @@
+
+ */
+
+-#ifdef _WIN32_WCE
+-#include "winceconfig.h"
+-#else
+-#ifdef WIN32
++#ifdef HAVE_CONFIG_H
++#include "config.h"
++#elif defined(WIN32)
+ #include "winconfig.h"
+ #else
+-#include "config.h"
+-#endif
++#error "No configuration file"
+ #endif
+
+-#if (defined(HAVE_LIBXM) && defined(HAVE_LIBXEXT) && defined(HAVE_LIBXT) && defined(HAVE_X11_XLIB_H) && defined(HAVE_XM_XM_H))
+-// Then we have enough for X-windows
++#if (defined(WITH_XWINDOWS))
++// X-Windows is required.
+
+ /* xwindows.c */
+
+@@ -162,6 +160,10 @@
+ #include <alloca.h>
+ #endif
+
++#ifdef HAVE_ERRNO_H
++#include <errno.h>
++#endif
++
+ /* what goes wrong? ... gid, fd, private15 inaccessible */
+ /* THIS NEEDS TO BE FIXED!!!! */
+ #define XLIB_ILLEGAL_ACCESS 1 /* We need access to some opaque structures */
+@@ -243,7 +245,6 @@
+ #include "memmgr.h"
+ #include "machine_dep.h"
+ #include "processes.h"
+-#include "basicio.h" // For process_may_block.
+
+ /* The following are only forward so we can declare attributes */
+ static void RaiseXWindows(TaskData *taskData, const char *s) __attribute__((noreturn));
+@@ -4693,6 +4694,36 @@
+ *tail = newp;
+ }
+
++// Test whether input is available and block if it is not.
++// N.B. There may be a GC while in here.
++// This was previously in basicio.cpp but has been moved here
++// since this is the only place it's used now.
++static void process_may_block(TaskData *taskData, int fd, int/* ioCall*/)
++{
++#ifdef __CYGWIN__
++ static struct timeval poll = {0,1};
++#else
++ static struct timeval poll = {0,0};
++#endif
++ fd_set read_fds;
++ int selRes;
++
++ while (1)
++ {
++
++ FD_ZERO(&read_fds);
++ FD_SET((int)fd,&read_fds);
++
++ /* If there is something there we can return. */
++ selRes = select(FD_SETSIZE, &read_fds, NULL, NULL, &poll);
++ if (selRes > 0) return; /* Something waiting. */
++ else if (selRes < 0 && errno != EINTR) // Maybe another thread closed descr
++ raise_syscall(taskData, "select failed %d\n", errno);
++ WaitInputFD waiter(fd);
++ processes->ThreadPauseForIO(taskData, &waiter);
++ }
++}
++
+ static Handle NextEvent(TaskData *taskData, Handle dsHandle /* handle to (X_Display_Object *) */)
+ {
+ for (;;)
+diff -u -r mlsource/BuildAll.sml mlsource/BuildAll.sml
+--- mlsource/BuildAll.sml 2008-04-21 13:37:58.000000000 +0200
++++ mlsource/BuildAll.sml 2009-09-15 08:56:47.000000000 +0200
+@@ -18,6 +18,9 @@
+ *)
+
+ (* Script to rebuild the compiler. *)
++(* This is used only during testing. The normal build process uses
++ BuildExport to export a newly compiled compiler and exportPoly
++ to compile the basis and produce an object file. *)
+
+ PolyML.print_depth 0;
+
+@@ -27,6 +30,8 @@
+ (* Compile the prelude and basis in the new compiler. *)
+ MLCompiler.use "mlsource/BuildBasis.sml";
+
+-(* This runs the new shell on top of the old one. *)
+-MLCompiler.shell();
+-PolyML.rootFunction();
++(* Use useString to start the new shell because it allows this
++ to be pasted into a window as a single item. Otherwise the
++ line to start the new shell will be in the buffer of the old
++ TextIO.stdIn not the one we've just built. *)
++MLCompiler.useString "PolyML.rootFunction();";
+diff -u -r mlsource/BuildBasis.sml mlsource/BuildBasis.sml
+--- mlsource/BuildBasis.sml 2008-03-28 11:56:30.000000000 +0100
++++ mlsource/BuildBasis.sml 2009-09-15 08:56:47.000000000 +0200
+@@ -48,7 +48,7 @@
+ else ()
+ end;
+
+-PolyML.print_depth 100;
++PolyML.print_depth 10;
+
+ (* Set the inline level to 40 which seems optimal. *)
+ PolyML.Compiler.maxInlineSize := 40;
+diff -u -r mlsource/MLCompiler/Boot/HashTable.ML mlsource/MLCompiler/Boot/HashTable.ML
+--- mlsource/MLCompiler/Boot/HashTable.ML 2008-03-14 08:31:03.000000000 +0100
++++ mlsource/MLCompiler/Boot/HashTable.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -38,8 +38,8 @@
+ type 'a hash
+ type 'a iter
+
+- val hashMake: int -> '_a hash
+- val hashSet: '_a hash * string * '_a -> unit
++ val hashMake: int -> 'a hash
++ val hashSet: 'a hash * string * 'a -> unit
+ val hashSub: 'a hash * string -> 'a option
+
+ (* An iterator over the non-empty entries in the table. *)
+@@ -140,15 +140,15 @@
+ find (hashN name)
+ end
+
+- fun hashSet (Frozen _, name : string, value : '_a) : unit =
++ fun hashSet (Frozen _, name : string, _ : 'a) : unit =
+ raise Fail ("Attempt to set a value with name (" ^ name ^ ") in a frozen hash table")
+
+- | hashSet (Hash {entries, used, hash}, name : string, value : '_a) =
++ | hashSet (Hash {entries, used, hash}, name : string, value : 'a) =
+ let
+ open Array
+ (* Enters the value at the first free entry at or after the
+ one pointed to by the hash value. *)
+- fun enterTab (A : '_a namedOption array, i : int, None : '_a namedOption) = ()
++ fun enterTab (_ : 'a namedOption array, _ : int, None : 'a namedOption) = ()
+ | enterTab (A, i, entry as Some (name,_)) =
+ let
+ fun enter (i : int) : unit =
+@@ -164,19 +164,19 @@
+ enter i
+ end
+
+- val A : '_a namedOption array = !entries;
++ val A : 'a namedOption array = !entries;
+ val N : int = length A;
+ val hashN : string -> int = !hash
+
+- val U : unit = enterTab (A, hashN name, Some (name, value));
+- val U : unit = used := !used + 1;
++ val () = enterTab (A, hashN name, Some (name, value));
++ val () = used := !used + 1;
+ in
+ (* Do we need to rehash ? *)
+ if !used * 5 > N * 4 (* More than 80% full so rehash *)
+ then
+ let
+ val newN : int = N * 2; (* Double the size *)
+- val newA : '_a namedOption array = array (newN, None);
++ val newA : 'a namedOption array = array (newN, None);
+ val hashNewN : string -> int = hashValue newN;
+
+ fun copyOver (index : int) : unit =
+@@ -191,8 +191,8 @@
+ copyOver (index - 1)
+ );
+
+- val U : unit = entries := newA;
+- val U : unit = hash := hashNewN;
++ val () = entries := newA;
++ val () = hash := hashNewN;
+ in
+ copyOver (length A - 1)
+ end
+Only in mlsource/MLCompiler/Boot: Misc.530.ML
+Only in mlsource/MLCompiler/Boot: PrettyPrinter.ML
+diff -u -r mlsource/MLCompiler/Boot/StretchArray.ML mlsource/MLCompiler/Boot/StretchArray.ML
+--- mlsource/MLCompiler/Boot/StretchArray.ML 2006-09-26 15:38:31.000000000 +0200
++++ mlsource/MLCompiler/Boot/StretchArray.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -114,7 +114,7 @@
+ | vector {contents = ref (AVector v), ...} = v
+
+ (* Turn an array into a vector and turn the ref into an immutable. *)
+- fun freeze {contents = ref (AVector v), ...} = ()
++ fun freeze {contents = ref (AVector _), ...} = ()
+ | freeze {contents = contents as ref (AnArray a), ...} =
+ (
+ contents := AVector(Array.vector a);
+diff -u -r mlsource/MLCompiler/Boot/UniversalTable.ML mlsource/MLCompiler/Boot/UniversalTable.ML
+--- mlsource/MLCompiler/Boot/UniversalTable.ML 2008-03-14 08:31:03.000000000 +0100
++++ mlsource/MLCompiler/Boot/UniversalTable.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -94,8 +94,8 @@
+ end;
+
+ local
+- fun fst (a,b) = a;
+- fun snd (a,b) = b;
++ fun fst (a,_) = a;
++ fun snd (_,b) = b;
+ in
+ fun univOver (Table tab) = (* Iterator over all the entries. *)
+ let
+@@ -123,9 +123,9 @@
+
+ (* Return the next FULL entry. *)
+
+- fun next (ti,[]) =
++ fun next (_ ,[]) =
+ raise InternalError "UniversalTable.univOver.next"
+- | next (ti,[x]) = makeIter (nextList ti)
++ | next (ti,[_]) = makeIter (nextList ti)
+ (* Finished one list - get the next. *)
+ | next (ti,_::T) = makeIter (ti,T)
+
+diff -u -r mlsource/MLCompiler/Boot/ml_bind.ML mlsource/MLCompiler/Boot/ml_bind.ML
+--- mlsource/MLCompiler/Boot/ml_bind.ML 2007-03-03 18:56:21.000000000 +0100
++++ mlsource/MLCompiler/Boot/ml_bind.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -23,6 +23,5 @@
+ structure Misc = Misc
+ structure HashTable = HashTable
+ structure UniversalTable = UniversalTable
+- structure PrettyPrinter = PrettyPrinter
+ structure StretchArray = StretchArray
+ end;
+Only in mlsource/MLCompiler: CODETREESIG.ML
+diff -u -r mlsource/MLCompiler/COMPILER_BODY.ML mlsource/MLCompiler/COMPILER_BODY.ML
+--- mlsource/MLCompiler/COMPILER_BODY.ML 2008-04-21 13:36:11.000000000 +0200
++++ mlsource/MLCompiler/COMPILER_BODY.ML 2009-09-15 08:56:47.000000000 +0200
+@@ -29,9 +29,6 @@
+
+ functor COMPILER_BODY (
+
+-(*****************************************************************************)
+-(* SYMSET *)
+-(*****************************************************************************)
+ structure SYMSET :
+ sig
+ type sys
+@@ -43,162 +40,36 @@
+ val semicolon: symset
+ end;
+
+-(*****************************************************************************)
+-(* LEX *)
+-(*****************************************************************************)
+-structure LEX :
+-sig
+- type lexan
+- type sys
+- type prettyPrinter
+-
+- val insymbol: lexan -> unit
+- val sy: lexan -> sys
+- val errorOccurred: lexan -> bool
+- val resetLexan: lexan -> unit
+- val flushLexan: lexan -> unit;
++structure LEX : LEXSIG
+
+- val initial: (unit -> char option) * Universal.universal list -> lexan;
+-end;
+-
+-(*****************************************************************************)
+-(* CODETREE *)
+-(*****************************************************************************)
+ structure CODETREE :
+ sig
+ type codetree
+- type prettyPrinter
++ type pretty
+
+ val genCode: codetree * Universal.universal list -> unit -> codetree
+- val pretty: codetree * prettyPrinter -> unit;
++ val pretty: codetree -> pretty;
+ end;
+
+-(*****************************************************************************)
+-(* STRUCTVALS *)
+-(*****************************************************************************)
+-structure STRUCTVALS :
+-sig
+- type structVals
+- type signatures
+- type fixStatus
+- type functors
+- type typeConstrs;
+-
+- type types
+- val isEmpty: types -> bool
+-
+- type values
+- val isValueConstructor: values -> bool
+-
+- datatype env = Env of
+- {
+- lookupVal: string -> values option,
+- lookupType: string -> typeConstrs option,
+- lookupFix: string -> fixStatus option,
+- lookupStruct: string -> structVals option,
+- lookupSig: string -> signatures option,
+- lookupFunct: string -> functors option,
+- enterVal: string * values -> unit,
+- enterType: string * typeConstrs -> unit,
+- enterFix: string * fixStatus -> unit,
+- enterStruct: string * structVals -> unit,
+- enterSig: string * signatures -> unit,
+- enterFunct: string * functors -> unit
+- };
+-end;
+-
+-(*****************************************************************************)
+-(* VALUEOPS *)
+-(*****************************************************************************)
+-structure VALUEOPS :
+-sig
+- type values
+- type structVals
+- type functors
+- type signatures
+- type fixStatus
+- type typeConstrs
+-
+- type nameSpace =
+- {
+- lookupVal: string -> values option,
+- lookupType: string -> typeConstrs option,
+- lookupFix: string -> fixStatus option,
+- lookupStruct: string -> structVals option,
+- lookupSig: string -> signatures option,
+- lookupFunct: string -> functors option,
+-
+- enterVal: string * values -> unit,
+- enterType: string * typeConstrs -> unit,
+- enterFix: string * fixStatus -> unit,
+- enterStruct: string * structVals -> unit,
+- enterSig: string * signatures -> unit,
+- enterFunct: string * functors -> unit,
+-
+- allVal: unit -> (string*values) list,
+- allType: unit -> (string*typeConstrs) list,
+- allFix: unit -> (string*fixStatus) list,
+- allStruct: unit -> (string*structVals) list,
+- allSig: unit -> (string*signatures) list,
+- allFunct: unit -> (string*functors) list
+- };
+-
+- val exnName : exn -> string
+-
+- val printSpaceTag: nameSpace Universal.tag
+- val nullEnvironment : nameSpace
+-end;
++structure STRUCTVALS : STRUCTVALSIG;
+
+-(*****************************************************************************)
+-(* STRUCTURES *)
+-(*****************************************************************************)
+-structure STRUCTURES :
+-sig
+- type structs
+- type lexan
+- type prettyPrinter
+- type codetree
+- type env
++structure VALUEOPS : VALUEOPSSIG;
+
+- type values
+- type structVals
+- type functors
+- type fixStatus
+- type typeConstrs
+- type signatures
++structure EXPORTTREE: EXPORTTREESIG
+
+- val pass2Structs: structs list * lexan * env -> unit
+- val checkForFreeTypeVars:
+- ((string*values->unit)->unit) * ((string*structVals->unit)->unit) *
+- ((string*functors->unit)->unit) * lexan -> unit
+- val pass4Structs:
+- codetree * structs list ->
+- { fixes: (string * fixStatus) list, values: (string * values) list,
+- structures: (string * structVals) list, signatures: (string * signatures) list,
+- functors: (string * functors) list, types: (string* typeConstrs) list };
+- val gencodeStructs: structs list * lexan -> codetree;
+- val displayStructs: structs list * int * prettyPrinter -> unit
+-end;
++structure STRUCTURES : STRUCTURESSIG
+
+-(*****************************************************************************)
+-(* PARSEDEC *)
+-(*****************************************************************************)
+ structure PARSEDEC :
+ sig
+ type lexan
+ type symset
+ type fixStatus
+- type structs
++ type program
+
+ val parseDec: symset * lexan *
+- { enterFix: string * fixStatus -> unit,
+- lookupFix: string -> fixStatus option }
+- -> structs list
++ { enterFix: string * fixStatus -> unit, lookupFix: string -> fixStatus option } -> program
+ end;
+
+-(*****************************************************************************)
+-(* DEBUG *)
+-(*****************************************************************************)
+ structure DEBUG :
+ sig
+ val parsetreeTag : bool Universal.tag
+@@ -207,15 +78,10 @@
+ val profilingTag : int Universal.tag
+ val traceCompilerTag : bool Universal.tag
+
+- val compilerOutputTag: (string->unit) Universal.tag
+-
+ val getParameter :
+ 'a Universal.tag -> Universal.universal list -> 'a
+ end;
+
+-(*****************************************************************************)
+-(* UTILITIES *)
+-(*****************************************************************************)
+ structure UTILITIES :
+ sig
+ val searchList: unit ->
+@@ -224,26 +90,8 @@
+ lookup: string -> 'a option}
+ end;
+
+-(*****************************************************************************)
+-(* PRETTYPRINTER *)
+-(*****************************************************************************)
+-structure PRETTYPRINTER :
+-sig
+- type prettyPrinter
+-
+- val ppAddString : prettyPrinter -> string -> unit
+- val ppBeginBlock : prettyPrinter -> int * bool -> unit
+- val ppEndBlock : prettyPrinter -> unit -> unit
+- val ppBreak : prettyPrinter -> int * int -> unit
+- val ppLineBreak : prettyPrinter -> unit -> unit
+- val ppEndStream : prettyPrinter -> unit -> unit
+-
+- val prettyPrint : int * (string -> unit) -> prettyPrinter;
+-end;
++structure PRETTY : PRETTYSIG
+
+-(*****************************************************************************)
+-(* MISC *)
+-(*****************************************************************************)
+ structure MISC :
+ sig
+ exception InternalError of string
+@@ -251,71 +99,8 @@
+ val quickSort : ('a -> 'a -> bool) -> 'a list -> 'a list
+ end;
+
+-(*****************************************************************************)
+-(* COMPILERBODY sharing constraints *)
+-(*****************************************************************************)
+-
+-sharing type
+- PRETTYPRINTER.prettyPrinter
+-= LEX.prettyPrinter
+-= STRUCTURES.prettyPrinter
+-= CODETREE.prettyPrinter
+-
+-sharing type
+- SYMSET.sys
+-= LEX.sys
+-
+-sharing type
+- SYMSET.symset
+-= PARSEDEC.symset
+-
+-sharing type
+- LEX.lexan
+-= PARSEDEC.lexan
+-= STRUCTURES.lexan
+-
+-sharing type
+- STRUCTVALS.fixStatus
+-= PARSEDEC.fixStatus
+-= VALUEOPS.fixStatus
+-= STRUCTURES.fixStatus
+-
+-sharing type
+- PARSEDEC.structs
+-= STRUCTURES.structs
+-
+-sharing type
+- STRUCTURES.codetree
+-= CODETREE.codetree
+-
+-sharing type
+- STRUCTVALS.env
+-= STRUCTURES.env
+-
+-sharing type
+- STRUCTVALS.typeConstrs
+-= STRUCTURES.typeConstrs
+-= VALUEOPS.typeConstrs
+-
+-sharing type
+- VALUEOPS.values
+-= STRUCTVALS.values
+-= STRUCTURES.values
+-
+-sharing type
+- VALUEOPS.structVals
+-= STRUCTVALS.structVals
+-= STRUCTURES.structVals
+-
+-sharing type
+- VALUEOPS.functors
+-= STRUCTVALS.functors
+-= STRUCTURES.functors
+-
+-sharing type
+- VALUEOPS.signatures
+-= STRUCTVALS.signatures
+-= STRUCTURES.signatures
++sharing STRUCTVALS.Sharing = VALUEOPS.Sharing = PRETTY.Sharing = STRUCTURES.Sharing
++ = LEX.Sharing = EXPORTTREE.Sharing = SYMSET = PARSEDEC = CODETREE
+
+ (*****************************************************************************)
+ (* COMPILERBODY export signature *)
+@@ -330,6 +115,7 @@
+ type structVals;
+ type signatures;
+ type functors;
++ type exportTree
+
+ type nameSpace =
+ {
+@@ -355,12 +141,18 @@
+ allFunct: unit -> (string*functors) list
+ };
+
+- (* The completed compiler. *)
++ type location =
++ { file: string, startLine: int, startPosition: int, endLine: int, endPosition: int }
++
++ (* The completed compiler.
++ Returns the parse tree and, if successful, a function that executes the
++ compiled code. *)
+ val compiler :
+- nameSpace * (unit->char option) * Universal.universal list -> unit ->
+- { fixes: (string * fixStatus) list, values: (string * values) list,
+- structures: (string * structVals) list, signatures: (string * signatures) list,
+- functors: (string * functors) list, types: (string * typeConstrs) list };
++ nameSpace * (unit->char option) * Universal.universal list ->
++ exportTree option * (unit ->
++ { fixes: (string * fixStatus) list, values: (string * values) list,
++ structures: (string * structVals) list, signatures: (string * signatures) list,
++ functors: (string * functors) list, types: (string * typeConstrs) list }) option;
+ end =
+
+ (*****************************************************************************)
+@@ -369,27 +161,34 @@
+ struct
+ open MISC;
+ open STRUCTVALS;
+- open PRETTYPRINTER;
++ open PRETTY;
+ open LEX;
+
+ type nameSpace = VALUEOPS.nameSpace
++ open STRUCTURES
++ open EXPORTTREE
+
+- fun printTimes print (parseTime,pass2Time,treeTime,codeTime,endRunTime) : unit =
++ fun printTimes printOut (parseTime,pass2Time,treeTime,codeTime,endRunTime) : unit =
+ let
+- fun printTime t = print(Time.fmt 1 t)
++ val message =
++ PrettyBlock(3, false, [],
++ [
++ PrettyString "Timing -",
++ PrettyBreak(1, 0),
++ PrettyString ("parse:" ^ Time.fmt 1 parseTime ^ ","),
++ PrettyBreak(1, 0),
++ PrettyString ("semantics:" ^ Time.fmt 1 (pass2Time-parseTime) ^ ","),
++ PrettyBreak(1, 0),
++ PrettyString ("translate:" ^ Time.fmt 1 (treeTime-pass2Time) ^ ","),
++ PrettyBreak(1, 0),
++ PrettyString ("generate:" ^ Time.fmt 1 (codeTime-treeTime) ^ ","),
++ PrettyBreak(1, 0),
++ PrettyString ("run:" ^ Time.fmt 1 endRunTime)
++ ]
++ )
+ in
+- print "Timing - parse:";
+- printTime(parseTime);
+- print ", semantics:";
+- printTime(pass2Time-parseTime);
+- print ", translate:";
+- printTime(treeTime-pass2Time);
+- print ", generate:";
+- printTime(codeTime-treeTime);
+- print ", run:";
+- printTime(endRunTime);
+- print "\n"
+- end
++ printOut message
++ end
+
+
+ (* switch profiling on/off *)
+@@ -409,14 +208,16 @@
+ op ++ (abortParse, semicolon)
+ end;
+
+- fun baseCompiler (lex : lexan, nameSpace: nameSpace, debugSwitches) : unit ->
+- { fixes: (string * fixStatus) list, values: (string * values) list,
+- structures: (string * structVals) list, signatures: (string * signatures) list,
+- functors: (string * functors) list, types: (string * typeConstrs) list } =
++ fun baseCompiler (lex : lexan, nameSpace: nameSpace, debugSwitches) :
++ exportTree option * (unit ->
++ { fixes: (string * fixStatus) list, values: (string * values) list,
++ structures: (string * structVals) list, signatures: (string * signatures) list,
++ functors: (string * functors) list, types: (string * typeConstrs) list }) option =
+ let (* let1 *)
+-
+- val compilerOutput = DEBUG.getParameter DEBUG.compilerOutputTag debugSwitches
+- and timing = DEBUG.getParameter DEBUG.timingTag debugSwitches
++
++ val compilerOutput = getCompilerOutput debugSwitches
++
++ val timing = DEBUG.getParameter DEBUG.timingTag debugSwitches
+ and printCodetree = DEBUG.getParameter DEBUG.codetreeTag debugSwitches
+ and printParsetree = DEBUG.getParameter DEBUG.parsetreeTag debugSwitches
+ and profiling = DEBUG.getParameter DEBUG.profilingTag debugSwitches
+@@ -447,200 +248,141 @@
+
+ val startTime = Timer.startCPUTimer();
+
+- (* Clear lexer error state (but NOT look-ahead state) *)
+- val U : unit = resetLexan lex;
+-
+- (*
+- Ignore semicolon (if any) from the previous declaration. The
+- very first token produced by the lexer is a semicolon, which
+- makes life easier. DON'T make this a loop because the prompt
+- only gets reset on a new call to "compiler". This means that
+- if we try to process more than one (empty) statement at a time,
+- we'll get the wrong (secondary) prompt!
+- SPF 19/4/96
+- *)
+- val U : unit =
++ val startLocn = location lex
++ val () =
+ if SYMSET.inside (sy lex, SYMSET.semicolon)
+ then insymbol lex
+ else ();
++
++ val parentTreeNav =
++ case List.find (Universal.tagIs rootTreeTag) debugSwitches of
++ SOME opt => Universal.tagProject rootTreeTag opt
++ | NONE => { parent = NONE, next = NONE, previous = NONE }
+ in (* let1 *)
+ (* An empty declaration (or end of file!) *)
+ if SYMSET.inside (sy lex, stopSyms)
+ then if errorOccurred lex (* We could have, for example, an unterminated comment. *)
+- then (resetLexan lex; raise Fail "Static errors (pass 1)")
+- else fn () => { fixes=[], values=[], structures=[], functors=[], types=[], signatures=[] } (* Do nothing *)
++ then (NONE, NONE)
++ else (SOME(locSpan(startLocn, location lex), []),
++ SOME (fn () => { fixes=[], values=[], structures=[], functors=[], types=[], signatures=[] })
++ ) (* Do nothing *)
+ else let (* let2 *)
+ (* create a "throw away" compiling environment for this topdec *)
+ val newFixEnv = UTILITIES.searchList ();
+ val enterFix = #enter newFixEnv;
+ val lookupFix = lookupDefault (#lookup newFixEnv) (#lookupFix globals);
+
+- (* parse a topdec *)
+- val parseTree : STRUCTURES.structs list =
+- PARSEDEC.parseDec (stopSyms, lex,
+- {enterFix = enterFix,
+- lookupFix = lookupFix});
++ (* parse a program: a sequence of topdecs ending with a semicolon. *)
++ val parseTree : STRUCTURES.program =
++ PARSEDEC.parseDec (stopSyms, lex, {enterFix = enterFix, lookupFix = lookupFix});
+
+ val parseTime = cpuTime startTime;
+- val UUU:unit =
++
++ val () =
+ if printParsetree
+- then let
+- val pstream = prettyPrint (77, compilerOutput);
+- in
+- ppBeginBlock pstream (0, false);
+- STRUCTURES.displayStructs (parseTree, 10000, pstream);
+- ppEndBlock pstream ()
+- end
+- else ();
+-
+- val U : unit =
+- if errorOccurred lex
+- then (resetLexan lex; raise Fail "Static errors (pass 1)")
+- else ()
+-
+- (* extend throw-away compiling environment *)
+- val newValEnv = UTILITIES.searchList();
+- val newTypeEnv = UTILITIES.searchList();
+- val newStrEnv = UTILITIES.searchList();
+- val newSigEnv = UTILITIES.searchList();
+- val newFuncEnv = UTILITIES.searchList();
+-
+- (* create an "env" from the throw-away environment *)
+- val lookupVal =
+- lookupDefault (#lookup newValEnv) (#lookupVal globals);
+-
+- val lookupType =
+- lookupDefault (#lookup newTypeEnv) (#lookupType globals);
+-
+- val lookupStruct =
+- lookupDefault (#lookup newStrEnv) (#lookupStruct globals);
+-
+- val lookupSig =
+- lookupDefault (#lookup newSigEnv) (#lookupSig globals);
+-
+- val lookupFunct =
+- lookupDefault (#lookup newFuncEnv) (#lookupFunct globals);
+-
+- (* For each declaration we enter a reference to the identifier in this
+- table. We can then construct code which will load each value into
+- a vector which can be returned. Used for variables and exceptions. *)
+- val locals =
+- {
+- lookupVal = lookupVal,
+- lookupType = lookupType,
+- lookupFix = lookupFix,
+- lookupStruct = lookupStruct,
+- lookupSig = lookupSig,
+- lookupFunct = lookupFunct,
+- enterVal = #enter newValEnv,
+- enterType = #enter newTypeEnv,
+- enterFix = enterFix,
+- enterStruct = #enter newStrEnv,
+- enterSig = #enter newSigEnv,
+- enterFunct = #enter newFuncEnv
+- };
+-
+- val localEnv : env = STRUCTVALS.Env locals;
+-
+- (* If no errors then do second pass to match identifiers
+- and declarations and return type of expression. *)
+- val UUU:unit = STRUCTURES.pass2Structs (parseTree, lex, localEnv);
+-
+- (* We need to check that no top-level value has a free type
+- variable in its type. We can only do that once unification
+- is complete because one declaration may "freeze" the type of
+- another within a single "topdec".
+- Don't do this check if we've already reported an error.
+- Mistyped top-level functions are given type ('a) which then
+- would be reported as an error here. *)
+- val U: unit =
+- if errorOccurred lex then ()
+- else STRUCTURES.checkForFreeTypeVars(#apply newValEnv, #apply newStrEnv,
+- #apply newFuncEnv, lex);
+-
+- val pass2Time = cpuTime startTime;
+-
+- val U : unit =
+- if errorOccurred lex
+- then (resetLexan lex; raise Fail "Static errors (pass2)")
++ then compilerOutput (STRUCTURES.displayProgram (parseTree, 10000))
+ else ();
+-
+- (* Only code-generate if there were no errors and
+- it's not a directive. *)
+- val optimisedCode : CODETREE.codetree =
+- STRUCTURES.gencodeStructs (parseTree, lex);
+- val treeTime = cpuTime startTime;
+-
+- val U : unit =
+- if errorOccurred lex
+- then (* Errors can be produced during the code-generation phase. *)
+- (resetLexan lex; raise Fail "Static errors (pass3)")
+- else ();
+-
+- val UUU:unit =
+- if printCodetree
+- then let
+- val pstream = prettyPrint (77, compilerOutput);
+- in
+- ppBeginBlock pstream (0, false);
+- CODETREE.pretty (optimisedCode, pstream);
+- ppEndBlock pstream ()
+- end
+- else ();
+-
+- val resultCode : unit -> CODETREE.codetree =
+- CODETREE.genCode(optimisedCode, debugSwitches);
+- val codeTime = cpuTime startTime;
+-
+- in (* let2 *)
+- (* This is the procedure which is returned as the result of
+- the compilation. *)
+- fn () =>
+- let (* let3 *)
+- (* Save the value of the profiling switch,
+- and switch profiling on if required. *)
+- val wasProfiling = profiling;
+
+- val startRunTime = Timer.startCPUTimer(); (* Save the run-time *)
+- val () = startProfile wasProfiling;
+-
+- val resultVec = (* Now run it *)
+- resultCode ()
+- handle exn => (* Exceptions in run-time code. *)
+- let
+- val () = stopProfile wasProfiling;
+- val endRunTime = cpuTime startRunTime;
+- (* if we are profiling, stop and force out the profile counts *)
+- val () = stopProfile wasProfiling;
+- in
+- (* print out timing info *)
+- if timing then printTimes compilerOutput (parseTime,pass2Time,treeTime,codeTime,endRunTime) else ();
+- raise exn
+- end
+-
+- val () = stopProfile wasProfiling;
+- val endRunTime = cpuTime startRunTime;
+-
+- val extractedResults = STRUCTURES.pass4Structs (resultVec, parseTree)
+-
+- in (* let3 *)
+- (* print out timing info *)
+- if timing then printTimes compilerOutput (parseTime,pass2Time,treeTime,codeTime,endRunTime) else ();
+-
+- extractedResults
+- end (* let3 *)
+- end (* let2 *)
+- end; (* let1 *)
+-
+- fun compiler (nameSpace: nameSpace, getChar: unit->char option, parameters: Universal.universal list) : unit ->
+- { fixes: (string * fixStatus) list, values: (string * values) list,
+- structures: (string * structVals) list, signatures: (string * signatures) list,
+- functors: (string * functors) list, types: (string * typeConstrs) list } =
++ in (* let2 *)
++ if errorOccurred lex
++ then (NONE, NONE) (* Error: No result and the parse tree won't be useful. *)
++ else let (* let3 *)
++ (* If no errors then do second pass to match identifiers
++ and declarations and return type of expression. *)
++ val () = STRUCTURES.pass2Structs (parseTree, lex, Env globals);
++
++ val pass2Time = cpuTime startTime;
++
++ in (* let3 *)
++ if errorOccurred lex
++ then (SOME(structsExportTree(parentTreeNav, parseTree)), NONE)
++ else let (* let4 *)
++
++ (* Only code-generate if there were no errors and
++ it's not a directive. *)
++ val optimisedCode : CODETREE.codetree =
++ STRUCTURES.gencodeStructs (parseTree, lex);
++ val treeTime = cpuTime startTime;
++
++ in
++ if errorOccurred lex
++ then (* Errors can be produced during the code-generation phase. *)
++ (SOME(structsExportTree(parentTreeNav, parseTree)), NONE) (* Error: No result. *)
++ else let (* let5 *)
++ val () =
++ if printCodetree
++ then compilerOutput(CODETREE.pretty optimisedCode)
++ else ();
++
++ val resultCode : unit -> CODETREE.codetree =
++ CODETREE.genCode(optimisedCode, debugSwitches);
++ val codeTime = cpuTime startTime;
++
++ (* This is the procedure which is returned as the result of
++ the compilation. *)
++ fun executeCode() =
++ let
++ (* Save the value of the profiling switch,
++ and switch profiling on if required. *)
++ val wasProfiling = profiling;
++
++ val startRunTime = Timer.startCPUTimer(); (* Save the run-time *)
++ val () = startProfile wasProfiling;
++
++ val resultVec = (* Now run it *)
++ (* If we were profiling or timing we have to handle the exception to turn
++ these off even though it will mess up information about where the exception
++ was raised. *)
++ if wasProfiling <> 0 orelse timing
++ then
++ (
++ resultCode ()
++ handle exn => (* Exceptions in run-time code. *)
++ let
++ val () = stopProfile wasProfiling;
++ val endRunTime = cpuTime startRunTime;
++ (* if we are profiling, stop and force out the profile counts *)
++ val () = stopProfile wasProfiling;
++ in
++ (* print out timing info *)
++ if timing then printTimes compilerOutput (parseTime,pass2Time,treeTime,codeTime,endRunTime) else ();
++ raise exn
++ end
++ )
++ else resultCode ()
++
++ val () = stopProfile wasProfiling;
++ val endRunTime = cpuTime startRunTime;
++
++ val extractedResults = STRUCTURES.pass4Structs (resultVec, parseTree)
++
++ in
++ (* print out timing info *)
++ if timing then printTimes compilerOutput (parseTime,pass2Time,treeTime,codeTime,endRunTime) else ();
++
++ extractedResults
++ end
++
++ in
++ (SOME(structsExportTree (parentTreeNav, parseTree)), SOME executeCode)
++ end (* let5 *)
++ end (* let4 *)
++ end (* let3 *)
++ end (* let2 *)
++ end; (* let1 *)
++
++ fun compiler (nameSpace: nameSpace, getChar: unit->char option, parameters: Universal.universal list) :
++ exportTree option * (unit ->
++ { fixes: (string * fixStatus) list, values: (string * values) list,
++ structures: (string * structVals) list, signatures: (string * signatures) list,
++ functors: (string * functors) list, types: (string * typeConstrs) list }) option =
+ let
+ val debugSwitches = parameters
+ val lex = LEX.initial(getChar, debugSwitches);
+ val traceCompiler = DEBUG.getParameter DEBUG.traceCompilerTag debugSwitches
+- val compilerOutput = DEBUG.getParameter DEBUG.compilerOutputTag debugSwitches
++
++ val compilerOutput = getCompilerOutput parameters
++ fun printReport s = compilerOutput(PrettyString s)
+ in
+ (
+ if traceCompiler
+@@ -650,29 +392,25 @@
+ handle
+ SML90.Interrupt =>
+ (
+- LEX.flushLexan lex; (* No longer needed? *)
+- compilerOutput ("Compilation interrupted\n");
++ printReport ("Compilation interrupted\n");
+ raise SML90.Interrupt
+ )
+-
+- | Fail s =>
+- raise Fail s (* static errors - caught by next level up *)
+
+ | InternalError s =>
+ let
+ val s' =
+ "Exception- InternalError: " ^ String.toString s ^ " raised while compiling"
+ in
+- compilerOutput (s' ^ "\n");
++ printReport (s' ^ "\n");
+ raise Fail s'
+ end
+
+ | exn =>
+ let
+ val s' =
+- "Exception- " ^ VALUEOPS.exnName exn ^ " unexpectedly raised while compiling"
++ "Exception- " ^ General.exnName exn ^ " unexpectedly raised while compiling"
+ in
+- compilerOutput (s' ^ "\n");
++ printReport (s' ^ "\n");
+ raise Fail s'
+ end
+ end
+Only in mlsource/MLCompiler: COPIER.sml
+Only in mlsource/MLCompiler: COPIERSIG.sml
+diff -u -r mlsource/MLCompiler/CodeTree/AMD64CODECONS.ML mlsource/MLCompiler/CodeTree/AMD64CODECONS.ML
+--- mlsource/MLCompiler/CodeTree/AMD64CODECONS.ML 2008-04-25 14:06:27.000000000 +0200
++++ mlsource/MLCompiler/CodeTree/AMD64CODECONS.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -45,20 +45,14 @@
+ structure DEBUG :
+ sig
+ val assemblyCodeTag : bool Universal.tag
+- val compilerOutputTag: (string->unit) Universal.tag
+ val getParameter :
+ 'a Universal.tag -> Universal.universal list -> 'a
+ end;
+
+-
+-
+ (*****************************************************************************)
+-(* MISC *)
++(* PRETTY for compilerOutTag *)
+ (*****************************************************************************)
+-structure MISC :
+-sig
+- exception InternalError of string
+-end;
++structure PRETTY: PRETTYSIG
+
+ ) :
+
+@@ -232,66 +226,15 @@
+ val traceContext: code -> string;
+ end (* CODECONS export signature *) =
+
+-
+-let
+-
+-(*****************************************************************************)
+-(* ADDRESS *)
+-(*****************************************************************************)
+-structure ADDRESS :
+-sig
+- type machineWord; (* NB *not* eqtype, 'cos it might be a closure *)
+- type short = Word.word;
+- type address;
+- type handler;
+-
+- val wordEq : machineWord * machineWord -> bool
+-
+- val isShort: 'a -> bool;
+- val toShort: 'a -> short;
+- val toMachineWord: 'a -> machineWord;
+-
+- val offsetAddr : address * short -> handler
+-
+- val alloc: (short * Word8.word * machineWord) -> address
+- val F_words : Word8.word
+-
+- val lock : address -> unit;
+-
+- val wordSize: int
+-end = Address;
+-
+-(*****************************************************************************)
+-(* CODESEG *)
+-(*****************************************************************************)
+-structure CODESEG :
+-sig
+- type machineWord;
+- type short;
+- type address;
+- type cseg;
+-
+- val csegMake: int -> cseg;
+- val csegConvertToCode: cseg -> unit;
+- val csegLock: cseg -> unit;
+- val csegGet: cseg * int -> Word8.word;
+- val csegSet: cseg * int * Word8.word -> unit;
+- val csegPutWord: cseg * int * machineWord -> unit;
+- val csegCopySeg: cseg * cseg * int * int -> unit;
+- val csegAddr: cseg -> address;
+- val csegPutConstant: cseg * int * machineWord * 'a -> unit;
+-end = CodeSeg;
+-
+-in
+-
+ (*****************************************************************************)
+ (* CODECONS functor body *)
+ (*****************************************************************************)
+ struct
+- open CODESEG;
++ open CodeSeg;
+ open DEBUG;
+- open ADDRESS;
+- open MISC;
++ open PRETTY
++ open Address;
++ open Misc;
+
+ val toInt = Word.toIntX (* This previously just cast the value so continue to treat it as signed. *)
+
+@@ -479,6 +422,9 @@
+
+ (* create and initialise a code segment *)
+ fun codeCreate (noClosure : bool, name : string, parameters) : code =
++ let
++ val printStream = PRETTY.getSimplePrinter parameters;
++ in
+ Code
+ {
+ codeVec = csegMake initialCodeSize, (* a byte array *)
+@@ -501,8 +447,9 @@
+ noClosure = noClosure,
+ branchCheck = ref addrZero,
+ printAssemblyCode = DEBUG.getParameter DEBUG.assemblyCodeTag parameters,
+- printStream = DEBUG.getParameter DEBUG.compilerOutputTag parameters
+- };
++ printStream = printStream
++ }
++ end;
+
+
+ (* Put 1 unsigned byte at a given offset in the segment. *)
+@@ -4096,7 +4043,7 @@
+ val nopCode : int list =
+ let
+ (* Add sufficient No-ops to round this to a full word. *)
+- val len = length stackCheckCode mod wordSize
++ val len = List.length stackCheckCode mod wordSize
+ in
+ if len = 0
+ then []
+@@ -4105,13 +4052,13 @@
+
+ in
+ val preludeCode = nopCode @ stackCheckCode;
+- val wordsForPrelude = length preludeCode div wordSize
++ val wordsForPrelude = List.length preludeCode div wordSize
+
+ (* +5 for code size, profile count, function name, register mask and constants count *)
+ val segSize = (getAddr (!ic)) div wordSize + constsInConstArea + wordsForPrelude + 5;
+
+ (* byte offset of L2 label relative to start of post-prelude code. *)
+- val L2Addr = mkAddr (~ (length stackCheckCode));
++ val L2Addr = mkAddr (~ (List.length stackCheckCode));
+ end; (* local *)
+
+ (* fix-up all the self-calls *)
+@@ -4299,6 +4246,4 @@
+ (* Function name and code offset to help tracing. *)
+ procName ^ ":" ^ Int.fmt StringCvt.HEX (getAddr ic)
+
+-end (* struct *)
+-
+ end (* CODECONS *);
+diff -u -r mlsource/MLCompiler/CodeTree/BaseCodeTree.sml mlsource/MLCompiler/CodeTree/BaseCodeTree.sml
+--- mlsource/MLCompiler/CodeTree/BaseCodeTree.sml 2008-04-21 13:30:51.000000000 +0200
++++ mlsource/MLCompiler/CodeTree/BaseCodeTree.sml 2009-09-15 08:56:45.000000000 +0200
+@@ -157,7 +157,7 @@
+ makeClosure : bool
+ };
+
+- open PrettyPrinter
++ open Pretty
+
+ val ioOp : int -> machineWord = RunCall.run_call1 RuntimeCalls.POLY_SYS_io_operation;
+
+@@ -188,286 +188,268 @@
+ end
+ else "<long>";
+
+- fun pretty (pt : codetree, pprint: prettyPrinter) : unit =
++ fun pretty (pt : codetree) : pretty =
+ let
+- fun pList ([]: 'b list) (sep: string) (disp: 'b->unit) = ()
+- | pList [h] sep disp = disp h
++ fun pList ([]: 'b list) (_: string) (_: 'b->pretty) = []
++ | pList [h] _ disp = [disp h]
+ | pList (h::t) sep disp =
+- (
+- ppBeginBlock pprint (0, false);
+- disp h;
+- ppBreak pprint (0, 0);
+- ppAddString pprint sep;
+- ppEndBlock pprint ();
+- ppBreak pprint (1, 0);
++ PrettyBlock (0, false, [],
++ [
++ disp h,
++ PrettyBreak (0, 0),
++ PrettyString sep
++ ]
++ ) ::
++ PrettyBreak (1, 0) ::
+ pList t sep disp
+- );
+
+- fun printList start lst sep =
+- (
+- ppBeginBlock pprint (1, true);
+- ppAddString pprint (start ^ "(");
+- pList lst sep (fn x => (pretty (x, pprint)));
+- ppBreak pprint (0, 0);
+- ppAddString pprint (")");
+- ppEndBlock pprint ()
+- );
++ fun printList start lst sep : pretty =
++ PrettyBlock (1, true, [],
++ PrettyString (start ^ "(") ::
++ pList lst sep (fn x => (pretty x)) @
++ [ PrettyBreak (0, 0), PrettyString (")") ]
++ )
+
+ fun printMonad name pt =
+- (
+- ppBeginBlock pprint (1, true);
+- ppAddString pprint (name^"(");
+- pretty (pt, pprint);
+- ppBreak pprint (0, 0);
+- ppAddString pprint (")");
+- ppEndBlock pprint ()
+- );
++ PrettyBlock (1, true, [],
++ [
++ PrettyString (name^"("),
++ pretty pt,
++ PrettyBreak (0, 0),
++ PrettyString (")")
++ ]
++ )
+
+ fun printDiad name (f,s) =
+- (
+- ppBeginBlock pprint (1, true);
+- ppAddString pprint (name^"(");
+- pretty (f, pprint);
+- ppAddString pprint ", ";
+- ppBreak pprint (0, 0);
+- pretty (s, pprint);
+- ppBreak pprint (0, 0);
+- ppAddString pprint (")");
+- ppEndBlock pprint ()
+- );
++ PrettyBlock (1, true, [],
++ [
++ PrettyString (name^"("),
++ pretty f,
++ PrettyString ", ",
++ PrettyBreak (0, 0),
++ pretty s,
++ PrettyBreak (0, 0),
++ PrettyString (")")
++ ]
++ )
+
+ fun printTriad name (f,s,t) =
+- (
+- ppBeginBlock pprint (1, true);
+- ppAddString pprint (name^"(");
+- pretty(f, pprint);
+- ppAddString pprint ", ";
+- ppBreak pprint (0, 0);
+- pretty(s, pprint);
+- ppAddString pprint ", ";
+- ppBreak pprint (0, 0);
+- pretty (t, pprint);
+- ppBreak pprint (0, 0);
+- ppAddString pprint (")");
+- ppEndBlock pprint ()
+- );
++ PrettyBlock (1, true, [],
++ [
++ PrettyString (name^"("),
++ pretty f,
++ PrettyString ", ",
++ PrettyBreak (0, 0),
++ pretty s,
++ PrettyString ", ",
++ PrettyBreak (0, 0),
++ pretty t,
++ PrettyBreak (0, 0),
++ PrettyString (")")
++ ]
++ )
+
+ in
+ case pt of
+- CodeNil => ppAddString pprint "NIL"
++ CodeNil => PrettyString "NIL"
+
+- | MatchFail => ppAddString pprint "MATCHFAIL"
++ | MatchFail => PrettyString "MATCHFAIL"
+
+ | AltMatch pair => printDiad "ALTMATCH" pair
+
+ | Eval {function, argList, earlyEval} =>
+- (
+- ppBeginBlock pprint (3, false);
+- pretty (function, pprint);
+- ppBreak pprint (0, 0);
+- if earlyEval
+- then
+- (
+- ppAddString pprint "{early}";
+- ppBreak pprint (0, 0)
+- )
+- else ();
+- printList "$" argList ",";
+- ppEndBlock pprint ()
+- )
++ PrettyBlock (3, false, [],
++ pretty function ::
++ PrettyBreak (0, 0) ::
++ (
++ if earlyEval
++ then [ PrettyString "{early}", PrettyBreak (0, 0) ]
++ else []
++ ) @
++ [ printList "$" argList "," ]
++ )
+
+ | Declar {value, addr, references} =>
+- (
+- ppBeginBlock pprint (1, false);
+- ppAddString pprint (concat
+- ["DECL #",
+- Int.toString addr,
+- "{",
+- Int.toString references,
+- " uses} ="]);
+- ppBreak pprint (1, 0);
+- pretty (value, pprint);
+- ppEndBlock pprint ()
+- )
++ PrettyBlock (1, false, [],
++ [
++ PrettyString (concat
++ ["DECL #", Int.toString addr, "{", Int.toString references, " uses} ="]),
++ PrettyBreak (1, 0),
++ pretty value
++ ]
++ )
+
+ | Extract {addr, level, fpRel, lastRef} =>
+- let
+- val last = if lastRef then ", last" else "";
+- val str : string =
+- if not fpRel
+- then concat ["CLOS(", Int.toString level, ",", Int.toString addr, last, ")"]
+- else if addr < 0
+- then concat ["PARAM(", Int.toString level, ",", Int.toString (~ addr), last, ")"]
+- else concat ["LOCAL(", Int.toString level, ",", Int.toString addr, last, ")"]
+- in
+- ppAddString pprint str
+- end
++ let
++ val last = if lastRef then ", last" else "";
++ val str : string =
++ if not fpRel
++ then concat ["CLOS(", Int.toString level, ",", Int.toString addr, last, ")"]
++ else if addr < 0
++ then concat ["PARAM(", Int.toString level, ",", Int.toString (~ addr), last, ")"]
++ else concat ["LOCAL(", Int.toString level, ",", Int.toString addr, last, ")"]
++ in
++ PrettyString str
++ end
+
+ | Indirect {base, offset} =>
+- let
+- val str = "INDIRECT(" ^ Int.toString offset ^ ", ";
+- in
+- ppAddString pprint str;
+- pretty (base, pprint);
+- ppAddString pprint ")"
+- end
++ let
++ val str = "INDIRECT(" ^ Int.toString offset ^ ", ";
++ in
++ PrettyBlock(0, false, [],
++ [ PrettyString str, pretty base, PrettyString ")" ]
++ )
++ end
+
+ | Lambda {body, isInline, name, closure, numArgs, level, closureRefs, makeClosure} =>
+- let
+- val inl =
+- case isInline of
+- NonInline => ""
+- | MaybeInline => "INLINE"
+- | SmallFunction => "SMALL"
+- | OnlyInline => "ONLYINLINE"
+- in
+- ppBeginBlock pprint (1, true);
+- ppAddString pprint ("LAMBDA"^inl^"(");
+- ppBreak pprint (1, 0);
+- ppAddString pprint name;
+- ppBreak pprint (1, 0);
+- ppAddString pprint ( "CL=" ^ Bool.toString makeClosure);
+- ppAddString pprint (" CR=" ^ Int.toString closureRefs);
+- ppAddString pprint (" LEV=" ^ Int.toString level);
+- ppAddString pprint (" ARGS=" ^ Int.toString numArgs);
+- printList " CLOS=" closure ",";
+- ppBreak pprint (1, 0);
+- pretty (body, pprint);
+- ppAddString pprint "){LAMBDA}";
+- ppEndBlock pprint ()
+- end
++ let
++ val inl =
++ case isInline of
++ NonInline => ""
++ | MaybeInline => "INLINE"
++ | SmallFunction => "SMALL"
++ | OnlyInline => "ONLYINLINE"
++ in
++ PrettyBlock (1, true, [],
++ [
++ PrettyString ("LAMBDA"^inl^"("),
++ PrettyBreak (1, 0),
++ PrettyString name,
++ PrettyBreak (1, 0),
++ PrettyString ( "CL=" ^ Bool.toString makeClosure),
++ PrettyString (" CR=" ^ Int.toString closureRefs),
++ PrettyString (" LEV=" ^ Int.toString level),
++ PrettyString (" ARGS=" ^ Int.toString numArgs),
++ printList " CLOS=" closure ",",
++ PrettyBreak (1, 0),
++ pretty body,
++ PrettyString "){LAMBDA}"
++ ]
++ )
++ end
+
+- | Constnt w => ppAddString pprint ("LIT" ^ stringOfWord w)
++ | Constnt w => PrettyString ("LIT" ^ stringOfWord w)
+
+ | Cond triple => printTriad "IF" triple
+
+ | Newenv ptl => printList "BLOCK" ptl ";"
+
+ | BeginLoop(loopExp, args) =>
+- (
+- ppBeginBlock pprint (3, false);
+- printList "BEGINLOOP" args ",";
+- ppBreak pprint (0, 0);
+- ppAddString pprint "(";
+- ppBreak pprint (0, 0);
+- pretty (loopExp, pprint);
+- ppBreak pprint (0, 0);
+- ppAddString pprint ")";
+- ppEndBlock pprint ()
+- )
++ PrettyBlock (3, false, [],
++ [
++ printList "BEGINLOOP" args ",",
++ PrettyBreak (0, 0),
++ PrettyString "(",
++ PrettyBreak (0, 0),
++ pretty loopExp,
++ PrettyBreak (0, 0),
++ PrettyString ")"
++ ]
++ )
+
+ | Loop ptl => printList "LOOP" ptl ","
+
+ | Raise c => printMonad "RAISE" c
+
+- | Handle {exp, taglist, handler} =>
+- (
+- ppBeginBlock pprint (3, false);
+- ppAddString pprint "HANDLE(";
+- pretty (exp, pprint);
+- ppAddString pprint "WITH";
+- ppBreak pprint (1, 0);
+- pretty (handler, pprint);
+- ppAddString pprint ")";
+- ppEndBlock pprint ()
+- )
++ | Handle {exp, handler, ...} =>
++ PrettyBlock (3, false, [],
++ [
++ PrettyString "HANDLE(",
++ pretty exp,
++ PrettyString "WITH",
++ PrettyBreak (1, 0),
++ pretty handler,
++ PrettyString ")"
++ ]
++ )
+
+- | Ldexc => ppAddString pprint "LDEXC"
++ | Ldexc => PrettyString "LDEXC"
+
+ | Case {cases, test, default, min, max} =>
+- (
+- ppBeginBlock pprint (1, true);
+- ppAddString pprint
+- (concat ["CASE ", Int.toString min, "-", Int.toString max, "(" ]);
+- pretty (test, pprint);
+- ppAddString pprint ")";
+- ppBreak pprint (1, 0);
+- ppAddString pprint "(";
+- ppBreak pprint (1, 0);
+- pList cases ","
+- (fn (exp : codetree, labels : int list) =>
+- (
+- ppBeginBlock pprint (1, true);
+- List.app (fn l =>
+- (
+- ppAddString pprint (Int.toString l ^ ":");
+- ppBreak pprint (1, 0)
+- )
+- ) labels;
+- pretty (exp, pprint);
+- ppEndBlock pprint ()
+- )
+- );
+- case default of
+- CodeNil => ()
+- | _ =>
+- (
+- ppBreak pprint (1, 0);
+- ppBeginBlock pprint (1, false);
+- ppAddString pprint "ELSE:";
+- ppBreak pprint (1, 0);
+- pretty (default, pprint);
+- ppEndBlock pprint ()
+- );
+- ppBreak pprint (1, 0);
+- ppAddString pprint (") {"^"CASE"^"}");
+- ppEndBlock pprint ()
+- )
++ PrettyBlock (1, true, [],
++ PrettyString
++ (concat ["CASE ", Int.toString min, "-", Int.toString max, "(" ]) ::
++ pretty test ::
++ PrettyBreak (1, 0) ::
++ PrettyString "(" ::
++ PrettyBreak (1, 0) ::
++ pList cases ","
++ (fn (exp : codetree, labels : int list) =>
++ PrettyBlock (1, true, [],
++ List.foldr (
++ fn (l, t) =>
++ PrettyString (Int.toString l ^ ":") ::
++ PrettyBreak (1, 0) :: t
++ ) [pretty exp] labels
++ )
++ ) @
++ (
++ case default of
++ CodeNil => []
++ | _ =>
++ [
++ PrettyBreak (1, 0),
++ PrettyBlock (1, false, [],
++ [
++ PrettyString "ELSE:",
++ PrettyBreak (1, 0),
++ pretty default
++ ]
++ )
++ ]
++ ) @
++ [ PrettyBreak (1, 0), PrettyString (") {"^"CASE"^"}") ]
++ )
+
+- | MutualDecs ptl => printList "MUTUAL" ptl " AND "
++ | MutualDecs ptl =>
++ printList "MUTUAL" ptl " AND "
+
+- | Recconstr ptl => printList "RECCONSTR" ptl ","
++ | Recconstr ptl =>
++ printList "RECCONSTR" ptl ","
+
+- | Container size => ppAddString pprint ("CONTAINER " ^ Int.toString size)
++ | Container size => PrettyString ("CONTAINER " ^ Int.toString size)
+
+ | SetContainer{container, tuple, size} =>
+- (
+- ppBeginBlock pprint (3, false);
+- ppAddString pprint ("SETCONTAINER(" ^ Int.toString size ^ ", ");
+- pretty (container, pprint);
+- ppBreak pprint (0, 0);
+- ppAddString pprint ",";
+- ppBreak pprint (1, 0);
+- pretty (tuple, pprint);
+- ppBreak pprint (0, 0);
+- ppAddString pprint ")";
+- ppEndBlock pprint ()
+- )
++ PrettyBlock (3, false, [],
++ [
++ PrettyString ("SETCONTAINER(" ^ Int.toString size ^ ", "),
++ pretty container,
++ PrettyBreak (0, 0),
++ PrettyString ",",
++ PrettyBreak (1, 0),
++ pretty tuple,
++ PrettyBreak (0, 0),
++ PrettyString ")"
++ ]
++ )
+
+ | TupleFromContainer (container, size) =>
+- (
+- ppBeginBlock pprint (3, false);
+- ppAddString pprint ("TUPLECONTAINER(" ^ Int.toString size ^ ", ");
+- ppBreak pprint (0, 0);
+- pretty (container, pprint);
+- ppBreak pprint (0, 0);
+- ppAddString pprint ")";
+- ppEndBlock pprint ()
+- )
+-
+- | Global glob =>
+- (
+- ppBeginBlock pprint (1, true);
+- ppAddString pprint "GLOBAL ";
+- prettyOptVal (glob, pprint);
+- ppAddString pprint " (*GLOBAL*)";
+- ppEndBlock pprint ()
+- )
++ PrettyBlock (3, false, [],
++ [
++ PrettyString ("TUPLECONTAINER(" ^ Int.toString size ^ ", "),
++ PrettyBreak (0, 0),
++ pretty container,
++ PrettyBreak (0, 0),
++ PrettyString ")"
++ ]
++ )
++
++ | Global ov =>
++ PrettyBlock (1, true, [],
++ [
++ PrettyString "GLOBAL (",
++ pretty (optGeneral ov),
++ PrettyString ", ",
++ PrettyBreak (1, 0),
++ pretty (optSpecial ov),
++ PrettyBreak (1, 0),
++ PrettyString ") (*GLOBAL*)"
++ ]
++ )
+
+ (* That list should be exhaustive! *)
+ end (* pretty *)
+-
+- and prettyOptVal (ov : optVal, pprint : prettyPrinter) =
+- (
+- ppAddString pprint "(";
+- pretty (optGeneral ov, pprint);
+- ppAddString pprint ", ";
+- ppBreak pprint (1, 0);
+- pretty (optSpecial ov, pprint);
+- ppBreak pprint (1, 0);
+- ppAddString pprint ")"
+- )
+-
++
+ and optGeneral (OptVal {general,...}) = general
+ | optGeneral (ValWithDecs {general, ...}) = general
+ | optGeneral (JustTheVal ct) = ct
+@@ -510,7 +492,7 @@
+ | Ldexc => 1
+ | Handle {exp,taglist,handler} => size exp + size handler + sizeList taglist + List.length taglist
+ | Recconstr cl => sizeList cl + 2 (* optimistic *)
+- | Container size => 1 (* optimistic *)
++ | Container _ => 1 (* optimistic *)
+ | SetContainer{container, tuple = Recconstr cl, ...} =>
+ (* We can optimise this. *) sizeList cl + size container
+ | SetContainer{container, tuple, size=len} => size container + size tuple + len
+diff -u -r mlsource/MLCompiler/CodeTree/BaseCodeTreeSig.sml mlsource/MLCompiler/CodeTree/BaseCodeTreeSig.sml
+--- mlsource/MLCompiler/CodeTree/BaseCodeTreeSig.sml 2008-04-21 13:30:51.000000000 +0200
++++ mlsource/MLCompiler/CodeTree/BaseCodeTreeSig.sml 2009-09-15 08:56:45.000000000 +0200
+@@ -22,7 +22,7 @@
+ (* Signature for the basic codetree types and operations. *)
+ signature BaseCodeTreeSig =
+ sig
+- type machineWord
++ type machineWord = Address.machineWord
+
+ datatype inlineStatus =
+ NonInline
+@@ -155,8 +155,9 @@
+ makeClosure : bool
+ };
+
+- type prettyPrinter
+- val pretty : codetree * prettyPrinter -> unit
+ val isSmall : codetree * int -> bool
+
++ type pretty
++ val pretty : codetree -> pretty
++
+ end;
+diff -u -r mlsource/MLCompiler/CodeTree/CODETREE.ML mlsource/MLCompiler/CodeTree/CODETREE.ML
+--- mlsource/MLCompiler/CodeTree/CODETREE.ML 2008-05-09 17:08:02.000000000 +0200
++++ mlsource/MLCompiler/CodeTree/CODETREE.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -34,7 +34,7 @@
+ (*****************************************************************************)
+ structure GCODE :
+ sig
+- type machineWord
++ type machineWord = Address.machineWord
+ type codetree
+ val gencode: codetree * Universal.universal list -> unit -> machineWord;
+ end (* GCODE *);
+@@ -47,70 +47,18 @@
+ val codetreeTag: bool Universal.tag (* If true then print the original code. *)
+ val codetreeAfterOptTag: bool Universal.tag (* If true then print the optimised code. *)
+ val maxInlineSizeTag: int Universal.tag
+- val compilerOutputTag: (string->unit) Universal.tag
+ val getParameter :
+ 'a Universal.tag -> Universal.universal list -> 'a
+ end (* DEBUG *);
+
+ (*****************************************************************************)
+-(* PRETTYPRINTER *)
++(* Pretty data structure *)
+ (*****************************************************************************)
+-structure PRETTYPRINTER :
+-sig
+- type prettyPrinter
+-
+- val ppAddString : prettyPrinter -> string -> unit
+- val ppBeginBlock : prettyPrinter -> int * bool -> unit
+- val ppEndBlock : prettyPrinter -> unit -> unit
+- val ppBreak : prettyPrinter -> int * int -> unit
+-
+- val prettyPrint : int * (string -> unit) -> prettyPrinter;
+-end;
+-
+-(*****************************************************************************)
+-(* MISC *)
+-(*****************************************************************************)
+-structure MISC :
+-sig
+- exception InternalError of string;
+-end;
+-
+-(* DCJM 8/8/00. Previously Address was a global but we aren't allowed
+- to have sharing constraints with globals in ML97. We could use a
+- "where type" constraint but then we couldn't bootstrap from ML90. *)
+-structure ADDRESS :
+-sig
+- type machineWord;
+- type short = Word.word;
+- type address;
+-
+- val alloc: short * Word8.word * machineWord -> address;
+- val call: address * machineWord -> machineWord;
+- val length: address -> short;
+-
+- val isShort: 'a -> bool;
+- val toShort: 'a -> short;
+- val toMachineWord: 'a -> machineWord;
+- val toAddress: machineWord -> address;
+-
+- val wordEq: machineWord * machineWord -> bool;
+-
+- val isWords : address -> bool;
+- val isMutable: address -> bool;
+-
+- val assignWord: address * short * machineWord -> unit;
+- val loadWord: address * short -> machineWord;
+- val F_words: Word8.word;
+- val F_mutable: Word8.word;
+- val lock: address -> unit
+-
+- val isIoAddress : address -> bool
+-end;
+-
++structure PRETTY : PRETTYSIG
+
+ structure STRUCTUREEQ:
+ sig
+- type machineWord
++ type machineWord = Address.machineWord
+ val structureEq: machineWord * machineWord -> bool;
+ end
+
+@@ -119,90 +67,27 @@
+ (*****************************************************************************)
+ (* CODETREE sharing constraints *)
+ (*****************************************************************************)
+-
+ sharing type
+- ADDRESS.machineWord
+-= BASECODETREE.machineWord
+-= STRUCTUREEQ.machineWord
+-= GCODE.machineWord
++ PRETTY.pretty
++= BASECODETREE.pretty
+
+ sharing type
+ BASECODETREE.codetree
+ = GCODE.codetree
+-
+-sharing type
+- PRETTYPRINTER.prettyPrinter
+-= BASECODETREE.prettyPrinter
+-
+-) :
+-
+-(*****************************************************************************)
+-(* CODETREE export signature *)
+-(*****************************************************************************)
+-sig
+- type machineWord
+- type codetree
+- type prettyPrinter
+-
+- val isCodeNil: codetree -> bool;
+- val CodeNil: codetree; (* Empty codetree NOT the code for "nil" *)
+- val CodeTrue: codetree; (* code for "true" *)
+- val CodeFalse: codetree; (* code for "false" *)
+- val CodeZero: codetree; (* code for 0, nil etc. *)
+-
+- val MatchFail: codetree; (* pattern match has failed *)
+- val mkAltMatch: codetree * codetree -> codetree;
+-
+- val mkRecLoad: int-> codetree;
+- val mkLoad: int * int -> codetree;
+- val mkConst: machineWord -> codetree;
+- val mkDec: int * codetree -> codetree;
+- val mkInd: int * codetree -> codetree;
+- val mkProc: codetree * int * int * string -> codetree;
+- val mkInlproc: codetree * int * int * string -> codetree;
+- val mkMacroProc: codetree * int * int * string -> codetree;
+- val mkIf: codetree * codetree * codetree -> codetree;
+- val mkWhile: codetree * codetree -> codetree;
+- val mkEnv: codetree list -> codetree;
+- val mkStr: string -> codetree;
+- val mkTuple: codetree list -> codetree;
+- val mkMutualDecs: codetree list -> codetree;
+- val mkRaise: codetree -> codetree;
+- val mkNot: codetree -> codetree;
+- val mkTestnull: codetree -> codetree;
+- val mkTestnotnull: codetree -> codetree;
+- val mkCor: codetree * codetree -> codetree;
+- val mkCand: codetree * codetree -> codetree;
+- val mkTestptreq: codetree * codetree -> codetree;
+- val mkTestinteq: codetree * codetree -> codetree;
+- val mkHandle: codetree * codetree list * codetree -> codetree;
+- val mkEval: codetree * codetree list * bool -> codetree;
+- val identityFunction: string -> codetree;
+- val Ldexc: codetree;
+- val mkContainer: int -> codetree
+- val mkSetContainer: codetree * codetree * int -> codetree
+- val mkTupleFromContainer: codetree * int -> codetree
+-
+- val multipleUses: codetree * (unit -> int) * int -> {load: int -> codetree, dec: codetree list};
+-
+- val pretty: codetree * prettyPrinter -> unit;
+- val evalue: codetree -> machineWord;
+- val genCode: codetree * Universal.universal list -> (unit -> codetree);
+-
+- val structureEq: machineWord * machineWord -> bool;
+-end (* CODETREE export signature *) =
++) : CODETREESIG =
+
+ (*****************************************************************************)
+ (* CODETREE functor body *)
+ (*****************************************************************************)
+ struct
+ open GCODE;
+- open ADDRESS;
++ open Address;
+ open StretchArray;
+- open MISC; (* after ADDRESS, so we get MISC.length, not ADDRESS.length *)
+ open RuntimeCalls; (* for POLY_SYS numbers and EXC_nil *)
+ open BASECODETREE;
+- open PRETTYPRINTER;
++ open PRETTY;
++
++ val InternalError = Misc.InternalError
+
+ val structureEq = STRUCTUREEQ.structureEq
+
+@@ -228,7 +113,7 @@
+ to get the value.
+ *)
+
+- fun errorEnv (lf: loadForm, i1: int, i2: int) : optVal =
++ fun errorEnv (_: loadForm, _: int, _: int) : optVal =
+ raise InternalError "error env";
+
+ fun optGeneral (OptVal {general,...}) = general
+@@ -243,23 +128,20 @@
+
+ fun optDecs (OptVal {decs,...}) = decs
+ | optDecs (ValWithDecs {decs, ...}) = decs
+- | optDecs (JustTheVal pt) = [];
++ | optDecs (JustTheVal _) = [];
+
+ fun optRec (OptVal {recCall,...}) = recCall
+ | optRec _ = ref false; (* Generate a temporary. *)
+
+ val simpleOptVal : codetree -> optVal = JustTheVal;
+
+- fun optVal (ov as {general, special, environ, decs, recCall}) : optVal =
++ fun optVal (ov as {general, special, decs, ...}) : optVal =
+ if isCodeNil special
+ then
+ case decs of
+ [] => JustTheVal general
+ | _ => ValWithDecs {general = general, decs = decs}
+ else OptVal ov;
+-
+- fun sizeOptVal (ov : optVal, size: codetree -> int) =
+- size (optGeneral ov);
+
+ (* minor HACKS *)
+ type casePair = codetree * int list;
+@@ -269,7 +151,7 @@
+ (* gets a value from the run-time system *)
+ val ioOp : int -> machineWord = RunCall.run_call1 POLY_SYS_io_operation;
+
+- fun apply f [] = () | apply f (h::t) = (f h; apply f t);
++ fun apply _ [] = () | apply f (h::t) = (f h; apply f t);
+
+ val word0 = toMachineWord 0;
+ val word1 = toMachineWord 1;
+@@ -435,9 +317,6 @@
+ fun mkTestnull xp1 = mkTestptreq (xp1, CodeZero);
+ fun mkTestnotnull xp1 = mkTestptrneq (xp1, CodeZero);
+
+- val testnullFunction =
+- mkInlproc (mkTestnull (mkLoad (~1, 0)), 0, 1, "");
+-
+ val mkIf = Cond ;
+ fun mkWhile(b, e) =
+ (* Generated as if b then (e; <loop>) else (). *)
+@@ -472,10 +351,10 @@
+ exactly once and in the correct order, however if the code is just a
+ constant or a load we can reduce the amount of code we generate by
+ simply returning the original code. *)
+- fun multipleUses (code as Constnt _, nextAddress, level) =
++ fun multipleUses (code as Constnt _, _, _) =
+ {load = (fn _ => code), dec = []}
+
+- | multipleUses (code as Extract{addr, level=loadLevel, ...}, nextAddress, level) =
++ | multipleUses (code as Extract{addr, level=loadLevel, ...}, _, level) =
+ let (* May have to adjust the level. *)
+ fun loadFn lev =
+ if lev = level
+@@ -496,8 +375,6 @@
+ fun identityFunction (name : string) : codetree =
+ mkInlproc (mkLoad (~1, 0), 0, 1, name) (* Returns its argument. *);
+
+- fun mkIndirect ct i = Indirect {base = ct, offset = i};
+-
+ (* Set the container to the fields of the record. Try to push this
+ down as far as possible. *)
+ fun mkSetContainer(container, Cond(ifpt, thenpt, elsept), size) =
+@@ -514,7 +391,7 @@
+ Newenv(applyLast entries)
+ end
+
+- | mkSetContainer(container, r as Raise _, size) =
++ | mkSetContainer(_, r as Raise _, _) =
+ r (* We may well have the situation where one branch of an "if" raises an
+ exception. We can simply raise the exception on that branch. *)
+
+@@ -536,7 +413,7 @@
+ let
+ val vec : address = alloc (toShort (List.length xp), F_mutable_words, word0);
+
+- fun copyToVec [] locn = ()
++ fun copyToVec [] _ = ()
+ | copyToVec (h :: t) locn =
+ (
+ assignWord (vec, toShort locn, makeVal h);
+@@ -573,7 +450,7 @@
+ then List.nth(recs, offset)
+ else (* This can arise if we're processing a branch of a case discriminating on
+ a datatype which won't actually match at run-time. *)
+- mkRaise (mkTuple [mkConst (toMachineWord EXC_Bind), mkStr "Bind", CodeZero])
++ mkRaise (mkTuple [mkConst (toMachineWord EXC_Bind), mkStr "Bind", CodeZero, CodeZero])
+
+ | findEntryInBlock (Constnt b) offset =
+ (
+@@ -584,9 +461,9 @@
+ before the invalid load, but we have to be careful that the
+ optimiser does not fall over. *)
+ if isShort b
+- orelse not (ADDRESS.isWords (toAddress b)) (* DCJM's bugfix SPF 25/1/95 *)
+- orelse ADDRESS.length (toAddress b) <= Word.fromInt offset
+- then mkRaise (mkTuple [mkConst (toMachineWord EXC_Bind), mkStr "Bind", CodeZero])
++ orelse not (Address.isWords (toAddress b)) (* DCJM's bugfix SPF 25/1/95 *)
++ orelse Address.length (toAddress b) <= Word.fromInt offset
++ then mkRaise (mkTuple [mkConst (toMachineWord EXC_Bind), mkStr "Bind", CodeZero, CodeZero])
+ else mkConst (loadWord (toAddress b, toShort offset))
+ )
+
+@@ -797,7 +674,7 @@
+ (* Evaluates expressions by code-generating and running them. *)
+ (* "resultCode" is a copied code expression. The result is either *)
+ (* a constant or an exception. *)
+- fun evaluate (resultCode as Constnt _) codegen =
++ fun evaluate (resultCode as Constnt _) _ =
+ (* May already have been reduced to a constant. *)
+ resultCode
+
+@@ -845,7 +722,7 @@
+ handle SML90.Interrupt => raise SML90.Interrupt (* Must not handle this *)
+ | _ => resultCode
+
+- fun loadArgs (argVec : address) ([]:codetree list) locn =
++ fun loadArgs (argVec : address) ([]:codetree list) _ =
+ (
+ lock argVec;
+ callFunction (toMachineWord argVec)
+@@ -1031,7 +908,7 @@
+ to the union of the current set and the saved set. *)
+ fun addFromSaved(UsageSet{locals=ref locals, args=ref args, clos}): unit =
+ let
+- fun addArray [] t = ()
++ fun addArray [] _ = ()
+ | addArray (head::tail) t =
+ (
+ StretchArray.update(t, head, true);
+@@ -1058,10 +935,10 @@
+ (* Differences of two sets, used as kill entries.
+ The differences are returned as Extract codetree entries. *)
+ fun computeKillSets(
+- thenUsage as UsageSet{locals=ref thenLoc, args=ref thenArgs, clos=thenClos},
+- elseUsage as UsageSet{locals=ref elseLoc, args=ref elseArgs, clos=elseClos}) =
++ (* then*) UsageSet{locals=ref thenLoc, args=ref thenArgs, clos=thenClos},
++ (* else *) UsageSet{locals=ref elseLoc, args=ref elseArgs, clos=elseClos}) =
+ let
+- fun killSets f [] [] inThenOnly inElseOnly = (inThenOnly, inElseOnly)
++ fun killSets _ [] [] inThenOnly inElseOnly = (inThenOnly, inElseOnly)
+
+ | killSets f [] (inElseH::inElseT) inThenOnly inElseOnly =
+ killSets f [] inElseT inThenOnly
+@@ -1131,7 +1008,7 @@
+ (* Map f onto a list tail first. N.B. It doesn't reverse the list.
+ Generally used to map "insert" over a list where we need to
+ ensure that last references to variables are detected correctly. *)
+- fun revmap f [] = []
++ fun revmap _ [] = []
+ | revmap f (a::b) =
+ let
+ val rest = revmap f b
+@@ -1161,7 +1038,7 @@
+ (* preCode.copyCode.insert.copyLambda.prev.makeClosureEntry *)
+ fun makeClosureEntry [] _ wasRefed = (* not found - construct new entry *)
+ let
+- val U =
++ val () =
+ newGrefs := mkGenLoad (addr, lev - 1, fpRel, false) :: !newGrefs;
+ val newAddr = !newNorefs + 1;
+ in
+@@ -1176,7 +1053,7 @@
+ then mkClosLoad newAddr (not wasRefed)
+ else makeClosureEntry t (newAddr - 1) wasRefed
+
+- | makeClosureEntry (_ ::_) newAddr wasRefed =
++ | makeClosureEntry (_ ::_) _ _ =
+ raise InternalError "makeClosureEntry: closure is not Extract";
+
+ in
+@@ -1190,12 +1067,12 @@
+ procedure will need one. *)
+ if lev = 0 (* Reference to the closure itself. *)
+ then let
+- val U : unit =
++ val () =
+ if addr <> 0 orelse fpRel
+ then raise InternalError "prev: badly-formed load"
+ else ();
+
+- val U : unit =
++ val () =
+ if closure then makeClosure := true else ();
+ val wasRefed = ! refsToClosure
+ in
+@@ -1205,7 +1082,7 @@
+
+ else if lev = 1 andalso addr > 0
+ then let (* local at this level *)
+- val U : unit =
++ val () =
+ if not fpRel
+ then raise InternalError "prev: badly-formed load"
+ else ();
+@@ -1214,7 +1091,7 @@
+ SOME c => c (* propagate constant, rather than using closure *)
+ | NONE =>
+ let
+- val U : unit =
++ val () =
+ if closure
+ then update (closuresForLocals, addr, true)
+ else ();
+@@ -1227,7 +1104,7 @@
+
+ else if lev = 1 andalso addr < 0
+ then let (* parameter at this level *)
+- val U : unit =
++ val () =
+ if not fpRel
+ then raise InternalError "prev: badly-formed load"
+ else ();
+@@ -1357,7 +1234,7 @@
+ makeClosure = makeClosure
+ }
+ end
+- | copyProcClosure pt makeClosure = pt (* may now be a constant *)
++ | copyProcClosure pt _ = pt (* may now be a constant *)
+ (* end copyProcClosure *);
+
+ in (* body of preCode.copyCode.insert *)
+@@ -1456,10 +1333,10 @@
+ (* Set the table entries. *)
+ (* DCJM 1/12/99. I think the reason for this is in case we have
+ reused the address in a different block. *)
+- val U = update (localUses, caddr, false); (* needed? *)
+- val U = update (closuresForLocals, caddr, false);
++ val () = update (localUses, caddr, false); (* needed? *)
++ val () = update (closuresForLocals, caddr, false);
+
+- val U : unit =
++ val () =
+ case pt of
+ Constnt _ => update (localConsts, caddr, SOME pt)
+ | _ => update (localConsts, caddr, NONE); (* needed? *)
+@@ -1529,7 +1406,7 @@
+ )
+ | applyFn _ = raise InternalError "applyFn: not a Declar"
+
+- val U = apply applyFn mutualDecs;
++ val () = apply applyFn mutualDecs;
+
+ (* Process the rest of the block. Identifies all other
+ references to these declarations. *)
+@@ -1546,13 +1423,13 @@
+ Lambda lam => copyLambda lam closure
+ | _ => insert dv;
+ (* SPF 18/5/95 - check whether we now have a constant *)
+- val U : unit =
++ val () =
+ case dec of
+ Constnt _ => update (localConsts, caddr, SOME dec)
+ | _ => update (localConsts, caddr, NONE); (* needed? *)
+
+ (* copyLambda may set "closure" to true. *)
+- val U : unit =
++ val () =
+ update (closuresForLocals, caddr, !closure);
+ in
+ mkDec (caddr, dec)
+@@ -1598,7 +1475,7 @@
+ (* Leave it for the moment. *)
+ else processClosures t (h :: outlist) someFound
+
+- | processClosures _ outlist someFound =
++ | processClosures _ _ _ =
+ raise InternalError "processClosures: not a Declar"
+
+ (* Now we know all the references we can complete
+@@ -1619,7 +1496,7 @@
+ mkDecRef value addr (if wasUsed then 1 else 0) :: copyEntries ds
+ )
+ end
+- | copyEntries (d::ds) =
++ | copyEntries (_::_) =
+ raise InternalError "copyEntries: Not a Declar";
+
+ val decs = copyEntries (processClosures copiedDecs [] false);
+@@ -1758,7 +1635,7 @@
+ val thenUsage = saveUsages();
+
+ (* Reset the use-counts to the saved value. *)
+- val U: unit = setToSaved usagesAfterIf;
++ val () = setToSaved usagesAfterIf;
+
+ (* Process the else-part. *)
+ val insElse = insert condElse;
+@@ -1773,7 +1650,7 @@
+ been set if they also appeared in the else-part.
+ This sets the usage sets to the union of the then-part,
+ the else-part and code after the if-expression. *)
+- val U: unit = addFromSaved thenUsage;
++ val () = addFromSaved thenUsage;
+
+ (* Add kill entries to the other branch. We simply add
+ Extract entries with lastRef=true before the appropriate
+@@ -1805,7 +1682,7 @@
+ datatype similarity = Different | Similar of loadForm;
+
+ fun similar (Extract (a as {addr=aAddr, level=aLevel, fpRel=aFpRel, lastRef=aRef}))
+- (Extract (b as {addr=bAddr, level=bLevel, fpRel=bFpRel, lastRef=bRef})) =
++ (Extract (b as {addr=bAddr, level=bLevel, fpRel=bFpRel, lastRef=_})) =
+ if aAddr = bAddr andalso aLevel = bLevel andalso aFpRel = bFpRel
+ then if aRef then Similar a else Similar b
+ else Different
+@@ -1814,12 +1691,12 @@
+ (Indirect{offset=bOff, base=bBase}) =
+ if aOff <> bOff then Different else similar aBase bBase
+
+- | similar (a:codetree) (b:codetree) = Different;
++ | similar (_:codetree) (_:codetree) = Different;
+
+ (* If we have a call to the int equality operation *)
+ (* then we may be able to use a case statement. *)
+ (* preCode.copyCode.insert.findCase *)
+- fun findCase (evl as Eval{ function=Constnt cv, argList, ... }) : caseVal =
++ fun findCase (Eval{ function=Constnt cv, argList, ... }) : caseVal =
+ (* Since we are comparing for equality with constants we
+ can do a case for short integers (tags) or arbitrary
+ precision integers. This will certainly work with the
+@@ -1957,11 +1834,11 @@
+ case a<last> of 1 => x | 2 => y | 3 => z
+ i.e. the test IS the last reference.
+ *)
+- Similar(testVar as {lastRef = true, addr, level, ...}) =>
++ Similar({lastRef = true, addr, level, ...}) =>
+ let (* Contains the last reference to the test variable. *)
+ (* Remove this variable from the usage table for the else-part
+ since we are lifting it up to the test. *)
+- val U: unit = removeItem(elseUsage, addr, level);
++ val () = removeItem(elseUsage, addr, level);
+ (* Compute the new kill sets. *)
+ val (killThenOnly, killElseOnly) =
+ computeKillSets(thenUsage, elseUsage);
+@@ -2052,8 +1929,7 @@
+
+ val insertedCode =
+ copyCode (pt,
+- fn (lf, i , b) =>
+- raise InternalError "outer level reached in copyCode",
++ fn _ => raise InternalError "outer level reached in copyCode",
+ stretchArray (initTrans, false),
+ ref false);
+ in
+@@ -2349,18 +2225,9 @@
+ | changeL(TupleFromContainer(container, size), nesting) =
+ TupleFromContainer(changeL(container, nesting), size)
+
+- | changeL(code, _) =
++ | changeL(_, _) =
+ (* The code we produce in these inline functions is very limited. *)
+- let
+- (* If we add something else it's very useful to know what it is. *)
+- val pprint = prettyPrint(77, fn s => TextIO.output(TextIO.stdOut,s));
+- in
+- ppBeginBlock pprint (1, false);
+- pretty (code, pprint);
+- ppEndBlock pprint ();
+ raise InternalError "changeL: Unknown code"
+- end
+-
+
+ in
+ case optGeneral entry of
+@@ -2445,7 +2312,7 @@
+ case (spec, pushProc) of
+ (Lambda{isInline=NonInline, ...}, true) => simpleOptVal gen
+ | _ => stripDecs ins (* Remove the declarations before entering it. *)
+- val U : unit = setTab (addrs, ov);
++ val () = setTab (addrs, ov);
+ in
+ (* Just return the declarations. *)
+ optDecs ins
+@@ -2456,7 +2323,7 @@
+ (* Declaration is simply giving a new name to a local
+ - can ignore this declaration. *)
+ val optVal = stripDecs ins (* Simply copy the entry. *)
+- val U : unit = setTab (addrs, optVal);
++ val () = setTab (addrs, optVal);
+ in
+ optDecs ins
+ end
+@@ -2504,7 +2371,7 @@
+ | _ =>
+ let (* Declare an identifier to have this value. *)
+ val decSpval = ! spval;
+- val UUU = spval := decSpval + 1 ;
++ val () = spval := decSpval + 1 ;
+
+ (* The table entry is similar to the result of the expression except
+ that the declarations are taken off and put into the containing
+@@ -2534,7 +2401,7 @@
+ recCall = optRec ins
+ };
+
+- val U : unit = setTab (addrs, optV);
++ val () = setTab (addrs, optV);
+ in
+ optDecs ins @ [mkDecRef gen decSpval 0]
+ end
+@@ -2563,7 +2430,7 @@
+
+ | optimise (CodeNil, _) = simpleOptVal CodeNil
+
+- | optimise (evl as Eval{function, argList, earlyEval}, tailCall) =
++ | optimise (Eval{function, argList, earlyEval}, tailCall) =
+ let
+ (* Get the function to be called and see if it is inline or
+ a lambda expression. *)
+@@ -2641,7 +2508,7 @@
+ it. Either loop or generate a function call. *)
+ notInlineCall recCall
+ | (_,
+- Lambda { isInline, body=lambdaBody, name=lambdaName, closureRefs, ...}) =>
++ Lambda { isInline, body=lambdaBody, name=lambdaName, ...}) =>
+ let
+ (* Calling inline proc or a lambda expression which is just called.
+ The procedure is replaced with a block containing declarations
+@@ -2653,7 +2520,7 @@
+ val localNewVec = stretchArray (initTrans, NONE);
+
+ (* copies the argument list. *)
+- fun copy [] argAddress = [] : codetree list
++ fun copy [] _ = [] : codetree list
+ | copy (h::t) argAddress =
+ let
+ fun setTab (index, v) = update (paramVec, ~index, SOME v);
+@@ -2704,7 +2571,7 @@
+ is the table for local declarations and the original
+ environment in which the function was declared for
+ non-locals. *)
+- fun lookupDec ({ addr=0, ...}, depth, 0) =
++ fun lookupDec ({ addr=0, ...}, _, 0) =
+ (* Recursive reference - shouldn't happen. *)
+ raise InternalError "lookupDec: Inline function recurses"
+ | lookupDec ({ addr=index, ...}, depth, 0) =
+@@ -2716,7 +2583,7 @@
+ in
+ changeLevel optVal (depth - nestingOfThisProcedure)
+ end
+- | lookupDec (ptr as { addr=index, ...}, depth, levels) =
++ | lookupDec (ptr, depth, levels) =
+ (optEnviron funct) (ptr, depth, levels - 1);
+
+ in
+@@ -2867,7 +2734,7 @@
+ recCall = foptRec,
+ environ = errorEnv
+ }
+- | prev (ptr as { addr=index, ...}, depth, 0) =
++ | prev ({ addr=index, ...}, depth, 0) =
+ if index > 0 (* locals *)
+ then changeLevel(getSome (localVec sub index)) (depth - nesting)
+ else (* index < 0 - parameters *)
+@@ -2878,7 +2745,7 @@
+ else (* Unchanged - get the entry from the table, converting
+ the level because it's in the surrounding scope. *)
+ changeLevel (getSome (Vector.sub(frozenParams, ~index))) (depth-nesting+1)
+- | prev (ptr as { addr=index, ...}, depth, levels) =
++ | prev (ptr, depth, levels) =
+ (optEnviron funct) (ptr, depth, levels - 1);
+
+ val newAddrTab = stretchArray (initTrans, NONE);
+@@ -2948,7 +2815,7 @@
+ (* Called initially or while we only have tail recursive
+ calls. We can inline the function. *)
+ let
+- fun prev (ptr as { addr=index, ...}, depth, 0) : optVal =
++ fun prev ({ addr=index, ...}, depth, 0) : optVal =
+ let (* On this level. *)
+ val optVal =
+ if index = 0
+@@ -2970,7 +2837,7 @@
+ in
+ changeLevel optVal (depth - nestingOfThisProcedure)
+ end
+- | prev (ptr as { addr=index, ...}, depth, levels) : optVal =
++ | prev (ptr, depth, levels) : optVal =
+ (* On another level. *)
+ (optEnviron funct) (ptr, depth, levels - 1);
+
+@@ -3143,7 +3010,7 @@
+ dependencies. *)
+
+ val nonLocals = ref nil;
+- fun addNonLocal(ext: loadForm as {addr, level, fpRel, ...}, depth) =
++ fun addNonLocal({addr, level, fpRel, ...}, depth) =
+ let
+ (* The level will be correct relative to the use, which may be
+ in an inner function. We want the level relative to the
+@@ -3160,7 +3027,7 @@
+
+ fun checkRecursion(ext as {fpRel=oldfpRel, ...}, levels, depth) =
+ case optGeneral(lookupNewAddr (ext, depth, levels)) of
+- (res as Extract(ext as {addr=0, fpRel=false, level, ...})) =>
++ (res as Extract(ext as {addr=0, fpRel=false, ...})) =>
+ (
+ (* If this is just a recursive call it doesn't count
+ as a non-local reference. This only happens if
+@@ -3171,7 +3038,7 @@
+ else addNonLocal(ext, depth);
+ res
+ )
+- | res as Extract(ext as {addr, level, fpRel, ...}) =>
++ | res as Extract ext =>
+ (
+ addNonLocal(ext, depth);
+ res
+@@ -3316,7 +3183,7 @@
+ val foptRec = ref false
+ (* First process as though it was not a BeginLoop but just a
+ set of declarations followed by an expression. *)
+- val firstBeginBody =
++ val _ =
+ optimiseProc
+ (mkEnv(args @ [body]), lookupNewAddr, lookupOldAddr,
+ enterDec, enterNewDec, nestingOfThisProcedure,
+@@ -3402,7 +3269,7 @@
+ let
+ val thenDecs = optDecs insSecond and elseDecs = optDecs insThird
+
+- fun replaceContainerDec([], ad) =
++ fun replaceContainerDec([], _) =
+ raise InternalError "replaceContainerDec"
+ | replaceContainerDec((hd as Declar{addr, ...})::tl, ad)=
+ if addr = ad
+@@ -3442,7 +3309,7 @@
+ List.tabulate(size,
+ fn n => mkDec(n+baseAddr, mkInd(n, mkLoad(containerAddr, 0))))
+ val specialEntries = List.tabulate(size, fn n => mkLoad(n+baseAddr, 0))
+- fun env (l:loadForm, depth, levels) : optVal =
++ fun env (l:loadForm, depth, _) : optVal =
+ changeLevel (simpleOptVal(Extract l)) (depth - nestingOfThisProcedure)
+ in
+ optVal
+@@ -3608,7 +3475,7 @@
+ for them and entering them in the table. *)
+ val startAddr = !spval
+ val addresses =
+- map (fn Declar{ value = decVal, addr, ... } =>
++ map (fn Declar{addr, ... } =>
+ let
+ val decSpval = !spval;
+ in
+@@ -3861,7 +3728,7 @@
+ are done exactly once. *)
+ val allConsts = ref true;
+
+- fun makeDecs [] addr = {decs = [], gen_args = [], spec_args = []}
++ fun makeDecs [] _ = {decs = [], gen_args = [], spec_args = []}
+ | makeDecs (h::t) addr =
+ let
+ (* Declare this value. If it is anything but a constant
+@@ -3871,7 +3738,7 @@
+ val rest = makeDecs t (addr + 1);
+ val gen = optGeneral thisArg;
+ val spec = optSpecial thisArg;
+- val UUU =
++ val () =
+ if not (isConstnt gen) then allConsts := false else ();
+
+ val specArgs =
+@@ -3892,7 +3759,7 @@
+
+ val vec = StretchArray.vector newTab
+
+- fun env ({addr, ...}:loadForm, depth, levels) : optVal =
++ fun env ({addr, ...}:loadForm, depth, _) : optVal =
+ changeLevel
+ (getSome (Vector.sub(vec, addr)))
+ (depth - nestingOfThisProcedure)
+@@ -3963,7 +3830,7 @@
+ recCall = ref false
+ }
+
+- | (_, gen) => (* No special case possible. *)
++ | (_, _) => (* No special case possible. *)
+ optVal
+ {
+ general = mkInd (offset, optGeneral source),
+@@ -4029,7 +3896,7 @@
+ val specialDecs =
+ List.tabulate(size, fn n => mkDec(n+baseAddr, mkInd(n, optGeneral optCont)))
+ val specialEntries = List.tabulate(size, fn n => mkLoad(n+baseAddr, 0))
+- fun env (l:loadForm, depth, levels) : optVal =
++ fun env (l:loadForm, depth, _) : optVal =
+ changeLevel (simpleOptVal(Extract l)) (depth - nestingOfThisProcedure)
+ in
+ optVal
+@@ -4068,7 +3935,7 @@
+ let
+ (* Get the declarations off the block and apply
+ pushSetContainer to the last. *)
+- fun applyToLast (d, []) = raise List.Empty
++ fun applyToLast (_, []) = raise List.Empty
+ | applyToLast (d, [last]) = pushSetContainer(last, d)
+ | applyToLast (d, hd :: tl) =
+ applyToLast(hd :: d, tl)
+@@ -4133,27 +4000,18 @@
+ val printCodeTree = DEBUG.getParameter DEBUG.codetreeTag debugSwitches
+ and printCodeTreeAfter = DEBUG.getParameter DEBUG.codetreeAfterOptTag debugSwitches
+ and maxInlineSize = DEBUG.getParameter DEBUG.maxInlineSizeTag debugSwitches
+- and stringPrint = DEBUG.getParameter DEBUG.compilerOutputTag debugSwitches
++ and compilerOut = PRETTY.getCompilerOutput debugSwitches
+
+ (* This ensures that everything is printed just before
+ it is code-generated. *)
+ val codeGenAndPrint =
+- if printCodeTreeAfter
+- then (fn code =>
+- let
+- val pprint = prettyPrint(77, stringPrint);
+- in
+- pretty (code, pprint);
+- codegen(code, debugSwitches)
+- end
+- )
+- else fn code => codegen(code, debugSwitches);
++ if printCodeTreeAfter
++ then fn code => (compilerOut(pretty code); codegen(code, debugSwitches))
++ else fn code => codegen(code, debugSwitches);
+
+ fun preCodeAndPrint code =
+ (
+- if printCodeTree
+- then pretty (code, prettyPrint(77, stringPrint))
+- else ();
++ if printCodeTree then compilerOut(pretty code) else ();
+ preCode (codeGenAndPrint, code)
+ )
+
+@@ -4276,7 +4134,7 @@
+ expandMutual dec @ expandMutual decs
+ | expandMutual ((dec as Declar _) :: decs) =
+ dec :: expandMutual decs
+- | expandMutual (dec :: decs) =
++ | expandMutual (_ :: decs) =
+ expandMutual decs; (* expression *)
+
+ (* There seems to be a problem with this code - we put declarations
+@@ -4302,7 +4160,7 @@
+ a block with declarations in it. The gaps are replaced with zero
+ values. However mutually recursive declarations may be in a random
+ order so the list may have to be sorted. *)
+- fun getValues ([]: codetree list) (addr: int): codetree list =
++ fun getValues ([]: codetree list) _ : codetree list =
+ [] (* Last of all the general value. *)
+
+ | getValues (decs as (Declar{addr=declAddr, ...} :: vs)) (addr: int): codetree list =
+@@ -4416,4 +4274,12 @@
+ end
+ end; (* genCode *)
+
++
++ structure Sharing =
++ struct
++ type machineWord = machineWord
++ type codetree = codetree
++ type pretty = pretty
++ end
++
+ end (* CODETREE functor body *);
+diff -u -r mlsource/MLCompiler/CodeTree/CODE_SEG.ML mlsource/MLCompiler/CodeTree/CODE_SEG.ML
+--- mlsource/MLCompiler/CodeTree/CODE_SEG.ML 2008-03-25 12:01:04.000000000 +0100
++++ mlsource/MLCompiler/CodeTree/CODE_SEG.ML 2009-09-15 08:56:45.000000000 +0200
+@@ -98,7 +98,7 @@
+
+ fun csegConvertToCode (r as ref (Bytes, addr)) : unit =
+ let
+- val U : unit = setFlags (addr, F_mutable_code);
++ val () = setFlags (addr, F_mutable_code);
+ in
+ r := (UnlockedCode, addr)
+ end
+@@ -107,7 +107,7 @@
+
+ fun csegLock (r as ref (UnlockedCode, addr)) : unit =
+ let
+- val U : unit = setFlags (addr, F_code);
++ val () = setFlags (addr, F_code);
+ in
+ r := (LockedCode, addr)
+ end
+@@ -198,7 +198,7 @@
+ raise InternalError "csegCopySeg: can only copy between byte segements"
+
+ (* Returns a value from the vector. *)
+- fun csegGet (ref (status, addr), byteIndex : int) : Word8.word =
++ fun csegGet (ref (_, addr), byteIndex : int) : Word8.word =
+ let
+ val lengthWords = objLength addr;
+ val lengthBytes = wordSize * lengthWords;
+@@ -219,7 +219,7 @@
+ end
+ end;
+
+- fun csegSet (ref (LockedCode, addr), byteIndex:int, value:Word8.word) : unit =
++ fun csegSet (ref (LockedCode, _), _, _) : unit =
+ raise InternalError "csegSet: can't change locked code segement"
+
+ | csegSet (r as (ref (status, addr)), byteIndex:int, value:Word8.word) : unit =
+diff -u -r mlsource/MLCompiler/CodeTree/CodeCons.i386.ML mlsource/MLCompiler/CodeTree/CodeCons.i386.ML
+--- mlsource/MLCompiler/CodeTree/CodeCons.i386.ML 2006-09-26 15:38:31.000000000 +0200
++++ mlsource/MLCompiler/CodeTree/CodeCons.i386.ML 2009-09-15 08:56:45.000000000 +0200
+@@ -1,5 +1,5 @@
+ (*
+- Copyright (c) 2000
++ Copyright (c) 2000-9
+ Cambridge University Technical Services Limited
+
+ This library is free software; you can redistribute it and/or
+@@ -19,9 +19,6 @@
+
+ structure CodeCons =
+ I386CODECONS (
+- structure CODESEG = CodeSeg
+ structure DEBUG = Debug
+- structure MISC = Boot.Misc
+- structure ADDRESS = Address
++ structure PRETTY = Pretty
+ );
+-
+diff -u -r mlsource/MLCompiler/CodeTree/CodeCons.x86_64.ML mlsource/MLCompiler/CodeTree/CodeCons.x86_64.ML
+--- mlsource/MLCompiler/CodeTree/CodeCons.x86_64.ML 2006-09-26 15:38:32.000000000 +0200
++++ mlsource/MLCompiler/CodeTree/CodeCons.x86_64.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -18,9 +18,7 @@
+
+ structure CodeCons =
+ AMD64CODECONS (
+- structure CODESEG = CodeSeg
+ structure DEBUG = Debug
+- structure MISC = Boot.Misc
+- structure ADDRESS = Address
++ structure PRETTY = Pretty
+ );
+
+diff -u -r mlsource/MLCompiler/CodeTree/GCode.ML mlsource/MLCompiler/CodeTree/GCode.ML
+--- mlsource/MLCompiler/CodeTree/GCode.ML 2008-03-25 12:07:47.000000000 +0100
++++ mlsource/MLCompiler/CodeTree/GCode.ML 2009-09-15 08:56:45.000000000 +0200
+@@ -22,7 +22,5 @@
+ structure CODECONS = CodeCons
+ structure TRANSTAB = TransTab
+ structure BASECODETREE = BaseCodeTree
+- structure MISC = Boot.Misc
+- structure ADDRESS = Address
+ );
+
+diff -u -r mlsource/MLCompiler/CodeTree/GCode.interpreted.ML mlsource/MLCompiler/CodeTree/GCode.interpreted.ML
+--- mlsource/MLCompiler/CodeTree/GCode.interpreted.ML 2008-03-25 12:08:12.000000000 +0100
++++ mlsource/MLCompiler/CodeTree/GCode.interpreted.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -23,7 +23,7 @@
+ structure CODESEG = CodeSeg
+ structure DEBUG = Debug
+ structure MISC = Boot.Misc
+- structure ADDRESS = Address
++ structure PRETTY = Pretty
+ );
+ in
+ structure GCode =
+@@ -31,7 +31,6 @@
+ structure CODECONS = CodeCons
+ structure BASECODETREE = BaseCodeTree
+ structure MISC = Boot.Misc
+- structure ADDRESS = Address
+ )
+ end;
+
+\ No newline at end of file
+diff -u -r mlsource/MLCompiler/CodeTree/G_CODE.ML mlsource/MLCompiler/CodeTree/G_CODE.ML
+--- mlsource/MLCompiler/CodeTree/G_CODE.ML 2008-04-21 13:30:52.000000000 +0200
++++ mlsource/MLCompiler/CodeTree/G_CODE.ML 2009-09-15 08:56:45.000000000 +0200
+@@ -44,9 +44,9 @@
+ (*****************************************************************************)
+ structure CODECONS :
+ sig
+- type machineWord;
++ type machineWord = Address.machineWord;
+ type short = Word.word;
+- type address;
++ type address = Address.address;
+ type addrs; (* NB this is *not* the same as "address" *)
+ type code;
+ type reg; (* Machine registers *)
+@@ -168,7 +168,7 @@
+ (*****************************************************************************)
+ structure TRANSTAB :
+ sig
+- type machineWord;
++ type machineWord = Address.machineWord;
+ type ttab;
+ type reg;
+ type code;
+@@ -289,50 +289,6 @@
+
+ end (* TRANSTAB *);
+
+-(*****************************************************************************)
+-(* MISC *)
+-(*****************************************************************************)
+-structure MISC :
+-sig
+- exception InternalError of string;
+-end;
+-
+-structure ADDRESS:
+-sig
+- type machineWord; (* NB *not* an eqtype *)
+- type short = Word.word;
+- type address;
+-
+- val wordEq: 'a * 'a -> bool;
+- val isShort: 'a -> bool;
+-
+- val unsafeCast : 'a -> 'b;
+-
+- val toMachineWord: 'a -> machineWord;
+- val toShort: 'a -> short;
+- val toAddress: machineWord -> address;
+-
+- val loadByte: (address * short) -> Word8.word;
+- val loadWord: address * short -> machineWord
+- val flags: address -> Word8.word;
+- val length: address -> short;
+-
+- val F_words: Word8.word;
+- val F_bytes : Word8.word;
+- val F_mutable: Word8.word;
+-
+- val alloc: short * Word8.word * machineWord -> address
+-
+- val isCode : address -> bool
+- val isWords : address -> bool
+-
+- val call: address * machineWord -> machineWord
+-
+- val wordSize: int
+-
+- val isIoAddress : address -> bool
+-end;
+-
+ structure BASECODETREE: BaseCodeTreeSig
+
+ (*****************************************************************************)
+@@ -357,20 +313,6 @@
+ sharing type
+ CODECONS.addrs
+ = TRANSTAB.addrs
+-
+-sharing type
+- ADDRESS.machineWord
+-= CODECONS.machineWord
+-= TRANSTAB.machineWord
+-= BASECODETREE.machineWord
+-
+-sharing type
+- ADDRESS.short
+-= CODECONS.short
+-
+-sharing type
+- ADDRESS.address
+-= CODECONS.address
+
+ sharing type
+ CODECONS.storeWidth
+@@ -393,15 +335,14 @@
+ struct
+ open CODECONS;
+ open TRANSTAB;
+- open ADDRESS;
+- open MISC; (* after address, so we get MISC.length, not ADDRESS.length *)
++ open Address;
++ open Misc; (* after address, so we get Misc.length, not Address.length *)
+ open RuntimeCalls; (* for POLY_SYS numbers *)
+ open BASECODETREE;
+
+ val F_mutable_words = Word8.orb (F_mutable, F_words);
+- val F_mutable_bytes = Word8.orb (F_mutable, F_bytes);
+
+- val objLength = ADDRESS.length;
++ val objLength = Address.length;
+
+ infix 7 regEq regNeq;
+
+@@ -432,8 +373,6 @@
+ | ToPstack (* Need a result but it can stay on the pseudo-stack *);
+
+ fun isNoResult NoResult = true | isNoResult _ = false;
+- fun isToReg (ToReg _) = true | isToReg _ = false;
+- fun isToPstack ToPstack = true | isToPstack _ = false;
+
+ (* Are we at the end of the procedure. *)
+ datatype tail =
+@@ -467,9 +406,9 @@
+ (* I've reverted to the original markStack in order to test my changes
+ to Transtab which should fix this problem along with others.
+ DCJM 28/6/2000 *)
+- fun markStack (transtable : ttab, cvec : code, carry : bool) : stackMark =
++ fun markStack (transtable : ttab, _ : code, _ : bool) : stackMark =
+ let
+-(* val U : unit =
++(* val () =
+ if carry
+ then let
+ val freeReg : reg = getAnyRegister (transtable, cvec);
+@@ -492,7 +431,6 @@
+ staticLinkRegSet : int -> regSet,
+ discardClosure : bool,
+ numOfArgs : int,
+- closureRefs : int,
+ debugSwitches : Universal.universal list) : address =
+ let
+ fun matchFailed _ = raise InternalError "codegen: unhandled pattern-match failure"
+@@ -506,7 +444,7 @@
+ fun registerArg reg uses =
+ if uses > 0
+ then let
+- val U : unit = getRegister (transtable, cvec, reg);
++ val () = getRegister (transtable, cvec, reg);
+ val addrInd = pushReg (transtable, reg);
+ in
+ incrUseCount (transtable, addrInd, uses - 1);
+@@ -522,7 +460,7 @@
+ (* The return address has already been pushed onto the stack,
+ probably because the normal call sequence does it. *)
+ val addr = incsp transtable;
+- val U : unit = incrUseCount (transtable, addr, 1000000);
++ val () = incrUseCount (transtable, addr, 1000000);
+ in
+ addr
+ end
+@@ -564,13 +502,13 @@
+ if i < numOfArgs andalso i < argRegs
+ then let
+ (* DCJM 29/11/99. Changed to use lastRef rather than reference counts. *)
+- val U : unit = Array.update (argRegTab, i, registerArg (argReg i) 1);
++ val () = Array.update (argRegTab, i, registerArg (argReg i) 1);
+ in
+ pushArgRegs (i + 1)
+ end
+ else ();
+ in
+- val U = pushArgRegs 0;
++ val () = pushArgRegs 0;
+ end;
+
+ fun exit () =
+@@ -581,15 +519,15 @@
+ if regReturn regEq regNone
+ then let
+ (* Reset to just above the return address. *)
+- val U : unit = resetStack (realstackptr transtable - 1, cvec);
++ val () = resetStack (realstackptr transtable - 1, cvec);
+ in
+ returnFromFunction (regNone, stackArgs, cvec)
+ end
+ else let
+ val (returnReg, returnOffset) =
+ loadEntry (cvec, transtable, returnAddress, false);
+- val U : unit = removeStackEntry (transtable, returnOffset)
+- val U : unit = resetStack (realstackptr transtable, cvec);
++ val () = removeStackEntry (transtable, returnOffset)
++ val () = resetStack (realstackptr transtable, cvec);
+ in
+ returnFromFunction (returnReg, stackArgs, cvec)
+ end;
+@@ -612,9 +550,9 @@
+ ToReg rr => ( getRegister (transtable, cvec, rr); rr )
+ | _ => getAnyRegister (transtable, cvec);
+
+- val U = allocStore (csize, flag, resultReg, cvec);
++ val () = allocStore (csize, flag, resultReg, cvec);
+ val resAddr = pushReg (transtable, resultReg);
+- val U : unit = containsLocal (transtable, resultReg); (* Not persistent address. *)
++ val () = containsLocal (transtable, resultReg); (* Not persistent address. *)
+ in
+ resAddr
+ end;
+@@ -622,7 +560,7 @@
+ (* Remove the mutable bit without affecting the use-count. *)
+ fun lockSegment (entry, flag) : unit =
+ let
+- val U = incrUseCount (transtable, entry, 1);
++ val () = incrUseCount (transtable, entry, 1);
+ val (baseReg, baseIndex) = loadEntry (cvec, transtable, entry, false);
+ in
+ CODECONS.setFlag (baseReg, cvec, flag);
+@@ -702,7 +640,7 @@
+
+ | AltMatch (exp1, exp2) =>
+ let
+- val U : unit = loads exp1;
++ val () = loads exp1;
+ in
+ loads exp2
+ end
+@@ -732,7 +670,7 @@
+
+ | Eval {function, argList, ...} =>
+ let
+- val U : unit = loads function;
++ val () = loads function;
+ in
+ List.app loads argList
+ end
+@@ -740,7 +678,7 @@
+ | Declar {addr, value, ...} =>
+ let
+ (* Indicate that this is a new declaration. *)
+- val U : unit = StretchArray.update (newDecs, addr, true);
++ val () = StretchArray.update (newDecs, addr, true);
+ in
+ loads value (* Check the expression. *)
+ end
+@@ -797,7 +735,7 @@
+ case pt of
+ MatchFail => (* A bit like Raise *)
+ let
+- val U : unit = matchFailFn ();
++ val () = matchFailFn ();
+ in
+ if needsResult
+ then MergeIndex(pushConst (transtable, DummyValue))
+@@ -831,7 +769,7 @@
+ will be removed by the lower-level code generator.
+ SPF 25/11/96
+ *)
+- val U : unit =
++ val () =
+ if (isEndOfProc tailKind) andalso not (haveExited transtable)
+ then exit ()
+ else ();
+@@ -841,7 +779,7 @@
+ unconditionalBranch (exp1Result, transtable, cvec);
+
+ (* If exp1 failed, we come here (with NO result). *)
+- val discard =
++ val _ =
+ mergeList (!failLabs, transtable, cvec, NoMerge, mark2)
+
+ (* Compile exp2 using the OLD matchFailFn *)
+@@ -867,7 +805,7 @@
+ Lambda {makeClosure = false, ...} => true
+ | _ => false;
+
+- val U : unit=
++ val ()=
+ makeEntry (transtable, cvec, decl, addr,
+ if references = 0 then 0 else 1, (* DCJM 29/11/99. *)
+ slProc);
+@@ -898,7 +836,7 @@
+ end
+
+ | Lambda lam =>
+- MergeIndex(genProc (lam, fn si => (), true, whereto, matchFailFn))
++ MergeIndex(genProc (lam, fn _ => (), true, whereto, matchFailFn))
+
+ | Constnt w =>
+ MergeIndex(pushConst (transtable, w))
+@@ -908,7 +846,7 @@
+
+ | Newenv vl =>
+ let (* Processes a list of entries. *)
+- fun codeList [] whereto =
++ fun codeList [] _ =
+ (* Either the list is empty or the previous entry was a
+ declaration. Generate a value to represent void.empty so
+ that there is something on the stack. *)
+@@ -919,7 +857,7 @@
+ | codeList ((valu as Declar _) :: valus) whereto =
+ (* Declaration. *)
+ let
+- val discard =
++ val _ =
+ gencde (valu, true, NoResult, NotEnd, matchFailFn, loopAddr);
+ in
+ codeList valus whereto
+@@ -932,7 +870,7 @@
+ | codeList (valu :: valus) whereto =
+ (* Expression in a sequence. *)
+ let
+- val discard =
++ val _ =
+ gencde (valu, true, NoResult, NotEnd, matchFailFn, loopAddr);
+ in
+ codeList valus whereto
+@@ -951,7 +889,7 @@
+ pushed onto the stack. This may be unnecessary if the loop body
+ is simple but is the only way to ensure that when we jump back to
+ the start we have the same state as when we started. *)
+- val U : unit =
++ val () =
+ pushAllBut(transtable, cvec, identifyLoads (args, transtable), allRegisters);
+ (* Load the arguments. We put them into registers at this stage
+ to ensure that constants and "direct" entries are loaded. They
+@@ -991,7 +929,7 @@
+ because we may have pushed some onto the stack as we loaded the
+ later ones. That's fine so long as when we loop we put the new
+ values in the same place. *)
+- val U : unit = clearCache transtable;
++ val () = clearCache transtable;
+ val argDestList = getLoopDestinations(argIndexList, transtable)
+ (* Start of loop *)
+ val startLoop (* L1 *) = ic cvec;
+@@ -1101,11 +1039,11 @@
+ let
+ (* Push all regs - we don't know what the state will be when
+ we reach the handler. *)
+-(* ... val U : unit = pushAll (transtable, cvec); ... *)
++(* ... val () = pushAll (transtable, cvec); ... *)
+ (* Experiment: don't push registers that aren't used in the handler. SPF 25/11/96 *)
+ (* i.e. Push all registers except those whose last use occurs in the expression
+ we're handling or in the set of exceptions we're catching. *)
+- val U : unit =
++ val () =
+ pushAllBut (transtable, cvec, identifyLoads (exp :: taglist, transtable),
+ allRegisters);
+ (* It's not clear what registers will be modified as a result of raising
+@@ -1122,13 +1060,13 @@
+ val mark : stackMark = markStack (transtable, cvec, needsResult);
+
+ (* Save old handler - push regHandler *)
+- val U : unit = genPush (regHandler, cvec);
++ val () = genPush (regHandler, cvec);
+ val oldIndex = incsp transtable;
+
+ (* Now it's on the real stack we can remove it from the pstack. *)
+- val U : unit = removeStackEntry(transtable, oldIndex);
++ val () = removeStackEntry(transtable, oldIndex);
+
+- fun genTag (tag : codetree) : handler =
++ fun genTag (tag : codetree) : TRANSTAB.handler =
+ let
+ (* Push address of new handler. *)
+ val rsp = realstackptr transtable;
+@@ -1140,7 +1078,7 @@
+ val stackLocn = pushValueToStack (cvec, transtable, locn, rsp + 2);
+
+ (* Now it's on the real stack we can remove it from the pstack. *)
+- val U : unit = removeStackEntry(transtable, stackLocn);
++ val () = removeStackEntry(transtable, stackLocn);
+ in
+ handlerLab
+ end;
+@@ -1157,10 +1095,10 @@
+ I don't think the fix-up order matters now. I think it had
+ something to do with avoiding converting short branches into
+ long ones. DCJM June 2000. *)
+- val handlerList : handler list = rev (map genTag (rev taglist));
++ val handlerList : TRANSTAB.handler list = rev (map genTag (rev taglist));
+
+ (* Initialise regHandler from regStackPtr *)
+- val U : unit = genRR (instrMove, regStackPtr, regNone, regHandler, cvec);
++ val () = genRR (instrMove, regStackPtr, regNone, regHandler, cvec);
+
+ (* SPF 27/11/96 - merged values don't necessarily go into regResult *)
+ val whereto : whereTo = chooseMergeRegister (transtable, whereto, tailKind);
+@@ -1170,7 +1108,7 @@
+ val bodyResult = genToRegister (exp, whereto, NotEnd, matchFailFn, loopAddr);
+
+ (* Reload the old value of regHandler i.e. remove handler. *)
+- val U : unit =
++ val () =
+ genLoad ((realstackptr transtable - startOfHandler - 1) * wordSize,
+ regStackPtr, regHandler, cvec)
+
+@@ -1180,7 +1118,7 @@
+ will be removed by the lower-level code generator.
+ SPF 25/11/96
+ *)
+- val U : unit =
++ val () =
+ if (isEndOfProc tailKind) andalso not (haveExited transtable)
+ then exit ()
+ else ();
+@@ -1191,14 +1129,14 @@
+ (* Remove any result at the start of the handler.
+ Need this because fixupH does not do setState.
+ (It probably should do, though the state is fairly simple). *)
+- val U : unit =
++ val () =
+ case bodyResult of
+ MergeIndex bodyIndex => removeStackEntry(transtable, bodyIndex)
+ | NoMerge => ();
+
+ (* Fix up the handler entry point - this resets the stack pointer
+ and clears the cache since the state is not known. *)
+- val U : unit list =
++ val _ =
+ map (fn handlerLab => fixupH (handlerLab, startOfHandler, transtable, cvec))
+ handlerList;
+
+@@ -1245,7 +1183,7 @@
+ expressions. There are a very few instances of the ML code
+ producing the equivalent of if-then without an else but they
+ are all cas*)
+- val U: unit = if noDefault andalso needsResult
++ val () = if noDefault andalso needsResult
+ then raise InternalError "Case - no default" else ();
+
+ val testValue = genToStack (test, matchFailFn);
+@@ -1255,14 +1193,14 @@
+
+ (* Count the total number of cases. *)
+ fun countCases [] = 0
+- | countCases ((caseExp : codetree, caseLabels : int list) :: cps) =
++ | countCases ((_ : codetree, caseLabels : int list) :: cps) =
+ List.length caseLabels + countCases cps;
+
+ (* This procedure decides whether to use a case instruction
+ or a comparison depending on whether the cases are sparse.
+ A more efficient algorithm, possibly using a binary chop,
+ should probably be used for the sparse cases. *)
+- fun caseCode (min:int) (max:int) (numberOfCases:int) [] : mergeResult =
++ fun caseCode (_:int) (_:int) (_:int) [] : mergeResult =
+ (* Put in the default case. *)
+ if needsDefaultCase
+ then genToRegister (default, whereto, tailKind, matchFailFn, loopAddr)
+@@ -1277,13 +1215,13 @@
+ indexedCase can modify the registers. *)
+ val (testReg, testIndex) =
+ loadEntry (cvec, transtable, testValue, true);
+- val U: unit = removeStackEntry (transtable, testIndex);
++ val () = removeStackEntry (transtable, testIndex);
+
+ (* Need a work register. *)
+- val U : unit = lockRegister (transtable, testReg);
++ val () = lockRegister (transtable, testReg);
+ val workReg = getAnyRegister(transtable, cvec);
+- val U: unit = freeRegister (transtable, workReg);
+- val U : unit = unlockRegister (transtable, testReg);
++ val () = freeRegister (transtable, workReg);
++ val () = unlockRegister (transtable, testReg);
+
+ val caseInstr : jumpTableAddrs =
+ indexedCase (testReg, workReg, min, max, noDefault, cvec);
+@@ -1305,7 +1243,7 @@
+ will be removed by the lower-level code generator.
+ SPF 25/11/96
+ *)
+- val U : unit =
++ val () =
+ if (isEndOfProc tailKind) andalso not (haveExited transtable)
+ then exit ()
+ else ();
+@@ -1313,7 +1251,7 @@
+ val lab =
+ unconditionalBranch (defaultRes, transtable, cvec);
+
+- val U : unit =
++ val () =
+ case defaultRes of
+ MergeIndex defaultIndex =>
+ removeStackEntry (transtable, defaultIndex)
+@@ -1343,7 +1281,7 @@
+ val expResult =
+ genToRegister (caseExp, whereto, tailKind, matchFailFn, loopAddr);
+
+- val U : unit =
++ val () =
+ if (isEndOfProc tailKind) andalso not (haveExited transtable)
+ then exit ()
+ else ();
+@@ -1358,7 +1296,7 @@
+ else let
+ val lab = unconditionalBranch (expResult, transtable, cvec);
+
+- val U : unit =
++ val () =
+ case expResult of
+ MergeIndex expIndex => removeStackEntry(transtable, expIndex)
+ | NoMerge => ();
+@@ -1389,7 +1327,7 @@
+ We need to do this because we're converting the case
+ expression, which has a single "last reference" marker
+ into a series of if-then-elses. *)
+- val U : unit =
++ val () =
+ if not lastTest
+ then incrUseCount (transtable, testValue, 1)
+ else ()
+@@ -1418,7 +1356,7 @@
+
+ (* Increment the use count so it doesn't get
+ thrown away. *)
+- val U = incrUseCount (transtable, testValue, 1);
++ val () = incrUseCount (transtable, testValue, 1);
+ val locn = pushConst (transtable, toMachineWord x);
+ val lab =
+ (* should do arbitrary precision test here???? SPF *)
+@@ -1440,7 +1378,7 @@
+ test value we need to decrement it here. That's
+ because on this branch we are not going to test it
+ again. DCJM 7/12/00. *)
+- val U : unit =
++ val () =
+ if not lastTest
+ then incrUseCount (transtable, testValue, ~1)
+ else ()
+@@ -1449,7 +1387,7 @@
+ val thisCaseRes =
+ genToRegister (caseExp, whereto, tailKind, matchFailFn, loopAddr);
+
+- val U : unit =
++ val () =
+ if isEndOfProc tailKind andalso not (haveExited transtable)
+ then exit ()
+ else ();
+@@ -1458,13 +1396,13 @@
+ val lab1 = unconditionalBranch (thisCaseRes, transtable, cvec);
+
+ (* remove result of this case from pstack *)
+- val U : unit =
++ val () =
+ case thisCaseRes of
+ MergeIndex resIndex => removeStackEntry(transtable, resIndex)
+ | NoMerge => ();
+
+ (* Do the other cases. *)
+- val U : unit = fixup (lab, transtable, cvec);
++ val () = fixup (lab, transtable, cvec);
+
+ val caseResult =
+ if lastCase
+@@ -1478,7 +1416,7 @@
+ val result = caseCode min max (countCases cases) cases;
+
+ (* v2.08 code-generator no longer clears the cache here *)
+- (* val U : unit = clearCache transtable; *)
++ (* val () = clearCache transtable; *)
+ in
+ result
+ end
+@@ -1496,14 +1434,14 @@
+ case dec of
+ Lambda (lam as { makeClosure,...}) =>
+ let
+- val discard =
++ val _ =
+ genProc
+ (lam,
+ (* This procedure is called once the closure has been
+ created but before the entries have been filled in. *)
+ fn (r : stackIndex) =>
+ let
+- val U : unit =
++ val () =
+ makeEntry (transtable, cvec, r, addr,
+ references, not makeClosure);
+ in (* Now time to do the other closures. *)
+@@ -1517,7 +1455,7 @@
+ end
+ | _ =>
+ let (* should only be constants i.e. procedures already compiled. *)
+- val U : unit =
++ val () =
+ makeEntry (transtable, cvec, genToStack (dec, matchFailFn),
+ addr, references, false);
+ in
+@@ -1527,7 +1465,7 @@
+ | genMutualDecs (_) =
+ raise InternalError "genMutualDecs - Not a declaration";
+
+- val U : unit = genMutualDecs dl;
++ val () = genMutualDecs dl;
+ in
+ NoMerge (* Unused. *)
+ end
+@@ -1553,14 +1491,14 @@
+ else let
+ (* Since the vector is immutable, we have to evaluate
+ all the values before we can allocate it. *)
+- fun loadSmallVector [] byteOffset =
++ fun loadSmallVector [] _ =
+ callgetvec (vecsize, F_words, whereto)
+
+ | loadSmallVector (h::t) byteOffset =
+ let
+ val v = genToStack (h, matchFailFn);
+ val vec = loadSmallVector t (byteOffset + wordSize)
+- val U : unit =
++ val () =
+ moveToVec (vec, v, byteOffset, STORE_WORD, cvec, transtable)
+ in
+ vec
+@@ -1569,7 +1507,7 @@
+ (* we have to make sure that the code-generator is not going to
+ reorder the instructions so an instruction which might trap
+ is put in the sequence of loads. *)
+- val U : unit = completeSegment cvec;
++ val () = completeSegment cvec;
+ in
+ MergeIndex vec
+ end
+@@ -1747,7 +1685,7 @@
+ `lastDec' is true if there are no more mutually recursive declarations.
+ *)
+ and genProc ({ closure=closureList, makeClosure, name=lambdaName,
+- body=lambdaBody, numArgs, closureRefs, ... }: lambdaForm,
++ body=lambdaBody, numArgs, ... }: lambdaForm,
+ mutualRecursive, lastDec, whereto, matchFailFn) =
+ let
+ fun allConstnt [] = true
+@@ -1755,8 +1693,8 @@
+ | allConstnt _ = false;
+
+ (* Finds the nth. item in the closure and returns the entry *)
+- fun findClosure (h::t) 1 = (* found it *) h
+- | findClosure (h::t) n = findClosure t (n - 1)
++ fun findClosure (h::_) 1 = (* found it *) h
++ | findClosure (_::t) n = findClosure t (n - 1)
+ | findClosure _ _ = raise InternalError "findClosure";
+ in
+ if not makeClosure
+@@ -1819,7 +1757,7 @@
+ else (* on the stack *)
+ pushNonLocal (transtable, newtab, pstackForDec (transtable, locn), makeSl, cvec)
+
+- | Extract {fpRel = false, addr = locn, lastRef, ...} => (* Try the next level *)
++ | Extract {fpRel = false, addr = locn, ...} => (* Try the next level *)
+ declOnPrevLevel
+ (locn,
+ fn () =>
+@@ -1877,7 +1815,7 @@
+
+ else (* Non-recursive. *)
+ case findClosure closureList prevloc of
+- Extract { addr=correctedLoc, fpRel, lastRef, ...} =>
++ Extract { addr=correctedLoc, fpRel, ...} =>
+ if fpRel
+ then (* On this level *)
+ let
+@@ -1955,10 +1893,10 @@
+ recursive references. This is left as the result for normal
+ references. *)
+ val result = pushCodeRef (transtable, newCode);
+- val U = mutualRecursive result; (* Any recursive references. *)
++ val () = mutualRecursive result; (* Any recursive references. *)
+ (* Now code-generate the procedure, throwing away the result which
+ will be put into the forward reference. *)
+- val discard : address =
++ val _ : address =
+ codegen
+ (lambdaBody,
+ newCode,
+@@ -1968,7 +1906,6 @@
+ slRegSet,
+ false, (* Presumably we need the static link, so don't discard regClosure. *)
+ numArgs,
+- closureRefs,
+ debugSwitches);
+ (* Note: we could sometimes discard the static link, but it's difficult
+ to work out when this would be safe. That's because it would be unsafe
+@@ -2026,7 +1963,7 @@
+ in the first place, but for now I'll do nothing (carefully).
+ SPF 2/5/97
+ *)
+- fun previous (locn, _, newtab, code) =
++ fun previous (locn, _, newtab, _) =
+ if locn = 0
+ then (* load the address of the closure itself *)
+ pushCodeRef (newtab, newCode)
+@@ -2040,32 +1977,31 @@
+ (lambdaBody,
+ newCode,
+ previous,
+- fn n => false,
+- fn (t, _, newtab, code) => raise InternalError "Not static link",
++ fn _ => false,
++ fn (_, _, _, _) => raise InternalError "Not static link",
+ fn _ => raise InternalError "Not static link",
+ true, (* Discard regClosure *)
+ numArgs,
+- closureRefs,
+ debugSwitches);
+
+ val result = pushConst (transtable, toMachineWord closureAddr);
+
+- val U : unit = mutualRecursive result;
++ val () = mutualRecursive result;
+ in
+ result
+ end
+
+ else let (* Full closure required. *)
+ (* Item n of the logical closure is which item of the physical closure? *)
+- fun translateClosureIndex (Constnt _ :: t) 1 =
++ fun translateClosureIndex (Constnt _ :: _) 1 =
+ raise InternalError "translateClosureIndex: constants don't belong in physical closure"
+
+- | translateClosureIndex (h :: t) 1 = 1
++ | translateClosureIndex (_ :: _) 1 = 1
+
+ | translateClosureIndex (Constnt _ :: t) n =
+ translateClosureIndex t (n - 1)
+
+- | translateClosureIndex (h :: t) n =
++ | translateClosureIndex (_ :: t) n =
+ translateClosureIndex t (n - 1) + 1
+
+ | translateClosureIndex [] _ =
+@@ -2109,12 +2045,11 @@
+ (lambdaBody,
+ newCode,
+ previous,
+- fn i => false,
+- fn (n , _, tt, code) => raise InternalError "Not static link",
++ fn _ => false,
++ fn (_ , _, _, _) => raise InternalError "Not static link",
+ fn _ => raise InternalError "Not static link",
+ false, (* We need regClosure *)
+ numArgs,
+- closureRefs,
+ debugSwitches);
+
+ val res : machineWord = toMachineWord codeAddr;
+@@ -2168,7 +2103,7 @@
+
+ fun nonConstntCount [] = 0
+ | nonConstntCount (Constnt _ :: t) = nonConstntCount t
+- | nonConstntCount (h :: t) = nonConstntCount t + 1;
++ | nonConstntCount (_ :: t) = nonConstntCount t + 1;
+
+ val closureSize = nonConstntCount closureList + 1;
+
+@@ -2179,7 +2114,7 @@
+ local
+ val locn = pushConst (transtable, res);
+ in
+- val U : unit = moveToVec (vector, locn, 0, STORE_WORD, cvec, transtable);
++ val () = moveToVec (vector, locn, 0, STORE_WORD, cvec, transtable);
+ end;
+
+ local
+@@ -2200,13 +2135,13 @@
+ *)
+ val locn = pushConst (transtable, DummyValue);
+ val wordsToClear : int = closureSize - 1;
+- val U : unit = incrUseCount (transtable, locn, wordsToClear -1);
++ val () = incrUseCount (transtable, locn, wordsToClear -1);
+
+ (* N.B. moveToVec doesn't count as a use of vector. *)
+ fun storeWord i =
+ moveToVec (vector, locn, i * wordSize, STORE_WORD, cvec, transtable)
+ in
+- val U : unit = forLoop storeWord 1 wordsToClear
++ val () = forLoop storeWord 1 wordsToClear
+ end;
+
+ (* Have to ensure that the closure remains on the psuedo-stack until
+@@ -2215,27 +2150,27 @@
+ could be zero when `mutualRecursive' returns. Have to increment
+ the use-count and then decrement it afterwards to make sure it
+ is still on the stack. *)
+- val U : unit = incrUseCount (transtable, vector, 1);
++ val () = incrUseCount (transtable, vector, 1);
+
+ (* Any mutually recursive references. *)
+- val U : unit = mutualRecursive vector;
++ val () = mutualRecursive vector;
+
+ (* Load items for the closure. *)
+- fun loadItems [] addr = ()
++ fun loadItems [] _ = ()
+ | loadItems (Constnt _ ::t) addr =
+ (* constants don't belong in the physical closure *)
+ loadItems t addr
+ | loadItems (h::t) addr =
+ let
+- val U : unit =
++ val () =
+ moveToVec (vector, genToStack (h, matchFailed), addr, STORE_WORD, cvec, transtable);
+ in
+ loadItems t (addr + wordSize)
+ end;
+
+- val U : unit = loadItems closureList wordSize;
+- val U : unit = lockSegment (vector, F_words);
+- val U : unit = incrUseCount (transtable, vector, ~1);
++ val () = loadItems closureList wordSize;
++ val () = lockSegment (vector, F_words);
++ val () = incrUseCount (transtable, vector, ~1);
+ in
+ vector
+ end
+@@ -2300,7 +2235,7 @@
+ val notB = unconditionalBranch (NoMerge, transtable, cvec);
+
+ (* Fill in the label for the then-part part. *)
+- val U : unit = fixup (a, transtable, cvec);
++ val () = fixup (a, transtable, cvec);
+
+ (* Now do the `else-part' and jump on the inverse of the condition. *)
+ val notC = genTest (elsePart, not jumpOn, matchFailFn);
+@@ -2308,14 +2243,14 @@
+ (* i.e. we drop though if the condition is the one we should have
+ jumped on. Now merge in the first label so we have both cases
+ when we should jump together, *)
+- val U = merge (b, transtable, cvec, NoMerge, mark2);
++ val _ = merge (b, transtable, cvec, NoMerge, mark2);
+
+ (* and now take the jump. *)
+ val resultLab = unconditionalBranch (NoMerge, transtable, cvec);
+
+ (* Come here if we are not jumping. *)
+- val U : unit = fixup (notB, transtable, cvec);
+- val U = merge (notC, transtable, cvec, NoMerge, mark1);
++ val () = fixup (notB, transtable, cvec);
++ val _ = merge (notC, transtable, cvec, NoMerge, mark1);
+ in
+ resultLab
+ end
+@@ -2327,7 +2262,7 @@
+ but this particular case is exceptionally important for
+ handling inlined selector functions. SPF 24/2/1998
+ *)
+- | Case {cases = [(result, [tag])], test, default, min, max} =>
++ | Case {cases = [(result, [tag])], test, default, ...} =>
+ let
+ val equalFun : codetree = Constnt (ioOp POLY_SYS_equala);
+ val arguments : codetree list = [test, Constnt (toMachineWord tag)];
+@@ -2353,7 +2288,7 @@
+ | codeBlock [h] = genTest (h, jumpOn, matchFailFn)
+ | codeBlock (h :: t) =
+ let
+- val U : mergeResult =
++ val _ : mergeResult =
+ gencde (h, true, NoResult, NotEnd, matchFailFn, NONE);
+ in
+ codeBlock t
+@@ -2502,9 +2437,9 @@
+ CodeNil => (* No else-part - used for pattern-matching too *)
+ let
+ (* code for "then part" - noResult 'cos we generate "void" below*)
+- val discard =
++ val _ =
+ genToRegister (thenExp, NoResult, tailKind, matchFailFn, loopAddr);
+- val discard = merge (lab, transtable, cvec, NoMerge, mark);
++ val _ = merge (lab, transtable, cvec, NoMerge, mark);
+ in
+ if needsResult
+ then MergeIndex(pushConst (transtable, DummyValue)) (* Generate a void result. *)
+@@ -2534,7 +2469,7 @@
+ val thenResult =
+ genToRegister (thenExp, whereto, tailKind, matchFailFn, loopAddr);
+
+- val U : unit =
++ val () =
+ if isEndOfProc tailKind andalso not (haveExited transtable)
+ then exit()
+ else ();
+@@ -2543,13 +2478,13 @@
+
+ (* Get rid of the result from the stack. If there is a result
+ then the "else-part" will push it. *)
+- val U : unit =
++ val () =
+ case thenResult of
+ MergeIndex thenIndex => removeStackEntry(transtable, thenIndex)
+ | NoMerge => ();
+
+ (* start of "else part" *)
+- val U : unit = fixup (lab, transtable, cvec);
++ val () = fixup (lab, transtable, cvec);
+ val elseResult =
+ genToRegister (elseExp, whereto, tailKind, matchFailFn, loopAddr)
+ in
+@@ -2570,7 +2505,7 @@
+ a list of pseudo-stack indexes for the registers. *)
+ fun evalArgs (argList : codetree list) : stackIndex list =
+ let
+- fun ldArgs [] (argNo : int) = []
++ fun ldArgs [] _ = []
+ | ldArgs (h::t) (argNo : int) =
+ let
+ val argLocn =
+@@ -2602,7 +2537,7 @@
+ the arguments. *)
+ fun pushArgs (argList : stackIndex list) : int * stackIndex list =
+ let
+- fun ldArgs [] (stackAddr : int) (argNo : int) = (stackAddr, [])
++ fun ldArgs [] (stackAddr : int) _ = (stackAddr, [])
+ | ldArgs (argLoc::t) (stackAddr : int) (argNo : int) =
+ if argNo < argRegs
+ then let (* Put into a register. *)
+@@ -2736,7 +2671,7 @@
+ Now try to generate the argument into the RIGHT register, to
+ minimise the moveArgs-generated register-shuffling. SPF 15/8/96
+ *)
+- fun genArgList n [] = [] : stackIndex list
++ fun genArgList _ [] = [] : stackIndex list
+ | genArgList n (arg :: args) =
+ let
+ val unsafelocn : stackIndex = genArg (n, arg, matchFailFn);
+@@ -2749,7 +2684,7 @@
+ val argsOnPstack : stackIndex list = genArgList 0 argList;
+
+ (* Now move the arguments to their final destination. *)
+- fun moveArgs [] argNo = []
++ fun moveArgs [] _ = []
+ | moveArgs (arg::args) argNo =
+ if argNo < argRegs
+ then let
+@@ -2769,7 +2704,7 @@
+ else argNo - numOfArgs;
+
+ (* Store it in the stack, reloading anything it displaces. *)
+- val U : unit = storeInStack (cvec, transtable, arg, offset);
++ val () = storeInStack (cvec, transtable, arg, offset);
+ in
+ moveArgs args (argNo + 1);
+ [] (* storeInStack removes its table entry *)
+@@ -2846,7 +2781,6 @@
+ fun callClosure (clos : codetree option): mergeResult =
+ let
+ val tailCall = isEndOfProc tailKind;
+- val bodyCall = not tailCall;
+
+ local
+ fun getArgRegs n =
+@@ -2905,7 +2839,7 @@
+ in
+ fun loadClosureProc (): (stackIndex option * bool * stackIndex list * reg list) =
+ case clos of
+- SOME(c as Constnt w) =>
++ SOME(Constnt w) =>
+ (* Do we need to load the closure register? *)
+ let
+ val addr = toAddress w;
+@@ -3030,7 +2964,7 @@
+ if 0 < length andalso length < 5
+ then let (* do it *)
+ val locn = genToStack (value, matchFailFn);
+- val U : unit = incrUseCount (transtable, locn, length - 1)
++ val () = incrUseCount (transtable, locn, length - 1)
+ val vec = callgetvec (length, flags, whereto);
+ val (storeKind, unitSize) =
+ if wordEq (flags, F_mutable_words)
+@@ -3242,7 +3176,6 @@
+ (* Cannot use a jump to local static-link procedures because
+ we may want local declarations on the current stack. *)
+ val tailCall = isEndOfProc tailKind andalso not fpRel;
+- val bodyCall = not tailCall;
+
+ (* Load and lock regClosure. Returns the indexes of
+ these entries in the stack. *)
+@@ -3257,7 +3190,7 @@
+ val SL = closureOrSlAddr
+ val closureIndex =
+ loadToSpecificReg (cvec, transtable, regClosure, SL, false);
+- val U : unit = lockRegister (transtable, regClosure);
++ val () = lockRegister (transtable, regClosure);
+ in
+ (NONE, false, [closureIndex], [regClosure])
+ end
+@@ -3271,9 +3204,9 @@
+ anything here. DCJM 21/12/00. *)
+
+ (* Get the static link register. Will set its value later. *)
+- val U : unit = getRegister (transtable, cvec, regClosure);
++ val () = getRegister (transtable, cvec, regClosure);
+ val closureIndex = pushReg (transtable, regClosure);
+- val U : unit = lockRegister (transtable, regClosure);
++ val () = lockRegister (transtable, regClosure);
+ in
+ (* Set value of static link register now. The static link entry
+ is now the address of the frame. DCJM 2/1/01. *)
+@@ -3352,9 +3285,9 @@
+ end (* genEval *);
+
+
+- val resultReg = genToRegister (pt, ToReg regResult, EndOfProc, matchFailed, NONE);
++ val _ = genToRegister (pt, ToReg regResult, EndOfProc, matchFailed, NONE);
+
+- val U : unit = if not (haveExited transtable) then exit () else ()
++ val () = if not (haveExited transtable) then exit () else ()
+ in
+
+ (* Having code generated the body of the procedure,
+@@ -3362,7 +3295,7 @@
+ copyCode (cvec, maxstack transtable, getModifedRegSet transtable)
+ end (* codegen *);
+
+- fun gencode (Lambda { name, body, numArgs, closureRefs, ...}, debugSwitches) =
++ fun gencode (Lambda { name, body, numArgs, ...}, debugSwitches) =
+ let (* We are compiling a procedure. *)
+ (* It is not essential to treat this specially, but it saves generating
+ a piece of code whose only function is to return the address of the
+@@ -3383,13 +3316,12 @@
+ codegen
+ (body,
+ newCode,
+- fn (i , _, newtab, code) => pushCodeRef (newtab, newCode),
+- fn i => false,
+- fn (i, _, tt, c) => raise InternalError "Not static link",
++ fn (_ , _, newtab, _) => pushCodeRef (newtab, newCode),
++ fn _ => false,
++ fn (_, _, _, _) => raise InternalError "Not static link",
+ fn _ => raise InternalError "Not static link",
+ true, (* Discard regClosure *)
+ numArgs,
+- closureRefs,
+ debugSwitches);
+
+ val res : machineWord = toMachineWord closureAddr;
+@@ -3407,13 +3339,12 @@
+ codegen
+ (pt,
+ newCode,
+- fn (i, _, tt, c) => raise InternalError "top level reached",
+- fn i => false,
+- fn (i, _, tt, c) => raise InternalError "Not static link",
++ fn (_, _, _, _) => raise InternalError "top level reached",
++ fn _ => false,
++ fn (_, _, _, _) => raise InternalError "Not static link",
+ fn _ => raise InternalError "Not static link",
+ true, (* Discard regClosure *)
+ 0, (* No args. *)
+- 0, (* No recursive references *)
+ debugSwitches);
+ in (* Result is a procedure to execute the code. *)
+ fn () => call (closureAddr, toMachineWord ())
+diff -u -r mlsource/MLCompiler/CodeTree/I386CODECONS.ML mlsource/MLCompiler/CodeTree/I386CODECONS.ML
+--- mlsource/MLCompiler/CodeTree/I386CODECONS.ML 2008-04-21 13:30:52.000000000 +0200
++++ mlsource/MLCompiler/CodeTree/I386CODECONS.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -42,38 +42,14 @@
+ structure DEBUG :
+ sig
+ val assemblyCodeTag : bool Universal.tag
+- val compilerOutputTag: (string->unit) Universal.tag
+ val getParameter :
+ 'a Universal.tag -> Universal.universal list -> 'a
+ end;
+
+-
+-
+-(*****************************************************************************)
+-(* MISC *)
+-(*****************************************************************************)
+-structure MISC :
+-sig
+- exception InternalError of string
+-end;
+-
+ (*****************************************************************************)
+-(* CODECONS sharing constraints *)
++(* PRETTY for compilerOutTag *)
+ (*****************************************************************************)
+-
+-(* removed SPF 24/9/94 ...
+-sharing type
+- ADDRESS.word
+-= CODESEG.word
+-
+-sharing type
+- ADDRESS.short
+-= CODESEG.short
+-
+-sharing type
+- ADDRESS.address
+-= CODESEG.address
+-... *)
++structure PRETTY: PRETTYSIG
+
+ ) :
+
+@@ -248,65 +224,15 @@
+ end (* CODECONS export signature *) =
+
+
+-let
+-
+-(*****************************************************************************)
+-(* ADDRESS *)
+-(*****************************************************************************)
+-structure ADDRESS :
+-sig
+- type machineWord; (* NB *not* eqtype, 'cos it might be a closure *)
+- type short = Word.word;
+- type address;
+- type handler;
+-
+- val wordEq : machineWord * machineWord -> bool
+-
+- val isShort: 'a -> bool;
+- val toShort: 'a -> short;
+- val toMachineWord: 'a -> machineWord;
+-
+- val offsetAddr : address * short -> handler
+-
+- val alloc: (short * Word8.word * machineWord) -> address
+- val F_words : Word8.word
+-
+- val lock : address -> unit;
+-
+- val wordSize: int
+-end = Address;
+-
+-(*****************************************************************************)
+-(* CODESEG *)
+-(*****************************************************************************)
+-structure CODESEG :
+-sig
+- type machineWord;
+- type short;
+- type address;
+- type cseg;
+-
+- val csegMake: int -> cseg;
+- val csegConvertToCode: cseg -> unit;
+- val csegLock: cseg -> unit;
+- val csegGet: cseg * int -> Word8.word;
+- val csegSet: cseg * int * Word8.word -> unit;
+- val csegPutWord: cseg * int * machineWord -> unit;
+- val csegCopySeg: cseg * cseg * int * int -> unit;
+- val csegAddr: cseg -> address;
+- val csegPutConstant: cseg * int * machineWord * 'a -> unit;
+-end = CodeSeg;
+-
+-in
+-
+ (*****************************************************************************)
+ (* CODECONS functor body *)
+ (*****************************************************************************)
+ struct
+- open CODESEG;
++ open CodeSeg;
+ open DEBUG;
+- open ADDRESS;
+- open MISC;
++ open PRETTY
++ open Address;
++ open Misc;
+
+ val toInt = Word.toIntX (* This previously just cast the value so continue to treat it as signed. *)
+
+@@ -328,7 +254,7 @@
+ fun exp2 0 = 1
+ | exp2 n = 2 * exp2 (n - 1);
+ in
+- val UUU =
++ val _ =
+ (
+ exp2_3 = exp2 3 andalso
+ exp2_6 = exp2 6 andalso
+@@ -475,11 +401,12 @@
+
+ fun (Code{pcOffset=a, ...}) is (Code{pcOffset=b, ...}) = a=b;
+
+- (* create and initialise a code segment *)
+- fun codeCreate (noClosure : bool, name : string, parameters) : code =
+- let
+- val words = codesize div 4
+- in
++ (* create and initialise a code segment *)
++ fun codeCreate (noClosure : bool, name : string, parameters) : code =
++ let
++ val words = codesize div 4
++ val printStream = PRETTY.getSimplePrinter parameters;
++ in
+ Code
+ {
+ codeVec = csegMake words, (* a byte array *)
+@@ -501,7 +428,7 @@
+ noClosure = noClosure,
+ branchCheck = ref addrZero,
+ printAssemblyCode = DEBUG.getParameter DEBUG.assemblyCodeTag parameters,
+- printStream = DEBUG.getParameter DEBUG.compilerOutputTag parameters
++ printStream = printStream
+ }
+ end;
+
+@@ -747,9 +674,6 @@
+
+ fun a regEq b = getReg a = getReg b;
+ fun a regNeq b = getReg a <> getReg b;
+- fun a regLeq b = getReg a <= getReg b;
+- fun a regGeq b = getReg a >= getReg b;
+- fun (Reg a) regMinus (Reg b) = a - b;
+
+ (* The number of the register. *)
+ fun nReg r =
+@@ -951,7 +875,7 @@
+ the referring procedure is finished and its address is known the
+ address will be plugged in to every procedure which needs it. *)
+ let
+- fun onList x [] = false
++ fun onList _ [] = false
+ | onList x (c::cs) = (x is c) orelse onList x cs ;
+
+ val codeList = ! otherCodes;
+@@ -965,7 +889,7 @@
+ fun removeLabel (lab:addrs, Code{longestBranch, labelList, ... }) : unit =
+ let
+ fun removeEntry ([]: labList) : labList = []
+- | removeEntry ((entry as ref (Jump32From addr)) :: t) =
++ | removeEntry ((ref (Jump32From _)) :: t) =
+ removeEntry t (* we discard long jumps *)
+
+ | removeEntry ((entry as ref (Jump8From addr)) :: t) =
+@@ -986,7 +910,7 @@
+ end;
+
+ (* Fix up the list of labels. *)
+- fun reallyFixBranches ([] : labels) cvec = ()
++ fun reallyFixBranches ([] : labels) _ = ()
+ | reallyFixBranches (h::t) (cvec as Code{codeVec=cseg, ic, branchCheck, ...}) =
+ ((case !h of
+ Jump8From addr =>
+@@ -1040,7 +964,7 @@
+ reallyFixBranches t cvec
+ )
+
+- fun fixRecursiveBranches (cvec, target, []) = ()
++ fun fixRecursiveBranches (_, _, []) = ()
+ | fixRecursiveBranches (cvec as Code{codeVec=cseg, ...}, target, addrH :: addrT) =
+ ((case !addrH of
+ Jump8From addr =>
+@@ -1075,7 +999,7 @@
+ );
+
+ (* The address is the offset of the offset, not the instruction itself. *)
+- fun fixRecursiveCalls (cvec, target, []) = ()
++ fun fixRecursiveCalls (_, _, []) = ()
+ | fixRecursiveCalls (cvec as Code{codeVec=cseg, ...}, target, addrH :: addrT) =
+ let
+ val instr : int = get8u (getAddr addrH - 1, cseg);
+@@ -1094,7 +1018,7 @@
+ end;
+
+ (* Deal with a pending fix-up. *)
+- fun reallyFixup (cvec as Code{justComeFrom=ref [], ... }) = ()
++ fun reallyFixup (Code{justComeFrom=ref [], ... }) = ()
+ | reallyFixup (cvec as Code{justComeFrom=jcf as ref labs, exited, ... }) =
+ (exited := false; reallyFixBranches labs cvec; jcf := []);
+
+@@ -1147,7 +1071,7 @@
+ end;
+
+ (* Apparently fix up jumps - actually just record where we have come from *)
+- fun fixup (labs:labels, cvec as Code{justComeFrom, exited, ic, branchCheck, procName, ...}) =
++ fun fixup (labs:labels, cvec as Code{justComeFrom, exited, ic, branchCheck, ...}) =
+ let
+ (* If the jump we are fixing up is immediately preceding,
+ we can remove it. It is particularly important to remove
+@@ -1252,7 +1176,7 @@
+ in
+ (* Now do this entry. *)
+ case !lab of
+- Jump32From addr => (* shouldn't happen? *)
++ Jump32From _ => (* shouldn't happen? *)
+ convertRest
+
+ | Jump8From addr =>
+@@ -1359,7 +1283,7 @@
+ let
+ (* If we have just jumped here we may be able to avoid generating a
+ jump instruction. *)
+- val U : unit = flushQueue cvec; (* Do any pending instructions. *)
++ val () = flushQueue cvec; (* Do any pending instructions. *)
+ val labs = ! justComeFrom;
+ in
+ justComeFrom := [];
+@@ -1407,7 +1331,7 @@
+ fun genSelfBranch (cvec as Code{justComeFrom, exited, ic, ... }) : labels =
+ let
+ (* Do any pending instructions. *)
+- val U : unit = flushQueue cvec;
++ val () = flushQueue cvec;
+
+ (* Can we get into the prelude with an 8-bit jump? *)
+ (* Conservative estimation needs to allow for:
+@@ -1431,7 +1355,7 @@
+ | tidy (ref (Jump32From _) :: t) = tidy t
+ | tidy (ref (Jump8From a) :: t) = (removeLabel (a, cvec); tidy t);
+
+- val U : unit = tidy longJumps;
++ val () = tidy longJumps;
+
+ (* do we actually need to insert a jump into the codestream? *)
+ val needsJump =
+@@ -1442,8 +1366,8 @@
+ if needsJump
+ then let
+ (* fix up pending short jumps to here *)
+- val U : unit = justComeFrom := shortJumps;
+- val U : unit = doPending (cvec, 5);
++ val () = justComeFrom := shortJumps;
++ val () = doPending (cvec, 5);
+
+ (* Now decide whether we can use an 8-bit jump here. *)
+ (* N.B. we use gen8u here, not genop, because the latter
+@@ -2005,7 +1929,7 @@
+ case callKind of
+ Recursive =>
+ let
+- val U : unit = mustCheckStack := true;
++ val () = mustCheckStack := true;
+ val lab = genSelfBranch cvec;
+ in
+ selfJumps := lab @ ! selfJumps
+@@ -2400,7 +2324,7 @@
+ implement arbitrary-precision operations. *)
+ fun genJO8 (addr, cvec as Code{ic, ...}) =
+ let
+- val U : unit = doPending (cvec, 12);
++ val () = doPending (cvec, 12);
+ val here = !ic;
+ (* jump address calculations are relative to the value
+ of the program counter *after* the instruction *)
+@@ -2412,7 +2336,7 @@
+
+
+ (* All these can be handled. *)
+- fun isCompRR tc = true;
++ fun isCompRR _ = true;
+
+ (* Is this argument acceptable as an immediate or should it be loaded into a register? *)
+ fun isCompRI (tc, cnstnt) =
+@@ -3106,7 +3030,7 @@
+ | instrModW =>
+ let
+ val c = toInt (toShort constnt)
+- val ASSERT = log2 c (* Check it's a power of 2. *)
++ val _ = log2 c (* Check it's a power of 2. *)
+ val tagged = tag (c-1)
+ in
+ genMove (rd, rs, cvec);
+@@ -3219,11 +3143,11 @@
+ *)
+ type jumpTableAddrs = addrs;
+
+- fun constrCases (p as (i,a)) = p;
++ fun constrCases (p as (_,_)) = p;
+
+ type caseList = cases list;
+
+- fun useIndexedCase (min:int, max:int, numberOfCases:int, exhaustive:bool) =
++ fun useIndexedCase (min:int, max:int, numberOfCases:int, _:bool) =
+ isShort min andalso
+ isShort max andalso
+ numberOfCases > 7 andalso
+@@ -3248,11 +3172,11 @@
+ val l1 = putConditional (JE, cvec);
+
+ (* Compare with the minimum. *)
+- val UUU = genImmed(CMP, r1, taggedMin, cvec);
++ val () = genImmed(CMP, r1, taggedMin, cvec);
+ val l2 = putConditional (JL, cvec);
+
+ (* Compare with the maximum. *)
+- val UUU = genImmed(CMP, r1, taggedMax, cvec);
++ val () = genImmed(CMP, r1, taggedMax, cvec);
+ val l3 = putConditional (JG, cvec);
+ in
+ [l1, l2, l3]
+@@ -3352,7 +3276,7 @@
+ fun print32 () =
+ let
+ val valu = get32s (!ptr, seg);
+- val U : unit = (ptr +:= 4);
++ val () = (ptr +:= 4);
+ in
+ if valu = tag 0 andalso !numOfConsts <> 0
+ then
+@@ -3386,7 +3310,7 @@
+ fun print16 () =
+ let
+ val valu = get16s (!ptr, seg);
+- val U : unit = (ptr +:= 2);
++ val () = (ptr +:= 2);
+ in
+ printHex valu
+ end;
+@@ -3394,7 +3318,7 @@
+ fun print8 () =
+ let
+ val valu = get8s (!ptr, seg);
+- val U : unit = ptr +:= 1;
++ val () = ptr +:= 1;
+ in
+ printHex valu
+ end;
+@@ -3402,7 +3326,7 @@
+ fun printJmp () =
+ let
+ val valu = get8s (!ptr, seg);
+- val U : unit = ptr +:= 1;
++ val () = ptr +:= 1;
+ in
+ printHex (valu + !ptr)
+ end;
+@@ -3411,7 +3335,7 @@
+ fun printEA () =
+ let
+ val modrm = Word8.toInt (csegGet (seg, !ptr));
+- val U : unit = (ptr +:= 1);
++ val () = (ptr +:= 1);
+ val md = modrm div 64;
+ val rm = modrm mod 8;
+ in
+@@ -3421,7 +3345,7 @@
+ else if rm = 4
+ then let (* s-i-b present. *)
+ val sib = Word8.toInt (csegGet (seg, !ptr));
+- val U : unit = (ptr +:= 1);
++ val () = (ptr +:= 1);
+ val ss = sib div 64;
+ val index = (sib div 8) mod 8;
+ val base = sib mod 8;
+@@ -3484,11 +3408,11 @@
+
+ while !ptr < endcode do
+ let
+- val U : unit = printHex (!ptr); (* The address. *)
+- val U : unit = print "\t";
++ val () = printHex (!ptr); (* The address. *)
++ val () = print "\t";
+
+ val opByte : int = get8u (!ptr, seg);
+- val U : unit = ptr +:= 1;
++ val () = ptr +:= 1;
+ in
+ if opByte = opToInt Group1_8_A orelse
+ opByte = opToInt Group1_32_A
+@@ -3544,7 +3468,7 @@
+ else if opByte = opToInt JMP_32
+ then let
+ val valu = get32s (!ptr, seg);
+- val U : unit = (ptr +:= 4);
++ val () = (ptr +:= 4);
+ in
+ print "jmp\t";
+ printHex (!ptr + valu)
+@@ -3553,7 +3477,7 @@
+ else if opByte = opToInt CALL_32
+ then let
+ val valu = get32s (!ptr, seg);
+- val U : unit = (ptr +:= 4);
++ val () = (ptr +:= 4);
+ in
+ print "call\t";
+ printHex (!ptr + valu)
+@@ -3769,7 +3693,7 @@
+ then let
+ (* Opcode is in next byte. *)
+ val opByte2 = Word8.toInt (csegGet (seg, !ptr));
+- val U : unit = (ptr +:= 1);
++ val () = (ptr +:= 1);
+ in
+ if opByte2 = 11 * 16 + 6 (* 0xb6 *)
+ then let
+@@ -3786,7 +3710,7 @@
+ opByte2 <= 8 * 16 + 15 (* 0x8f *)
+ then let
+ val valu = get32s (!ptr, seg);
+- val U : unit = (ptr +:= 4);
++ val () = (ptr +:= 4);
+ in
+ print
+ (if opByte2 = 8 * 16 (* 0x80 *)
+@@ -3915,9 +3839,9 @@
+ let
+
+ (* This aligns ic onto a fullword boundary. *)
+- val U : unit = align (0, cvec);
++ val () = align (0, cvec);
+ val endic = !ic; (* Remember end *)
+- val U : unit = gen32u (0, cvec); (* Marker - 0 (changes !ic) *)
++ val () = gen32u (0, cvec); (* Marker - 0 (changes !ic) *)
+
+ (* Prelude consists of
+ 1) nops to make it a whole number of words
+@@ -3926,7 +3850,7 @@
+ *)
+ local
+ (* little-endian *)
+- fun getBytes (0, x) = []
++ fun getBytes (0, _) = []
+ | getBytes (n, x) = (x mod exp2_8) :: getBytes (n - 1, x div exp2_8);
+
+ fun testRegAndTrap (reg, entryPt) =
+@@ -3996,7 +3920,7 @@
+ val nopCode : int list =
+ let
+ (* Add sufficient No-ops to round this to a full word. *)
+- val len = length stackCheckCode mod wordSize
++ val len = List.length stackCheckCode mod wordSize
+ in
+ if len = 0
+ then []
+@@ -4005,21 +3929,21 @@
+
+ in
+ val preludeCode = nopCode @ stackCheckCode;
+- val wordsForPrelude = length preludeCode div wordSize
++ val wordsForPrelude = List.length preludeCode div wordSize
+
+ (* +4 for code size, profile count, function name and constants count *)
+ (* +1 for register mask. *)
+ val segSize = (getAddr (!ic)) div wordSize + wordsForPrelude + 4 + 1;
+
+ (* byte offset of L2 label relative to start of post-prelude code. *)
+- val L2Addr = mkAddr (~ (length stackCheckCode));
++ val L2Addr = mkAddr (~ (List.length stackCheckCode));
+ end; (* local *)
+
+ (* fix-up all the self-calls *)
+- val U : unit =
++ val () =
+ fixRecursiveCalls (cvec, L2Addr, selfCalls);
+
+- val U : unit =
++ val () =
+ fixRecursiveBranches (cvec, L2Addr, selfJumps);
+
+ (* Now make the byte segment that we'll turn into the code segment *)
+@@ -4047,7 +3971,7 @@
+ fun putPreludeList [] = ()
+ | putPreludeList (w::ws) = (putPrelude w; putPreludeList ws);
+ in
+- val U : unit = putPreludeList preludeCode
++ val () = putPreludeList preludeCode
+ end;
+
+ local
+@@ -4058,7 +3982,7 @@
+ val byteEndofcode = endOfCode * 4;
+ val addr = mkAddr byteEndofcode;
+ in
+- val U : unit = set32u (byteEndofcode, addr, seg)
++ val () = set32u (byteEndofcode, addr, seg)
+ end;
+
+ (* Put in the number of constants. This must go in before we actually put
+@@ -4067,21 +3991,21 @@
+ local
+ val addr = mkAddr ((endOfCode + 3 + 1) * 4);
+ in
+- val U : unit = set32u (2, addr, seg)
++ val () = set32u (2, addr, seg)
+ end;
+
+ (* Next the profile count. *)
+ local
+ val addr = mkAddr ((endOfCode + 1) * 4);
+ in
+- val U : unit = set32u (0, addr, seg)
++ val () = set32u (0, addr, seg)
+ end;
+
+ (* Now we've filled in all the C integers; now we need to convert the segment
+ into a proper code segment before it's safe to put in any ML values.
+ SPF 13/2/97
+ *)
+- val U : unit = csegConvertToCode seg;
++ val () = csegConvertToCode seg;
+
+ local
+ (* why do we treat the empty string as a special case? SPF 15/7/94 *)
+@@ -4104,7 +4028,7 @@
+ end
+ val regSet = List.foldl encodeReg 0w0 registerSet
+ in
+- val U : unit = csegPutWord (seg, endOfCode + 3, toMachineWord regSet);
++ val () = csegPutWord (seg, endOfCode + 3, toMachineWord regSet);
+ end;
+ end; (* scope of endOfCode *)
+ in
+@@ -4154,7 +4078,7 @@
+ way and I'm not completely sure that everything that needs a mutable
+ allocation actually asks for it yet. SPF 19/2/97
+ *)
+- val U : unit = lock addr;
++ val () = lock addr;
+ in
+ addr
+ end
+@@ -4162,9 +4086,9 @@
+ (* Now we know the address of this object we can fix up
+ any forward references outstanding. This is put in here
+ because there may be directly recursive references. *)
+- val U : unit = fixOtherRefs (cvec, toMachineWord addr);
++ val () = fixOtherRefs (cvec, toMachineWord addr);
+
+- val U : unit =
++ val () =
+ if printAssemblyCode
+ then (* print out the code *)
+ (
+@@ -4201,6 +4125,4 @@
+ (* Function name and code offset to help tracing. *)
+ procName ^ ":" ^ Int.fmt StringCvt.HEX (getAddr ic)
+
+-end (* struct *)
+-
+-end (* CODECONS *);
++end (* struct *) (* CODECONS *);
+diff -u -r mlsource/MLCompiler/CodeTree/INTCODECONS.ML mlsource/MLCompiler/CodeTree/INTCODECONS.ML
+--- mlsource/MLCompiler/CodeTree/INTCODECONS.ML 2008-04-21 13:30:52.000000000 +0200
++++ mlsource/MLCompiler/CodeTree/INTCODECONS.ML 2009-09-15 08:56:45.000000000 +0200
+@@ -37,11 +37,14 @@
+ structure DEBUG :
+ sig
+ val assemblyCodeTag : bool Universal.tag
+- val compilerOutputTag: (string->unit) Universal.tag
+ val getParameter :
+ 'a Universal.tag -> Universal.universal list -> 'a
+ end;
+
++(*****************************************************************************)
++(* PRETTY for compilerOutTag *)
++(*****************************************************************************)
++structure PRETTY: PRETTYSIG
+
+
+ (*****************************************************************************)
+@@ -259,18 +262,18 @@
+
+ fun forLoop f i n = if i > n then () else (f i; forLoop f (i + 1) n);
+
+- fun applyList (f, []) = ()
++ fun applyList (_, []) = ()
+ | applyList (f, h::t) =
+ let
+- val U : unit = f h;
++ val () = f h;
+ in
+ applyList (f, t)
+ end;
+
+- fun applyCountList (f, n, []) = ()
++ fun applyCountList (_, _, []) = ()
+ | applyCountList (f, n, h::t) =
+ let
+- val U : unit = f (n, h);
++ val () = f (n, h);
+ in
+ applyCountList (f, n + 1, t)
+ end;
+@@ -426,7 +429,7 @@
+ val opcode_callSlC = Opcode 89;
+ val opcode_ioVec_5 = Opcode 90;
+ val opcode_ioVec_6 = Opcode 91;
+- val opcode_integerAdd = Opcode 92;
++(* val opcode_integerAdd = Opcode 92;
+ val opcode_integerMinus = Opcode 93;
+ val opcode_integerEqual = Opcode 94;
+ val opcode_integerLeq = Opcode 95;
+@@ -434,7 +437,7 @@
+ val opcode_integerGreater = Opcode 96;
+ val opcode_booleanOr = Opcode 97;
+ val opcode_wordEqual = Opcode 98;
+- val opcode_assignWord = Opcode 99;
++ val opcode_assignWord = Opcode 99;*)
+ val opcode_resetR_1 = Opcode 100;
+ val opcode_resetR_2 = Opcode 101;
+ val opcode_resetR_3 = Opcode 102;
+@@ -474,140 +477,140 @@
+
+ fun repUpdate (Opcode n, s) = Array.update (repArray, n, s);
+
+- val U : unit = repUpdate(opcode_enterInt, "enterInt");
+- val U : unit = repUpdate(opcode_jump, "jump");
+- val U : unit = repUpdate(opcode_jumpFalse, "jumpFalse");
+- val U : unit = repUpdate(opcode_delHandler, "delHandler");
+- val U : unit = repUpdate(opcode_jumpI, "jumpI");
+- val U : unit = repUpdate(opcode_jumpIFalse, "jumpIFalse");
+- val U : unit = repUpdate(opcode_delHandlerI, "delHandlerI");
+- val U : unit = repUpdate(opcode_caseSwitch, "caseSwitch");
+- val U : unit = repUpdate(opcode_callSl, "callSl");
+- val U : unit = repUpdate(opcode_callSlX, "callSlX");
+- val U : unit = repUpdate(opcode_callClosure, "callClosure");
+- val U : unit = repUpdate(opcode_returnW, "returnW");
+- val U : unit = repUpdate(opcode_pad, "pad");
++ val () = repUpdate(opcode_enterInt, "enterInt");
++ val () = repUpdate(opcode_jump, "jump");
++ val () = repUpdate(opcode_jumpFalse, "jumpFalse");
++ val () = repUpdate(opcode_delHandler, "delHandler");
++ val () = repUpdate(opcode_jumpI, "jumpI");
++ val () = repUpdate(opcode_jumpIFalse, "jumpIFalse");
++ val () = repUpdate(opcode_delHandlerI, "delHandlerI");
++ val () = repUpdate(opcode_caseSwitch, "caseSwitch");
++ val () = repUpdate(opcode_callSl, "callSl");
++ val () = repUpdate(opcode_callSlX, "callSlX");
++ val () = repUpdate(opcode_callClosure, "callClosure");
++ val () = repUpdate(opcode_returnW, "returnW");
++ val () = repUpdate(opcode_pad, "pad");
+ (* ...
+- val U : unit = repUpdate(opcode_projectW, "projectW");
++ val () = repUpdate(opcode_projectW, "projectW");
+ ... *)
+- val U : unit = repUpdate(opcode_raiseEx, "raiseEx");
+- val U : unit = repUpdate(opcode_getStoreW, "getStoreW");
+- val U : unit = repUpdate(opcode_nonLocal, "nonLocal");
+- val U : unit = repUpdate(opcode_localW, "localW");
+- val U : unit = repUpdate(opcode_indirectW, "indirectW");
+- val U : unit = repUpdate(opcode_moveToVecW, "moveToVecW");
+- val U : unit = repUpdate(opcode_setStackValW, "setStackValW");
+- val U : unit = repUpdate(opcode_resetW, "resetW");
+- val U : unit = repUpdate(opcode_resetR_w, "resetR_w");
+- val U : unit = repUpdate(opcode_constAddr, "constAddr");
+- val U : unit = repUpdate(opcode_constAddrX_b, "constAddrX_b");
+- val U : unit = repUpdate(opcode_constAddrX_w, "constAddrX_w");
+- val U : unit = repUpdate(opcode_constIntW, "constIntW");
+- val U : unit = repUpdate(opcode_ioVecEntry, "ioVecEntry");
+- val U : unit = repUpdate(opcode_constNil, "constNil");
+- val U : unit = repUpdate(opcode_jumpBack, "jumpBack");
+- val U : unit = repUpdate(opcode_returnB, "returnB");
++ val () = repUpdate(opcode_raiseEx, "raiseEx");
++ val () = repUpdate(opcode_getStoreW, "getStoreW");
++ val () = repUpdate(opcode_nonLocal, "nonLocal");
++ val () = repUpdate(opcode_localW, "localW");
++ val () = repUpdate(opcode_indirectW, "indirectW");
++ val () = repUpdate(opcode_moveToVecW, "moveToVecW");
++ val () = repUpdate(opcode_setStackValW, "setStackValW");
++ val () = repUpdate(opcode_resetW, "resetW");
++ val () = repUpdate(opcode_resetR_w, "resetR_w");
++ val () = repUpdate(opcode_constAddr, "constAddr");
++ val () = repUpdate(opcode_constAddrX_b, "constAddrX_b");
++ val () = repUpdate(opcode_constAddrX_w, "constAddrX_w");
++ val () = repUpdate(opcode_constIntW, "constIntW");
++ val () = repUpdate(opcode_ioVecEntry, "ioVecEntry");
++ val () = repUpdate(opcode_constNil, "constNil");
++ val () = repUpdate(opcode_jumpBack, "jumpBack");
++ val () = repUpdate(opcode_returnB, "returnB");
+ (* ...
+- val U : unit = repUpdate(opcode_projectB, "projectB");
++ val () = repUpdate(opcode_projectB, "projectB");
+ ... *)
+- val U : unit = repUpdate(opcode_getStoreB, "getStoreB");
+- val U : unit = repUpdate(opcode_localB, "localB");
+- val U : unit = repUpdate(opcode_indirectB, "indirectB");
+- val U : unit = repUpdate(opcode_moveToVecB, "moveToVecB");
+- val U : unit = repUpdate(opcode_setStackValB, "setStackValB");
+- val U : unit = repUpdate(opcode_resetB, "resetB");
+- val U : unit = repUpdate(opcode_resetRB, "resetRB");
+- val U : unit = repUpdate(opcode_constIntB, "constIntB");
+- val U : unit = repUpdate(opcode_local_0, "local_0");
+- val U : unit = repUpdate(opcode_local_1, "local_1");
+- val U : unit = repUpdate(opcode_local_2, "local_2");
+- val U : unit = repUpdate(opcode_local_3, "local_3");
+- val U : unit = repUpdate(opcode_local_4, "local_4");
+- val U : unit = repUpdate(opcode_local_5, "local_5");
+- val U : unit = repUpdate(opcode_local_6, "local_6");
+- val U : unit = repUpdate(opcode_local_7, "local_7");
+- val U : unit = repUpdate(opcode_local_8, "local_8");
+- val U : unit = repUpdate(opcode_local_9, "local_9");
+- val U : unit = repUpdate(opcode_local_10, "local_10");
+- val U : unit = repUpdate(opcode_local_11, "local_11");
+- val U : unit = repUpdate(opcode_indirect_0, "indirect_0");
+- val U : unit = repUpdate(opcode_indirect_1, "indirect_1");
+- val U : unit = repUpdate(opcode_indirect_2, "indirect_2");
+- val U : unit = repUpdate(opcode_indirect_3, "indirect_3");
+- val U : unit = repUpdate(opcode_indirect_4, "indirect_4");
+- val U : unit = repUpdate(opcode_indirect_5, "indirect_5");
+- val U : unit = repUpdate(opcode_const_0, "const_0");
+- val U : unit = repUpdate(opcode_const_1, "const_1");
+- val U : unit = repUpdate(opcode_const_2, "const_2");
+- val U : unit = repUpdate(opcode_const_3, "const_3");
+- val U : unit = repUpdate(opcode_const_4, "const_4");
+- val U : unit = repUpdate(opcode_const_10, "const_10");
+- val U : unit = repUpdate(opcode_return_0, "return_0");
+- val U : unit = repUpdate(opcode_return_1, "return_1");
+- val U : unit = repUpdate(opcode_return_2, "return_2");
+- val U : unit = repUpdate(opcode_return_3, "return_3");
+- val U : unit = repUpdate(opcode_moveToVec_0, "moveToVec_0");
+- val U : unit = repUpdate(opcode_moveToVec_1, "moveToVec_1");
+- val U : unit = repUpdate(opcode_moveToVec_2, "moveToVec_2");
+- val U : unit = repUpdate(opcode_moveToVec_3, "moveToVec_3");
+- val U : unit = repUpdate(opcode_moveToVec_4, "moveToVec_4");
+- val U : unit = repUpdate(opcode_moveToVec_5, "moveToVec_5");
+- val U : unit = repUpdate(opcode_moveToVec_6, "moveToVec_6");
+- val U : unit = repUpdate(opcode_moveToVec_7, "moveToVec_7");
+- val U : unit = repUpdate(opcode_reset_1, "reset_1");
+- val U : unit = repUpdate(opcode_reset_2, "reset_2");
+- val U : unit = repUpdate(opcode_getStore_2, "getStore_2");
+- val U : unit = repUpdate(opcode_getStore_3, "getStore_3");
+- val U : unit = repUpdate(opcode_getStore_4, "getStore_4");
+- val U : unit = repUpdate(opcode_nonLocalL_1, "nonLocalL_1");
+- val U : unit = repUpdate(opcode_nonLocalL_2, "nonLocalL_2");
+- val U : unit = repUpdate(opcode_nonLocalL_3, "nonLocalL_3");
+- val U : unit = repUpdate(opcode_callSlC, "callSlC");
+- val U : unit = repUpdate(opcode_callSlCX, "callSlCX");
+- val U : unit = repUpdate(opcode_ioVec_5, "ioVec_5");
+- val U : unit = repUpdate(opcode_ioVec_6, "opcode_ioVec_6");
++ val () = repUpdate(opcode_getStoreB, "getStoreB");
++ val () = repUpdate(opcode_localB, "localB");
++ val () = repUpdate(opcode_indirectB, "indirectB");
++ val () = repUpdate(opcode_moveToVecB, "moveToVecB");
++ val () = repUpdate(opcode_setStackValB, "setStackValB");
++ val () = repUpdate(opcode_resetB, "resetB");
++ val () = repUpdate(opcode_resetRB, "resetRB");
++ val () = repUpdate(opcode_constIntB, "constIntB");
++ val () = repUpdate(opcode_local_0, "local_0");
++ val () = repUpdate(opcode_local_1, "local_1");
++ val () = repUpdate(opcode_local_2, "local_2");
++ val () = repUpdate(opcode_local_3, "local_3");
++ val () = repUpdate(opcode_local_4, "local_4");
++ val () = repUpdate(opcode_local_5, "local_5");
++ val () = repUpdate(opcode_local_6, "local_6");
++ val () = repUpdate(opcode_local_7, "local_7");
++ val () = repUpdate(opcode_local_8, "local_8");
++ val () = repUpdate(opcode_local_9, "local_9");
++ val () = repUpdate(opcode_local_10, "local_10");
++ val () = repUpdate(opcode_local_11, "local_11");
++ val () = repUpdate(opcode_indirect_0, "indirect_0");
++ val () = repUpdate(opcode_indirect_1, "indirect_1");
++ val () = repUpdate(opcode_indirect_2, "indirect_2");
++ val () = repUpdate(opcode_indirect_3, "indirect_3");
++ val () = repUpdate(opcode_indirect_4, "indirect_4");
++ val () = repUpdate(opcode_indirect_5, "indirect_5");
++ val () = repUpdate(opcode_const_0, "const_0");
++ val () = repUpdate(opcode_const_1, "const_1");
++ val () = repUpdate(opcode_const_2, "const_2");
++ val () = repUpdate(opcode_const_3, "const_3");
++ val () = repUpdate(opcode_const_4, "const_4");
++ val () = repUpdate(opcode_const_10, "const_10");
++ val () = repUpdate(opcode_return_0, "return_0");
++ val () = repUpdate(opcode_return_1, "return_1");
++ val () = repUpdate(opcode_return_2, "return_2");
++ val () = repUpdate(opcode_return_3, "return_3");
++ val () = repUpdate(opcode_moveToVec_0, "moveToVec_0");
++ val () = repUpdate(opcode_moveToVec_1, "moveToVec_1");
++ val () = repUpdate(opcode_moveToVec_2, "moveToVec_2");
++ val () = repUpdate(opcode_moveToVec_3, "moveToVec_3");
++ val () = repUpdate(opcode_moveToVec_4, "moveToVec_4");
++ val () = repUpdate(opcode_moveToVec_5, "moveToVec_5");
++ val () = repUpdate(opcode_moveToVec_6, "moveToVec_6");
++ val () = repUpdate(opcode_moveToVec_7, "moveToVec_7");
++ val () = repUpdate(opcode_reset_1, "reset_1");
++ val () = repUpdate(opcode_reset_2, "reset_2");
++ val () = repUpdate(opcode_getStore_2, "getStore_2");
++ val () = repUpdate(opcode_getStore_3, "getStore_3");
++ val () = repUpdate(opcode_getStore_4, "getStore_4");
++ val () = repUpdate(opcode_nonLocalL_1, "nonLocalL_1");
++ val () = repUpdate(opcode_nonLocalL_2, "nonLocalL_2");
++ val () = repUpdate(opcode_nonLocalL_3, "nonLocalL_3");
++ val () = repUpdate(opcode_callSlC, "callSlC");
++ val () = repUpdate(opcode_callSlCX, "callSlCX");
++ val () = repUpdate(opcode_ioVec_5, "ioVec_5");
++ val () = repUpdate(opcode_ioVec_6, "opcode_ioVec_6");
+
+ (* ...
+ (* added missing instructions (not used yet!) SPF 28/6/95 *)
+ (* Removed them again, becuase I'd rather see UNKNOWN if they
+ ever get generated. SPF 9/1/96 *)
+- val U : unit = repUpdate(opcode_integerAdd, "integerAdd");
+- val U : unit = repUpdate(opcode_integerMinus, "integerMinus");
+- val U : unit = repUpdate(opcode_integerEqual, "integerEqual");
+- val U : unit = repUpdate(opcode_integerLeq, "integerLeq");
+- val U : unit = repUpdate(opcode_integerGreater,"integerGreater");
+- val U : unit = repUpdate(opcode_booleanOr, "booleanOr");
+- val U : unit = repUpdate(opcode_wordEqual, "wordEqual");
+- val U : unit = repUpdate(opcode_assignWord, "assignWord");
++ val () = repUpdate(opcode_integerAdd, "integerAdd");
++ val () = repUpdate(opcode_integerMinus, "integerMinus");
++ val () = repUpdate(opcode_integerEqual, "integerEqual");
++ val () = repUpdate(opcode_integerLeq, "integerLeq");
++ val () = repUpdate(opcode_integerGreater,"integerGreater");
++ val () = repUpdate(opcode_booleanOr, "booleanOr");
++ val () = repUpdate(opcode_wordEqual, "wordEqual");
++ val () = repUpdate(opcode_assignWord, "assignWord");
+ ... *)
+
+- val U : unit = repUpdate(opcode_resetR_1, "resetR_1");
+- val U : unit = repUpdate(opcode_resetR_2, "resetR_2");
+- val U : unit = repUpdate(opcode_resetR_3, "resetR_3");
+- val U : unit = repUpdate(opcode_tupleW, "tupleW");
+- val U : unit = repUpdate(opcode_tupleB, "tupleB");
+- val U : unit = repUpdate(opcode_tuple_2, "tuple_2");
+- val U : unit = repUpdate(opcode_tuple_3, "tuple_3");
+- val U : unit = repUpdate(opcode_tuple_4, "tuple_4");
+- val U : unit = repUpdate(opcode_lock, "lock");
+- val U : unit = repUpdate(opcode_ldexc, "ldexc");
+- val U : unit = repUpdate(opcode_ioVec_225, "ioVec_225");
+- val U : unit = repUpdate(opcode_ioVec_226, "ioVec_226");
+- val U : unit = repUpdate(opcode_ioVec_229, "ioVec_229");
+- val U : unit = repUpdate(opcode_ioVec_233, "ioVec_233");
+- val U : unit = repUpdate(opcode_ioVec_236, "ioVec_236");
+- val U : unit = repUpdate(opcode_ioVec_251, "ioVec_251");
+- val U : unit = repUpdate(opcode_ioVec_253, "ioVec_253");
+- val U : unit = repUpdate(opcode_ioVec_255, "ioVec_255");
+- val U : unit = repUpdate(opcode_setHandler, "setHandler");
+- val U : unit = repUpdate(opcode_pushHandler, "pushHandler");
+- val U : unit = repUpdate(opcode_setHandlerI, "setHandlerI");
+- val U : unit = repUpdate(opcode_tailbb, "tailbb");
+- val U : unit = repUpdate(opcode_tail, "tail");
+- val U : unit = repUpdate(opcode_tail3b, "tail3b");
+- val U : unit = repUpdate(opcode_tail4b, "tail4b");
+- val U : unit = repUpdate(opcode_tail3_2, "tail3_2");
+- val U : unit = repUpdate(opcode_tail3_3, "tail3_3");
++ val () = repUpdate(opcode_resetR_1, "resetR_1");
++ val () = repUpdate(opcode_resetR_2, "resetR_2");
++ val () = repUpdate(opcode_resetR_3, "resetR_3");
++ val () = repUpdate(opcode_tupleW, "tupleW");
++ val () = repUpdate(opcode_tupleB, "tupleB");
++ val () = repUpdate(opcode_tuple_2, "tuple_2");
++ val () = repUpdate(opcode_tuple_3, "tuple_3");
++ val () = repUpdate(opcode_tuple_4, "tuple_4");
++ val () = repUpdate(opcode_lock, "lock");
++ val () = repUpdate(opcode_ldexc, "ldexc");
++ val () = repUpdate(opcode_ioVec_225, "ioVec_225");
++ val () = repUpdate(opcode_ioVec_226, "ioVec_226");
++ val () = repUpdate(opcode_ioVec_229, "ioVec_229");
++ val () = repUpdate(opcode_ioVec_233, "ioVec_233");
++ val () = repUpdate(opcode_ioVec_236, "ioVec_236");
++ val () = repUpdate(opcode_ioVec_251, "ioVec_251");
++ val () = repUpdate(opcode_ioVec_253, "ioVec_253");
++ val () = repUpdate(opcode_ioVec_255, "ioVec_255");
++ val () = repUpdate(opcode_setHandler, "setHandler");
++ val () = repUpdate(opcode_pushHandler, "pushHandler");
++ val () = repUpdate(opcode_setHandlerI, "setHandlerI");
++ val () = repUpdate(opcode_tailbb, "tailbb");
++ val () = repUpdate(opcode_tail, "tail");
++ val () = repUpdate(opcode_tail3b, "tail3b");
++ val () = repUpdate(opcode_tail4b, "tail4b");
++ val () = repUpdate(opcode_tail3_2, "tail3_2");
++ val () = repUpdate(opcode_tail3_3, "tail3_3");
+ in
+ fun repr (Opcode n) : string = Array.sub (repArray, n);
+ end;
+@@ -615,61 +618,59 @@
+
+ local
+ val sizeArray : int Array.array = Array.array (256, 1);
+-
+- fun sizeUpdate (Opcode n, s) = Array.update (sizeArray, n, s);
+
+ fun sizeUpdate (Opcode n, s) = Array.update (sizeArray, n, s);
+
+- val U : unit = sizeUpdate(opcode_enterInt , 2); (* Restored DCJM 22/9/00. *)
+-(* val U : unit = sizeUpdate(opcode_enterInt , 4); *)(* SPF 30/1/97 *)
+- val U : unit = sizeUpdate(opcode_jump , 2);
+- val U : unit = sizeUpdate(opcode_jumpFalse , 2);
+- val U : unit = sizeUpdate(opcode_delHandler , 2);
+- val U : unit = sizeUpdate(opcode_jumpI , 2);
+- val U : unit = sizeUpdate(opcode_jumpIFalse , 2);
+- val U : unit = sizeUpdate(opcode_delHandlerI , 2);
+- val U : unit = sizeUpdate(opcode_caseSwitch , 3);
+- val U : unit = sizeUpdate(opcode_callSl , 7);
+- val U : unit = sizeUpdate(opcode_callSlX , 9);
+- val U : unit = sizeUpdate(opcode_returnW , 3);
+-(* val U : unit = sizeUpdate(opcode_projectW , 3); *)
+- val U : unit = sizeUpdate(opcode_getStoreW , 3);
+- val U : unit = sizeUpdate(opcode_nonLocal , 7);
+- val U : unit = sizeUpdate(opcode_localW , 3);
+- val U : unit = sizeUpdate(opcode_indirectW , 3);
+- val U : unit = sizeUpdate(opcode_moveToVecW , 3);
+- val U : unit = sizeUpdate(opcode_setStackValW, 3);
+- val U : unit = sizeUpdate(opcode_resetW , 3);
+- val U : unit = sizeUpdate(opcode_resetR_w , 3);
+- val U : unit = sizeUpdate(opcode_constAddr , 3);
+- val U : unit = sizeUpdate(opcode_constAddrX_b , 4);
+- val U : unit = sizeUpdate(opcode_constAddrX_w , 5);
+- val U : unit = sizeUpdate(opcode_constIntW , 3);
+- val U : unit = sizeUpdate(opcode_ioVecEntry , 2);
+- val U : unit = sizeUpdate(opcode_jumpBack , 2);
+- val U : unit = sizeUpdate(opcode_returnB , 2);
+-(* val U : unit = sizeUpdate(opcode_projectB , 2); *)
+- val U : unit = sizeUpdate(opcode_getStoreB , 2);
+- val U : unit = sizeUpdate(opcode_localB , 2);
+- val U : unit = sizeUpdate(opcode_indirectB , 2);
+- val U : unit = sizeUpdate(opcode_moveToVecB , 2);
+- val U : unit = sizeUpdate(opcode_setStackValB, 2);
+- val U : unit = sizeUpdate(opcode_resetB , 2);
+- val U : unit = sizeUpdate(opcode_resetRB , 2);
+- val U : unit = sizeUpdate(opcode_constIntB , 2);
+- val U : unit = sizeUpdate(opcode_nonLocalL_1 , 2);
+- val U : unit = sizeUpdate(opcode_nonLocalL_2 , 2);
+- val U : unit = sizeUpdate(opcode_nonLocalL_3 , 2);
+- val U : unit = sizeUpdate(opcode_callSlC , 4);
+- val U : unit = sizeUpdate(opcode_callSlCX , 5);
+- val U : unit = sizeUpdate(opcode_tupleW , 3);
+- val U : unit = sizeUpdate(opcode_tupleB , 2);
+- val U : unit = sizeUpdate(opcode_setHandler , 2);
+- val U : unit = sizeUpdate(opcode_setHandlerI , 2);
+- val U : unit = sizeUpdate(opcode_tailbb , 3);
+- val U : unit = sizeUpdate(opcode_tail , 5);
+- val U : unit = sizeUpdate(opcode_tail3b , 2);
+- val U : unit = sizeUpdate(opcode_tail4b , 2);
++ val () = sizeUpdate(opcode_enterInt , 2); (* Restored DCJM 22/9/00. *)
++(* val () = sizeUpdate(opcode_enterInt , 4); *)(* SPF 30/1/97 *)
++ val () = sizeUpdate(opcode_jump , 2);
++ val () = sizeUpdate(opcode_jumpFalse , 2);
++ val () = sizeUpdate(opcode_delHandler , 2);
++ val () = sizeUpdate(opcode_jumpI , 2);
++ val () = sizeUpdate(opcode_jumpIFalse , 2);
++ val () = sizeUpdate(opcode_delHandlerI , 2);
++ val () = sizeUpdate(opcode_caseSwitch , 3);
++ val () = sizeUpdate(opcode_callSl , 7);
++ val () = sizeUpdate(opcode_callSlX , 9);
++ val () = sizeUpdate(opcode_returnW , 3);
++(* val () = sizeUpdate(opcode_projectW , 3); *)
++ val () = sizeUpdate(opcode_getStoreW , 3);
++ val () = sizeUpdate(opcode_nonLocal , 7);
++ val () = sizeUpdate(opcode_localW , 3);
++ val () = sizeUpdate(opcode_indirectW , 3);
++ val () = sizeUpdate(opcode_moveToVecW , 3);
++ val () = sizeUpdate(opcode_setStackValW, 3);
++ val () = sizeUpdate(opcode_resetW , 3);
++ val () = sizeUpdate(opcode_resetR_w , 3);
++ val () = sizeUpdate(opcode_constAddr , 3);
++ val () = sizeUpdate(opcode_constAddrX_b , 4);
++ val () = sizeUpdate(opcode_constAddrX_w , 5);
++ val () = sizeUpdate(opcode_constIntW , 3);
++ val () = sizeUpdate(opcode_ioVecEntry , 2);
++ val () = sizeUpdate(opcode_jumpBack , 2);
++ val () = sizeUpdate(opcode_returnB , 2);
++(* val () = sizeUpdate(opcode_projectB , 2); *)
++ val () = sizeUpdate(opcode_getStoreB , 2);
++ val () = sizeUpdate(opcode_localB , 2);
++ val () = sizeUpdate(opcode_indirectB , 2);
++ val () = sizeUpdate(opcode_moveToVecB , 2);
++ val () = sizeUpdate(opcode_setStackValB, 2);
++ val () = sizeUpdate(opcode_resetB , 2);
++ val () = sizeUpdate(opcode_resetRB , 2);
++ val () = sizeUpdate(opcode_constIntB , 2);
++ val () = sizeUpdate(opcode_nonLocalL_1 , 2);
++ val () = sizeUpdate(opcode_nonLocalL_2 , 2);
++ val () = sizeUpdate(opcode_nonLocalL_3 , 2);
++ val () = sizeUpdate(opcode_callSlC , 4);
++ val () = sizeUpdate(opcode_callSlCX , 5);
++ val () = sizeUpdate(opcode_tupleW , 3);
++ val () = sizeUpdate(opcode_tupleB , 2);
++ val () = sizeUpdate(opcode_setHandler , 2);
++ val () = sizeUpdate(opcode_setHandlerI , 2);
++ val () = sizeUpdate(opcode_tailbb , 3);
++ val () = sizeUpdate(opcode_tail , 5);
++ val () = sizeUpdate(opcode_tail3b , 2);
++ val () = sizeUpdate(opcode_tail4b , 2);
+ in
+ fun size (Opcode n) : int = Array.sub (sizeArray, n);
+ end;
+@@ -767,6 +768,7 @@
+ fun codeCreate (noClosure : bool, name : string, parameters) : code =
+ let
+ val words : int = codesize div wordLength();
++ val printStream = PRETTY.getSimplePrinter parameters;
+ in
+ Code
+ {
+@@ -784,7 +786,7 @@
+ noClosure = noClosure,
+ constLoads = ref [],
+ printAssemblyCode = DEBUG.getParameter DEBUG.assemblyCodeTag parameters,
+- printStream = DEBUG.getParameter DEBUG.compilerOutputTag parameters
++ printStream = printStream
+ }
+ end;
+
+@@ -809,14 +811,14 @@
+ fun genByte (ival: int, cvec: code) : unit =
+ let
+ val icVal : addrs = ! (ic cvec);
+- val U : unit = putByte (ival, icVal, cvec);
++ val () = putByte (ival, icVal, cvec);
+ in
+ ic cvec := icVal addrPlus 1
+ end;
+
+ fun genBytes (ival: int, length: int, cvec: code) : unit =
+ let
+- val U : unit = genByte (ival mod 256, cvec);
++ val () = genByte (ival mod 256, cvec);
+ in
+ if length = 1 then ()
+ else genBytes (ival div 256, length - 1, cvec)
+@@ -828,7 +830,7 @@
+ (* puts "length" bytes of "val" into locations "addr", "addr"+1... *)
+ fun putBytes (ival : int, length : int, addr : addrs, cvec : code) : unit =
+ let
+- val U : unit = putByte (ival mod 256, addr, cvec);
++ val () = putByte (ival mod 256, addr, cvec);
+ in
+ if length = 1 then ()
+ else putBytes (ival div 256, length - 1, addr addrPlus 1, cvec)
+@@ -859,7 +861,7 @@
+ let
+ val offset = !(stackReset cvec);
+
+- val U : unit =
++ val () =
+ if offset < 0
+ then raise InternalError ("resetSp: bad reset value " ^ Int.toString offset)
+
+@@ -869,7 +871,7 @@
+ else if 255 <= offset
+ then let
+ val opc = if !(carry cvec) then opcode_resetR_w else opcode_resetW;
+- val U : unit = genByte (opcode_down opc, cvec);
++ val () = genByte (opcode_down opc, cvec);
+ in
+ genWord (offset, cvec)
+ end
+@@ -877,7 +879,7 @@
+ else if !(carry cvec)
+ then if 3 < offset
+ then let
+- val U : unit = genByte (opcode_down opcode_resetRB, cvec);
++ val () = genByte (opcode_down opcode_resetRB, cvec);
+ in
+ genByte (offset, cvec)
+ end
+@@ -889,7 +891,7 @@
+
+ else if 2 < offset
+ then let
+- val U : unit = genByte (opcode_down opcode_resetB, cvec);
++ val () = genByte (opcode_down opcode_resetB, cvec);
+ in
+ genByte (offset, cvec)
+ end
+@@ -915,14 +917,14 @@
+ fun removeLabel (lab : addrs, cvec : code) : unit =
+ let
+ fun removeEntry ([]: labList) : labList = []
+- | removeEntry ((entry as ref (Jump16From _)) :: t) =
++ | removeEntry ((ref (Jump16From _)) :: t) =
+ removeEntry t (* we discard all long jumps *)
+
+ | removeEntry ((entry as ref (Jump8From addr)) :: t) =
+ if lab = addr
+ then removeEntry t
+ else let
+- val U : unit =
++ val () =
+ if addr addrLt !(longestBranch cvec)
+ then longestBranch cvec := addr
+ else ();
+@@ -940,13 +942,13 @@
+ (* Offsets are calculated from the END of the instruction, which explains the "+ 1" *)
+ val newOffset : int = target addrMinus (addr addrPlus 1);
+
+- val U : unit =
++ val () =
+ if 0 <= newOffset andalso newOffset < 256 then ()
+ else raise InternalError "fixupOffset: jump too far (8-bit offset)"
+
+ val oldOffset : int = getByte (addr, cvec);
+
+- val U : unit =
++ val () =
+ if oldOffset = 0 then ()
+ else raise InternalError "fixupOffset: 8-bit branch already fixed up"
+
+@@ -954,7 +956,7 @@
+ We're about to fix up the jump, so remove it from the
+ list of pending short jumps.
+ *)
+- val U : unit = removeLabel (addr, cvec);
++ val () = removeLabel (addr, cvec);
+ in
+ putByte (newOffset, addr, cvec)
+ end
+@@ -964,13 +966,13 @@
+ (* Offsets are calculated from the END of the instruction, which explains the "+ 2" *)
+ val newOffset : int = target addrMinus (addr addrPlus 2);
+
+- val U : unit =
++ val () =
+ if ~32768 <= newOffset andalso newOffset < 32768 then ()
+ else raise InternalError "fixupOffset: jump too far (16-bit offset)"
+
+ val oldOffset : int = getBytes (2, addr, cvec);
+
+- val U : unit =
++ val () =
+ if oldOffset = 0 then ()
+ else raise InternalError "fixupOffset: 16-bit branch already fixed up"
+ in
+@@ -978,11 +980,11 @@
+ end;
+
+
+- fun fixup ([] : labels, cvec: code) : unit = ()
++ fun fixup ([] : labels, _: code) : unit = ()
+ | fixup (lab : labels, cvec: code) : unit =
+ let
+ (* Deal with any pending resets. *)
+- val U : unit = resetSp cvec;
++ val () = resetSp cvec;
+ val target : addrs = ! (ic cvec);
+ in
+ applyList (fn (ref jf) => fixupOffset (jf, target, cvec), lab)
+@@ -994,13 +996,13 @@
+ (* All labels are created as short jumps *)
+ val lab : jumpFrom ref = ref (Jump8From addr);
+
+- val U : unit =
++ val () =
+ if addr addrLt !(longestBranch cvec)
+ then longestBranch cvec := addr
+ else ();
+
+ (* Add to the list of pending fixups *)
+- val U : unit = labelList cvec := lab :: !(labelList cvec);
++ val () = labelList cvec := lab :: !(labelList cvec);
+ in
+ [lab]
+ end;
+@@ -1047,13 +1049,13 @@
+ (* Offsets are calculated from the END of the instruction, which explains the "+ 1" *)
+ val newOffset : int = here addrMinus (addr addrPlus 1);
+
+- val U : unit =
++ val () =
+ if 0 <= newOffset andalso newOffset < 256 then ()
+ else raise InternalError "checkBranchList: offset too large to convert"
+
+ val oldOffset : int = getByte (addr, cvec);
+
+- val U : unit =
++ val () =
+ if oldOffset = 0 then ()
+ else raise InternalError "checkBranchList: 8-bit offset already fixed up";
+
+@@ -1063,19 +1065,19 @@
+ val newInstrByte : int = oldInstrByte + 4;
+
+ (* Fix up the instruction and offset *)
+- val U : unit = putByte (newInstrByte, instrAddr, cvec);
+- val U : unit = putByte (newOffset, addr, cvec);
++ val () = putByte (newInstrByte, instrAddr, cvec);
++ val () = putByte (newOffset, addr, cvec);
+
+ (* Generate the indirection itself, and alter the jump state *)
+- val U : unit = genWord (0, cvec);
+- val U : unit = lab := Jump16From here;
++ val () = genWord (0, cvec);
++ val () = lab := Jump16From here;
+ in
+ convertRest
+ end
+ else let
+ (* Not ready to remove this. Just find out if
+ this is an earlier branch and continue. *)
+- val U : unit =
++ val () =
+ if addr addrLt !(longestBranch cvec)
+ then longestBranch cvec := addr
+ else ();
+@@ -1090,23 +1092,23 @@
+ (* Must save the stack-reset, otherwise "fixup" will try
+ to reset it. *)
+ val sr = ! (stackReset cvec);
+- val U : unit = stackReset cvec := 0;
++ val () = stackReset cvec := 0;
+
+ (* Must skip round the branches unless we have just
+ taken an unconditional branch. *)
+ val lab : labels =
+ if branched then noJump
+ else let
+- val U : unit = genByte(opcode_down opcode_jump, cvec);
+- val U : unit = genByte(0, cvec);
++ val () = genByte(opcode_down opcode_jump, cvec);
++ val () = genByte(0, cvec);
+ in
+ makeLabel(cvec, !(ic cvec) addrPlus ~1)
+ end
+
+ (* Find the new longest branch while converting the labels *)
+- val U : unit = longestBranch cvec := addrLast;
+- val U : unit = labelList cvec := convertLabels (! (labelList cvec));
+- val U : unit = fixup (lab, cvec); (* Continue with normal processing. *)
++ val () = longestBranch cvec := addrLast;
++ val () = labelList cvec := convertLabels (! (labelList cvec));
++ val () = fixup (lab, cvec); (* Continue with normal processing. *)
+ in
+ stackReset cvec := sr (* Restore old value. *)
+ end
+@@ -1114,7 +1116,7 @@
+
+ (* Dave had some complicated scheme here - with the new representation of
+ labels, everything gets much simpler. *)
+- fun linkLabels (lab1 : labels, lab2 : labels, cvec : code) : labels =
++ fun linkLabels (lab1 : labels, lab2 : labels, _ : code) : labels =
+ lab1 @ lab2;
+
+ (* Put in the opcode for an instruction. *)
+@@ -1123,14 +1125,14 @@
+ val opn : int = opcode_down opc;
+
+ (* ...
+- val U : unit =
++ val () =
+ if 0 <= opn andalso opn < 256 andalso opn <> opcode_down opcode_booleanOr
+ then ()
+ else raise InternalError ("genOpc: bad opcode: " ^ Int.toString opn);
+ ... *)
+
+- val U : unit = checkBranchList (cvec, false, size);
+- val U : unit = resetSp cvec;
++ val () = checkBranchList (cvec, false, size);
++ val () = resetSp cvec;
+ in
+ genByte (opn, cvec)
+ end;
+@@ -1159,13 +1161,13 @@
+
+ else if 0 <= arg1 andalso arg1 <= 254 (* why not 255? *)
+ then let
+- val U : unit = genOpc(opB, 2, cvec);
++ val () = genOpc(opB, 2, cvec);
+ in
+ genByte(arg1, cvec)
+ end
+
+ else let
+- val U : unit = genOpc(opW, 3, cvec);
++ val () = genOpc(opW, 3, cvec);
+ in
+ genWord(arg1, cvec)
+ end;
+@@ -1210,7 +1212,7 @@
+ let
+ (* The destination addresses immediately follow the case instruction
+ so we must make sure there is enough room. *)
+- val U : unit = genOpc (opcode_caseSwitch, 3 + arg1 * 2, cvec);
++ val () = genOpc (opcode_caseSwitch, 3 + arg1 * 2, cvec);
+ in
+ genWord (arg1, cvec)
+ end;
+@@ -1222,7 +1224,7 @@
+ 2, 4, arg1, cvec);
+
+ (* Single byte argument. *)
+- fun genIoVecEntry (arg: int, cvec : code) : unit =
++(* fun genIoVecEntry (arg: int, cvec : code) : unit =
+ case arg of (* Some of these entries are very common. *)
+ 5 => genOpc(opcode_ioVec_5, 1, cvec)
+ | 6 => genOpc(opcode_ioVec_6, 1, cvec)
+@@ -1236,10 +1238,10 @@
+ | 255 => genOpc(opcode_ioVec_255, 1, cvec)
+ | _ =>
+ let
+- val U : unit = genOpc(opcode_ioVecEntry, 2, cvec);
++ val () = genOpc(opcode_ioVecEntry, 2, cvec);
+ in
+ genByte(arg, cvec)
+- end;
++ end;*)
+
+ fun genNonLocal (arg1 : int, arg2 : int, arg3 : int, cvec: code) : unit =
+ if arg1 <= 0 orelse arg2 <= 0
+@@ -1248,30 +1250,30 @@
+ else if arg1 <= 16 andalso arg2 <= 3 andalso ~6 <= arg3 andalso arg3 <= 9
+ then let (* use a coded representation *)
+ val opc = opcode_up(opcode_down opcode_nonLocalL_1 + arg2 - 1);
+- val U : unit = genOpc (opc, 1, cvec);
++ val () = genOpc (opc, 1, cvec);
+ in
+ genByte((arg1 - 1) * 16 + arg3 + 6, cvec)
+ end
+
+ else let
+- val U : unit = genOpc (opcode_nonLocal, 5, cvec);
+- val U : unit = genWord (arg1, cvec);
+- val U : unit = genWord (arg2, cvec);
++ val () = genOpc (opcode_nonLocal, 5, cvec);
++ val () = genWord (arg1, cvec);
++ val () = genWord (arg2, cvec);
+ in
+ genWord (arg3, cvec)
+ end;
+
+ fun genEnterInt (cvec: code, args: int) : unit =
+ let
+- val U : unit = genByte(opcode_down opcode_enterInt, cvec);
+- val U : unit = genByte(args + 1, cvec);
++ val () = genByte(opcode_down opcode_enterInt, cvec);
++ val () = genByte(args + 1, cvec);
+ in
+ ()
+ end;
+
+ fun genEnterIntCall (cvec: code, args: int) : unit =
+ let
+- val U : unit =
++ val () =
+ if args < MAXINTARGS then ()
+ else raise InternalError "genEnterIntCall: too many arguments";
+ in
+@@ -1287,14 +1289,14 @@
+
+ fun genEnterIntProc (cvec: code, args: int) : unit =
+ let
+- val U : unit =
++ val () =
+ if args < MAXINTARGS then ()
+ else raise InternalError "genEnterIntProc: too many arguments";
+
+ val argCode : int = MAXINTARGS + args;
+
+ (* Primary entry point (address 0) *)
+- val U : unit = genEnterInt(cvec, argCode);
++ val () = genEnterInt(cvec, argCode);
+ in
+ ()
+ end;
+@@ -1304,22 +1306,22 @@
+ if opc = opcode_setHandler orelse
+ opc = opcode_jumpFalse
+ then let (* The next instruction may or will be executed. *)
+- val U : unit = genOpc (opc, 3, cvec); (* why not 2? *)
+- val U : unit = genByte (0, cvec);
++ val () = genOpc (opc, 3, cvec); (* why not 2? *)
++ val () = genByte (0, cvec);
+ in
+ makeLabel (cvec, !(ic cvec) addrPlus ~1)
+ end
+
+ else let (* Unconditional branches. *)
+- val U : unit = resetSp cvec;
+- val U : unit = genByte (opcode_down opc, cvec);
+- val U : unit = genByte (0, cvec);
++ val () = resetSp cvec;
++ val () = genByte (opcode_down opc, cvec);
++ val () = genByte (0, cvec);
+ val lab : labels = makeLabel (cvec, !(ic cvec) addrPlus ~1);
+
+ (* Having just generated an unconditional branch we can extend
+ branches without the overhead of an extra branch. That's
+ why we did a genByte, rather than a genOpc, just now. *)
+- val U : unit = checkBranchList (cvec, true, 0);
++ val () = checkBranchList (cvec, true, 0);
+ in
+ lab
+ end;
+@@ -1327,28 +1329,28 @@
+ (* Generate either a short or long jump. *)
+ fun jumpback (lab: addrs, cvec: code) : unit =
+ let
+- val U : unit = resetSp cvec;
++ val () = resetSp cvec;
+
+ (* Don't use genOpc(opcode_jump) because we want to check the branch
+ list afterwards, and also because it might generate some code if
+ we try to use a short branch and take it over the limit. *)
+ val newOffset : int = !(ic cvec) addrMinus lab;
+
+- val U : unit =
++ val () =
+ if newOffset < 256
+ then let (* short *)
+ (* For opcode_jumpBack, exceptionally, the offset is relative
+ to the START of the instruction. Also, the offset is
+ backwards, as opposed to the usual forwards convention. *)
+- val U : unit = genByte (opcode_down opcode_jumpBack, cvec);
++ val () = genByte (opcode_down opcode_jumpBack, cvec);
+ in
+ genByte (newOffset, cvec)
+ end
+ else let (* must use indirect jump *)
+ (* For all other jumps, the offset is relative to the END of
+ the instruction, which explains the "0" and the "+ 4". *)
+- val U : unit = genByte (opcode_down opcode_jumpI, cvec);
+- val U : unit = genByte (0, cvec); (* Indirect through next word. *)
++ val () = genByte (opcode_down opcode_jumpI, cvec);
++ val () = genByte (0, cvec); (* Indirect through next word. *)
+ in
+ genWord (~ (newOffset + 4), cvec)
+ end;
+@@ -1364,7 +1366,7 @@
+ fn (fixupAddr : addrs, constNum : int) =>
+ let
+ val oldOffset : int = getBytes (2, fixupAddr, cvec);
+- val U : unit =
++ val () =
+ if oldOffset = 0 then ()
+ else raise InternalError "fixupConstantLoad: already fixed-up";
+
+@@ -1376,7 +1378,7 @@
+ (* Offsets are calculated from the END of the instruction, which explains the "+ 2" *)
+ val newOffset : int = constAddr addrMinus (fixupAddr addrPlus 2);
+
+- val U : unit =
++ val () =
+ if 0 <= newOffset andalso newOffset < 65536 then ()
+ else raise InternalError "fixupConstantLoad: constant too distant (16-bit offset)"
+ in
+@@ -1412,7 +1414,7 @@
+ let
+ (* Remember address of the indirection so we can fix it up later *)
+ val fixupAddrs : addrs = !(ic cvec);
+- val U : unit = genWord (0, cvec);
++ val () = genWord (0, cvec);
+ in
+ constLoads cvec := (fixupAddrs, constNum) :: !(constLoads cvec)
+ end;
+@@ -1430,13 +1432,13 @@
+
+ else if iVal < 256
+ then let
+- val U : unit = genOpc (opcode_constIntB, 2, cvec);
++ val () = genOpc (opcode_constIntB, 2, cvec);
+ in
+ genByte (iVal, cvec)
+ end
+
+ else let
+- val U : unit = genOpc (opcode_constIntW, 3, cvec);
++ val () = genOpc (opcode_constIntW, 3, cvec);
+ in
+ genWord (iVal, cvec)
+ end
+@@ -1444,7 +1446,7 @@
+
+ else let (* address or large short *)
+ val constNum : int = addConstToVec (WVal value, cvec);
+- val U : unit =
++ val () =
+ if not usePortableConstantOffset
+ then genOpc (opcode_constAddr, 3, cvec)
+ else if constNum < 256
+@@ -1473,8 +1475,8 @@
+ will (hopefully) fix the "jump too large" which appeared
+ when I added the extra return-point. SPF 3/8/95 *)
+ val size : int = if mustReset then 23 else 20;
+- val U : unit = checkBranchList (cvec, false, size);
+- val U : unit = resetSp cvec;
++ val () = checkBranchList (cvec, false, size);
++ val () = resetSp cvec;
+ in
+ while (getAddr (! (ic cvec)) + length) mod 4 <> (* 0 *) 2 do
+ genByte (opcode_down opcode_pad, cvec)
+@@ -1482,7 +1484,7 @@
+
+ fun genCallClosure (cvec: code) : unit =
+ let
+- val U : unit = alignOffWord(cvec, 1);
++ val () = alignOffWord(cvec, 1);
+ in
+ genOpc (opcode_callClosure, 1, cvec)
+ end;
+@@ -1493,30 +1495,30 @@
+ case (toslide, slideby) of
+ (3, 2) =>
+ let
+- val U : unit = alignOffWord (cvec, 1);
++ val () = alignOffWord (cvec, 1);
+ in
+ genOpc (opcode_tail3_2, 1, cvec)
+ end
+
+ | (3, 3) =>
+ let
+- val U : unit = alignOffWord (cvec, 1);
++ val () = alignOffWord (cvec, 1);
+ in
+ genOpc (opcode_tail3_3, 1, cvec)
+ end
+
+ | (3, _) =>
+ let
+- val U : unit = alignOffWord (cvec, 2);
+- val U : unit = genOpc (opcode_tail3b, 2, cvec);
++ val () = alignOffWord (cvec, 2);
++ val () = genOpc (opcode_tail3b, 2, cvec);
+ in
+ genByte (slideby, cvec)
+ end
+
+ | (4, _) =>
+ let
+- val U : unit = alignOffWord (cvec, 2);
+- val U : unit = genOpc (opcode_tail4b, 2, cvec);
++ val () = alignOffWord (cvec, 2);
++ val () = genOpc (opcode_tail4b, 2, cvec);
+ in
+ genByte (slideby, cvec)
+ end
+@@ -1524,17 +1526,17 @@
+
+ | (_, _) =>
+ let (* General byte case *)
+- val U : unit = alignOffWord (cvec, 3);
+- val U : unit = genOpc (opcode_tailbb, 3, cvec);
+- val U : unit = genByte (toslide, cvec);
++ val () = alignOffWord (cvec, 3);
++ val () = genOpc (opcode_tailbb, 3, cvec);
++ val () = genByte (toslide, cvec);
+ in
+ genByte (slideby, cvec)
+ end
+
+ else let (* General case. *)
+- val U : unit = alignOffWord (cvec, 5);
+- val U : unit = genOpc (opcode_tail, 5, cvec);
+- val U : unit = genWord (toslide, cvec);
++ val () = alignOffWord (cvec, 5);
++ val () = genOpc (opcode_tail, 5, cvec);
++ val () = genWord (toslide, cvec);
+ in
+ genWord(slideby, cvec)
+ end; (* genTailCall *)
+@@ -1559,12 +1561,12 @@
+ the referring procedure is finished and its address is known the
+ address will be plugged in to every procedure which needs it. *)
+ let
+- fun onList x [] = false
++ fun onList _ [] = false
+ | onList x (c::cs) = (x is c) orelse onList x cs;
+
+ val codeList = ! (otherCodes r);
+
+- val U : unit =
++ val () =
+ if onList into codeList
+ then ()
+ else otherCodes r := into :: codeList;
+@@ -1577,7 +1579,7 @@
+ fun genRecRef (target : code, into: code) : unit =
+ let
+ val constNum : int = codeConst (target, into);
+- val U : unit =
++ val () =
+ if not usePortableConstantOffset
+ then genOpc (opcode_constAddr, 3, into)
+ else if constNum < 256
+@@ -1635,21 +1637,21 @@
+ (* Adds in the reset. *)
+ fun resetStack (offset : int, carryValue : bool, cvec : code) : unit =
+ let
+- val U : unit =
++ val () =
+ if 0 < offset then ()
+ else raise InternalError ("resetStack: bad offset " ^ Int.toString offset);
+
+- val U : unit = stackReset cvec := !(stackReset cvec) + offset;
++ val () = stackReset cvec := !(stackReset cvec) + offset;
+ in
+ carry cvec := carryValue
+ end;
+
+ fun printCode (seg: cseg, procName: string, endcode : int, printStream) : unit =
+ let
+- val U : unit = printStream "\n";
+- val U : unit =
++ val () = printStream "\n";
++ val () =
+ if procName = "" (* No name *) then printStream "?" else printStream procName;
+- val U : unit = printStream ":\n";
++ val () = printStream ":\n";
+
+ (* prints a string representation of a number *)
+ fun printHex (v : int) : unit = printStream(Int.fmt StringCvt.HEX v);
+@@ -1678,9 +1680,9 @@
+ fun printDisp (len: int, spacer: string, addToList: bool) : unit =
+ let
+ val ad : int = getB(len, !ptr, seg) + !ptr + len;
+- val U : unit = if addToList then addInd ad else ();
+- val U : unit = printStream spacer;
+- val U : unit = printHex ad;
++ val () = if addToList then addInd ad else ();
++ val () = printStream spacer;
++ val () = printHex ad;
+ in
+ ptr := !ptr + len
+ end;
+@@ -1688,22 +1690,22 @@
+ (* Prints an operand of an instruction *)
+ fun printOp (len: int, spacer : string) : unit =
+ let
+- val U : unit = printStream spacer;
+- val U : unit = printHex (getB (len, !ptr, seg));
++ val () = printStream spacer;
++ val () = printHex (getB (len, !ptr, seg));
+ in
+ ptr := !ptr + len
+ end;
+
+- val U : unit =
++ val () =
+ while !ptr < endcode
+ do let
+ val addr : int = !ptr;
+- val U : unit = printHex addr; (* The address. *)
++ val () = printHex addr; (* The address. *)
+
+- val U : unit =
++ val () =
+ if (case !indirections of v :: _ => v = addr | [] => false)
+ then let (* It's an address. *)
+- val U : unit = printDisp (2, "\t", false);
++ val () = printDisp (2, "\t", false);
+ in
+ case !indirections of
+ _ :: vs => indirections := vs
+@@ -1711,10 +1713,10 @@
+ end
+
+ else let (* It's an instruction. *)
+- val U : unit = printStream "\t";
++ val () = printStream "\t";
+ val opc : opcode = opcode_up (Word8.toInt (csegGet (seg, !ptr))); (* opcode *)
+- val U : unit = ptr := !ptr + 1;
+- val U : unit = printStream (repr opc);
++ val () = ptr := !ptr + 1;
++ val () = printStream (repr opc);
+
+ val sz : int = size opc;
+ in
+@@ -1735,24 +1737,24 @@
+
+ else if opc = opcode_jumpBack (* Should be negative *)
+ then let
+- val U : unit = printStream "\t";
+- val U : unit = printHex((!ptr - 1) - getB(1,!ptr,seg));
++ val () = printStream "\t";
++ val () = printHex((!ptr - 1) - getB(1,!ptr,seg));
+ in
+ ptr := !ptr + 1
+ end
+
+ else if opc = opcode_nonLocal
+ then let
+- val U : unit = printOp (2, "\t");
+- val U : unit = printOp (2, ",");
++ val () = printOp (2, "\t");
++ val () = printOp (2, ",");
+ in
+ printOp(2, ",")
+ end
+
+ else if opc = opcode_callSl
+ then let
+- val U : unit = printDisp (2, "\t", false);
+- val U : unit = printOp (2, ",");
++ val () = printDisp (2, "\t", false);
++ val () = printOp (2, ",");
+ in
+ printOp (2, ",")
+ end
+@@ -1785,13 +1787,13 @@
+ then let
+ (* Have to find out how many items there are. *)
+ val limit : int = getB (2, !ptr, seg);
+- val U : unit = printOp (2, "\t");
++ val () = printOp (2, "\t");
+ val base : int = !ptr;
+
+- fun printEntry (i : int) =
++ fun printEntry (_ : int) =
+ let
+- val U : unit = printStream "\n\t";
+- val U : unit = printHex(base + getB(2, !ptr, seg));
++ val () = printStream "\n\t";
++ val () = printHex(base + getB(2, !ptr, seg));
+ in
+ ptr := !ptr + 2
+ end;
+@@ -1801,14 +1803,14 @@
+
+ else if opc = opcode_tail
+ then let
+- val U : unit = printOp (2, "\t");
++ val () = printOp (2, "\t");
+ in
+ printOp (2, ",")
+ end
+
+ else if opc = opcode_tailbb
+ then let
+- val U : unit = printOp (1, "\t");
++ val () = printOp (1, "\t");
+ in
+ printOp (1, ",")
+ end
+@@ -1891,7 +1893,7 @@
+ case c of
+ CVal c =>
+ let
+- val U : unit = printStream(if noClosure c then "code:\t" else "clos:\t");
++ val () = printStream(if noClosure c then "code:\t" else "clos:\t");
+ in
+ printStream(procName c)
+ end
+@@ -1900,10 +1902,10 @@
+ if isShort w
+ then let
+ val value : int = Word.toInt (toShort w);
+- val U : unit = printStream "short:\t";
+- val U : unit = printHex(value, printStream);
+- val U : unit = printStream " (";
+- val U : unit = printStream (Int.toString value);
++ val () = printStream "short:\t";
++ val () = printHex(value, printStream);
++ val () = printStream " (";
++ val () = printStream (Int.toString value);
+ in
+ printStream ")"
+ end
+@@ -1933,13 +1935,13 @@
+ else printWords(a, printStream) (* Not a proper tuple (shouldn't occur) *)
+ end;
+
+- fun printConstants (addr : int, [] : const list, printStream) : unit = ()
++ fun printConstants (_ : int, [] : const list, _) : unit = ()
+ | printConstants (addr : int, h :: t, printStream) : unit =
+ let
+- val U : unit = printHex(addr, printStream);
+- val U : unit = printStream "\t";
+- val U : unit = printConst(h, printStream);
+- val U : unit = printStream "\n";
++ val () = printHex(addr, printStream);
++ val () = printStream "\t";
++ val () = printConst(h, printStream);
++ val () = printStream "\n";
+ in
+ printConstants (addr + wordLength(), t, printStream)
+ end;
+@@ -1969,7 +1971,7 @@
+ if c is refTo
+ then let (* A reference to this one. *)
+ (* Fix up the forward reference. *)
+- val U : unit = constLabels (refFrom, num, value);
++ val () = constLabels (refFrom, num, value);
+ in
+ (* decrement the "pending references" count *)
+ noc := !noc - 1
+@@ -1978,7 +1980,7 @@
+ | _ => ();
+
+ (* look down its list of forward references until we find ourselves. *)
+- val U : unit =
++ val () =
+ applyCountList (putNonLocalConst, 1, !(constVec refFrom));
+ in
+ (* If there are no more references, we can lock it. *)
+@@ -2002,13 +2004,13 @@
+ (* Now round up to 8 byte boundary. This makes porting to a 64 bit
+ machine much simpler. DCJM 22/9/00. *)
+ val alignTo = if wordLength() < 8 then 8 else wordLength();
+- val U : unit =
++ val () =
+ while (getAddr (! (ic cvec)) mod alignTo) <> 0 do
+ genByte (opcode_down opcode_pad, cvec);
+
+ (* This also aligns ic onto a fullword boundary. *)
+ val endIC = !(ic cvec); (* Remember end *)
+- val U : unit = genBytes (0, wordLength(), cvec); (* Marker *)
++ val () = genBytes (0, wordLength(), cvec); (* Marker *)
+
+ (* +4 for code size, profile count, function name and constants count *)
+ val numOfConst = !(numOfConsts cvec);
+@@ -2016,21 +2018,21 @@
+ val segSize : int = endOfCode + numOfConst + 4;
+
+ (* fix-up all the constant loads (or indirections) *)
+- val U : unit = fixupConstantLoads (cvec, endIC, !(constLoads cvec));
++ val () = fixupConstantLoads (cvec, endIC, !(constLoads cvec));
+
+ (* Now make the byte segment that we'll turn into the code segment *)
+ val seg : cseg = csegMake segSize;
+- val U : unit = resultSeg cvec := Set seg;
++ val () = resultSeg cvec := Set seg;
+
+ (* Copy the code into the new segment. *)
+- val U : unit = csegCopySeg (codeVec cvec, seg, getAddr (!(ic cvec)), 0);
++ val () = csegCopySeg (codeVec cvec, seg, getAddr (!(ic cvec)), 0);
+
+ (* Byte offset of start of code. *)
+ local
+ val byteEndOfCode = endOfCode * wordLength();
+ val addr = mkAddr byteEndOfCode;
+ in
+- val U : unit = setLong (byteEndOfCode, addr, seg);
++ val () = setLong (byteEndOfCode, addr, seg);
+ end;
+
+ (* Put in the number of constants. This must go in before
+@@ -2038,21 +2040,21 @@
+ local
+ val addr = mkAddr ((segSize - 1) * wordLength());
+ in
+- val U : unit = setLong (numOfConst + 1, addr, seg)
++ val () = setLong (numOfConst + 1, addr, seg)
+ end;
+
+ (* Next the profile count. *)
+ local
+ val addr = mkAddr ((endOfCode + 1) * wordLength());
+ in
+- val U : unit = setLong (0, addr, seg)
++ val () = setLong (0, addr, seg)
+ end;
+
+ (* Now we've filled in all the C integers; now we need to convert the segment
+ into a proper code segment before it's safe to put in any ML values.
+ SPF 13/2/97
+ *)
+- val U : unit = csegConvertToCode seg;
++ val () = csegConvertToCode seg;
+
+ local
+ (* why do we treat the empty string as a special case? SPF 15/7/94 *)
+@@ -2061,19 +2063,19 @@
+ val name : string = procName cvec;
+ val nameWord : machineWord = if name = "" then toMachineWord 0 else toMachineWord name;
+ in
+- val U : unit = csegPutWord (seg, endOfCode + 2, nameWord)
++ val () = csegPutWord (seg, endOfCode + 2, nameWord)
+ end;
+
+
+ (* and then copy the objects from the constant list. *)
+- fun putLocalConsts [] num = ()
++ fun putLocalConsts [] _ = ()
+ | putLocalConsts (c::cs) num =
+ let
+- val U : unit =
++ val () =
+ case c of
+ WVal w => (* an ordinary (non-short) constant *)
+ let
+- val U : unit = constLabels (cvec, num, w);
++ val () = constLabels (cvec, num, w);
+ in
+ numOfConsts cvec := ! (numOfConsts cvec) - 1
+ end
+@@ -2085,11 +2087,11 @@
+ putLocalConsts cs (num + 1)
+ end;
+
+- val U : unit = putLocalConsts (! (constVec cvec)) 1;
++ val () = putLocalConsts (! (constVec cvec)) 1;
+
+ (* Switch off "mutable" bit now if we have no
+ forward or recursive references to fix-up *)
+- val U : unit =
++ val () =
+ if !(numOfConsts cvec) = 0
+ then csegLock seg
+ else ();
+@@ -2106,7 +2108,7 @@
+ way and I'm not completely sure that everything that needs a mutable
+ allocation actually asks for it yet. SPF 19/2/97
+ *)
+- val U : unit = lock addr;
++ val () = lock addr;
+ in
+ addr
+ end
+@@ -2114,19 +2116,19 @@
+ (* Now we know the address of this object we can fix up
+ any forward references outstanding. This is put in here
+ because there may be directly recursive references. *)
+- val U : unit = fixOtherRefs (cvec, toMachineWord addr);
++ val () = fixOtherRefs (cvec, toMachineWord addr);
+
+- val U : unit =
++ val () =
+ if printAssemblyCode
+ then let (* print out the code *)
+- val U : unit = printCode (seg, procName cvec, getAddr endIC, printStream);
++ val () = printCode (seg, procName cvec, getAddr endIC, printStream);
+ (* Skip: byte offset of start of code segment,
+ number of constants,
+ profiling word,
+ name of code segment
+ *)
+ val constants : const list = ! (constVec cvec);
+- val U : unit = printConstants (getAddr endIC + 4*wordLength(), constants, printStream);
++ val () = printConstants (getAddr endIC + 4*wordLength(), constants, printStream);
+ in
+ printStream"\n"
+ end
+@@ -2140,7 +2142,7 @@
+ fn (cvec : code) =>
+ let
+ (* Make sure any pending stack resets are done. *)
+- val U : unit = resetSp cvec
++ val () = resetSp cvec
+ in
+ ! (ic cvec)
+ end;
+diff -u -r mlsource/MLCompiler/CodeTree/INTGCODE.ML mlsource/MLCompiler/CodeTree/INTGCODE.ML
+--- mlsource/MLCompiler/CodeTree/INTGCODE.ML 2008-04-21 13:30:52.000000000 +0200
++++ mlsource/MLCompiler/CodeTree/INTGCODE.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -34,8 +34,8 @@
+ (*****************************************************************************)
+ structure CODECONS :
+ sig
+- type machineWord;
+- type address;
++ type machineWord = Address.machineWord;
++ type address = Address.address;
+ type code;
+ type opcode;
+ eqtype addrs; (*hacky! *)
+@@ -142,57 +142,8 @@
+ exception InternalError of string;
+ end;
+
+-(* DCJM 26/9/00. Previously Address was a global but we aren't allowed
+- to have sharing constraints with globals in ML97. We could use a
+- "where type" constraint but then we couldn't bootstrap from ML90. *)
+-(*****************************************************************************)
+-(* ADDRESS *)
+-(*****************************************************************************)
+-structure ADDRESS :
+-sig
+- type machineWord; (* NB *not* an eqtype *)
+- type short = Word.word;
+- type address;
+-
+- val wordEq: 'a * 'a -> bool;
+- val isShort: 'a -> bool;
+-
+- val unsafeCast : 'a -> 'b;
+-
+- val toMachineWord: 'a -> machineWord;
+- val toShort: 'a -> short;
+- val toAddress: machineWord -> address;
+-
+- val loadByte: (address * short) -> Word8.word;
+- val loadWord: address * short -> machineWord
+- val flags: address -> Word8.word;
+- val length: address -> short;
+- val wordSize: int
+- val F_words: Word8.word;
+- val F_bytes : Word8.word;
+- val F_mutable: Word8.word;
+-
+- val alloc: short * Word8.word * machineWord -> address
+-
+- val isCode : address -> bool
+-
+- val call: address * machineWord -> machineWord
+-end
+-
+ structure BASECODETREE: BaseCodeTreeSig
+
+-(*****************************************************************************)
+-(* GCODE sharing constraints *)
+-(*****************************************************************************)
+-sharing type
+- ADDRESS.machineWord
+-= CODECONS.machineWord
+-= BASECODETREE.machineWord
+-
+-sharing type
+- ADDRESS.address
+-= CODECONS.address
+-
+ ) :
+
+ (*****************************************************************************)
+@@ -226,16 +177,12 @@
+ struct
+
+ open CODECONS;
+- open ADDRESS;
++ open Address;
+ open BASECODETREE;
+ open MISC;
+
+
+ open RuntimeCalls; (* for POLY_SYS numbers *)
+-
+- val F_mutable_words = Word8.orb (F_mutable, F_words);
+-
+- val objLength = ADDRESS.length;
+
+ (* gets a value from the run-time system;
+ usually this is a closure, but sometimes it's an int. *)
+@@ -243,23 +190,11 @@
+
+ (* minor HACKS *)
+ fun forLoop f i n = if i > n then () else (f i; forLoop f (i + 1) n);
+- fun apply f [] = () | apply f (h::t) = (f h; apply f t);
+-
+- val short0 : short = toShort 0;
+- val short1 : short = toShort 1;
+- val short2 : short = toShort 2;
++ fun apply _ [] = () | apply f (h::t) = (f h; apply f t);
+
+ val word0 = toMachineWord 0;
+- val word1 = toMachineWord 1;
+
+ val DummyValue : machineWord = word0; (* used as result of "raise e" etc. *)
+- val UnitValue : machineWord = word0; (* unit *)
+- val False : machineWord = word0; (* false *)
+- val True : machineWord = word1; (* true *)
+- val Zero : machineWord = word0; (* 0 *)
+-
+- val constntTrue = Constnt True;
+- val constntFalse = Constnt False;
+
+ (* copied from CTREE.ML for efficiency (local calls can be inlined) *)
+
+@@ -304,7 +239,6 @@
+ fun matchFailed _ = raise InternalError "codegen: unhandled pattern-match failure"
+
+ val initTrans = 5; (* Initial size of tables. *)
+- val initStack = 10;
+
+ datatype decEntry =
+ StackAddr of int
+@@ -330,7 +264,7 @@
+ (* Pushes a local or non-local stack value. *)
+ fun pushStackValue (addr : int, level : int) : unit =
+ let
+- val U : unit =
++ val () =
+ if level > 0
+ then (* Non-local *)
+ genNonLocal(!realstackptr, level, addr, cvec)
+@@ -362,7 +296,7 @@
+ case loadStaticLink (locn, 1) of
+ Recursive code =>
+ let
+- val U : unit = genRecRef (code, cvec)
++ val () = genRecRef (code, cvec)
+ in
+ incsp ()
+ end
+@@ -370,7 +304,7 @@
+ | Address (addr, level) =>
+ pushStackValue (addr, level)
+
+- | StaticLink (code, level) =>
++ | StaticLink _ =>
+ raise InternalError "locaddr: illegal use of static-link function"
+ end; (* locaddr *)
+
+@@ -380,7 +314,7 @@
+ (* Save the stack pointer value here. We may want to reset the stack. *)
+ val oldsp = !realstackptr;
+
+- val U : unit =
++ val () =
+ case pt of
+ MatchFail =>
+ (* Leave stack adjustments until later *)
+@@ -394,7 +328,7 @@
+ (* Cut back the stack and branch *)
+ val adjustment = !realstackptr - oldsp;
+
+- val U : unit =
++ val () =
+ if adjustment < 0
+ then raise InternalError ("gencde (AltMatch): bad adjustment " ^ Int.toString adjustment)
+ else if !exited orelse adjustment = 0
+@@ -402,39 +336,39 @@
+ else
+ resetStack (adjustment, false, cvec);
+
+- val U : unit = realstackptr := oldsp;
++ val () = realstackptr := oldsp;
+
+ val thisFailure : labels = putBranchInstruction (jump, cvec);
+- val U : unit = exited := true
++ val () = exited := true
+ in
+ failLabs := thisFailure :: !failLabs
+ end;
+
+- val U : unit =
++ val () =
+ gencde (exp1, whereto, tailKind, newMatchFailFn, loopAddr);
+
+ (* Get rid of the result from the stack.
+ If there is a result then exp2 will push it. *)
+- val U : unit = case whereto of ToStack => decsp () | NoResult => ();
++ val () = case whereto of ToStack => decsp () | NoResult => ();
+ val exp1Exited : bool = !exited;
+
+ (* If exp1 succeeded, we skip exp2 *)
+ val suceedLab : labels =
+ if exp1Exited then noJump else putBranchInstruction (jump, cvec);
+
+- val U : unit =
++ val () =
+ if !realstackptr = oldsp then ()
+ else raise InternalError "gencde: bad stack value"
+
+ (* If exp1 failed, we come here (with NO result). *)
+- val U : unit = exited := false; (* Don't try to be too clever *)
+- val U : unit = apply (fn (lab : labels) => fixup (lab, cvec)) (!failLabs);
++ val () = exited := false; (* Don't try to be too clever *)
++ val () = apply (fn (lab : labels) => fixup (lab, cvec)) (!failLabs);
+
+ (* Compile exp2 using the OLD matchFailFn *)
+- val U : unit = gencde (exp2, whereto, tailKind, matchFailFn, loopAddr);
++ val () = gencde (exp2, whereto, tailKind, matchFailFn, loopAddr);
+
+ (* If exp1 succeeded, we merge back in here. *)
+- val U : unit = fixup (suceedLab, cvec);
++ val () = fixup (suceedLab, cvec);
+ in
+ exited := (!exited andalso exp1Exited)
+ end
+@@ -449,7 +383,7 @@
+ Lambda (lam as {makeClosure = false, name, ...}) =>
+ let
+ val newCode : code = codeCreate (true, name, parameters);
+- val U : unit =
++ val () =
+ STRETCHARRAY.update (decVec, addr, ProcConst newCode);
+ in
+ genSlProc (lam, newCode)
+@@ -457,7 +391,7 @@
+
+ | _ => (* Other declaration - to the stack. *)
+ let
+- val U : unit = gencde (value, ToStack, NotEnd, matchFailFn, loopAddr);
++ val () = gencde (value, ToStack, NotEnd, matchFailFn, loopAddr);
+ in
+ STRETCHARRAY.update (decVec, addr, StackAddr(!realstackptr))
+ end
+@@ -475,7 +409,7 @@
+
+ | Indirect {base, offset} =>
+ let
+- val U : unit = gencde (base, ToStack, NotEnd, matchFailFn, loopAddr);
++ val () = gencde (base, ToStack, NotEnd, matchFailFn, loopAddr);
+ in
+ genIndirect (offset, cvec)
+ end
+@@ -485,7 +419,7 @@
+
+ | Constnt w =>
+ let
+- val U : unit = pushConst (w, cvec);
++ val () = pushConst (w, cvec);
+ in
+ incsp ()
+ end
+@@ -506,7 +440,7 @@
+ fun codeList [] = ()
+ | codeList (valu :: valus) =
+ let
+- val U : unit =
++ val () =
+ case valu of
+ MutualDecs dl => genMutualDecs (dl, matchFailFn)
+ | Declar _ => gencde (valu, ToStack, NotEnd, matchFailFn, loopAddr)
+@@ -557,10 +491,10 @@
+ an argument may depend on the current value of others. Only when we've
+ evaluated all of them can we overwrite the original argument positions. *)
+ fun loadArgs ([], []) = !realstackptr - startSp (* The offset of all the args. *)
+- | loadArgs (arg:: argList, argOffset :: argIndexList) =
++ | loadArgs (arg:: argList, _ :: argIndexList) =
+ let
+ (* Evaluate all the arguments. *)
+- val U: unit = gencde (arg, ToStack, NotEnd, matchFailFn, NONE);
++ val () = gencde (arg, ToStack, NotEnd, matchFailFn, NONE);
+ val argOffset = loadArgs(argList, argIndexList);
+ in
+ genSetStackVal(argOffset, cvec); (* Copy the arg over. *)
+@@ -569,7 +503,7 @@
+ end
+ | loadArgs _ = raise InternalError "loadArgs: Mismatched arguments";
+
+- val U: int = loadArgs(argList, argIndexList)
++ val _: int = loadArgs(argList, argIndexList)
+ in
+ if !realstackptr <> startSp
+ then resetStack (!realstackptr - startSp, false, cvec) (* Remove any local variables. *)
+@@ -581,8 +515,8 @@
+
+ | Raise exp =>
+ let
+- val U : unit = gencde (exp, ToStack, NotEnd, matchFailFn, loopAddr);
+- val U : unit = genRaiseEx cvec;
++ val () = gencde (exp, ToStack, NotEnd, matchFailFn, loopAddr);
++ val () = genRaiseEx cvec;
+ in
+ exited := true
+ end
+@@ -592,17 +526,17 @@
+ type handler = labels;
+
+ (* Save old handler *)
+- val U : unit = genPushHandler cvec;
+- val U : unit = incsp ();
++ val () = genPushHandler cvec;
++ val () = incsp ();
+
+ fun genTag (tag : codetree) : handler =
+ let
+ (* Push address of new handler. *)
+ val handlerLab : labels = putBranchInstruction (setHandler, cvec);
+- val U : unit = incsp ();
++ val () = incsp ();
+
+ (* Push the exception to be caught. *)
+- val U : unit = gencde (tag, ToStack, NotEnd, matchFailFn, loopAddr)
++ val () = gencde (tag, ToStack, NotEnd, matchFailFn, loopAddr)
+ in
+ handlerLab
+ end;
+@@ -619,7 +553,7 @@
+ (* Code generate the body; "NotEnd" because we have to come back
+ to remove the handler; "ToStack" because delHandler needs
+ a result to carry down. *)
+- val U : unit = gencde (exp, ToStack, NotEnd, matchFailFn, loopAddr);
++ val () = gencde (exp, ToStack, NotEnd, matchFailFn, loopAddr);
+
+ (* Now get out of the handler and restore the old one. *)
+ val skipHandler : labels = putBranchInstruction (delHandler, cvec);
+@@ -638,16 +572,16 @@
+ values off full-word boundaries (either return addresses or
+ catch-phrases) point into code-segments.
+ *)
+- val U : unit = realstackptr := oldsp;
+- val U : unit = exited := false;
+- val U : unit = alignOffWord (cvec, 0);
+- val U : unit = apply (fn handlerLab => fixup (handlerLab, cvec)) handlerList;
++ val () = realstackptr := oldsp;
++ val () = exited := false;
++ val () = alignOffWord (cvec, 0);
++ val () = apply (fn handlerLab => fixup (handlerLab, cvec)) handlerList;
+ (* If we were executing machine code we must re-enter the interpreter. *)
+- val U : unit = genEnterIntCatch cvec;
+- val U : unit = gencde (handler, ToStack, NotEnd, matchFailFn, loopAddr);
++ val () = genEnterIntCatch cvec;
++ val () = gencde (handler, ToStack, NotEnd, matchFailFn, loopAddr);
+
+ (* Finally fix-up the jump around the handler *)
+- val U : unit = fixup (skipHandler, cvec);
++ val () = fixup (skipHandler, cvec);
+ in
+ exited := false
+ end
+@@ -655,12 +589,12 @@
+ | Ldexc =>
+ let
+ (* Get the name of the exception. *)
+- val U : unit = genLdexc cvec
++ val () = genLdexc cvec
+ in
+ incsp ()
+ end
+
+- | Case (cas as {cases, test, default, min, max}) =>
++ | Case (cas as {cases, min, max, ...}) =>
+ let
+ val numberOfCases = List.length cases;
+ in
+@@ -675,15 +609,15 @@
+ fun loadItems [] = ()
+ | loadItems (v :: vs) =
+ let
+- val U : unit = gencde (v, ToStack, NotEnd, matchFailFn, loopAddr);
++ val () = gencde (v, ToStack, NotEnd, matchFailFn, loopAddr);
+ in
+ loadItems vs
+ end;
+
+ val size : int = List.length recList;
+
+- val U : unit = loadItems recList;
+- val U : unit = genTuple (size, cvec);
++ val () = loadItems recList;
++ val () = genTuple (size, cvec);
+ in
+ realstackptr := !realstackptr - (size - 1)
+ end
+@@ -737,7 +671,7 @@
+
+ )
+
+- | TupleFromContainer(container, size) =>
++ | TupleFromContainer(container, _) =>
+ (* Create a tuple from the contents of a container. *)
+ (
+ (* TODO: This returns a MUTABLE record which is different from the
+@@ -777,7 +711,7 @@
+ val newsp = oldsp + 1;
+ val adjustment = !realstackptr - newsp;
+
+- val U : unit =
++ val () =
+ if !exited orelse adjustment = 0
+ then ()
+ else if adjustment < ~1
+@@ -795,7 +729,7 @@
+ let
+ val adjustment = !realstackptr - oldsp;
+
+- val U : unit =
++ val () =
+ if !exited orelse adjustment = 0
+ then ()
+ else if adjustment < 0
+@@ -822,15 +756,15 @@
+ val newCode : code = codeCreate(false, #name lam, parameters);
+
+ (* The only global references are recursive ones (?) *)
+- fun loadRecLink (addr : int, level : int) : slValue =
++ fun loadRecLink (_ : int, _ : int) : slValue =
+ Recursive newCode;
+
+ (* Code-gen procedure. No non-local references. *)
+ val res : address =
+ codegen (#body lam, newCode, loadRecLink, #numArgs lam, parameters);
+
+- val U : unit = pushConst(toMachineWord res, cvec);
+- val U : unit = incsp();
++ val () = pushConst(toMachineWord res, cvec);
++ val () = incsp();
+ in
+ if mutualDecs then doNext () else ()
+ end
+@@ -857,51 +791,51 @@
+ in
+ if mutualDecs
+ then let (* Have to make the closure now and fill it in later. *)
+- val U : unit = genGetStore (sizeOfClosure, cvec);
+- val U : unit = incsp ();
++ val () = genGetStore (sizeOfClosure, cvec);
++ val () = incsp ();
+
+ (* Put code address into closure *)
+- val U : unit = pushConst(toMachineWord res, cvec);
+- val U : unit = genMoveToVec(0, cvec);
++ val () = pushConst(toMachineWord res, cvec);
++ val () = genMoveToVec(0, cvec);
+
+ val entryAddr : int = !realstackptr;
+
+- val U : unit = doNext (); (* Any mutually recursive procedures. *)
++ val () = doNext (); (* Any mutually recursive procedures. *)
+
+ (* Push the address of the vector - If we have processed other
+ closures the vector will no longer be on the top of the stack. *)
+- val U : unit = pushStackValue (~ entryAddr, 0);
++ val () = pushStackValue (~ entryAddr, 0);
+
+ (* Load items for the closure. *)
+ fun loadItems ([], _) = ()
+ | loadItems (v :: vs, addr : int) =
+ let
+ (* Generate an item and move it into the vector *)
+- val U : unit = gencde (v, ToStack, NotEnd, matchFailed, NONE);
+- val U : unit = genMoveToVec(addr, cvec);
+- val U : unit = decsp ();
++ val () = gencde (v, ToStack, NotEnd, matchFailed, NONE);
++ val () = genMoveToVec(addr, cvec);
++ val () = decsp ();
+ in
+ loadItems (vs, addr + 1)
+ end;
+
+- val U : unit = loadItems (#closure lam, 1);
+- val U : unit = genLock cvec; (* Lock it. *)
++ val () = loadItems (#closure lam, 1);
++ val () = genLock cvec; (* Lock it. *)
+
+ (* Remove the extra reference. *)
+- val U : unit = resetStack (1, false, cvec);
++ val () = resetStack (1, false, cvec);
+ in
+ realstackptr := !realstackptr - 1
+ end
+
+ else let
+ (* Put it on the stack. *)
+- val U : unit = pushConst (toMachineWord res, cvec);
+- val U : unit = incsp ();
++ val () = pushConst (toMachineWord res, cvec);
++ val () = incsp ();
+
+- val U : unit =
++ val () =
+ apply (fn (pt: codetree) => gencde (pt, ToStack, NotEnd, matchFailFn, NONE)) (#closure lam);
+
+- val U : unit = genTuple (sizeOfClosure, cvec);
++ val () = genTuple (sizeOfClosure, cvec);
+ in
+ realstackptr := !realstackptr - (sizeOfClosure - 1)
+ end
+@@ -945,7 +879,7 @@
+
+ (* Now code-generate the procedure. We can throw away the result because
+ it will be assigned into the value we have just returned. *)
+- val U : address =
++ val _ : address =
+ codegen (#body lam, newCode, loadSl, #numArgs lam, parameters)
+ in
+ ()
+@@ -959,9 +893,9 @@
+ matchFailFn : unit -> unit,
+ loopAddr) : unit =
+ let
+- val U : unit = gencde (first, ToStack, NotEnd, matchFailFn, loopAddr);
++ val () = gencde (first, ToStack, NotEnd, matchFailFn, loopAddr);
+ val toElse : labels = putBranchInstruction(jumpFalse, cvec);
+- val U : unit = decsp();
++ val () = decsp();
+ in
+ case third of
+ CodeNil => (* No else-part *)
+@@ -971,18 +905,18 @@
+ value to get the stack level right we generate it with ``noresult''
+ and the stack resetting mechanism will ensure that a result is
+ pushed if it is needed. *)
+- val U : unit = gencde (second, NoResult, tailKind, matchFailFn, loopAddr);
+- val U : unit = fixup (toElse, cvec) (* Skipped the then-part. *)
++ val () = gencde (second, NoResult, tailKind, matchFailFn, loopAddr);
++ val () = fixup (toElse, cvec) (* Skipped the then-part. *)
+ in
+ exited := false (* If the test failed we won't have exited. *)
+ end
+
+ | _ =>
+ let
+- val U : unit = gencde (second, whereto, tailKind, matchFailFn, loopAddr);
++ val () = gencde (second, whereto, tailKind, matchFailFn, loopAddr);
+ (* Get rid of the result from the stack. If there is a result then the
+ ``else-part'' will push it. *)
+- val U : unit = case whereto of ToStack => decsp () | NoResult => ();
++ val () = case whereto of ToStack => decsp () | NoResult => ();
+
+ val thenExited : bool = !exited;
+
+@@ -991,13 +925,13 @@
+ else putBranchInstruction (jump, cvec);
+
+ (* start of "else part" *)
+- val U : unit = fixup (toElse, cvec);
+- val U : unit = exited := false;
+- val U : unit = gencde (third, whereto, tailKind, matchFailFn, loopAddr);
++ val () = fixup (toElse, cvec);
++ val () = exited := false;
++ val () = gencde (third, whereto, tailKind, matchFailFn, loopAddr);
+
+ val elseExited : bool= !exited;
+
+- val U : unit = fixup (toExit, cvec);
++ val () = fixup (toExit, cvec);
+ in
+ exited := (thenExited andalso elseExited) (* Only exited if both sides did. *)
+ end
+@@ -1012,7 +946,7 @@
+ fun loadArgs [] = ()
+ | loadArgs (v :: vs) =
+ let (* Push each expression onto the stack. *)
+- val U : unit = gencde(v, ToStack, NotEnd, matchFailFn, NONE);
++ val () = gencde(v, ToStack, NotEnd, matchFailFn, NONE);
+ in
+ loadArgs vs
+ end;
+@@ -1027,12 +961,12 @@
+ | EndOfProc => (* Tail recursive call. *)
+ let
+ (* Get the return address onto the top of the stack. *)
+- val U : unit = pushStackValue (0, 0);
++ val () = pushStackValue (0, 0);
+
+ (* Slide the return address, closure and args over the
+ old closure, return address and args, and reset the
+ stack. Then jump to the closure. *)
+- val U : unit =
++ val () =
+ genTailCall(argsToPass + 2, !realstackptr - 1 + (numOfArgs - argsToPass), cvec);
+ (* It's "-1" not "-2", because we didn't bump the realstackptr
+ when we pushed the return address. SPF 3/1/97 *)
+@@ -1040,7 +974,7 @@
+ exited := true
+ end;
+
+- val U : unit =
++ val () =
+ case #function eval of
+ (* The procedure is being loaded from the stack or closure so it
+ may be a static-link procedure. *)
+@@ -1048,7 +982,7 @@
+ let
+ (* Since the procedure is on the stack there can be no side-effects
+ in loading it. Can therefore load the arguments now. *)
+- val U : unit = loadArgs argList;
++ val () = loadArgs argList;
+
+ val staticLinkValue =
+ if #fpRel ext
+@@ -1069,7 +1003,7 @@
+ case staticLinkValue of
+ Address (addr, level) =>
+ let
+- val U : unit = pushStackValue (addr, level);
++ val () = pushStackValue (addr, level);
+ in
+ callClosure ()
+ end
+@@ -1077,8 +1011,8 @@
+ (* recursive reference to a procedure - not static link. *)
+ | Recursive code =>
+ let
+- val U : unit = genRecRef (code, cvec);
+- val U : unit = incsp();
++ val () = genRecRef (code, cvec);
++ val () = incsp();
+ in
+ callClosure ()
+ end
+@@ -1086,7 +1020,7 @@
+ (* Static link *)
+ | StaticLink (code, level) =>
+ let
+- val U : unit = genCallSl(!realstackptr, level, code, cvec);
++ val () = genCallSl(!realstackptr, level, code, cvec);
+ in
+ incsp ()
+ end
+@@ -1111,11 +1045,11 @@
+ safeToLeave base
+ | _ => false
+
+- val U : unit =
++ val () =
+ if (case argList of [] => true | _ => safeToLeave (#function eval))
+ then let
+ (* Can load the args first. *)
+- val U : unit = loadArgs argList;
++ val () = loadArgs argList;
+ in
+ gencde (#function eval, ToStack, NotEnd, matchFailFn, NONE)
+ end
+@@ -1125,10 +1059,10 @@
+ risk leaving. It might have a side-effect and we must
+ ensure that any side-effects it has are done before the
+ arguments are loaded. *)
+- val U : unit = gencde(#function eval, ToStack, NotEnd, matchFailFn, NONE);
+- val U : unit = loadArgs(argList);
++ val () = gencde(#function eval, ToStack, NotEnd, matchFailFn, NONE);
++ val () = loadArgs(argList);
+ (* Load the procedure again. *)
+- val U : unit = genLocal(argsToPass, cvec);
++ val () = genLocal(argsToPass, cvec);
+ in
+ incsp ()
+ end
+@@ -1138,7 +1072,7 @@
+ end; (* Not Extract *)
+
+ (* Make sure we interpret when we return from the call *)
+- val U : unit = genEnterIntCall (cvec, argsToPass);
++ val () = genEnterIntCall (cvec, argsToPass);
+
+ in (* body of genEval *)
+ realstackptr := !realstackptr - argsToPass (* Args popped by caller. *)
+@@ -1158,24 +1092,24 @@
+ generate them. *)
+ val whereto = case #default pt of CodeNil => NoResult | _ => whereto;
+
+- val U : unit = gencde (#test pt, ToStack, NotEnd, matchFailFn, loopAddr);
++ val () = gencde (#test pt, ToStack, NotEnd, matchFailFn, loopAddr);
+
+ (* The exit jumps are chained together. *)
+ val lastEndJump : labels ref = ref noJump;
+ val limit : int = #max pt - #min pt;
+
+- val U : unit =
++ val () =
+ if #min pt = 0 then ()
+ else let (* Subtract lower limit. *)
+- val U : unit = pushConst(toMachineWord (#min pt), cvec);
+- val U : unit = pushConst(ioOp POLY_SYS_aminus, cvec);
+- val U : unit = genCallClosure cvec;
++ val () = pushConst(toMachineWord (#min pt), cvec);
++ val () = pushConst(ioOp POLY_SYS_aminus, cvec);
++ val () = genCallClosure cvec;
+ in
+ genEnterIntCall (cvec, 2) (* added SPF 28/6/95 *)
+ end;
+
+- val U : unit = genCase (limit, cvec);
+- val U : unit = decsp ();
++ val () = genCase (limit, cvec);
++ val () = decsp ();
+
+ (* Addresses are relative to the first entry in the vector. *)
+ val startVec : addrs = ic cvec;
+@@ -1184,16 +1118,16 @@
+ will be overwritten by the actual address later. *)
+ val defaultAddr : int = (limit + 1) * 2;
+
+- val U : unit =
++ val () =
+ forLoop (fn (_ : int) => genWord (defaultAddr, cvec)) 0 limit;
+
+ (* The default case, if any, follows the case statement. *)
+- val U : unit =
++ val () =
+ case #default pt of
+ CodeNil => ()
+ | c => gencde (c, whereto, tailKind, matchFailFn, loopAddr);
+
+- val U : unit = exited := false;
++ val () = exited := false;
+
+ (* Now generate the code for each of the cases. *)
+ fun genEachCase ([] : (codetree * int list) list) : unit = ()
+@@ -1201,7 +1135,7 @@
+ let
+ (* First exit from the previous case or the default if
+ this is the first. *)
+- val U : unit =
++ val () =
+ lastEndJump :=
+ linkLabels
+ (!lastEndJump,
+@@ -1209,7 +1143,7 @@
+ cvec);
+
+ (* Remove the result - the last case will leave it. *)
+- val U : unit = case whereto of ToStack => decsp () | NoResult => ();
++ val () = case whereto of ToStack => decsp () | NoResult => ();
+
+ (* Now put the address of this code into the table if
+ an entry has not already been set. If it has the new
+@@ -1224,19 +1158,19 @@
+ else ()
+ end
+
+- val U : unit = apply genEachMatch matches;
++ val () = apply genEachMatch matches;
+
+ (* Generate code for this case *)
+- val U : unit = exited := false;
+- val U : unit = gencde (body, whereto, tailKind, matchFailFn, loopAddr);
++ val () = exited := false;
++ val () = gencde (body, whereto, tailKind, matchFailFn, loopAddr);
+ in
+ genEachCase otherCases
+ end; (* genEachCase *)
+
+- val U : unit = genEachCase (#cases pt);
++ val () = genEachCase (#cases pt);
+
+ (* Finally go down the list of exit labels pointing them to here. *)
+- val U : unit = fixup (!lastEndJump, cvec);
++ val () = fixup (!lastEndJump, cvec);
+ in
+ exited := false
+ end (* genDenseCase *)
+@@ -1268,22 +1202,22 @@
+ val lastOne : bool = case cs of [] => true | _ => false;
+
+ (* Is this really safe? What about multiple side-effects? SPF *)
+- val U : unit = gencde (#test pt, ToStack, NotEnd, matchFailFn, loopAddr);
++ val () = gencde (#test pt, ToStack, NotEnd, matchFailFn, loopAddr);
+
+ (* Push the value to be compared. *)
+- val U : unit = pushConst(toMachineWord c, cvec);
++ val () = pushConst(toMachineWord c, cvec);
+
+ (* Compare them. If this is the last one compare for equality and
+ so skip to the next case if it is not equal, if there are more
+ compare for inequality and skip the other tests if it matches. *)
+- val U : unit =
++ val () =
+ pushConst (ioOp (if lastOne then POLY_SYS_int_eq else POLY_SYS_int_neq), cvec);
+
+- val U : unit = genCallClosure cvec;
+- val U : unit = genEnterIntCall(cvec, 2); (* added SPF 28/6/95 *)
++ val () = genCallClosure cvec;
++ val () = genEnterIntCall(cvec, 2); (* added SPF 28/6/95 *)
+
+ val lab : labels = putBranchInstruction (jumpFalse, cvec);
+- val U : unit = decsp (); (* Remove result of test. *)
++ val () = decsp (); (* Remove result of test. *)
+ in (* body of putInCases *)
+ if lastOne
+ then lab (* last one - skip if value does not match. *)
+@@ -1291,7 +1225,7 @@
+ (* More than one. If this one matches skip the other tests. *)
+ (* Drop through to other tests if it does not match. *)
+ val rLab : labels = putInCases cs;
+- val U : unit = fixup (lab, cvec);
++ val () = fixup (lab, cvec);
+ in
+ rLab
+ end
+@@ -1300,13 +1234,13 @@
+ val lab : labels = putInCases matches;
+
+ (* Now the expression. *)
+- val U : unit = gencde(body, whereto, tailKind, matchFailFn, loopAddr);
++ val () = gencde(body, whereto, tailKind, matchFailFn, loopAddr);
+ val thisHasExited : bool = !exited;
+
+ (* Remove the result - the default case will leave it. *)
+- val U : unit = case whereto of ToStack => decsp () | NoResult => ();
++ val () = case whereto of ToStack => decsp () | NoResult => ();
+
+- val U : unit =
++ val () =
+ lastEndJump :=
+ linkLabels
+ (!lastEndJump,
+@@ -1314,8 +1248,8 @@
+ cvec);
+
+ (* Now the next case. *)
+- val U : unit = fixup (lab, cvec);
+- val U : unit = exited := false;
++ val () = fixup (lab, cvec);
++ val () = exited := false;
+ in
+ caseCode (otherCases, othersExited andalso thisHasExited)
+ end; (* caseCode *)
+@@ -1323,14 +1257,14 @@
+ (* First the cases. *)
+ val casesExited : bool = caseCode (#cases pt, true);
+
+- val U : unit = exited := false;
++ val () = exited := false;
+
+- val U : unit =
++ val () =
+ case #default pt of
+ CodeNil => ()
+- | c => (* put in the default *)
++ | _ => (* put in the default *)
+ let
+- val U : unit = gencde(#default pt, whereto, tailKind, matchFailFn, loopAddr);
++ val () = gencde(#default pt, whereto, tailKind, matchFailFn, loopAddr);
+ in
+ exited := (!exited andalso casesExited)
+ end;
+@@ -1342,7 +1276,7 @@
+ (* Mutually recursive declarations. May be either procedures, constants
+ or reccons (from type constructors). Recurse down the list pushing the
+ addresses of the closure vectors, then unwind the recursion and fill them in. *)
+- and genMutualDecs ([], matchFailFn) : unit = ()
++ and genMutualDecs ([], _) : unit = ()
+ | genMutualDecs (Declar decl :: otherDecs, matchFailFn) : unit =
+ (
+ case #value decl of
+@@ -1352,9 +1286,9 @@
+ (* Create a code-segment and put it in the table in case of
+ mutually recursive references. *)
+ val newCode : code = codeCreate(true, #name lam, parameters);
+- val U : unit = STRETCHARRAY.update (decVec, #addr decl, ProcConst newCode);
++ val () = STRETCHARRAY.update (decVec, #addr decl, ProcConst newCode);
+ (* Deal with any other possible references. *)
+- val U : unit = genMutualDecs (otherDecs, matchFailFn);
++ val () = genMutualDecs (otherDecs, matchFailFn);
+ in
+ (* Can now process this procedure since we have made an entry
+ in the table for everything it could refer to. *)
+@@ -1364,7 +1298,7 @@
+ else let (* Closure. *)
+ fun doRest () : unit =
+ let
+- val U : unit = STRETCHARRAY.update (decVec, #addr decl, StackAddr (! realstackptr));
++ val () = STRETCHARRAY.update (decVec, #addr decl, StackAddr (! realstackptr));
+ in
+ (* Now time to do the other closures. *)
+ genMutualDecs (otherDecs, matchFailFn)
+@@ -1375,8 +1309,8 @@
+
+ | dec => (* constants or reccons.*)
+ let
+- val U : unit = gencde (dec, ToStack, NotEnd, matchFailFn, NONE);
+- val U : unit = STRETCHARRAY.update (decVec, #addr decl, StackAddr (!realstackptr));
++ val () = gencde (dec, ToStack, NotEnd, matchFailFn, NONE);
++ val () = STRETCHARRAY.update (decVec, #addr decl, StackAddr (!realstackptr));
+ in
+ genMutualDecs (otherDecs, matchFailFn)
+ end
+@@ -1388,15 +1322,15 @@
+ break-point instruction in the machine-code instruction set to make sure
+ that the code is interpreted. It is a no-op if we are already
+ interpreting. *)
+- val U : unit = genEnterIntProc (cvec, numOfArgs); (* SPF 23/6/95 *)
++ val () = genEnterIntProc (cvec, numOfArgs); (* SPF 23/6/95 *)
+
+ (* Generate the procedure. *)
+ (* Assume we always want a result. There is otherwise a problem if the
+ called routine returns a result of type void (i.e. no result) but the
+ caller wants a result (e.g. the identity function). *)
+- val U : unit = gencde (pt, ToStack, EndOfProc, matchFailed, NONE);
++ val () = gencde (pt, ToStack, EndOfProc, matchFailed, NONE);
+
+- val U : unit = if !exited then () else genReturn (numOfArgs, cvec);
++ val () = if !exited then () else genReturn (numOfArgs, cvec);
+ in (* body of codegen *)
+ (* Having code-generated the body of the procedure, it is copied
+ into a new data segment. *)
+@@ -1415,7 +1349,7 @@
+ val newCode : code = codeCreate (false, #name lam, parameters);
+
+ (* The only global references are recursive ones (?) *)
+- fun loadRecLink (level : int, addr : int) : slValue =
++ fun loadRecLink (_ : int, _ : int) : slValue =
+ Recursive newCode;
+
+ (* This procedure must have no non-local references. *)
+@@ -1433,7 +1367,7 @@
+ val newCode : code = codeCreate(false, "<top level>", parameters);
+
+ (* There ane *no* global references at all *)
+- fun loadRecLink (level : int, addr : int) : slValue =
++ fun loadRecLink (_ : int, _ : int) : slValue =
+ raise InternalError "top level reached";
+
+ val closureAddr : address =
+diff -u -r mlsource/MLCompiler/CodeTree/PPCCODECONS.ML mlsource/MLCompiler/CodeTree/PPCCODECONS.ML
+--- mlsource/MLCompiler/CodeTree/PPCCODECONS.ML 2008-04-21 13:30:52.000000000 +0200
++++ mlsource/MLCompiler/CodeTree/PPCCODECONS.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -422,10 +422,10 @@
+
+ val toInt = Word.toIntX (* This previously just cast the value so continue to treat it as signed. *)
+
+- fun applyCountList (f, n, []) = ()
++ fun applyCountList (_, _, []) = ()
+ | applyCountList (f, n, h::t) =
+ let
+- val U : unit = f (n, h);
++ val () = f (n, h);
+ in
+ applyCountList (f, n + 1, t)
+ end;
+@@ -471,7 +471,7 @@
+ fun exp2 0 = 1
+ | exp2 n = 2 * exp2 (n - 1);
+ in
+- val U : bool =
++ val _ : bool =
+ (
+ exp2_1 = exp2 1 andalso
+ exp2_2 = exp2 2 andalso
+@@ -541,7 +541,6 @@
+
+ val mask2Bits = short3; (* least significant 2 bits *)
+ val mask3Bits = short7; (* least significant 3 bits *)
+- val mask5Bits = short31; (* least significant 5 bits *)
+ val mask6Bits = short63; (* least significant 6 bits *)
+ val mask7Bits = short127; (* least significant 7 bits *)
+ val mask8Bits = short255; (* least significant 8 bits *)
+@@ -618,11 +617,6 @@
+ val int16_0 = Imm16 0;
+ val int16_1 = Imm16 1;
+ val int16_2 = Imm16 2;
+- val int16_3 = Imm16 3;
+- val int16_4 = Imm16 4;
+- val int16_6 = Imm16 6;
+- val int16_8 = Imm16 8;
+- val int16_16 = Imm16 16;
+ end; (* int16 *)
+
+
+@@ -635,10 +629,7 @@
+ quantity when we actually generate the code.
+ *)
+ abstype int24 = Imm24 of int
+- with
+- fun isZero24 (Imm24 0) = true
+- | isZero24 (Imm24 _) = false;
+-
++ with
+ fun getInt24 (Imm24 i) = i;
+
+ (* is24Bit is the test for signed 24-bit immediates *)
+@@ -674,10 +665,7 @@
+ quantity when we actually generate the code.
+ *)
+ abstype int14 = Imm14 of int
+- with
+- fun isZero14 (Imm14 0) = true
+- | isZero14 (Imm14 _) = false;
+-
++ with
+ fun getInt14 (Imm14 i) = i;
+
+ (* is14Bit is the test for signed 14-bit immediates *)
+@@ -713,32 +701,8 @@
+ quantity when we actually generate the code.
+ *)
+ abstype int10 = Imm10 of int
+- with
+- fun isZero10 (Imm10 0) = true
+- | isZero10 (Imm10 _) = false;
+-
++ with
+ fun getInt10 (Imm10 i) = i;
+-
+- (* is10Bit is the test for signed 10-bit immediates *)
+- fun is10Bit i = ~ exp2_9 <= i andalso i < exp2_9;
+-
+- fun int10 i =
+- if is10Bit i
+- then
+- if i < 0
+- then Imm10 (exp2_10 + i)
+- else Imm10 i
+- else let
+- val msg =
+- concat
+- [
+- "int10: can't convert ",
+- Int.toString i,
+- " into a 10-bit signed immediate"
+- ]
+- in
+- raise InternalError msg
+- end;
+
+ val int10_0 = Imm10 0;
+ val int10_4 = Imm10 4;
+@@ -757,7 +721,6 @@
+ val int10_444 = Imm10 444;
+ val int10_459 = Imm10 459
+ val int10_467 = Imm10 467;
+- val int10_512 = Imm10 512; (* *unsigned* 512 *)
+ val int10_520 = Imm10 520; (* *unsigned* 520 *)
+ val int10_528 = Imm10 528; (* *unsigned* 528 *)
+ val int10_747 = Imm10 747; (* *unsigned* 747 *)
+@@ -803,7 +766,6 @@
+ val int5_5 = Imm5 5;
+ val int5_12 = Imm5 12;
+ val int5_13 = Imm5 13;
+- val int5_31 = Imm5 31;
+ end; (* int5 *)
+
+ (*****************************************************************************)
+@@ -821,7 +783,7 @@
+ val lo16 = pi mod exp2_16;
+ val hi16 = pi div exp2_16;
+
+- val U : unit =
++ val () =
+ if isUnsigned16Bit hi16
+ then ()
+ else let
+@@ -853,7 +815,7 @@
+ val lo16 = i mod exp2_16;
+ val hi16 = i div exp2_16;
+
+- val U : unit =
++ val () =
+ if is16Bit hi16
+ then ()
+ else let
+@@ -902,7 +864,7 @@
+ val regCode = NONE; (* No special register required *)
+ val regClosure = Reg 24; (* address of closure (or static link) *)
+ val regReturn = Reg 25; (* return address *)
+- val regTemp3 = Reg 26; (* Unsaved temporary. *)
++ (*val regTemp3 = Reg 26;*) (* Unsaved temporary. *)
+ val regStackPtr = Reg 27; (* current ML stack pointer *)
+ (* r28 is no longer used *)
+ val regHeapPtr = Reg 29; (* current heap allocation pointer *)
+@@ -936,9 +898,6 @@
+
+ fun a regEq b = getReg a = getReg b;
+ fun a regNeq b = getReg a <> getReg b;
+- fun a regLeq b = getReg a <= getReg b;
+- fun a regGeq b = getReg a >= getReg b;
+- fun (Reg a) regMinus (Reg b) = a - b;
+
+ (* The number of the register. *)
+ fun nReg (Reg n) =
+@@ -1213,7 +1172,7 @@
+ (bits21_25, bits16_20, bits11_15, bits1_10, bits0_0 = 1)
+ end;
+
+- fun printUnknown (instr : int, printStream) : unit =
++ fun printUnknown (_ : int, printStream) : unit =
+ let
+ in
+ printStream "??????\t"
+@@ -1234,7 +1193,7 @@
+
+ fun printArithmeticXform (name : string, instr : int, printStream) : unit =
+ let
+- val (RT : int, RA : int, RB : int, op2: int, Rc : bool) =
++ val (RT : int, RA : int, RB : int, _: int, Rc : bool) =
+ splitXform instr;
+ in
+ printStream name;
+@@ -1262,7 +1221,7 @@
+
+ fun printLogicalXform (name : string, instr : int, printStream) : unit =
+ let
+- val (RS : int, RA : int, RB : int, op2: int, Rc : bool) =
++ val (RS : int, RA : int, RB : int, _: int, Rc : bool) =
+ splitXform instr;
+ in
+ printStream name;
+@@ -1290,7 +1249,7 @@
+
+ fun printStorageXform (name : string, instr : int, printStream) : unit =
+ let
+- val (RT : int, RA : int, RB : int, op2: int, Rc : bool) =
++ val (RT : int, RA : int, RB : int, _: int, _ : bool) =
+ splitXform instr;
+ in
+ printStream name;
+@@ -1332,7 +1291,7 @@
+
+ fun printExt31 (instr : int, printStream) : unit =
+ let
+- val (F1 : int, F2 : int, F3 : int, OP2 : int, F4 : bool) =
++ val (F1 : int, F2 : int, F3 : int, OP2 : int, _ : bool) =
+ splitXform instr;
+ in
+ case OP2 of
+@@ -1647,7 +1606,7 @@
+ val MemRegisterStackOverflow = 32 (* Called when the stack limit is reached. *)
+ val MemRegisterStackOverflowEx = 36 (* Called when the stack limit is reached. *)
+ val MemRegisterRaiseException = 40 (* Called to raise an exception with an exception packet. *)
+- val MemRegisterIOEntry = 44 (* Called to make an IO call. Not currently used by the code-generator. *)
++ (*val MemRegisterIOEntry = 44 *)(* Called to make an IO call. Not currently used by the code-generator. *)
+ val MemRegisterRaiseDiv = 48 (* Called to raise a divide exception. *)
+ val MemRegisterArbEmulation = 52 (* Called to emulate an arbitrary precision instruction. *)
+
+@@ -1840,15 +1799,6 @@
+ DformQuad (ADDIS, rt', ra', SI)
+ end;
+
+- fun add (rt : reg, ra : reg, rb : reg) : quad =
+- let
+- val rt' : int5 = getReg5 rt;
+- val ra' : int5 = getReg5 ra;
+- val rb' : int5 = getReg5 rb;
+- in
+- XformQuad (EXT31, rt', ra', rb', op31ToInt10 ADD, false)
+- end;
+-
+ fun sub (rt : reg, ra : reg, rb : reg) : quad =
+ let
+ val rt' : int5 = getReg5 rt;
+@@ -1929,15 +1879,6 @@
+ DformQuad (ANDIDOT, rs', ra', UI)
+ end;
+
+- fun andisDot (ra : reg, rs : reg, UI : int16) : quad =
+- let
+- val ra' : int5 = getReg5 ra;
+- val rs' : int5 = getReg5 rs;
+- in
+- (* the RA and RS fields are "backwards" in logical operations *)
+- DformQuad (ANDISDOT, rs', ra', UI)
+- end;
+-
+ (* "and" is an ML keyword, so we use "and_" *)
+ fun and_ (ra : reg, rs : reg, rb : reg) : quad =
+ let
+@@ -2008,9 +1949,6 @@
+
+ fun mflr (rt : reg) : quad =
+ XformQuad (EXT31, getReg5 rt, LR, int5_0, op31ToInt10 MFSPR, false);
+-
+- fun mfctr (rt : reg) : quad =
+- XformQuad (EXT31, getReg5 rt, CTR, int5_0, op31ToInt10 MFSPR, false);
+ end;
+
+ (*****************************************************************************)
+@@ -2303,11 +2241,6 @@
+ fun mergeCacheStates (Unreachable, state) = state
+ | mergeCacheStates (Reachable lr1, Reachable lr2) = Reachable (lr1 andalso lr2)
+ | mergeCacheStates (state, Unreachable) = state
+-
+- (* Use this when we modify (only) LR *)
+- fun LRmodified Unreachable = Unreachable
+- | LRmodified (Reachable true) = Reachable false
+- | LRmodified state = state;
+
+ (* Does LR cache the return address? *)
+ fun LRcacheActive Unreachable = true (* sic *)
+@@ -2325,9 +2258,6 @@
+ datatype jumpFrom =
+ Jump14From of addrs * cacheState (* branch instruction has 14-bit offset field *)
+ | Jump24From of addrs * cacheState; (* branch instruction has 24-bit offset field *)
+-
+- fun isLongJump (Jump24From _ ) = true
+- | isLongJump (Jump14From _ ) = false
+
+ (* We need a jumpFrom ref, because we may have to indirect short branches
+ via long branches if the offset won't fit into 14 bits *)
+@@ -2399,24 +2329,17 @@
+
+ fun codeVec (Code {codeVec,...}) = codeVec;
+ fun ic (Code {ic,...}) = ic;
+- fun constVec (Code {constVec,...}) = constVec;
+- fun numOfConsts (Code {numOfConsts,...}) = numOfConsts;
+ fun stackReset (Code {stackReset ,...}) = stackReset;
+ fun pcOffset (Code {pcOffset,...}) = pcOffset;
+ fun labelList (Code {labelList,...}) = labelList;
+ fun longestBranch (Code {longestBranch,...}) = longestBranch;
+ fun procName (Code {procName,...}) = procName;
+ fun otherCodes (Code {otherCodes,...}) = otherCodes;
+- fun resultSeg (Code {resultSeg,...}) = resultSeg;
+ fun mustCheckStack (Code {mustCheckStack,...}) = mustCheckStack;
+ fun justComeFrom (Code {justComeFrom,...}) = justComeFrom;
+- fun selfCalls (Code {selfCalls,...}) = selfCalls;
+- fun selfJumps (Code {selfJumps,...}) = selfJumps;
+- fun noClosure (Code {noClosure,...}) = noClosure;
+ fun cacheState (Code {cacheState,...}) = cacheState;
+
+ fun scSet (Set x) = x | scSet _ = raise Match;
+- fun isSet (Set _) = true | isSet _ = false
+
+ fun unreachable (Code {justComeFrom, cacheState, ...}) =
+ case (justComeFrom, cacheState) of
+@@ -2427,11 +2350,6 @@
+ the pcOffset ref is the same. N.B. NOT its contents. *)
+ infix is;
+ fun a is b = (pcOffset a = pcOffset b);
+-
+- fun sameConst (WVal w1, WVal w2) = wordEq (w1, w2)
+- | sameConst (HVal h1, HVal h2) = h1 = h2
+- | sameConst (CVal c1, CVal c2) = c1 is c2
+- | sameConst (_, _) = false;
+
+ val codesize = 32; (* bytes. Initial size of segment. *)
+
+@@ -2563,7 +2481,7 @@
+ (* Make a reference to another procedure. Usually this will be a forward *)
+ (* reference but it may have been compiled already, in which case we can *)
+ (* put the code address in now. *)
+- fun codeConst (Code {resultSeg = ref(Set seg), ... }, into) =
++ fun codeConst (Code {resultSeg = ref(Set seg), ... }, _) =
+ (* Already done. *) WVal (toMachineWord(csegAddr seg))
+ | codeConst (r, into) = (* forward *)
+ (* Add the referring procedure onto the list of the procedure
+@@ -2571,7 +2489,7 @@
+ the referring procedure is finished and its address is known the
+ address will be plugged in to every procedure which needs it. *)
+ let
+- fun onList x [] = false
++ fun onList _ [] = false
+ | onList x (c::cs) = (x is c) orelse onList x cs;
+
+ val codeList = ! (otherCodes r);
+@@ -2595,14 +2513,14 @@
+ fun removeLabel (lab : addrs, cvec) : unit =
+ let
+ fun removeEntry ([]: labList) : labList = []
+- | removeEntry ((entry as ref (Jump24From _)) :: t) =
++ | removeEntry ((ref (Jump24From _)) :: t) =
+ removeEntry t (* we discard all long jumps *)
+
+ | removeEntry ((entry as ref (Jump14From (addr,_))) :: t) =
+ if lab addrEq addr
+ then removeEntry t
+ else let
+- val U : unit =
++ val () =
+ if addr addrLt !(longestBranch cvec)
+ then longestBranch cvec := addr
+ else ();
+@@ -2680,7 +2598,7 @@
+ We're about to fix up the jump, so remove it from the
+ list of pending short jumps.
+ *)
+- val U : unit = removeLabel (addr, cvec);
++ val () = removeLabel (addr, cvec);
+
+ val oldInstr : quad = getCodeQuad (addr, cvec);
+ val newInstr : quad = fixupCondBranch (oldInstr, diff14);
+@@ -2753,7 +2671,7 @@
+ fun genRawInstruction (instr : quad, cvec : code) : unit =
+ if unreachable cvec then ()
+ else let
+- val U : unit = reallyFixup cvec;
++ val () = reallyFixup cvec;
+ in
+ genCodeQuad (instr, cvec)
+ end;
+@@ -2771,7 +2689,7 @@
+ let
+ val sr = stackReset cvec;
+ val adj = !sr * 4;
+- val U : unit = sr := 0;
++ val () = sr := 0;
+ in
+ genRawInstructionList (addImmed (regStackPtr, regStackPtr, adj), cvec)
+ end;
+@@ -2818,11 +2736,11 @@
+ if !icRef wordAddrMinus addr = 1
+ then let
+ (* simply skip back one instruction *)
+- val U : unit = icRef := addr;
++ val () = icRef := addr;
+ (* remove the label from the "pending jumps" list *)
+- val U : unit = removeLabel (addr, cvec);
++ val () = removeLabel (addr, cvec);
+ (* update the cached state, to reflect the dummy fixup *)
+- val U : unit =
++ val () =
+ cacheState cvec :=
+ mergeCacheStates (!(cacheState cvec), cachedState);
+ in
+@@ -2834,9 +2752,9 @@
+ if !icRef wordAddrMinus addr = 1
+ then let
+ (* simply skip back one instruction *)
+- val U : unit = icRef := addr;
++ val () = icRef := addr;
+ (* update the cached state, to reflect the dummy fixup *)
+- val U : unit =
++ val () =
+ cacheState cvec :=
+ mergeCacheStates (!(cacheState cvec), cachedState);
+ in
+@@ -2857,7 +2775,7 @@
+ let
+ (* Any pending stack reset must be done now.
+ That may involve fixing up pending jumps. *)
+- val U : unit = genPendingStackAdjustment cvec;
++ val () = genPendingStackAdjustment cvec;
+ in
+ (* Add together the jumps to here, updating the cache state *)
+ justComeFrom cvec := checkLabsCarefully lab @ !(justComeFrom cvec)
+@@ -2878,7 +2796,7 @@
+ (* val maxDiff = 100; for testing purposes *)
+ val maxDiff : int = (exp2_13 - 1000) - needed;
+
+- fun inList x [] = false
++ fun inList _ [] = false
+ | inList x (h::t) = (x = h) orelse inList x t;
+
+ (* Go down the list converting any long labels, and finding the
+@@ -2908,24 +2826,24 @@
+ if here wordAddrMinus addr > maxDiff
+ then let (* Getting close - convert it. *)
+ (* fix up the short branch to here *)
+- val U : unit = branchInPoint cvec;
+- val U : unit = reallyFixupBranch (!lab, here, cvec);
++ val () = branchInPoint cvec;
++ val () = reallyFixupBranch (!lab, here, cvec);
+
+ (* recompute "here", in case we've generated some code *)
+ val here : addrs = !(ic cvec);
+ (* long jump to the final destination *)
+- val U : unit = genCodeQuad (branchAlwaysQuad, cvec);
++ val () = genCodeQuad (branchAlwaysQuad, cvec);
+ (* alter the jump state on the old label (and discard the new one) *)
+- val U : unit = lab := Jump24From (here, cachedState);
++ val () = lab := Jump24From (here, cachedState);
+ (* We don't fall through from here. *)
+- val U : unit = cancelFallThrough cvec;
++ val () = cancelFallThrough cvec;
+ in
+ convertRest
+ end
+ else let
+ (* Not ready to remove this. Just find out if
+ this is an earlier branch and continue. *)
+- val U : unit =
++ val () =
+ if addr addrLt !(longestBranch cvec)
+ then longestBranch cvec := addr
+ else ();
+@@ -2940,24 +2858,24 @@
+ (* Must save the stack-reset, otherwise "fixup" will try
+ to reset it. *)
+ val sr = ! (stackReset cvec);
+- val U : unit = stackReset cvec := 0;
++ val () = stackReset cvec := 0;
+
+ (* Must skip round the branches unless we have just
+ taken an unconditional branch. *)
+ val lab =
+ if unreachable cvec then []
+ else let
+- val U : unit = genRawInstruction (branchAlwaysQuad, cvec);
++ val () = genRawInstruction (branchAlwaysQuad, cvec);
+ val lab = [makeLongLabel cvec];
+- val U : unit = cancelFallThrough cvec;
++ val () = cancelFallThrough cvec;
+ in
+ lab
+ end
+
+ (* Find the new longest branch while converting the labels *)
+- val U : unit = longestBranch cvec := addrLast;
+- val U : unit = labelList cvec := convertLabels (! (labelList cvec));
+- val U : unit = fixup (lab, cvec); (* Continue with normal processing. *)
++ val () = longestBranch cvec := addrLast;
++ val () = labelList cvec := convertLabels (! (labelList cvec));
++ val () = fixup (lab, cvec); (* Continue with normal processing. *)
+ in
+ stackReset cvec := sr (* Restore old value. *)
+ end
+@@ -2974,7 +2892,7 @@
+ fun genInstruction (instr : quad, cvec : code) : unit =
+ let
+ (* fix up any pending-overflow jumps *)
+- val U : unit = checkBranchList (0, cvec);
++ val () = checkBranchList (0, cvec);
+ in
+ genRawInstruction (instr, cvec)
+ end;
+@@ -3005,7 +2923,7 @@
+ then 4 * !(stackReset cvec)
+ else 0;
+
+- val U : unit =
++ val () =
+ if rt regEq regStackPtr
+ then stackReset cvec := 0
+ else ();
+@@ -3029,7 +2947,7 @@
+ if unreachable cvec then []
+ else let
+ (* generate stack adjustment (if necessary) *)
+- val U : unit = genPendingStackAdjustment cvec;
++ val () = genPendingStackAdjustment cvec;
+
+ (*
+ If we are branching and we have just arrived from somewhere
+@@ -3052,7 +2970,7 @@
+ the jumps.
+ SPF 1/12/95
+ *)
+- val U : unit = justComeFrom cvec := [];
++ val () = justComeFrom cvec := [];
+
+ (*
+ The following code is very delicate. If we've just made the
+@@ -3067,7 +2985,7 @@
+ then oldLab
+ else let
+ (* generate the actual branch *)
+- val U : unit = genInstruction (branchAlwaysQuad, cvec);
++ val () = genInstruction (branchAlwaysQuad, cvec);
+ in
+ makeLongLabel cvec :: oldLab
+ end;
+@@ -3077,7 +2995,7 @@
+ the label would propagate the wrong cacheState forwards.
+ SPF 1/12/95
+ *)
+- val U : unit = cancelFallThrough cvec;
++ val () = cancelFallThrough cvec;
+ in
+ lab
+ end;
+@@ -3085,8 +3003,8 @@
+ fun putConditional (test : testCode, cvec : code) : labels =
+ if unreachable cvec then [] (* SPF 5/6/95 *)
+ else let
+- val U : unit = genPendingStackAdjustment cvec; (* may generate code *)
+- val U : unit = genInstruction (condBranch (test, int14_0), cvec);
++ val () = genPendingStackAdjustment cvec; (* may generate code *)
++ val () = genInstruction (condBranch (test, int14_0), cvec);
+ in
+ (* Make a label for this instruction. *)
+ [makeShortLabel cvec]
+@@ -3108,7 +3026,7 @@
+ fun genX31 (rt : reg, ra : reg, rb : reg, op2 : opCode31,
+ rc : bool, cvec : code) : unit =
+ let
+- val U : unit =
++ val () =
+ if rt regEq regStackPtr orelse
+ ra regEq regStackPtr orelse
+ rb regEq regStackPtr
+@@ -3162,9 +3080,6 @@
+ fun genMtlr (rs : reg, cvec : code) : unit =
+ genInstruction (mtlr rs, cvec);
+
+- fun genMflr (rt : reg, cvec : code) : unit =
+- genInstruction (mflr rt, cvec);
+-
+ fun genMtctr (rs : reg, cvec : code) : unit =
+ genInstruction (mtctr rs, cvec);
+
+@@ -3189,7 +3104,7 @@
+ then raise InternalError ("genLoad: can't use " ^ regRepr regTemp1)
+ else let
+ (* Do we need to fix-up the stack pointer? *)
+- val U : unit =
++ val () =
+ if rt regEq regStackPtr
+ then genPendingStackAdjustment cvec
+ else ();
+@@ -3216,7 +3131,7 @@
+ then raise InternalError ("genStore: can't use " ^ regRepr regTemp1)
+ else let
+ (* Do we need to fix-up the stack pointer? *)
+- val U : unit =
++ val () =
+ if rs regEq regStackPtr
+ then genPendingStackAdjustment cvec
+ else ();
+@@ -3260,7 +3175,7 @@
+ then raise InternalError ("genStoreByte: can't use " ^ regRepr regTemp1)
+ else let
+ (* Do we need to fix-up the stack pointer? *)
+- val U : unit =
++ val () =
+ if rs regEq regStackPtr
+ then genPendingStackAdjustment cvec
+ else ();
+@@ -3303,9 +3218,9 @@
+
+ (* Exported - Can we store the value without going through a register?
+ No. *)
+- fun isStoreI (cnstnt: machineWord, _, _) : bool = false;
++ fun isStoreI _ : bool = false;
+
+- fun genStoreI (cnstnt: machineWord, offset: int, rb: reg, width, index: reg, cvec: code) : unit =
++ fun genStoreI _ : unit =
+ raise InternalError "Not implemented: genStoreI";
+
+ (* Store a value on the stack. This is used when the registers need to be
+@@ -3315,7 +3230,7 @@
+ (* Just adjust stackReset to decrement the virtual stack pointer;
+ genStore handles everything else. *)
+ val sr = stackReset cvec;
+- val U : unit = sr := !sr - 1;
++ val () = sr := !sr - 1;
+ in
+ genStoreWord (r, 0, regStackPtr, regNone, cvec) (* corrupts regTemp1 *)
+ end;
+@@ -3565,11 +3480,11 @@
+ (* Return and remove args from stack. *)
+ fun returnFromFunction (returnReg, args, cvec) : unit =
+ let (* mtlr resReg; blr *)
+- val U : unit = resetStack (args, cvec); (* Add in the reset. *)
+- val U : unit =
++ val () = resetStack (args, cvec); (* Add in the reset. *)
++ val () =
+ if returnAddrIsCached cvec then () else genMtlr (returnReg, cvec);
+- val U : unit = genPendingStackAdjustment cvec;
+- val U : unit = genInstruction (blrQuad, cvec);
++ val () = genPendingStackAdjustment cvec;
++ val () = genInstruction (blrQuad, cvec);
+ in
+ (* That's the end of this basic block *)
+ cancelFallThrough cvec
+@@ -3578,11 +3493,11 @@
+ (* Only used for while-loops. *)
+ fun jumpback (lab, stackCheck, cvec) : unit =
+ let
+- val U : unit = genPendingStackAdjustment cvec;
++ val () = genPendingStackAdjustment cvec;
+
+ (* Put in a stack check. This is used to allow
+ the code to be interrupted. *)
+- val U : unit =
++ val () =
+ if stackCheck
+ then
+ let
+@@ -3597,9 +3512,9 @@
+ clearAllCaches cvec
+ end
+ else ();
+- val U : unit = reallyFixup cvec;
++ val () = reallyFixup cvec;
+ val wordOffset : int = lab wordAddrMinus (! (ic cvec));
+- val U : unit = genInstruction (uncondBranch (int24 wordOffset), cvec)
++ val () = genInstruction (uncondBranch (int24 wordOffset), cvec)
+ in
+ cancelFallThrough cvec
+ end;
+@@ -3613,13 +3528,13 @@
+ else let
+ val bytes : int = (length + 1) * 4;
+ val lengthWord : int = length + (Word8.toInt flag * exp2_24);
+- val U : unit = genPendingStackAdjustment cvec;
++ val () = genPendingStackAdjustment cvec;
+ (* Load r12 with the length word first. This simplifies recovering if we
+ get a trap since we then know how much space we actually wanted. *)
+- val U : unit = genLoadImmed(regTemp2, lengthWord, cvec);
++ val () = genLoadImmed(regTemp2, lengthWord, cvec);
+ (* addi rhp, rhp, -bytes ; cmpl rhp,rhl; bge+ L1 *)
+- val U : unit = genInstructionList (addImmed (regHeapPtr, regHeapPtr, ~bytes), cvec)
+- val U : unit = genCmpl (regHeapPtr, regHeapLim, cvec);
++ val () = genInstructionList (addImmed (regHeapPtr, regHeapPtr, ~bytes), cvec)
++ val () = genCmpl (regHeapPtr, regHeapLim, cvec);
+ val skipTrap = putConditional (GeInv, cvec)
+ in
+ genLoad(MemRegisterHeapOverflow, regMemRegs, regZero, cvec);
+@@ -3642,7 +3557,7 @@
+ end
+
+ (* Don't need to do anything on this machine. *)
+- val completeSegment = (fn code => ());
++ val completeSegment = (fn _ => ());
+
+ (***************************************************************************
+ General operations
+@@ -3745,17 +3660,17 @@
+ lab1:
+ *)
+
+- val U : unit = genInstruction (slwiDot (regZero, r, 31), cvec);
++ val () = genInstruction (slwiDot (regZero, r, 31), cvec);
+ (* Jump round the trap. We invert the prediction flag here because the
+ default for a forward jump is "not taken" and this normally will be. *)
+ val skipTrap = putConditional (NeInv, cvec)
+- val U : unit = genTrapCacheFlush cvec;
++ val () = genTrapCacheFlush cvec;
+ val lab : addrs = ! (ic cvec);
+- val U : unit = genLoad(MemRegisterArbEmulation, regMemRegs, regZero, cvec);
+- val U : unit = genMtlr(regZero, cvec);
+- val U : unit = genInstruction(blrlQuad, cvec);
+- val U : unit = fixup(skipTrap, cvec);
+- val U : unit = clearAllCaches cvec; (* If we've taken the trap LR won't be valid. *)
++ val () = genLoad(MemRegisterArbEmulation, regMemRegs, regZero, cvec);
++ val () = genMtlr(regZero, cvec);
++ val () = genInstruction(blrlQuad, cvec);
++ val () = fixup(skipTrap, cvec);
++ val () = clearAllCaches cvec; (* If we've taken the trap LR won't be valid. *)
+ in
+ lab
+ end;
+@@ -3767,7 +3682,7 @@
+ if rx regEq ry
+ then genTagTest1 (rx, cvec)
+ else let
+- val U : unit = genAnd (regTemp1, rx, ry, cvec);
++ val () = genAnd (regTemp1, rx, ry, cvec);
+ in
+ genTagTest1 (regTemp1, cvec)
+ end;
+@@ -3791,7 +3706,7 @@
+ ***************************************************************************)
+
+ (* All are implemented. *)
+- fun isCompRR tc = true;
++ fun isCompRR _ = true;
+
+
+ (* Is this argument acceptable as an immediate or should it be *)
+@@ -3816,7 +3731,7 @@
+ case tc of
+ Wrd test =>
+ let
+- val U : unit = genCmpl (r1, r2, cvec); (* Word comparisons are unsigned. *)
++ val () = genCmpl (r1, r2, cvec); (* Word comparisons are unsigned. *)
+ in
+ putConditional (test, cvec)
+ end
+@@ -3840,21 +3755,21 @@
+ trap which causes the RTS to emulate the immediately following
+ comparison.
+ *)
+- val U : unit =
++ val () =
+ case test of
+ Eq => genOr (regTemp1, r1, r2, cvec)
+ | Ne => genOr (regTemp1, r1, r2, cvec)
+ | _ => genAnd (regTemp1, r1, r2, cvec);
+- val U : unit = genInstruction (slwiDot (regTemp1, regTemp1, 31), cvec);
+- val U : unit = genTrapCacheFlush cvec;
++ val () = genInstruction (slwiDot (regTemp1, regTemp1, 31), cvec);
++ val () = genTrapCacheFlush cvec;
+ val skipTrap = putConditional (NeInv, cvec)
+- val U : unit = genLoad(MemRegisterArbEmulation, regMemRegs, regZero, cvec);
+- val U : unit = genMtlr(regZero, cvec);
+- val U : unit = genInstruction(blrlQuad, cvec);
+- val U : unit = fixup(skipTrap, cvec);
++ val () = genLoad(MemRegisterArbEmulation, regMemRegs, regZero, cvec);
++ val () = genMtlr(regZero, cvec);
++ val () = genInstruction(blrlQuad, cvec);
++ val () = fixup(skipTrap, cvec);
+
+- val U : unit = genCmp (r1, r2, cvec);
+- val U : unit = clearAllCaches cvec; (* If we've taken the trap LR won't be valid. *)
++ val () = genCmp (r1, r2, cvec);
++ val () = clearAllCaches cvec; (* If we've taken the trap LR won't be valid. *)
+ in
+ putConditional (test, cvec)
+ end
+@@ -3867,7 +3782,7 @@
+ case tc of
+ Short =>
+ let
+- val U : unit = genInstruction (andiDot (regTemp1, r, int16_1), cvec);
++ val () = genInstruction (andiDot (regTemp1, r, int16_1), cvec);
+ in
+ (* jump if the result is non-zero *)
+ putConditional (Ne, cvec)
+@@ -3875,7 +3790,7 @@
+
+ | Long =>
+ let
+- val U : unit = genInstruction (andiDot (regTemp1, r, int16_1), cvec);
++ val () = genInstruction (andiDot (regTemp1, r, int16_1), cvec);
+ in
+ (* jump if the result is zero *)
+ putConditional (Eq, cvec)
+@@ -3885,7 +3800,7 @@
+ let
+ val c : int = toInt (toShort cnstnt);
+ val ui : int16 = unsignedInt16 (tagged c);
+- val U : unit = genCmpli (r, ui, cvec); (* Word comparisons are unsigned. *)
++ val () = genCmpli (r, ui, cvec); (* Word comparisons are unsigned. *)
+ in
+ putConditional (test, cvec)
+ end
+@@ -3918,15 +3833,15 @@
+ means we take the trap which causes the RTS to emulate the
+ immediately following comparison.
+ *)
+- val U : unit = genInstruction (slwiDot (regTemp1, r, 31), cvec);
+- val U : unit = genTrapCacheFlush cvec;
++ val () = genInstruction (slwiDot (regTemp1, r, 31), cvec);
++ val () = genTrapCacheFlush cvec;
+ val skipTrap = putConditional (NeInv, cvec)
+- val U : unit = genLoad(MemRegisterArbEmulation, regMemRegs, regZero, cvec);
+- val U : unit = genMtlr(regZero, cvec);
+- val U : unit = genInstruction(blrlQuad, cvec);
+- val U : unit = fixup(skipTrap, cvec);
+- val U : unit = genCmpi (r, si, cvec);
+- val U : unit = clearAllCaches cvec; (* If we've taken the trap LR won't be valid. *)
++ val () = genLoad(MemRegisterArbEmulation, regMemRegs, regZero, cvec);
++ val () = genMtlr(regZero, cvec);
++ val () = genInstruction(blrlQuad, cvec);
++ val () = fixup(skipTrap, cvec);
++ val () = genCmpi (r, si, cvec);
++ val () = clearAllCaches cvec; (* If we've taken the trap LR won't be valid. *)
+ in
+ putConditional (test, cvec)
+ end
+@@ -3974,7 +3889,7 @@
+ (* General register/register operation. *)
+ fun genRR (instr : instrs, r1 : reg, r2 : reg, rd : reg, cvec : code) : unit =
+ let
+- val U : unit =
++ val () =
+ (*
+ We shouldn't do arithmetic on the stack pointer,
+ but we ought to check, just in case.
+@@ -3992,7 +3907,7 @@
+ | InstrAddA =>
+ let
+ (* Untag one of the arguments. *)
+- val U: unit = genAddImmed (regTemp2, r2, ~1, cvec)
++ val () = genAddImmed (regTemp2, r2, ~1, cvec)
+ val lab : addrs = genTagTest2 (r1, r2, cvec)
+ in
+ genAddoDot (rd, r1, regTemp2, cvec);
+@@ -4002,7 +3917,7 @@
+ | InstrSubA =>
+ let
+ (* Untag one of the arguments. *)
+- val U: unit = genAddImmed (regTemp2, r2, ~1, cvec)
++ val () = genAddImmed (regTemp2, r2, ~1, cvec)
+ val lab : addrs = genTagTest2 (r1, r2, cvec)
+ in
+ genSubfcoDot (rd, regTemp2, r1, cvec);
+@@ -4011,7 +3926,7 @@
+
+ | InstrRevSubA =>
+ let
+- val U: unit = genAddImmed (regTemp2, r1, ~1, cvec)
++ val () = genAddImmed (regTemp2, r1, ~1, cvec)
+ val lab : addrs = genTagTest2 (r1, r2, cvec);
+ in
+ genSubfcoDot (rd, regTemp2, r2, cvec);
+@@ -4021,7 +3936,7 @@
+ | InstrMulA =>
+ let
+ (* Remove the tag from one of the args. *)
+- val U: unit = genAddImmed (regTemp2, r2, ~1, cvec);
++ val () = genAddImmed (regTemp2, r2, ~1, cvec);
+ (* Now test the tags. *)
+ val lab : addrs = genTagTest2 (r1, r2, cvec)
+ in
+@@ -4073,7 +3988,7 @@
+ | InstrDivW =>
+ let
+ (* Test for zero. The addi instruction doesn't set the condition code. *)
+- val U: unit = genCmpi (r2, int16_1, cvec);
++ val () = genCmpi (r2, int16_1, cvec);
+ val skipException = putConditional(NeInv, cvec)
+ in
+ (* Raise the divide exception: lwz r0,48(r13); mtlr r0; blrl; *)
+@@ -4098,7 +4013,7 @@
+ use division, multiplication and subtraction. *)
+ let
+ (* Test for zero. The addi instruction doesn't set the condition code. *)
+- val U: unit = genCmpi (r2, int16_1, cvec);
++ val () = genCmpi (r2, int16_1, cvec);
+ val skipException = putConditional(NeInv, cvec)
+ in
+ (* Raise the divide exception: lwz r0,48(r13); mtlr r0; blrl; *)
+@@ -4126,7 +4041,7 @@
+
+ | InstrXorW =>
+ let
+- val U : unit = genXor (regTemp2, r1, r2, cvec)
++ val () = genXor (regTemp2, r1, r2, cvec)
+ in
+ (* restore tag bit *)
+ genInstructionList (orImmed (rd, regTemp2, 1), cvec)
+@@ -4232,7 +4147,7 @@
+ we have to tag the immediate value. *)
+ fun genRI (instr : instrs, rs : reg, constnt : machineWord, rd : reg, cvec) : unit =
+ let
+- val U : unit =
++ val () =
+ (*
+ We shouldn't do arithmetic on the stack pointer,
+ but we ought to check, just in case.
+@@ -4253,7 +4168,7 @@
+ | InstrAddA => (* Arbitrary precision addition. *)
+ let
+ val c = toInt (toShort constnt)
+- val U : unit = genLoadImmed (regTemp2, tagged c - 1, cvec);
++ val () = genLoadImmed (regTemp2, tagged c - 1, cvec);
+ val lab : addrs = genTagTest1 (rs, cvec);
+ in
+ genAddoDot (rd, rs, regTemp2, cvec);
+@@ -4263,7 +4178,7 @@
+ | InstrSubA => (* Arbitrary precision subtraction. *)
+ let
+ val c = toInt (toShort constnt)
+- val U : unit = genLoadImmed (regTemp2, tagged c - 1, cvec);
++ val () = genLoadImmed (regTemp2, tagged c - 1, cvec);
+ val lab : addrs = genTagTest1 (rs, cvec);
+ in
+ genSubfcoDot (rd, regTemp2, rs, cvec);
+@@ -4273,7 +4188,7 @@
+ | InstrRevSubA => (* Arbitrary precision reverse subtraction. *)
+ let
+ val c = toInt (toShort constnt)
+- val U : unit = genLoadImmed (regTemp2, tagged c + 1, cvec);
++ val () = genLoadImmed (regTemp2, tagged c + 1, cvec);
+ val lab : addrs = genTagTest1 (rs, cvec);
+ in
+ genSubfcoDot (rd, rs, regTemp2, cvec);
+@@ -4478,30 +4393,19 @@
+ while !ptr addrLt lastAddr do
+ let
+ val thisAddr : addrs = !ptr;
+- val U : unit = ptr := thisAddr wordAddrPlus 1;
++ val () = ptr := thisAddr wordAddrPlus 1;
+
+ val byteAddr : int = getByteAddr thisAddr;
+ val instr : int = fromQuad (getQuad (thisAddr, seg));
+- val U : unit = printHex(byteAddr, printStream); (* The address. *)
+- val U : unit = printStream "\t";
+- val U : unit = printHexN (8, instr, printStream); (* The naked instruction. *)
+- val U : unit = printStream "\t";
+- val U : unit = printInstr (byteAddr, instr, printStream); (* The decoded instruction. *)
++ val () = printHex(byteAddr, printStream); (* The address. *)
++ val () = printStream "\t";
++ val () = printHexN (8, instr, printStream); (* The naked instruction. *)
++ val () = printStream "\t";
++ val () = printInstr (byteAddr, instr, printStream); (* The decoded instruction. *)
+ in
+ printStream "\n"
+ end
+ end; (* printCode *)
+-
+- fun loadUnsigned (a : address, offset : int) : int =
+- let (* Power PC is a big-endian machine *)
+- val byteOffset : int = 4 * offset;
+- val b0 = Word.fromLargeWord(Word8.toLargeWord(loadByte (a, toShort byteOffset)));
+- val b1 = Word.fromLargeWord(Word8.toLargeWord(loadByte (a, toShort (byteOffset + 1))));
+- val b2 = Word.fromLargeWord(Word8.toLargeWord(loadByte (a, toShort (byteOffset + 2))));
+- val b3 = Word.fromLargeWord(Word8.toLargeWord(loadByte (a, toShort (byteOffset + 3))));
+- in
+- fromQuad (Quad (b0, b1, b2, b3))
+- end;
+
+ (* constLabels - fill in a constant in the code. *)
+ fun constLabels (Code{resultSeg=ref rseg, pcOffset=ref offset, ...},
+@@ -4562,7 +4466,6 @@
+ noClosure,
+ selfCalls = ref selfCalls,
+ selfJumps = ref selfJumps,
+- mustCheckStack = ref callsAProc,
+ numOfConsts,
+ ic,
+ constVec = ref constVec,
+@@ -4577,7 +4480,7 @@
+ val endIC = !ic; (* Remember end *)
+
+ (* Generate end-of-code marker *)
+- val UUU = genCodeQuad (toQuad 0, cvec); (* changes !ic *)
++ val () = genCodeQuad (toQuad 0, cvec); (* changes !ic *)
+
+ (*****************************************************************************
+ N.B. The calling sequence has been simplified since it's no longer necessary
+@@ -4698,9 +4601,6 @@
+ 1) moving or(lr,2) to regReturn
+ 2) stack checking code
+ *)
+-
+- (* size of the segment in bytes *)
+- val byteSegSize : int = segSize * 4;
+
+ val preludeCode =
+ (* L1, L2 here *)
+@@ -4724,25 +4624,25 @@
+ end; (* local *)
+
+ (* fix-up all the self-calls *)
+- val U : unit = fixupRecursiveCalls (L3Addr, selfCalls, cvec);
+- val U : unit = fixupRecursiveBranches (L4Addr, selfJumps, cvec);
++ val () = fixupRecursiveCalls (L3Addr, selfCalls, cvec);
++ val () = fixupRecursiveBranches (L4Addr, selfJumps, cvec);
+
+ (* Now make the byte segment that we'll turn into the code segment *)
+ val seg : cseg = csegMake segSize;
+ val offset = spaceForPrelude;
+
+- val U : unit = resultSeg := Set seg;
++ val () = resultSeg := Set seg;
+
+ (* Copy the code into the new segment. *)
+- val U : unit = pcOffset := offset;
+- val U : unit = csegCopySeg (codeVec, seg, getByteAddr (! ic), offset);
++ val () = pcOffset := offset;
++ val () = csegCopySeg (codeVec, seg, getByteAddr (! ic), offset);
+
+ (* insert prelude code into segment *)
+ local
+ fun putPreludeQuad (wordAddr : int, w : quad) =
+ setQuad (w, mkWordAddr wordAddr, seg);
+ in
+- val U : unit = applyCountList (putPreludeQuad, 0, preludeCode);
++ val () = applyCountList (putPreludeQuad, 0, preludeCode);
+ end;
+
+ local
+@@ -4753,7 +4653,7 @@
+ val quad = toQuad (getByteAddr endOfCode);
+ val addr = endOfCode;
+ in
+- val U : unit = setQuad (quad, addr, seg)
++ val () = setQuad (quad, addr, seg)
+ end;
+
+ (* Put in the number of constants. This must go in before
+@@ -4762,7 +4662,7 @@
+ val quad = toQuad 2; (* Just two constants now. *)
+ val addr = endOfCode wordAddrPlus 4;
+ in
+- val U : unit = setQuad (quad, addr, seg)
++ val () = setQuad (quad, addr, seg)
+ end;
+
+ (* Next the profile count. *)
+@@ -4770,14 +4670,14 @@
+ val quad = toQuad 0;
+ val addr = endOfCode wordAddrPlus 1;
+ in
+- val U : unit = setQuad (quad, addr, seg)
++ val () = setQuad (quad, addr, seg)
+ end;
+
+ (* Now we've filled in all the C integers; now we need to convert the segment
+ into a proper code segment before it's safe to put in any ML values.
+ SPF 13/2/97
+ *)
+- val U : unit = csegConvertToCode seg;
++ val () = csegConvertToCode seg;
+
+ local
+ (* why do we treat the empty string as a special case? SPF 15/7/94 *)
+@@ -4787,7 +4687,7 @@
+ val nameWord : machineWord = if name = "" then toMachineWord 0 else toMachineWord name;
+ val addr : addrs = endOfCode wordAddrPlus 2;
+ in
+- val U : unit = csegPutWord (seg, getWordAddr addr, nameWord)
++ val () = csegPutWord (seg, getWordAddr addr, nameWord)
+ end
+ local
+ (* Encode the register mask. This encoding must be the same
+@@ -4802,7 +4702,7 @@
+ end
+ val regSet = List.foldl encodeReg 0w0 registerSet
+ in
+- val U : unit = csegPutWord (seg,
++ val () = csegPutWord (seg,
+ getWordAddr(endOfCode wordAddrPlus 3), toMachineWord regSet);
+ end;
+ end; (* scope of endofcode *)
+@@ -4836,7 +4736,7 @@
+
+ (* Switch off "mutable" bit now if we have no
+ forward or recursive references to fix-up *)
+- val U : unit =
++ val () =
+ if ! numOfConsts = 0 then csegLock seg else ();
+
+ (* Do we need to make a closure, or just return the code? *)
+@@ -4851,7 +4751,7 @@
+ way and I'm not completely sure that everything that needs a mutable
+ allocation actually asks for it yet. SPF 19/2/97
+ *)
+- val U : unit = lock addr;
++ val () = lock addr;
+ in
+ addr
+ end
+@@ -4859,9 +4759,9 @@
+ (* Now we know the address of this object we can fix up
+ any forward references outstanding. This is put in here
+ because there may be directly recursive references. *)
+- val U : unit = fixOtherRefs (cvec, toMachineWord addr);
++ val () = fixOtherRefs (cvec, toMachineWord addr);
+
+- val U : unit =
++ val () =
+ if printAssemblyCode
+ then let (* print out the code *)
+ (* endcode is the address of the end-of-code marker word. *)
+@@ -4896,13 +4796,13 @@
+
+ fun constrCases (i, a) : cases = {tag = i, addr = a}
+
+- fun useIndexedCase (min, max, numberOfCases, exhaustive) : bool =
++ fun useIndexedCase _ : bool =
+ false; (* Never use indexed case. *)
+
+- fun indexedCase (reg, reg2, min, max, exhaustive, cvec) : jumpTableAddrs =
++ fun indexedCase _ : jumpTableAddrs =
+ raise InternalError "Not implemented: indexedCase";
+
+- fun makeJumpTable (startTab, cl, default, min, max, cvec) : unit =
++ fun makeJumpTable _ : unit =
+ raise InternalError "Not implemented: makeJumpTable";
+
+ fun codeAddress (cvec: code) : address option =
+diff -u -r mlsource/MLCompiler/CodeTree/SPARCCODECONS.ML mlsource/MLCompiler/CodeTree/SPARCCODECONS.ML
+--- mlsource/MLCompiler/CodeTree/SPARCCODECONS.ML 2008-04-21 13:30:52.000000000 +0200
++++ mlsource/MLCompiler/CodeTree/SPARCCODECONS.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -342,10 +342,10 @@
+
+ val toInt = Word.toIntX (* This previously just cast the value so continue to treat it as signed. *)
+
+- fun applyCountList (f, n, []) = ()
++ fun applyCountList (_, _, []) = ()
+ | applyCountList (f, n, h::t) =
+ let
+- val U : unit = f (n, h);
++ val () = f (n, h);
+ in
+ applyCountList (f, n + 1, t)
+ end;
+@@ -380,7 +380,7 @@
+ fun exp2 0 = 1
+ | exp2 n = 2 * exp2 (n - 1);
+ in
+- val U : bool =
++ val _ : bool =
+ (
+ exp2_2 = exp2 2 andalso
+ exp2_3 = exp2 3 andalso
+@@ -420,7 +420,6 @@
+ val TAGMASK = 3;
+ val DATATAG = 1;
+ val CODETAG = 2;
+- val FLAGLENGTH = 8; (* There are 8 flag bits in the length word *)
+
+ (* tag a short constant *)
+ fun semiTagged c = exp2_2 * c;
+@@ -442,35 +441,35 @@
+ val g6 = Reg 6;
+ val g7 = Reg 7;
+ val o0 = Reg 8;
+- val o1 = Reg 9;
++(* val o1 = Reg 9;
+ val o2 = Reg 10;
+ val o3 = Reg 11;
+- val o4 = Reg 12;
++ val o4 = Reg 12; *)
+ val o5 = Reg 13;
+- val o6 = Reg 14;
++(* val o6 = Reg 14; *)
+ val o7 = Reg 15;
+ val l0 = Reg 16;
+- val l1 = Reg 17;
++(* val l1 = Reg 17;
+ val l2 = Reg 18;
+ val l3 = Reg 19;
+ val l4 = Reg 20;
+ val l5 = Reg 21;
+- val l6 = Reg 22;
++ val l6 = Reg 22; *)
+ val l7 = Reg 23;
+ val i0 = Reg 24;
+- val i1 = Reg 25;
++(* val i1 = Reg 25; *)
+ val i2 = Reg 26;
+ val i3 = Reg 27;
+ val i4 = Reg 28;
+ val i5 = Reg 29;
+- val i6 = Reg 30;
+- val i7 = Reg 31;
++(* val i6 = Reg 30;
++ val i7 = Reg 31;*)
+
+ val psp = g4;
+ val phr = g3;
+ val regResult = o0;
+ val regClosure = o5;
+- val regCode = NONE;
++(* val regCode = NONE;*)
+ val regStackPtr = g4;
+ val regHandler = g3;
+ val regReturn = o7;
+@@ -649,7 +648,6 @@
+ fun selfJumps (Code {selfJumps,...}) = selfJumps;
+ fun accCache (Code {accCache,...}) = accCache;
+ fun noClosure (Code {noClosure,...}) = noClosure;
+- fun constLoads (Code {constLoads,...}) = constLoads;
+
+ fun unreachable cvec =
+ case ! (justComeFrom cvec) of
+@@ -669,11 +667,6 @@
+ the resultSeg ref is the same. N.B. NOT its contents. *)
+ infix is;
+ fun a is b = (resultSeg a = resultSeg b);
+-
+- fun sameConst (WVal w1, WVal w2) = wordEq (w1, w2)
+- | sameConst (HVal h1, HVal h2) = h1 = h2
+- | sameConst (CVal c1, CVal c2) = c1 is c2
+- | sameConst (_, _) = false;
+
+ (* create and initialise a code segment *)
+ fun codeCreate (noClosure, name, parameters) : code =
+@@ -769,7 +762,6 @@
+ setQuad (instr, addr, seg)
+ end;
+
+- fun isSet (Set _) = true | isSet _ = false
+ fun scSet (Set x) = x | scSet _ = raise Match;
+
+ (* Test condition codes. *)
+@@ -792,7 +784,6 @@
+ val gu = Test 12; (* high *)
+ val cc = Test 13; (* carry clear *)
+ val pos = Test 14; (* plus *)
+- val vc = Test 15; (* no overflow *)
+
+ fun tstRepr tst =
+ if tst = never then "n"
+@@ -829,17 +820,11 @@
+ (* add "tag" bit *)
+ v + exp2_13
+ end;
+-
+- fun isRegister (Register r) = true
+- | isRegister (Imm13 i) = false;
+-
+- fun isImm13 (Register r) = false
+- | isImm13 (Imm13 i) = true;
+
+- fun getRegister (Register r) = r
+- | getRegister (Imm13 i) = raise InternalError "getRegister";
++ fun isImm13 (Register _) = false
++ | isImm13 (Imm13 _) = true;
+
+- fun getImm13 (Register r) = raise InternalError "getImm13"
++ fun getImm13 (Register _) = raise InternalError "getImm13"
+ | getImm13 (Imm13 i) = i;
+
+ fun eqMode13 (Register x) (Register y) = (x regEq y)
+@@ -873,7 +858,6 @@
+ end;
+
+ (* These are provided for convenience. *)
+- val o5M = mReg o5;
+ val i3M = mReg i3;
+ val i4M = mReg i4;
+ val i5M = mReg i5;
+@@ -905,8 +889,6 @@
+ result is (should be) >= exp2_29 i.e. it's not a 30-bit short.
+ SPF 19/12/95
+ *)
+- fun getMode30 (Imm30 i) = (* remove sign *)
+- if i < 0 then exp2_30 + i else i;
+
+ (* But we can work round this by returning a
+ (signed) short. SPF 19/12/95
+@@ -1375,12 +1357,12 @@
+ deferred the branch is assumed to have happened first. *)
+
+ (* Fix up the list of labels. *)
+- fun reallyFixupBranches (cvec, target, []) = ()
++ fun reallyFixupBranches (_, _, []) = ()
+ | reallyFixupBranches (cvec, target, addrH :: addrT) =
+ let
+ val wordDiff : int = target wordAddrMinus addrH;
+ val jumpInstr = getCodeQuad (addrH, cvec);
+- val U : unit =
++ val () =
+ if not (is22Bit wordDiff) (* 22 bit signed number *)
+ then raise InternalError "reallyFixupBranches: jump too large"
+ else (* Set this addr to point to the destination. *)
+@@ -1389,7 +1371,7 @@
+ reallyFixupBranches (cvec, target, addrT)
+ end;
+
+- fun fixupRecursiveBranches (cvec, targetInstr, target, []) = ()
++ fun fixupRecursiveBranches (_, _, _, []) = ()
+ | fixupRecursiveBranches (cvec, targetInstr, target, addrH :: addrT) =
+ let
+ val nextAddr : addrs = addrH wordAddrPlus 1;
+@@ -1411,7 +1393,7 @@
+ if not (is22Bit wordDiff)
+ then raise InternalError "fixupRecursiveBranches: jump too large"
+ else let
+- val U : unit =
++ val () =
+ setCodeQuad (fixupBranch (jumpInstr, immed22 wordDiff), addrH, cvec);
+ in
+ setCodeQuad (targetInstr, nextAddr, cvec)
+@@ -1421,7 +1403,7 @@
+ fixupRecursiveBranches (cvec, targetInstr, target, addrT)
+ end;
+
+- fun fixupRecursiveCalls (cvec, targetInstr, target, []) = ()
++ fun fixupRecursiveCalls (_, _, _, []) = ()
+ | fixupRecursiveCalls (cvec, targetInstr, target, addrH :: addrT) =
+ let
+ val nextAddr : addrs = addrH wordAddrPlus 1;
+@@ -1445,7 +1427,7 @@
+ if not (is30Bit wordDiff)
+ then raise InternalError "fixupRecursiveCalls: jump too large"
+ else let
+- val U : unit =
++ val () =
+ setCodeQuad (callQuad (immed30 wordDiff), addrH, cvec);
+ in
+ setCodeQuad (targetInstr, nextAddr, cvec)
+@@ -1479,7 +1461,7 @@
+ if getCodeQuad (addr wordAddrPlus 1, cvec) = nopQuad
+ then let
+ (* Put the instruction in the delay slot *)
+- val U : unit = setCodeQuad (instr, addr wordAddrPlus 1, cvec);
++ val () = setCodeQuad (instr, addr wordAddrPlus 1, cvec);
+ in
+ (* Keep this label in the list for the next instruction. *)
+ addr :: fillDelays addrs
+@@ -1487,13 +1469,13 @@
+ else let (* Fix this up here. *) (* genLoadConstant? SPF *)
+ val wordDiff : int = ! (ic cvec) wordAddrMinus addr;
+ val jumpInstr = getCodeQuad (addr, cvec);
+- val U : unit =
++ val () =
+ if not (is22Bit wordDiff) (* 22 bit signed number *)
+ then raise InternalError "genInstruction: jump too large"
+ else (* Set this addr to point to the destination. *)
+ setCodeQuad (fixupBranch (jumpInstr, immed22 wordDiff), addr, cvec);
+ (* Must generate the instruction. *)
+- val U : unit = exited cvec := false;
++ val () = exited cvec := false;
+ in
+ fillDelays addrs
+ end;
+@@ -1508,7 +1490,7 @@
+ if not (! (exited cvec)) then genCodeQuad (instr, cvec) else ()
+ end (* genInstruction *);
+
+- fun genInstructionList (cvec, []) = ()
++ fun genInstructionList (_, []) = ()
+ | genInstructionList (cvec, w::ws) =
+ (genInstruction (w, cvec); genInstructionList (cvec, ws));
+
+@@ -1522,11 +1504,6 @@
+ Empty => false
+ | Copy r => r regEq reg
+
+- fun cacheEmpty cvec =
+- case !(accCache cvec) of
+- Empty => true
+- | _ => false;
+-
+ fun genUntagInstr (reg, cvec) =
+ genInstruction (format3_2 (SUB, reg, immed13_DATATAG, i4), cvec);
+
+@@ -1627,7 +1604,7 @@
+ fun putPendingInDelay (cvec : code) : quad = (* returns instruction to put in delay slot *)
+ let
+ (* Must take a jump here if it is pending. Can't put a jump in a delay slot. *)
+- val U = reallyFixup cvec;
++ val () = reallyFixup cvec;
+ (* justComeFrom cvec = [] *)
+
+ val reset = ! (stackReset cvec) * wordSize;
+@@ -1635,8 +1612,8 @@
+ if reset = 0 then nopQuad (* nothing useful to do *)
+ else let
+ val (cl,imm) = immedCodeOffset reset;
+- val U : unit = genInstructionList (cvec, cl);
+- val U : unit = stackReset cvec := 0;
++ val () = genInstructionList (cvec, cl);
++ val () = stackReset cvec := 0;
+ in
+ format3_2 (ADD, psp, imm, psp)
+ end
+@@ -1671,18 +1648,18 @@
+ val delayQuad = getCodeQuad (addr wordAddrPlus 1, cvec);
+
+ (* skip back two instructions *)
+- val U : unit = ic cvec := addr;
++ val () = ic cvec := addr;
+
+ (* put the delay slot back into the instruction flow,
+ using genCodeQuad not genInstruction to avoid
+ prematurely fixing up any jumps. *)
+- val U : unit =
++ val () =
+ if delayQuad <> nopQuad
+ then genCodeQuad (delayQuad, cvec)
+ else ();
+
+ (* We're now falling-through (rather than jumping) *)
+- val U : unit = exited cvec := false;
++ val () = exited cvec := false;
+ in
+ addrs
+ end
+@@ -1755,7 +1732,7 @@
+ (* Generates an unconditional call. *)
+ fun genCall (cvec : code) =
+ let
+- val U : unit = clearCache cvec; (* end of basic block *)
++ val () = clearCache cvec; (* end of basic block *)
+ val delayQuad = putPendingInDelay cvec; (* may generate code *)
+ in
+ genInstruction (call0, cvec);
+@@ -1766,7 +1743,7 @@
+ fun putConditional (test : testCode, cvec : code) : labels =
+ if unreachable cvec then [] (* SPF 5/6/95 *)
+ else let
+- val U : unit = clearCache cvec; (* end of basic block *)
++ val () = clearCache cvec; (* end of basic block *)
+ val delayQuad = putPendingInDelay cvec; (* may generate code *)
+
+ (* If we have a pending instruction we put it in the delay slot
+@@ -1789,12 +1766,12 @@
+ of the operands? Let's check! SPF 16/5/95 *)
+ fun type2 (c2 : op3_2) (r : reg, m : mode13, rd : reg, cvec : code) : unit =
+ let
+- val U : unit =
++ val () =
+ if cached (rd, cvec)
+ then clearCache cvec
+ else ();
+
+- val U : unit =
++ val () =
+ if r regEq psp orelse
+ rd regEq psp orelse
+ eqMode13 m pspM
+@@ -1844,7 +1821,7 @@
+ in
+ if is13Bit adj
+ then let
+- val U : unit =
++ val () =
+ if cached (dest, cvec) then clearCache cvec else ();
+ in
+ genInstruction (format3_2 (ADD, psp, immed13 adj, dest), cvec)
+@@ -1906,7 +1883,7 @@
+
+ fun genLoadImmed (v : int, rd : reg, cvec : code) : unit =
+ let
+- val U : unit =
++ val () =
+ if cached (rd, cvec)
+ then clearCache cvec
+ else ();
+@@ -1914,7 +1891,7 @@
+ (* We shouldn't load immediates into psp, but if we try to,
+ we have to ensure that it won't be corrupted by a
+ subsequent stack adjustment. SPF 16/5/95 *)
+- val U : unit =
++ val () =
+ if rd regEq psp
+ then doPendingStackAdjustment cvec
+ else ();
+@@ -1947,7 +1924,7 @@
+ (* We should have 0 <= flags < exp2_8; 0 < wordCount < exp2_24 *)
+ fun genLoadLengthWordImmed (flags:int, wordCount:int, rd : reg, cvec) : unit =
+ let
+- val U : unit =
++ val () =
+ if cached (rd, cvec)
+ then clearCache cvec
+ else ();
+@@ -1955,7 +1932,7 @@
+ (* We shouldn't load immediates into psp, but if we try to,
+ we have to ensure that it won't be corrupted by a
+ subsequent stack adjustment. SPF 16/5/95 *)
+- val U : unit =
++ val () =
+ if rd regEq psp
+ then doPendingStackAdjustment cvec
+ else ();
+@@ -1978,13 +1955,13 @@
+
+ fun genLoadInstr (iop : op3_3) (rb : reg, m : mode13, rd : reg, cvec : code) : unit =
+ let
+- val U : unit =
++ val () =
+ if cached (rd, cvec)
+ then clearCache cvec
+ else ();
+
+ (* Do we need to fix-up the stack pointer? *)
+- val U : unit =
++ val () =
+ if rd regEq psp orelse
+ rb regEq psp orelse
+ eqMode13 m pspM
+@@ -1996,13 +1973,13 @@
+
+ fun genLoad (offset : int, rb : reg, rd : reg, cvec : code) : unit =
+ let
+- val U : unit =
++ val () =
+ if cached (rd, cvec)
+ then clearCache cvec
+ else ();
+
+ (* Do we need to fix-up the stack pointer? *)
+- val U : unit =
++ val () =
+ if rd regEq psp
+ then doPendingStackAdjustment cvec
+ else ();
+@@ -2023,7 +2000,7 @@
+ fun genStoreOp iop (rd : reg, offset : int, rb : reg, cvec : code) : unit =
+ let
+ (* Do we need to fix-up the stack pointer? Yes, if that's the register we're storing. *)
+- val U : unit =
++ val () =
+ if rd regEq psp
+ then doPendingStackAdjustment cvec
+ else ();
+@@ -2088,9 +2065,9 @@
+ value and it will definitely be better to do this by loading the untagged
+ value directly into the register. This is very infrequent though, so for
+ the moment we don't do it. *)
+- fun isStoreI (cnstnt: machineWord, _, _) : bool = false;
++ fun isStoreI _ : bool = false;
+
+- fun genStoreI (cnstnt: machineWord, offset: int, rb: reg, width, index: reg, cvec: code) : unit =
++ fun genStoreI _ : unit =
+ raise InternalError "Not implemented: genStoreI";
+
+ (* Store a value on the stack. This is used when the registers need to be
+@@ -2098,12 +2075,12 @@
+ fun genPush (r : reg, cvec : code) : unit =
+ let
+ (* If the adjusted byte-offset won't fit into 13 bits, flush the stack reset. *)
+- val U : unit =
++ val () =
+ if is13Bit (4 * (!(stackReset cvec) - 1)) then ()
+ else doPendingStackAdjustment cvec;
+
+ (* generate the store *)
+- val U : unit = genStoreWord (r, ~4, psp, cvec)
++ val () = genStoreWord (r, ~4, psp, cvec)
+ in
+ (* Finally adjust the stack reset (rather than adjusting the stack pointer itself). *)
+ stackReset cvec := !(stackReset cvec) - 1
+@@ -2114,7 +2091,7 @@
+ (* Use i5 as a spare register. *)
+ fun genLoadPush (offset : int, base : reg, cvec : code) : unit =
+ let
+- val U : unit = genLoad (offset, base, i5, cvec);
++ val () = genLoad (offset, base, i5, cvec);
+ in
+ genPush (i5, cvec)
+ end;
+@@ -2125,7 +2102,7 @@
+
+ fun genJmpl (m : mode13, breg : reg, lreg : reg, cvec : code) : unit =
+ let
+- val U : unit = clearCache cvec; (* end of basic block *)
++ val () = clearCache cvec; (* end of basic block *)
+ val delayQuad = putPendingInDelay cvec; (* may generate code *)
+ in
+ (* jmpl breg+m,lreg *)
+@@ -2139,7 +2116,7 @@
+ (* Make a reference to another procedure. Usually this will be a forward *)
+ (* reference but it may have been compiled already, in which case we can *)
+ (* put the code address in now. *)
+- fun codeConst (Code {resultSeg = ref(Set(seg, _)), ... }, into) =
++ fun codeConst (Code {resultSeg = ref(Set(seg, _)), ... }, _) =
+ (* Already done. *) WVal (toMachineWord(csegAddr seg))
+ | codeConst (r, into) = (* forward *)
+ (* Add the referring procedure onto the list of the procedure
+@@ -2147,7 +2124,7 @@
+ the referring procedure is finished and its address is known the
+ address will be plugged in to every procedure which needs it. *)
+ let
+- fun onList x [] = false
++ fun onList _ [] = false
+ | onList x (c::cs) = (x is c) orelse onList x cs;
+
+ val codeList = ! (otherCodes r);
+@@ -2307,7 +2284,7 @@
+ (* Mustn't add to selfJumps list unless we're actually generating code! *)
+ if unreachable cvec then ()
+ else let
+- val U : unit =
++ val () =
+ (* Put return address in the correct register. *)
+ if returnReg regEq regReturn then ()
+ else genMove (mReg returnReg, regReturn, cvec);
+@@ -2315,7 +2292,7 @@
+ case callKind of
+ Recursive =>
+ let
+- val U : unit = mustCheckStack cvec := true;
++ val () = mustCheckStack cvec := true;
+ val lab = unconditionalBranch cvec;
+ in
+ selfJumps cvec := lab @ !(selfJumps cvec)
+@@ -2465,7 +2442,7 @@
+ end
+
+ (* Don't need to do anything on the Sparc. *)
+- val completeSegment = (fn (cvec : code) => ());
++ val completeSegment = (fn (_ : code) => ());
+
+ datatype instrs =
+ instrMove
+@@ -2648,8 +2625,8 @@
+ case tc of
+ Short => false
+ | Long => false
+- | Wrd t => true
+- | Arb t => true;
++ | Wrd _ => true
++ | Arb _ => true;
+
+ (* Is this argument acceptable as an immediate or should it be *)
+ (* loaded into a register? *)
+@@ -3076,17 +3053,17 @@
+ while !ptr addrLt lastAddr do
+ let
+ val thisAddr : addrs = !ptr;
+- val U : unit = ptr := thisAddr wordAddrPlus 1;
++ val () = ptr := thisAddr wordAddrPlus 1;
+ val instr : int = fromQuad (getQuad (thisAddr, seg));
+
+ val byteAddr : int = getByteAddr thisAddr;
+ val topByte : int = Word8.toInt (csegGet (seg, byteAddr));
+ val format : int = topByte div exp2_6;
+
+- val U : unit = printHex byteAddr; (* The real address. *)
+- val U : unit = printStream "\t";
++ val () = printHex byteAddr; (* The real address. *)
++ val () = printStream "\t";
+
+- val U : unit =
++ val () =
+ if format = 0
+ then let
+ val op2 = (instr div exp2_22) mod 8; (* op2 field *)
+@@ -3160,7 +3137,7 @@
+ (JMPL,"jmpl")
+ ]
+
+- fun printFromTable x [] = printHex op3
++ fun printFromTable _ [] = printHex op3
+ | printFromTable x ((y,s)::t) =
+ if x = op3_2ToInt y then printStream s else printFromTable op3 t
+
+@@ -3227,29 +3204,6 @@
+ end (* while *)
+ end (* scope of ptr *)
+ end (* printCode *);
+-
+- fun loadUnsigned (a : address, offset : int) : int =
+- let (* SPARC is a big-endian machine *)
+- val byteOffset : int = 4 * offset;
+- val b0 : short = Word.fromLargeWord(Word8.toLargeWord(loadByte (a, toShort byteOffset)));
+- val b1 : short = Word.fromLargeWord(Word8.toLargeWord(loadByte (a, toShort (byteOffset + 1))));
+- val b2 : short = Word.fromLargeWord(Word8.toLargeWord(loadByte (a, toShort (byteOffset + 2))));
+- val b3 : short = Word.fromLargeWord(Word8.toLargeWord(loadByte (a, toShort (byteOffset + 3))));
+- in
+- fromQuad (Quad (b0, b1, b2, b3))
+- end;
+-
+- (* Bootstrapping problems currently prevent us from using Address.nameOfCode *)
+- fun nameOfCode (a : address) : string =
+- let
+- val objLength : int = toInt (ADDRESS.length a);
+- val lastWord : int = objLength - 1;
+- val constCount : int = loadUnsigned (a, lastWord);
+- val codeName : machineWord = loadWord (a, toShort (lastWord - constCount));
+- in
+- unsafeCast codeName
+- end;
+-
+
+ (* set the num'th constant in cvec to be value *)
+ fun constLabels (cvec : code, addr: addrs, value : machineWord) : unit =
+@@ -3436,13 +3390,13 @@
+ val L4Addr = mkWordAddr (~ (List.length stackCheckCode));
+ val L4Target =
+ case stackCheckCode of
+- (c::cs) => c (* never a jump *)
++ (c::_) => c (* never a jump *)
+ | [] => nopQuad (* should never get used *)
+
+ val L3Addr = mkWordAddr (~ (lengthO7Code + List.length stackCheckCode));
+ val L3Target =
+ case o7Code of
+- (c::cs) => c (* never a jump *)
++ (c::_) => c (* never a jump *)
+ | [] => L4Target; (* shouldn't occur *)
+ end; (* local *)
+
+@@ -3454,24 +3408,24 @@
+ val constStartAddr : addrs = lastAddr wordAddrPlus 3;
+
+ (* fix-up all the self-calls *)
+- val U : unit =
++ val () =
+ fixupRecursiveCalls (cvec, L3Target, L3Addr, !(selfCalls cvec));
+
+- val U : unit =
++ val () =
+ fixupRecursiveBranches (cvec, L4Target, L4Addr, !(selfJumps cvec));
+
+ (* Now make the byte segment that we'll turn into the code segment *)
+ val seg : cseg = csegMake segSize;
+
+ (* Copy the code into the new segment. *)
+- val U : unit = csegCopySeg (codeVec cvec, seg, getByteAddr endIC, spaceForPrelude);
++ val () = csegCopySeg (codeVec cvec, seg, getByteAddr endIC, spaceForPrelude);
+
+ (* insert prelude code into segment *)
+ local
+ fun putPreludeQuad (wordAddr : int, w : quad) =
+ setQuad (w, mkWordAddr wordAddr, seg);
+ in
+- val U : unit = applyCountList (putPreludeQuad, 0, preludeCode);
++ val () = applyCountList (putPreludeQuad, 0, preludeCode);
+ end;
+
+ (* Zero end-of-code marker *)
+@@ -3479,7 +3433,7 @@
+ val addr : addrs = lastAddr;
+ val quad : quad = toQuad 0;
+ in
+- val U : unit = setQuad (quad, addr, seg)
++ val () = setQuad (quad, addr, seg)
+ end;
+
+ (* Byte offset of start of code. *)
+@@ -3487,7 +3441,7 @@
+ val addr : addrs = lastAddr wordAddrPlus 1;
+ val quad : quad = toQuad (getByteAddr addr);
+ in
+- val U : unit = setQuad (quad, addr, seg)
++ val () = setQuad (quad, addr, seg)
+ end;
+
+ (* Next the profile count. *)
+@@ -3495,7 +3449,7 @@
+ val addr : addrs = lastAddr wordAddrPlus 2;
+ val quad : quad = toQuad 0;
+ in
+- val U : unit = setQuad (quad, addr, seg)
++ val () = setQuad (quad, addr, seg)
+ end;
+
+ (* Put in the number of constants (including the name string). This
+@@ -3504,15 +3458,15 @@
+ val addr : addrs = constStartAddr wordAddrPlus 2;
+ val quad : quad = toQuad 2;
+ in
+- val U : unit = setQuad (quad, addr, seg)
++ val () = setQuad (quad, addr, seg)
+ end;
+
+ (* Now we've filled in all the C integers; now we need to convert the segment
+ into a proper code segment before it's safe to put in any ML values.
+ SPF 13/2/97
+ *)
+- val U : unit = csegConvertToCode seg;
+- val U : unit = resultSeg cvec := Set (seg, spaceForPrelude);
++ val () = csegConvertToCode seg;
++ val () = resultSeg cvec := Set (seg, spaceForPrelude);
+
+ local
+ val procName = procName cvec
+@@ -3560,14 +3514,14 @@
+
+ (* forward-reference - fix up later when we compile
+ the referenced code *)
+- | putLocalConst (CVal _, addr) = ();
++ | putLocalConst (CVal _, _) = ();
+
+- val U : unit = List.app putLocalConst (! (constVec cvec));
++ val () = List.app putLocalConst (! (constVec cvec));
+
+
+ (* Switch off "mutable" bit now if we have no
+ forward or recursive references to fix-up *)
+- val U : unit =
++ val () =
+ if !(numOfConsts cvec) = 0
+ then csegLock seg
+ else ();
+@@ -3584,7 +3538,7 @@
+ way and I'm not completely sure that everything that needs a mutable
+ allocation actually asks for it yet. SPF 19/2/97
+ *)
+- val U : unit = lock addr;
++ val () = lock addr;
+ in
+ addr
+ end
+@@ -3592,12 +3546,12 @@
+ (* Now we know the address of this object we can fix up
+ any forward references outstanding. This is put in here
+ because there may be directly recursive references. *)
+- val U : unit = fixOtherRefs (cvec, toMachineWord addr);
++ val () = fixOtherRefs (cvec, toMachineWord addr);
+
+- val U : unit =
++ val () =
+ if printAssemblyCode
+ then let (* print out the code *)
+- val U : unit = printCode (seg, procName cvec, lastAddr, printStream);
++ val () = printCode (seg, procName cvec, lastAddr, printStream);
+ in
+ printStream "\n"
+ end
+@@ -3608,7 +3562,6 @@
+
+ (* We need these types although we don't generate indexed cases. *)
+ type cases = int * addrs; (* should tag be a short??? *)
+- fun constrCases (p as (i,a)) = p;
+
+ (* Dummy implementation ...
+ type jumpTableAddrs = unit;
+@@ -3634,11 +3587,11 @@
+ *)
+ type jumpTableAddrs = addrs;
+
+- fun constrCases (p as (i,a)) = p;
++ fun constrCases p = p;
+
+ type caseList = cases list;
+
+- fun useIndexedCase (min:int, max:int, numberOfCases:int, exhaustive:bool) =
++ fun useIndexedCase (min:int, max:int, numberOfCases:int, _:bool) =
+ isShort min andalso
+ isShort max andalso
+ numberOfCases > 7 andalso
+@@ -3682,32 +3635,31 @@
+ CODETAG. No scaling is required - lucky!
+ *)
+ val adjust : mode13 = genImmedData (cvec, ~ (tagged min + CODETAG));
+- val U : unit = genAdd (valReg, adjust, i5, cvec);
++ val () = genAdd (valReg, adjust, i5, cvec);
+
+ (* i5 now contains the index into the jumptable *)
+
+- val U : unit = genLoadInstr LD (workReg, i5M, i5, cvec);
++ val () = genLoadInstr LD (workReg, i5M, i5, cvec);
+
+ (* i5 now contains the distance between the jumptable and our destination,
+ (adjusted for the +2 offset).
+ *)
+- val U : unit = genJmpl (i5M, workReg, g0, cvec);
++ val () = genJmpl (i5M, workReg, g0, cvec);
+
+- val U : unit = fixupHandler (tableBase, cvec);
++ val () = fixupHandler (tableBase, cvec);
+
+ (* We generate the table itself here *)
+ val tableBase : addrs = ! (ic cvec);
+ val tableWords : int = max - min + 1;
+- val tableBytes : int = tableWords * wordSize;
+- val U : unit = ic cvec := tableBase wordAddrPlus tableWords;
++ val () = ic cvec := tableBase wordAddrPlus tableWords;
+
+ (* ...
+ (* We haven't really fallen through to here. *)
+- val U : unit = exited cvec := true;
++ val () = exited cvec := true;
+ ... *)
+
+ (* The default case comes in here. *)
+- val U : unit = fixup (rangeCheck, cvec);
++ val () = fixup (rangeCheck, cvec);
+ in
+ (* Return the address of the jumptable *)
+ tableBase : jumpTableAddrs
+diff -u -r mlsource/MLCompiler/CodeTree/StructureEquality.sml mlsource/MLCompiler/CodeTree/StructureEquality.sml
+--- mlsource/MLCompiler/CodeTree/StructureEquality.sml 2008-03-25 11:53:13.000000000 +0100
++++ mlsource/MLCompiler/CodeTree/StructureEquality.sml 2009-09-15 08:56:46.000000000 +0200
+@@ -58,7 +58,6 @@
+ let
+ (* we promise to be very careful! *)
+ val toAddress : 'a -> address = unsafeCast;
+- val toShort : 'a -> short = unsafeCast;
+
+ (* Both addresses *)
+ val aa : address = toAddress a;
+diff -u -r mlsource/MLCompiler/CodeTree/TRANS_TAB.ML mlsource/MLCompiler/CodeTree/TRANS_TAB.ML
+--- mlsource/MLCompiler/CodeTree/TRANS_TAB.ML 2008-04-21 13:30:52.000000000 +0200
++++ mlsource/MLCompiler/CodeTree/TRANS_TAB.ML 2009-09-15 08:56:45.000000000 +0200
+@@ -127,11 +127,12 @@
+ sig
+ (* Produce debugging output. *)
+ val pstackTraceTag : bool Universal.tag
+- val compilerOutputTag: (string->unit) Universal.tag
+ val getParameter :
+ 'a Universal.tag -> Universal.universal list -> 'a
+ end;
+
++structure PRETTY: PRETTYSIG
++
+ (*****************************************************************************)
+ (* MISC *)
+ (*****************************************************************************)
+@@ -399,9 +400,6 @@
+ else SomeRegisters merged
+ end
+
+- fun setToList AllRegisters = listOfAllRegisters
+- | setToList (SomeRegisters r) = r
+-
+ fun inverseSet AllRegisters = SomeRegisters []
+ | inverseSet (SomeRegisters []) = AllRegisters
+ | inverseSet (SomeRegisters r) =
+@@ -416,7 +414,7 @@
+ SomeRegisters(diff(listOfAllRegisters, r))
+ end
+
+- fun inSet(r, AllRegisters) = true
++ fun inSet(_, AllRegisters) = true
+ | inSet(r, SomeRegisters l) =
+ let
+ fun inset [] = false
+@@ -483,8 +481,6 @@
+ | Direct of {base: reg, offset: int} (* Register/Offset *)
+ | Stack of int (* On the real stack. *)
+ | Container of stackIndex list (* A group of stack entries. *)
+-
+- fun isRegister (Register _) = true | isRegister _ = false;
+
+ datatype stackEntry =
+ NoStackEntry
+@@ -531,7 +527,6 @@
+ type rset = {vec: int array, nextr: int ref, modSet: regSet ref, freeRegs: int ref};
+
+ fun Vec ({vec ,...}:rset) = vec;
+- fun Nextr ({nextr,...}:rset) = nextr;
+
+ val vecSize = regs;
+
+@@ -705,24 +700,28 @@
+ pstackTrace: bool,
+ printStream: string->unit
+ };
+-
+- fun ttabCreate debugSwitches =
+- Ttab
+- {
+- decToPstack = stretchArray (initTrans,noIndex),
+- isProc = stretchArray (initTrans,false),
+- regset = rsetMake(),
+- pstack = stretchArray (initStack,NoStackEntry),
+- pstackptr = ref first,
+- realstackptr = ref 0,
+- maxstack = ref 1,
+- exited = ref false,
+- branched = ref false,
+- marker = ref first,
+- lowestDirect = ref first,
+- pstackTrace = DEBUG.getParameter DEBUG.pstackTraceTag debugSwitches,
+- printStream = DEBUG.getParameter DEBUG.compilerOutputTag debugSwitches
+- };
++
++ fun ttabCreate debugSwitches =
++ let
++ val printStream = PRETTY.getSimplePrinter debugSwitches
++ in
++ Ttab
++ {
++ decToPstack = stretchArray (initTrans,noIndex),
++ isProc = stretchArray (initTrans,false),
++ regset = rsetMake(),
++ pstack = stretchArray (initStack,NoStackEntry),
++ pstackptr = ref first,
++ realstackptr = ref 0,
++ maxstack = ref 1,
++ exited = ref false,
++ branched = ref false,
++ marker = ref first,
++ lowestDirect = ref first,
++ pstackTrace = DEBUG.getParameter DEBUG.pstackTraceTag debugSwitches,
++ printStream = printStream
++ }
++ end
+
+ fun decToPstack (Ttab {decToPstack ,...}) = decToPstack;
+ fun isProc (Ttab {isProc ,...}) = isProc;
+@@ -852,7 +851,7 @@
+ printStream "]"
+ )
+
+- fun printEntry printStream NoStackEntry entry = ()
++ fun printEntry _ NoStackEntry _ = ()
+ | printEntry printStream (StackEntry {ent, uses, cache, destStack}) entry =
+ (
+ printStream(Int.toString(getIndex entry));
+@@ -927,7 +926,7 @@
+ then regNone
+ else if not keepIfCache orelse
+ (case stacken of
+- Register reg => true
++ Register _ => true
+ | Stack i => i < 0
+ | _ => false)
+
+@@ -1047,14 +1046,14 @@
+ reused. *)
+ fun lockRegister (table as Ttab{pstackTrace, ...}, reg) =
+ let
+- val U : unit = addRegUse (table, reg);
++ val () = addRegUse (table, reg);
+ in
+ if pstackTrace then printStack table "lockRegister" "" else ()
+ end;
+
+ fun unlockRegister (table as Ttab{pstackTrace, ...}, reg) : unit =
+ let
+- val U : unit = free (regset table) reg;
++ val () = free (regset table) reg;
+ in
+ if pstackTrace then printStack table "unlockRegister" "" else ()
+ end;
+@@ -1157,7 +1156,7 @@
+ stretchSub (decToPstack table, locn);
+
+ (* Called when a value has been newly created and so must be local. *)
+- fun containsLocal (table, reg) : unit = ();
++ fun containsLocal (_, _) : unit = ();
+
+ (* Register to register move. *)
+ fun moveRR rs rd cvec = genRR (instrMove, rs, regNone, rd, cvec);
+@@ -1239,18 +1238,7 @@
+ stretchUpdate (pstack, getIndex entry,
+ makeStackEntry (Register destReg) regNone
+ uses destStack)
+- );
+-
+- fun discardDirect () =
+- (
+- (free (regset table) base) : unit;
+-
+- if cacheReg regNeq regNone
+- then (free (regset table) cacheReg)
+- else ();
+-
+- stretchUpdate (pstack, getIndex entry, NoStackEntry)
+- );
++ )
+ in
+ if not (inSet(base, regSet))
+ then ()
+@@ -1353,17 +1341,6 @@
+ makeStackEntry (Register destReg) regNone uses destStack)
+
+ end;
+-
+- fun discardReg () =
+- (
+- (free (regset table) reg) : unit;
+-
+- if cacheReg regNeq regNone
+- then (free (regset table) cacheReg)
+- else ();
+-
+- stretchUpdate (pstack, getIndex entry, NoStackEntry)
+- );
+ in
+ if not (inSet(reg, regSet))
+ then ()
+@@ -1500,7 +1477,7 @@
+ let
+ val useTab = stretchArray (initStack, 0);
+
+- fun checkReg [] r = false
++ fun checkReg [] _ = false
+ | checkReg (h::t) r = h regEq r orelse checkReg t r
+ in
+ but
+@@ -1546,7 +1523,7 @@
+ fun pushNonArguments (table as Ttab{pstack, ...}, cvec, args, pushTheseRegs) : reg list =
+ let
+
+- fun checkAddress [] addr = false
++ fun checkAddress [] _ = false
+ | checkAddress (h::t) addr = h indexEq addr orelse checkAddress t addr
+ val onList = checkAddress args
+
+@@ -1610,7 +1587,7 @@
+
+
+ (* bugfixed makeEntry added 30/3/95 *)
+- fun makeEntry (table as Ttab{pstackTrace, printStream, ...}, cvec : code, index, locn, use, isP) : unit =
++ fun makeEntry (table as Ttab{pstackTrace, printStream, ...}, _ : code, index, locn, use, isP) : unit =
+ (
+ stretchUpdate (isProc table, locn, isP);
+ stretchUpdate (decToPstack table, locn, index);
+@@ -1741,7 +1718,7 @@
+ let
+ val rs = regset table;
+ val r = getReg rs;
+- val U : unit =
++ val () =
+ if r regNeq regNone
+ then free rs r
+ else ()
+@@ -1749,15 +1726,15 @@
+ r regEq regNone
+ end;
+
+- val U : unit = removeFromCache table allRegisters untilSomethingFree;
++ val () = removeFromCache table allRegisters untilSomethingFree;
+ val r = getReg (regset table);
+ in
+ if r regNeq regNone then r
+ else let
+- val U : unit = pushAll (table, cvec);
++ val () = pushAll (table, cvec);
+
+ (* Pushed values stay in the cache. *)
+- val U : unit =
++ val () =
+ removeFromCache table allRegisters untilSomethingFree;
+ val r = getReg (regset table);
+ in (* If we still haven't found anything we are in big trouble. *)
+@@ -1910,7 +1887,7 @@
+ use-count for entry. Doesn't push anything new on the pstack. *)
+ fun loadPstackEntry (table as Ttab{pstackTrace, ...}) locn (* Offset on the stack *) destReg cvec =
+ let
+- val (realLoc, {cache = cacheReg, ent, ...}) = pstackRealEntry table locn
++ val (_, {cache = cacheReg, ent, ...}) = pstackRealEntry table locn
+ in
+ if cacheReg regNeq regNone
+ then
+@@ -1982,7 +1959,7 @@
+ not matter, but if this is actually a reference to a parameter
+ which could be loaded onto the stack again we have to be careful
+ that the cache does not indicate a register which has been changed. *)
+- val U: unit =
++ val () =
+ if willTrample
+ then stretchUpdate (pstack, getIndex realLoc,
+ makeStackEntry stackEntry regNone uses destStack)
+@@ -2027,12 +2004,12 @@
+ | Stack index => (0 <= index orelse not lastRef)
+ | _ => false
+ (* If we are going to cache it we musn't let it be removed. *)
+- val U: unit =
++ val () =
+ if cacheIt
+ then incrUseCount (table, entry, 1)
+ else ();
+
+- val U: unit = loadPstackEntry table entry resultReg cvec;
++ val () = loadPstackEntry table entry resultReg cvec;
+ val newEntry = pushReg (table, resultReg);
+
+ in
+@@ -2193,7 +2170,7 @@
+ else let
+ val reg = getAnyRegister (table, cvec);
+ val off = (realstackVal table - 1) * wordSize;
+- val U : unit =
++ val () =
+ genLoad (addr + off, regStackPtr, reg, cvec);
+ in
+ reg
+@@ -2281,10 +2258,10 @@
+
+ else if isStoreI(lit, STORE_WORD, false)
+ then let (* Store immediate. *)
+- val U : unit = loadEntryBeforeOverwriting cvec table locn;
++ val () = loadEntryBeforeOverwriting cvec table locn;
+
+ val locn = ((realstackVal table) - locn - 1) * wordSize
+- val U : unit = genStoreI (lit, locn, regStackPtr, STORE_WORD, regNone, cvec);
++ val () = genStoreI (lit, locn, regStackPtr, STORE_WORD, regNone, cvec);
+ in
+ (* Remove the entry for the literal. *)
+ incrUseCount (table, entry, ~1)
+@@ -2295,8 +2272,8 @@
+ | Direct {base, offset} =>
+ if preferLoadPush andalso isPush andalso cacheReg regEq regNone
+ then let (* Push memory. *)
+- val U : unit = loadEntryBeforeOverwriting cvec table locn;
+- val U : unit = genLoadPush (offset, base, cvec);
++ val () = loadEntryBeforeOverwriting cvec table locn;
++ val () = genLoadPush (offset, base, cvec);
+ in
+ incrUseCount (table, entry, ~1);
+ inc (realstackptr table)
+@@ -2308,9 +2285,9 @@
+ | Stack index =>
+ if preferLoadPush andalso isPush andalso cacheReg regEq regNone
+ then let (* Push stack entry. *)
+- val U : unit = loadEntryBeforeOverwriting cvec table locn;
++ val () = loadEntryBeforeOverwriting cvec table locn;
+ val locn = index + (realstackVal table - 1) * wordSize;
+- val U : unit = genLoadPush (locn, regStackPtr, cvec);
++ val () = genLoadPush (locn, regStackPtr, cvec);
+ in
+ incrUseCount (table, entry, ~1);
+ inc (realstackptr table)
+@@ -2332,9 +2309,9 @@
+ procedures. *)
+ fun pushValueToStack (cvec, table, entry, stackOffset) : stackIndex =
+ let
+- val U : unit = storeInStack (cvec, table, entry, stackOffset - 1)
++ val () = storeInStack (cvec, table, entry, stackOffset - 1)
+
+- val U : unit =
++ val () =
+ (* Remove any entries above the stack offset we need. *)
+ if realstackVal table > stackOffset
+ then resetButReload (cvec, table, stackOffset)
+@@ -2414,7 +2391,7 @@
+ | _ =>
+ let
+ val (topReg, topEntry) = loadEntry (cvec, table, entry, false);
+- val U = removeStackEntry(table, topEntry); (* Remove the entry for the register. *)
++ val () = removeStackEntry(table, topEntry); (* Remove the entry for the register. *)
+ (* and push the indirection *)
+ (* Profiling shows that this search is where the compiler can spend most
+ of its time. To speed it up we keep a lower limit pointer which saves
+@@ -2503,13 +2480,13 @@
+ last free register. We could flush the registers and reuse topReg
+ for valReg. Increment the use count on the register just to be sure. *)
+ let
+- val U : unit = incrUseCount (table, vecEntry, 1);
++ val () = incrUseCount (table, vecEntry, 1);
+ val (topReg, topEntry) = loadEntry (cvec, table, vecEntry, false);
+
+ (* We have to be careful if we have just used the last free register to
+ load the vector address. We could flush the registers and reuse topReg
+ for valReg. Increment the use count on the register just to be sure. *)
+- val U : unit = lockRegister (table, topReg);
++ val () = lockRegister (table, topReg);
+
+ fun storeViaRegister () =
+ let
+@@ -2545,9 +2522,6 @@
+ entries elsewhere on the stack, but because the argument area is not
+ represented by entries on the pstack it won't work for them. *)
+ fun loadIfArg (cvec, table, entry) : stackIndex =
+- let
+- val (_,valEntry) = pstackRealEntry table entry
+- in
+ case (pstackRealEntry table entry) of
+ (_,{ent = Stack index, ...}) =>
+ if index > 0
+@@ -2559,7 +2533,6 @@
+ else entry
+
+ | _ => entry (* return the original. *)
+- end;
+
+ fun getRegisterSet (addr: machineWord): regSet =
+ (* The set of register modified by a function. *)
+@@ -2630,7 +2603,7 @@
+ (* Set the state to the saved values. *)
+ fun setState (save : savedState, table as Ttab{pstack, pstackTrace, printStream, ...}, cvec, carry, mark, isMerge): mergeResult =
+ let
+- val U : unit =
++ val () =
+ if pstackTrace then printState printStream save "setState" else ();
+
+ (* This is logically unnecessary, but increases the likelihood
+@@ -2638,7 +2611,7 @@
+ into the *same* register in the different branches. That in
+ turn decreases the work we have to do when we merge the
+ branches back again. SPF 5/6/95 *)
+- val U : unit =
++ val () =
+ setNextRegNo (regset table, #nextRegNo save);
+
+ val topReg =
+@@ -2703,7 +2676,7 @@
+
+ let
+ val oldPstackptr = pstackVal table;
+- val U = pstackptr table := pStackPtr save;
++ val () = pstackptr table := pStackPtr save;
+
+ (* Go up the entries putting them onto the table from the saved
+ state, then come back setting the use-counts where appropriate.
+@@ -2793,7 +2766,7 @@
+ else ()
+ )
+ end;
+- val U: unit = putOnEntries first;
++ val () = putOnEntries first;
+
+ val result: mergeResult =
+ case carry of
+@@ -2808,68 +2781,10 @@
+ end
+ end;
+
+- (* Loads all "direct" entries into registers. This is done when saving the
+- state before a branch to avoid a problem when the states are merged back.
+- When the states are merged we do it by loading entries into registers,
+- but we may not have enough registers to load all the direct entries, so
+- we do it now, and push entries to the stack as necessary. *)
+- (* I've removed the calls to this to help test the new code with
+- explicit stack destinations. DCJM 28/6/2000. *)
+- fun loadDirectEntries (table as Ttab{pstack, ...}) cvec =
+- let
+- (* Load any values above "stackOffset". *)
+- fun loadEntries entry max =
+- if entry indexGeq max then ()
+- else
+- (
+- case (pstackEntry table entry) of
+- StackEntry {ent = Direct {base, ...}, uses, cache, destStack} =>
+- if uses <= 0
+- then ()
+-
+- else if cache regNeq regNone
+- then let
+- val newStackent =
+- makeStackEntry (Register cache) regNone uses destStack;
+- val U : unit =
+- stretchUpdate (pstack, getIndex entry, newStackent)
+- in
+- freeRegister (table, base)
+- end
+-
+- else let
+- val reg = getAnyRegister (table, cvec);
+- in
+- (* Getting a register could cause this entry to
+- be pushed onto the stack, so we have to check again. *)
+- case (pstackEntry table entry) of
+- StackEntry {ent = Direct {base, offset}, cache, uses, destStack} =>
+- let
+- val U : unit = genLoad (offset, base, reg, cvec)
+- val newStackent =
+- makeStackEntry (Register reg) regNone uses destStack
+- val U : unit =
+- stretchUpdate (pstack, getIndex entry, newStackent)
+- in
+- freeRegister (table, base)
+- end
+-
+- | _ => (* Direct stackentry has already been pushed. *)
+- freeRegister (table, reg)
+- end (* not cached *)
+- | _ => () (* not direct *)
+- ;
+-
+- loadEntries (entry indexPlus 1) max
+- ); (* end loadEntries *)
+- in
+- loadEntries (! (lowestDirect table)) (pstackVal table)
+- end;
+
+ fun unconditionalBranch (result, table, cvec) : labels =
+ if branchedVal table then noJump
+ else let
+- (* val U : unit = loadDirectEntries table cvec *)
+ val state = saveState (table, cvec);
+ in
+ branched table := true;
+@@ -3085,7 +3000,7 @@
+ from the saved state. *)
+ fun getMinStack s i =
+ case (pstackEntry table s, pStackEntry save s) of
+- (StackEntry {ent = Stack addr, ...}, _) => i
++ (StackEntry {ent = Stack _, ...}, _) => i
+ | (StackEntry _, StackEntry{ent = Stack addr, ...}) =>
+ (* We have an entry which has been pushed in
+ the saved state but not in the current state.
+@@ -3251,8 +3166,7 @@
+ case (pstackEntry table s, pStackEntry save s) of
+ (StackEntry {uses = tabUses, cache = tabCache, ent = tabEnt,
+ destStack = tabDest},
+- StackEntry {uses = saveUses, cache = saveCache, ent = saveEnt,
+- destStack = saveDest}) =>
++ StackEntry {cache = saveCache, ent = saveEnt, ...}) =>
+ let
+ fun flushCache () =
+ if tabCache regNeq regNone andalso tabCache regNeq saveCache
+@@ -3284,13 +3198,13 @@
+ loaded in a reverse merge. *)
+ needOtherWay := true
+ )
+- | Literal w =>
++ | Literal _ =>
+ (
+ case saveEnt of
+ Literal _ => flushCache()
+ | _ => raise InternalError "Literal mismatch"
+ )
+- | CodeRef c =>
++ | CodeRef _ =>
+ (
+ case saveEnt of
+ CodeRef _ => flushCache()
+@@ -3500,7 +3414,7 @@
+
+ (* Lock the register to make sure that
+ we don't accidentally reuse it for the result. *)
+- val U : unit = lockRegister (table, initialReg2);
++ val () = lockRegister (table, initialReg2);
+
+ (* Get a result register. It's a shame that if the value is
+ already in the desired result register, then we have to
+@@ -3533,27 +3447,27 @@
+ if prefReg regEq initialReg2
+ then if canShareRegs
+ then let (* We WANT to reuse the argument register for the result *)
+- val U : unit = unlockRegister (table, initialReg2);
++ val () = unlockRegister (table, initialReg2);
+ val (arg2Reg, arg2RegLoc) = loadEntry (cvec, table, initialReg2Loc, true);
+- val U : unit = addRegUse (table, arg2Reg); (* For use as result reg. *)
+- val U : unit = lockRegister (table, arg2Reg);
++ val () = addRegUse (table, arg2Reg); (* For use as result reg. *)
++ val () = lockRegister (table, arg2Reg);
+ in
+ (arg2Reg, arg2RegLoc, arg2Reg)
+ end
+ else (initialReg2, initialReg2Loc, getAnyRegister (table, cvec))
+ else let
+- val U : unit = getRegister (table, cvec, prefReg);
++ val () = getRegister (table, cvec, prefReg);
+ in
+ (initialReg2, initialReg2Loc, prefReg)
+ end;
+
+ (* Generate the code. Since we've reversed the operation *)
+ (* we have to use the reverse instruction. *)
+- val U : unit = genRI (revinstr, arg2Reg, lit, resReg, cvec);
++ val () = genRI (revinstr, arg2Reg, lit, resReg, cvec);
+
+ (* Push the result onto the stack. *)
+ val rreg = pushReg (table, resReg);
+- val U : unit = unlockRegister (table, arg2Reg);
++ val () = unlockRegister (table, arg2Reg);
+ in
+ (* Remove the argument register. *)
+ incrUseCount (table, arg2RegLoc, ~1);
+@@ -3564,7 +3478,7 @@
+ fun genBinaryRI lit =
+ let
+ val (initialReg1, initialReg1Loc) = loadEntry (cvec, table, arg1, false);
+- val U : unit = lockRegister (table, initialReg1);
++ val () = lockRegister (table, initialReg1);
+
+ val (arg1Reg, arg1RegLoc, resReg) : reg * stackIndex * reg =
+ case hint of
+@@ -3573,23 +3487,23 @@
+ if prefReg regEq initialReg1
+ then if canShareRegs
+ then let (* We WANT to reuse the argument register for the result *)
+- val U : unit = unlockRegister (table, initialReg1);
++ val () = unlockRegister (table, initialReg1);
+ val (arg1Reg, arg1RegLoc) = loadEntry (cvec, table, initialReg1Loc, true);
+- val U : unit = addRegUse (table, arg1Reg); (* For use as result reg. *)
+- val U : unit = lockRegister (table, arg1Reg);
++ val () = addRegUse (table, arg1Reg); (* For use as result reg. *)
++ val () = lockRegister (table, arg1Reg);
+ in
+ (arg1Reg, arg1RegLoc, arg1Reg)
+ end
+ else (initialReg1, initialReg1Loc, getAnyRegister (table, cvec))
+ else let
+- val U : unit = getRegister (table, cvec, prefReg);
++ val () = getRegister (table, cvec, prefReg);
+ in
+ (initialReg1, initialReg1Loc, prefReg)
+ end;
+
+- val U : unit = genRI (instr, arg1Reg, lit, resReg, cvec);
++ val () = genRI (instr, arg1Reg, lit, resReg, cvec);
+ val rreg = pushReg (table, resReg);
+- val U : unit = unlockRegister (table, arg1Reg);
++ val () = unlockRegister (table, arg1Reg);
+ in
+ incrUseCount (table, arg1RegLoc, ~1);
+ incrUseCount (table, arg2, ~1);
+@@ -3599,10 +3513,10 @@
+ fun genBinaryRR () =
+ let
+ val (initialReg1, initialReg1Loc) = loadEntry (cvec, table, arg1, false);
+- val U : unit = lockRegister (table, initialReg1);
++ val () = lockRegister (table, initialReg1);
+
+ val (initialReg2, initialReg2Loc) = loadEntry (cvec, table, arg2, false);
+- val U : unit = lockRegister (table, initialReg2);
++ val () = lockRegister (table, initialReg2);
+
+ (* We could improve this by considering what happens if arg1Reg and arg2Reg both share with prefReg,
+ but that's getting too obscure to be worthe considering, and would require the
+@@ -3620,10 +3534,10 @@
+ if prefReg regEq initialReg1
+ then if canShareRegs
+ then let (* We WANT to reuse the argument register for the result. *)
+- val U : unit = unlockRegister (table, initialReg1);
++ val () = unlockRegister (table, initialReg1);
+ val (arg1Reg, arg1RegLoc) = loadEntry (cvec, table, initialReg1Loc, true);
+- val U : unit = addRegUse (table, arg1Reg); (* For use as result reg. *)
+- val U : unit = lockRegister (table, arg1Reg);
++ val () = addRegUse (table, arg1Reg); (* For use as result reg. *)
++ val () = lockRegister (table, arg1Reg);
+ in
+ (arg1Reg, arg1RegLoc, initialReg2, initialReg2Loc, arg1Reg)
+ end
+@@ -3632,25 +3546,25 @@
+ else if prefReg regEq initialReg2
+ then if canShareRegs
+ then let (* We WANT to reuse the argument register for the result *)
+- val U : unit = unlockRegister (table, initialReg2);
++ val () = unlockRegister (table, initialReg2);
+ val (arg2Reg, arg2RegLoc) = loadEntry (cvec, table, initialReg2Loc, true);
+- val U : unit = addRegUse (table, arg2Reg); (* For use as result reg. *)
+- val U : unit = lockRegister (table, arg2Reg);
++ val () = addRegUse (table, arg2Reg); (* For use as result reg. *)
++ val () = lockRegister (table, arg2Reg);
+ in
+ (initialReg1, initialReg1Loc, arg2Reg, arg2RegLoc, arg2Reg)
+ end
+ else (initialReg1, initialReg1Loc, initialReg2, initialReg2Loc, getAnyRegister (table, cvec))
+
+ else let
+- val U : unit = getRegister (table, cvec, prefReg);
++ val () = getRegister (table, cvec, prefReg);
+ in
+ (initialReg1, initialReg1Loc, initialReg2, initialReg2Loc, prefReg)
+ end;
+
+- val U = genRR (instr, arg1Reg, arg2Reg, resReg, cvec);
+- val rreg = pushReg (table, resReg);
+- val U : unit = unlockRegister (table, arg1Reg);
+- val U : unit = unlockRegister (table, arg2Reg);
++ val () = genRR (instr, arg1Reg, arg2Reg, resReg, cvec);
++ val rreg = pushReg (table, resReg);
++ val () = unlockRegister (table, arg1Reg);
++ val () = unlockRegister (table, arg2Reg);
+ in
+ incrUseCount (table, arg2RegLoc, ~1); (* Remove the register entries. *)
+ incrUseCount (table, arg1RegLoc, ~1);
+@@ -3682,7 +3596,7 @@
+ | (_,_) =>
+ genBinaryRR ();
+
+- val U : unit = if pstackTrace then printStack table "binaryOp" "" else ();
++ val () = if pstackTrace then printStack table "binaryOp" "" else ();
+ in
+ result
+ end;
+@@ -3697,7 +3611,7 @@
+ val (addrReg, addrEntry) = loadEntry (cvec, table, addr, false)
+ (* This register must be locked so that we don't reuse it for the
+ index or value. *)
+- val U : unit = lockRegister (table, addrReg);
++ val () = lockRegister (table, addrReg);
+
+ (* The values are indexes but if we use a constant offset it must be in bytes. *)
+ val unitSize = case width of STORE_WORD => wordSize | STORE_BYTE => 1
+@@ -3713,7 +3627,7 @@
+ fun storeIndexedViaRegister () =
+ let
+ val (indexReg, indexRegEntry) = loadEntry (cvec, table, offset, false);
+- val U : unit = lockRegister (table, indexReg);
++ val () = lockRegister (table, indexReg);
+ val (valReg, regEntry) = loadEntry (cvec, table, value, false);
+ in
+ genStore (valReg, 0, addrReg, width, indexReg, cvec);
+@@ -3779,7 +3693,6 @@
+ (* Generate a binary compare and jump operation. *)
+ fun compareAndBranch (arg1, arg2, t, revt, table as Ttab{pstackTrace, ...}, cvec) : labels =
+ let
+- (* val U : unit = loadDirectEntries table cvec; *)
+ val (_,{ent = firstEnt,...}) = pstackRealEntry table arg1;
+ val (_,{ent = secondEnt,...}) = pstackRealEntry table arg2;
+
+@@ -3806,9 +3719,9 @@
+ fun genCompRR test =
+ let
+ val (arg1Reg, arg1RegLoc) = loadEntry (cvec, table, arg1, false);
+- val U : unit = lockRegister (table, arg1Reg);
++ val () = lockRegister (table, arg1Reg);
+ val (arg2Reg, arg2RegLoc) = loadEntry (cvec, table, arg2, false);
+- val U : unit = unlockRegister (table, arg1Reg);
++ val () = unlockRegister (table, arg1Reg);
+ in
+ (* Remove the register entries. *)
+ incrUseCount (table, arg1RegLoc, ~1);
+diff -u -r mlsource/MLCompiler/CodeTree/TransTab.ML mlsource/MLCompiler/CodeTree/TransTab.ML
+--- mlsource/MLCompiler/CodeTree/TransTab.ML 2005-09-17 18:40:08.000000000 +0200
++++ mlsource/MLCompiler/CodeTree/TransTab.ML 2009-09-15 08:56:45.000000000 +0200
+@@ -22,8 +22,7 @@
+ (
+ structure CODECONS = CodeCons
+ structure DEBUG = Debug
+- structure ARRAY = Array
+- structure STRETCHARRAY = StretchArray
+ structure ADDRESS = Address
+ structure MISC = Misc
++ structure PRETTY = Pretty
+ )
+diff -u -r mlsource/MLCompiler/CodeTree/ml_bind.ML mlsource/MLCompiler/CodeTree/ml_bind.ML
+--- mlsource/MLCompiler/CodeTree/ml_bind.ML 2008-04-21 13:30:52.000000000 +0200
++++ mlsource/MLCompiler/CodeTree/ml_bind.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -19,12 +19,9 @@
+
+ structure CodeTree =
+ CODETREE (
++ structure PRETTY = Pretty
+ structure GCODE = GCode
+ structure DEBUG = Debug
+- structure PRETTYPRINTER = Boot.PrettyPrinter
+- structure MISC = Boot.Misc
+- structure STRETCHARRAY = StretchArray
+- structure ADDRESS = Address
+ structure STRUCTUREEQ = StructureEquality
+ structure BASECODETREE = BaseCodeTree
+ );
+diff -u -r mlsource/MLCompiler/CompilerBody.ML mlsource/MLCompiler/CompilerBody.ML
+--- mlsource/MLCompiler/CompilerBody.ML 2008-04-21 13:36:11.000000000 +0200
++++ mlsource/MLCompiler/CompilerBody.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -36,6 +36,7 @@
+ structure DEBUG = Debug
+ structure UTILITIES = Utilities
+ structure MISC = Misc
+- structure PRETTYPRINTER = PrettyPrinter
++ structure PRETTY = Pretty
++ structure EXPORTTREE = ExportTreeStruct
+ ) ;
+
+diff -u -r mlsource/MLCompiler/CompilerVersion.sml mlsource/MLCompiler/CompilerVersion.sml
+--- mlsource/MLCompiler/CompilerVersion.sml 2008-05-31 09:28:24.000000000 +0200
++++ mlsource/MLCompiler/CompilerVersion.sml 2009-09-15 08:56:47.000000000 +0200
+@@ -1,5 +1,5 @@
+ (*
+- Copyright (c) 2007-8 David C.J. Matthews
++ Copyright (c) 2007-9 David C.J. Matthews
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+@@ -18,5 +18,7 @@
+
+ structure CompilerVersion =
+ struct
+- val compilerVersion = "5.2 Release"
++ val compilerVersion = "5.3 Enhanced Reporting Testing"
++ val versionNumber = 530
++ val versionSuffix = Int.toString versionNumber
+ end;
+Only in mlsource/MLCompiler: CopierStruct.sml
+Only in mlsource/MLCompiler: DEBUGGERSIG.sml
+diff -u -r mlsource/MLCompiler/DEBUGGER_.sml mlsource/MLCompiler/DEBUGGER_.sml
+--- mlsource/MLCompiler/DEBUGGER_.sml 2008-04-21 13:34:12.000000000 +0200
++++ mlsource/MLCompiler/DEBUGGER_.sml 2009-09-15 08:56:46.000000000 +0200
+@@ -23,64 +23,12 @@
+ (*****************************************************************************)
+ (* STRUCTVALS *)
+ (*****************************************************************************)
+-structure STRUCTVALS :
+-sig
+- type types
+- type typeConstrs
+- type fixStatus
+- type structVals
+- type signatures
+- type functors
+- type values
+- type codetree
+- type valAccess
+- val Global: codetree -> valAccess
+- val makeValueConstr: string * types * bool * valAccess -> values;
+-end;
++structure STRUCTVALS : STRUCTVALSIG;
+
+ (*****************************************************************************)
+ (* VALUEOPS *)
+ (*****************************************************************************)
+-structure VALUEOPS :
+-sig
+- type codetree
+- type types
+- type values
+- type fixStatus
+- type structVals
+- type prettyPrinter
+- type machineWord
+- type signatures
+- type functors
+- type typeConstrs
+-
+- type nameSpace =
+- {
+- lookupVal: string -> values option,
+- lookupType: string -> typeConstrs option,
+- lookupFix: string -> fixStatus option,
+- lookupStruct: string -> structVals option,
+- lookupSig: string -> signatures option,
+- lookupFunct: string -> functors option,
+-
+- enterVal: string * values -> unit,
+- enterType: string * typeConstrs -> unit,
+- enterFix: string * fixStatus -> unit,
+- enterStruct: string * structVals -> unit,
+- enterSig: string * signatures -> unit,
+- enterFunct: string * functors -> unit,
+-
+- allVal: unit -> (string*values) list,
+- allType: unit -> (string*typeConstrs) list,
+- allFix: unit -> (string*fixStatus) list,
+- allStruct: unit -> (string*structVals) list,
+- allSig: unit -> (string*signatures) list,
+- allFunct: unit -> (string*functors) list
+- };
+-
+- val mkGvar: string * types * codetree -> values
+- val mkGex: string * types * codetree -> values
+-end
++structure VALUEOPS : VALUEOPSSIG;
+
+ structure CODETREE :
+ sig
+@@ -90,12 +38,7 @@
+ val CodeZero: codetree;
+ end
+
+-structure TYPETREE:
+-sig
+- type types
+- val unitType: types;
+- val exnType: types;
+-end
++structure TYPETREE: TYPETREESIG
+
+ structure ADDRESS :
+ sig
+@@ -103,111 +46,23 @@
+ val toMachineWord: 'a -> machineWord
+ end;
+
+-sharing type
+- CODETREE.machineWord
+-= VALUEOPS.machineWord
+-= ADDRESS.machineWord
+-
+-sharing type
+- CODETREE.codetree
+-= VALUEOPS.codetree
+-= STRUCTVALS.codetree
+-
+-sharing type
+- STRUCTVALS.values
+-= VALUEOPS.values
+-
+-sharing type
+- STRUCTVALS.types
+-= VALUEOPS.types
+-= TYPETREE.types
+-
+-sharing type
+- STRUCTVALS.typeConstrs
+-= VALUEOPS.typeConstrs
+-
+-sharing type
+- STRUCTVALS.fixStatus
+-= VALUEOPS.fixStatus
+-
+-sharing type
+- STRUCTVALS.structVals
+-= VALUEOPS.structVals
+-
+-sharing type
+- STRUCTVALS.signatures
+-= VALUEOPS.signatures
+-
+-sharing type
+- STRUCTVALS.functors
+-= VALUEOPS.functors
+-)
+-:
+-sig
+- type types
+- type values
+- type machineWord
+- type fixStatus
+- type structVals
+- type typeConstrs
+- type signatures
+- type functors
+-
+- datatype environEntry =
+- EnvValue of string * types
+- | EnvException of string * types
+- | EnvVConstr of string * types * bool
+- | EnvStaticLevel
+-
+- type nameSpace =
+- {
+- lookupVal: string -> values option,
+- lookupType: string -> typeConstrs option,
+- lookupFix: string -> fixStatus option,
+- lookupStruct: string -> structVals option,
+- lookupSig: string -> signatures option,
+- lookupFunct: string -> functors option,
+-
+- enterVal: string * values -> unit,
+- enterType: string * typeConstrs -> unit,
+- enterFix: string * fixStatus -> unit,
+- enterStruct: string * structVals -> unit,
+- enterSig: string * signatures -> unit,
+- enterFunct: string * functors -> unit,
+-
+- allVal: unit -> (string*values) list,
+- allType: unit -> (string*typeConstrs) list,
+- allFix: unit -> (string*fixStatus) list,
+- allStruct: unit -> (string*structVals) list,
+- allSig: unit -> (string*signatures) list,
+- allFunct: unit -> (string*functors) list
+- };
+-
+- (* The debugger function supplied to the compiler. *)
+- type debugger = int * values * int * string * string * nameSpace -> unit
+- val nullDebug: debugger
+-
+- val debuggerFunTag : debugger Universal.tag
+-
+- datatype debugReason =
+- DebugEnter of machineWord * types
+- | DebugLeave of machineWord * types
+- | DebugException of exn
+- | DebugStep
++structure COPIER: COPIERSIG
++structure TYPEIDCODE: TYPEIDCODESIG
+
+- (* Functions inserted into the compiled code. *)
+- val debugFunction:
+- debugger * debugReason * string * string * int -> environEntry list -> machineWord list -> unit
+-end
++sharing STRUCTVALS.Sharing = VALUEOPS.Sharing = TYPETREE.Sharing = COPIER.Sharing =
++ TYPEIDCODE.Sharing = CODETREE = ADDRESS
++)
++: DEBUGGERSIG
+ =
+ struct
+- open STRUCTVALS VALUEOPS CODETREE
++ open STRUCTVALS VALUEOPS CODETREE COPIER TYPETREE
+
+ (* The static environment contains these kinds of entries. *)
+ datatype environEntry =
+- EnvValue of string * types
+- | EnvException of string * types
+- | EnvVConstr of string * types * bool
++ EnvValue of string * types * locationProp list
++ | EnvException of string * types * locationProp list
++ | EnvVConstr of string * types * bool * int * locationProp list
++ | EnvTypeid of { original: typeId, freeId: typeId }
+ | EnvStaticLevel
+
+ datatype debugReason =
+@@ -224,54 +79,103 @@
+ val debuggerFunTag : debugger Universal.tag = Universal.tag()
+ fun nullDebug _ = ()
+
++ (* When stopped at a break-point any Bound ids must be replaced by Free ids.
++ We make new Free ids at this point. *)
++ fun envTypeId (id as Bound { description, ...}) =
++ EnvTypeid { original = id, freeId = makeFreeId(Global CodeZero, isEquality id, description) }
++ | envTypeId id = EnvTypeid { original = id, freeId = id }
++
+ (* Reason codes passed to the debugger function. *)
+ val debugEnterFun = 1
+ and debugLeaveFun = 2
+ and debugExceptFun = 3
+ and debugLineChange = 4
+
+- val dummyValue = mkGvar("", TYPETREE.unitType, CodeZero)
+-
++ val dummyValue = mkGvar("", TYPETREE.unitType, CodeZero, [])
+ fun makeSpace ctEnv rtEnv =
+ let
++ (* Values must be copied so that compile-time type IDs are replaced by their run-time values. *)
++ local
++ fun searchType (EnvTypeid{original, freeId } :: ntl, valu :: vl) typeid =
++ let
++ in
++ if sameTypeId(original, typeid)
++ then
++ case freeId of
++ Free { uid, allowUpdate, description, ... } =>
++ (* This can occur for datatypes inside functions. *)
++ Free { access= Global(mkConst valu), uid=uid, allowUpdate=allowUpdate, description=description }
++ | _ => raise Misc.InternalError "searchType: TypeFunction"
++ else searchType(ntl, vl) typeid
++ end
++
++ | searchType(EnvVConstr _ :: ntl, _ :: vl) typeid = searchType(ntl, vl) typeid
++ | searchType(EnvValue _ :: ntl, _ :: vl) typeid = searchType(ntl, vl) typeid
++ | searchType(EnvStaticLevel :: ntl, vl) typeid = searchType(ntl, vl) typeid
++ | searchType(EnvException _ :: ntl, _ :: vl) typeid = searchType(ntl, vl) typeid
++
++ | searchType _ typeid =
++ let
++ val description =
++ case typeid of
++ Bound { description, ...} => description
++ | Free { description, ...} => description
++ | TypeFunction _ => raise Misc.InternalError "searchType: TypeFunction"
++ in
++ (* The type ID is missing. Make a new temporary ID. *)
++ makeFreeId(Global(TYPEIDCODE.codeForUniqueId()), isEquality typeid, description)
++ end
++
++ fun copyId(Free{ access=Global _ , ...}) = NONE (* Use original *)
++ | copyId id = SOME(searchType(ctEnv, rtEnv) id)
++ in
++ fun runTimeType ty =
++ copyType (ty, fn x => x,
++ fn tcon => copyTypeConstr (tcon, copyId, fn x => x, fn s => s))
++ end
++
+ (* Create the environment. *)
+- fun lookupValues (EnvValue(name, ty) :: ntl, valu :: vl) s =
++ fun lookupValues (EnvValue(name, ty, location) :: ntl, valu :: vl) s =
+ if name = s
+- then SOME(mkGvar(name, ty, mkConst valu))
++ then SOME(mkGvar(name, runTimeType ty, mkConst valu, location))
+ else lookupValues(ntl, vl) s
+
+- | lookupValues (EnvException(name, ty) :: ntl, valu :: vl) s =
++ | lookupValues (EnvException(name, ty, location) :: ntl, valu :: vl) s =
+ if name = s
+- then SOME(mkGex(name, ty, mkConst valu))
++ then SOME(mkGex(name, runTimeType ty, mkConst valu, location))
+ else lookupValues(ntl, vl) s
+
+- | lookupValues (EnvVConstr(name, ty, nullary) :: ntl, valu :: vl) s =
++ | lookupValues (EnvVConstr(name, ty, nullary, count, location) :: ntl, valu :: vl) s =
+ if name = s
+- then SOME(makeValueConstr(name, ty, nullary, Global(mkConst valu)))
++ then SOME(makeValueConstr(name, runTimeType ty, nullary, count, Global(mkConst valu), location))
+ else lookupValues(ntl, vl) s
+
+ | lookupValues (EnvStaticLevel :: ntl, vl) s =
+ (* Static level markers have no effect here. *)
+ lookupValues(ntl, vl) s
+
+- | lookupValues _ _ =
++ | lookupValues (EnvTypeid _ :: ntl, _ :: vl) s = lookupValues(ntl, vl) s
++
++ | lookupValues _ _ =
+ (* The name we are looking for isn't in
+ the environment.
+ The lists should be the same length. *)
+ NONE
+
+- fun allValues (EnvValue(name, ty) :: ntl, valu :: vl) =
+- (name, mkGvar(name, ty, mkConst valu)) :: allValues(ntl, vl)
++ fun allValues (EnvValue(name, ty, location) :: ntl, valu :: vl) =
++ (name, mkGvar(name, runTimeType ty, mkConst valu, location)) :: allValues(ntl, vl)
+
+- | allValues (EnvException(name, ty) :: ntl, valu :: vl) =
+- (name, mkGex(name, ty, mkConst valu)) :: allValues(ntl, vl)
++ | allValues (EnvException(name, ty, location) :: ntl, valu :: vl) =
++ (name, mkGex(name, runTimeType ty, mkConst valu, location)) :: allValues(ntl, vl)
+
+- | allValues (EnvVConstr(name, ty, nullary) :: ntl, valu :: vl) =
+- (name, makeValueConstr(name, ty, nullary, Global(mkConst valu))) ::
++ | allValues (EnvVConstr(name, ty, nullary, count, location) :: ntl, valu :: vl) =
++ (name, makeValueConstr(name, runTimeType ty, nullary, count, Global(mkConst valu), location)) ::
+ allValues(ntl, vl)
+
+ | allValues (EnvStaticLevel :: ntl, vl) = allValues(ntl, vl)
+
++ | allValues (EnvTypeid _ :: ntl, _ :: vl) = allValues(ntl, vl)
++
+ | allValues _ = []
+
+ (* We have a full environment here for future expansion but at
+@@ -299,7 +203,7 @@
+ length we build them separately. This allows the
+ nameTypeList to be built at compile time and reduces
+ the run-time costs. *)
+- fun debugFunction (debugger, reason, fileName, functionName, line) staticEnv valueList =
++ fun debugFunction (debugger, reason, functionName, location) staticEnv valueList =
+ let
+ (* The function name supplied is made up to be suitable for output
+ when profiling. We need to clean it up a bit for use here. The
+@@ -329,20 +233,35 @@
+ val (code, value) =
+ case reason of
+ DebugEnter (argValue, argType) =>
+- (debugEnterFun, mkGvar("", argType, mkConst argValue))
++ (debugEnterFun, mkGvar("", argType, mkConst argValue, [DeclaredAt location]))
+ | DebugLeave (fnResult, resType) =>
+- (debugLeaveFun, mkGvar("", resType, mkConst fnResult))
++ (debugLeaveFun, mkGvar("", resType, mkConst fnResult, [DeclaredAt location]))
+ | DebugException exn =>
+ let
+ val exnVal = ADDRESS.toMachineWord exn
+ (* The exception is always a value of type exn. *)
+- val resVal = mkGvar("", TYPETREE.exnType, mkConst exnVal)
++ val resVal = mkGvar("", TYPETREE.exnType, mkConst exnVal, [DeclaredAt location])
+ in
+ (debugExceptFun, resVal)
+ end
+ | DebugStep =>
+ (debugLineChange, dummyValue)
+ in
+- debugger(code, value, line, fileName, processedName, makeSpace staticEnv valueList)
++ debugger(code, value, #startLine location, #file location, processedName, makeSpace staticEnv valueList)
+ end
++
++ structure Sharing =
++ struct
++ type types = types
++ type values = values
++ type machineWord = machineWord
++ type fixStatus = fixStatus
++ type structVals = structVals
++ type typeConstrs = typeConstrs
++ type signatures = signatures
++ type functors = functors
++ type locationProp = locationProp
++ type environEntry = environEntry
++ type typeId = typeId
++ end
+ end;
+diff -u -r mlsource/MLCompiler/Debug.ML mlsource/MLCompiler/Debug.ML
+--- mlsource/MLCompiler/Debug.ML 2008-04-21 13:33:24.000000000 +0200
++++ mlsource/MLCompiler/Debug.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -36,14 +36,11 @@
+ local
+ open Universal
+ in
+- (* Print error and warning messages. *)
+- val errorMessageProcTag: (string * bool * int -> unit) tag = tag()
+- (* Compiler output. Used for timing information and compiler debug output. *)
+- val compilerOutputTag: (string->unit) tag = tag()
+ (* Get the current line number. *)
+ val lineNumberTag: (unit->int) tag = tag()
+-
+- (* File name. Only used in the debugger so may be taken out. *)
++ (* Get the current offset (position on line or in file). *)
++ val offsetTag: (unit->int) tag = tag()
++ (* File name. *)
+ val fileNameTag: string tag = tag()
+
+ (* Print times for compilation and execution: default false. *)
+@@ -56,12 +53,8 @@
+ val printDepthFunTag: (unit->int) tag = tag()
+ (* Length of line in PolyML.print. error messages etc. *)
+ val lineLengthTag: int tag = tag()
+- (* ML97 or ML90 mode? default ML97 *)
+- val ml90Tag: bool tag = tag()
+ (* Compile in debugging code? default false *)
+ val debugTag: bool tag = tag()
+- (* Stream to use for output in PolyML.print *)
+- val printStringTag: (string->unit) tag = tag()
+ (* Compilation fine tuning. *)
+ (* Should functors be made inline? default true. *)
+ val inlineFunctorsTag: bool tag = tag()
+@@ -81,18 +74,24 @@
+ val pstackTraceTag: bool tag = tag()
+ (* Print assembly code in code-generator? default false *)
+ val assemblyCodeTag: bool tag = tag()
++ (* Report unreferenced identifiers as warnings *)
++ val reportUnreferencedIdsTag: bool tag = tag()
+
+ (* To avoid circularity of dependencies a few tags are defined
+ elsewhere: *)
+- (* val printSpaceTag: ValueOps.nameSpace tag
+- val debuggerFunTag: Debgger.debugger tag *)
++ (* ValueOps.printSpaceTag: ValueOps.nameSpace tag
++ Debugger.debuggerFunTag: Debugger.debugger tag
++ Pretty.printOutputTag: (pretty->unit) tag
++ Pretty.compilerOutputTag: (pretty->unit) tag
++ Lex.errorMessageProcTag: (pretty * bool * int -> unit) tag
++ ExportTreeString.rootTreeTag: (unit -> exportTree) tag
++ *)
+
+
+ val defaults =
+ [
+- tagInject errorMessageProcTag (fn _ => raise Fail "error in program"),
+- tagInject compilerOutputTag (fn _ => ()), (* Discard output. *)
+ tagInject lineNumberTag (fn () => 0), (* Zero line number *)
++ tagInject offsetTag (fn () => 0), (* Zero offset *)
+ tagInject fileNameTag "",
+ tagInject inlineFunctorsTag true,
+ tagInject maxInlineSizeTag 40,
+@@ -107,9 +106,8 @@
+ tagInject printDepthFunTag (fn () => 0),
+ tagInject lineLengthTag 77,
+ tagInject traceCompilerTag false,
+- tagInject ml90Tag false,
+ tagInject debugTag false,
+- tagInject printStringTag (fn s => raise Fail "No stream")
++ tagInject reportUnreferencedIdsTag false
+ ]
+
+ fun getParameter (t:'a tag) (tagList: universal list) :'a =
+diff -u -r mlsource/MLCompiler/Debugger.sml mlsource/MLCompiler/Debugger.sml
+--- mlsource/MLCompiler/Debugger.sml 2008-04-21 13:34:12.000000000 +0200
++++ mlsource/MLCompiler/Debugger.sml 2009-09-15 08:56:47.000000000 +0200
+@@ -25,4 +25,6 @@
+ structure VALUEOPS = ValueOps
+ structure TYPETREE = TypeTree
+ structure ADDRESS = Address
++ structure COPIER = CopierStruct
++ structure TYPEIDCODE = TypeIDCodeStruct
+ );
+Only in mlsource/MLCompiler: EXPORTTREESIG.sml
+Only in mlsource/MLCompiler: ExportTree.sml
+Only in mlsource/MLCompiler: ExportTreeStruct.sml
+diff -u -r mlsource/MLCompiler/INITIALISE_.ML mlsource/MLCompiler/INITIALISE_.ML
+--- mlsource/MLCompiler/INITIALISE_.ML 2008-05-31 15:29:57.000000000 +0200
++++ mlsource/MLCompiler/INITIALISE_.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -2,7 +2,7 @@
+ Copyright (c) 2000
+ Cambridge University Technical Services Limited
+
+- Updated David C.J. Matthews 2008
++ Updated David C.J. Matthews 2008-9
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+@@ -27,214 +27,12 @@
+
+ functor INITIALISE_ (
+
+-(*****************************************************************************)
+-(* TYPETREE *)
+-(*****************************************************************************)
+-structure TYPETREE :
+-sig
+- type types;
+- type typeConstrs;
+-
+- val mkTypeVar: int * bool * bool * bool -> types;
+- val mkTypeConstruction: string * typeConstrs * types list -> types;
+- val mkProductType: types list -> types;
+- val mkFunctionType: types * types -> types;
+- val mkOverloadSet: typeConstrs list -> types;
+- val mkLabelled: {name: string, typeof: types } list * bool -> types;
+- val mkLabelEntry: string * types -> {name: string, typeof: types };
+-
+- val sortLabels: {name: string, typeof: types } list * (string -> unit) ->
+- {name: string, typeof: types } list;
+-
+- val boolType: types;
+- val intType: types;
+- val stringType: types;
+- val unitType: types;
+- val charType: types;
+- val wordType: types;
+- val exnType: types;
+-
+- type prettyPrinter
+- val displayTypeConstrs: typeConstrs * int * prettyPrinter * bool -> unit
+-end;
+-
+-(*****************************************************************************)
+-(* STRUCTVALS *)
+-(*****************************************************************************)
+-structure STRUCTVALS :
+-sig
+-
+- (* Structures *)
+- type structVals;
+- type signatures;
+- type valAccess;
+- type codetree;
+- type values;
+- type typeId;
+-
+- val undefinedStruct: structVals;
+- val structSignat: structVals -> signatures;
+-
+- val makeEmptyGlobal: string -> structVals;
+- val makeLocalStruct: string * signatures -> structVals;
+-
+- (* Functors *)
+- type functors;
+- val makeFunctor: string * structVals * signatures * valAccess -> functors;
+-
+- (* Signatures *)
+- type univTable;
+- val sigTab: signatures -> univTable;
+- val makeSignatures: string -> signatures;
+- val makeCopy: string * signatures * int * int -> signatures;
+-
+- val makeFreeId: unit -> typeId;
+- val makeBoundId: int -> typeId;
+-
+- (* Types *)
+- type types;
+- type typeConstrs;
+-
+- val emptyType: types;
+- val tcSetConstructors: typeConstrs * values list -> unit;
+- val tcTypeVars: typeConstrs -> types list
+- val makeTypeConstrs:
+- string * types list * types * typeId * bool * int -> typeConstrs;
+- val makeFrozenTypeConstrs:
+- string * types list * types * typeId * bool * int -> typeConstrs;
+-
+- val generalisable: int;
+-
+- val boolType: typeConstrs;
+- val intType: typeConstrs;
+- val charType: typeConstrs;
+- val stringType: typeConstrs;
+- val realType: typeConstrs;
+- val refType: typeConstrs;
+- val unitType: typeConstrs;
+- val exnType: typeConstrs;
+- val wordType: typeConstrs;
+- val listType: typeConstrs;
+-
+- (* Access to values, structures etc. *)
+- val makeGlobal: codetree -> valAccess;
+-
+- (* Values. *)
+-
+- datatype typeDependent =
+- Print
+- | PrintSpace
+- | MakeString
+- | MakeStringSpace
+- | InstallPP
+- | Equal
+- | NotEqual
+- | AddOverload
+- | TypeDep;
+-
+- val makeFormalV: string * types * int -> values;
+- val makeFormalEx: string * types * int -> values;
+- val makeOverloaded: string * types * typeDependent -> values;
+-
+- type fixStatus;
+- datatype env = Env of
+- {
+- lookupVal: string -> values option,
+- lookupType: string -> typeConstrs option,
+- lookupFix: string -> fixStatus option,
+- lookupStruct: string -> structVals option,
+- lookupSig: string -> signatures option,
+- lookupFunct: string -> functors option,
+- enterVal: string * values -> unit,
+- enterType: string * typeConstrs -> unit,
+- enterFix: string * fixStatus -> unit,
+- enterStruct: string * structVals -> unit,
+- enterSig: string * signatures -> unit,
+- enterFunct: string * functors -> unit
+- };
+-
+- val makeEnv: signatures -> env;
+-
+- type 'a tag;
+-
+- val valueVar: values tag;
+- val typeConstrVar: typeConstrs tag;
+- val fixVar: fixStatus tag;
+- val structVar: structVals tag;
+- val signatureVar: signatures tag;
+- val functorVar: functors tag;
+-end;
+-
+-
+-(*****************************************************************************)
+-(* VALUEOPS *)
+-(*****************************************************************************)
+-structure VALUEOPS :
+-sig
+- type codetree
+- type types
+- type values
+- type representations
+- type prettyPrinter
+- type structVals
+- type functors
+- type signatures
+- type fixStatus
+- type typeConstrs
+- type nameSpace;
+-
+- (* Construction functions. *)
+- val mkGvar: string * types * codetree -> values
+- val mkGex: string * types * codetree -> values
+- val mkGconstr: string * types * codetree * bool -> values
+-
+- (* Standard values *)
+- val nilConstructor: values;
+- val consConstructor: values;
+-
+- val RefForm: representations;
+- val BoxedForm: representations;
+- val EnumForm: int -> representations;
+-
+- val createNullaryConstructor: representations * string -> codetree
+- val createUnaryConstructor: representations * string -> codetree
+-
+- val displayFixStatus: fixStatus * int * prettyPrinter -> unit
+- (* nameSpace arg is used to get fixity and for exception packets. bool arg is ture if we
+- should print type with the structure name. *)
+- val displaySignatures: signatures * int * prettyPrinter * nameSpace * bool -> unit
+- val displayStructures: structVals * int * prettyPrinter * nameSpace * bool -> unit
+- val displayFunctors: functors * int * prettyPrinter * nameSpace * bool -> unit
+- val displayValues: values * int * prettyPrinter * nameSpace * bool -> unit
+- val printValues: values * int * prettyPrinter * nameSpace -> unit
+-
+- val printSpaceTag: nameSpace Universal.tag
+-
+-end;
+-
+-(*****************************************************************************)
+-(* CODETREE *)
+-(*****************************************************************************)
+-structure CODETREE :
+-sig
+- type machineWord
+- type codetree
+-
+- val CodeNil: codetree;
+- val CodeZero: codetree;
+- val mkEnv: codetree list -> codetree;
+- val mkDec: int * codetree -> codetree;
+- val mkLoad: int * int -> codetree;
+- val mkInd: int * codetree -> codetree;
+- val mkConst: machineWord -> codetree;
+- val mkInlproc: codetree * int * int * string -> codetree;
+- val mkIf: codetree * codetree * codetree -> codetree;
+- val mkEval: codetree * codetree list * bool -> codetree;
+- val identityFunction: string -> codetree;
+- val mkTuple: codetree list -> codetree;
+- val mkStr: string -> codetree;
+- val mkRaise: codetree -> codetree;
+-end;
++structure LEX: LEXSIG
++structure TYPETREE : TYPETREESIG;
++structure STRUCTVALS : STRUCTVALSIG;
++structure VALUEOPS : VALUEOPSSIG;
++structure CODETREE : CODETREESIG
++structure EXPORTTREE: EXPORTTREESIG
+
+ (*****************************************************************************)
+ (* MAKE *)
+@@ -251,37 +49,58 @@
+ type signatures;
+ type functors;
+
+- type nameSpace;
++ type nameSpace =
++ {
++ lookupVal: string -> values option,
++ lookupType: string -> typeConstrs option,
++ lookupFix: string -> fixStatus option,
++ lookupStruct: string -> structVals option,
++ lookupSig: string -> signatures option,
++ lookupFunct: string -> functors option,
++
++ enterVal: string * values -> unit,
++ enterType: string * typeConstrs -> unit,
++ enterFix: string * fixStatus -> unit,
++ enterStruct: string * structVals -> unit,
++ enterSig: string * signatures -> unit,
++ enterFunct: string * functors -> unit,
++
++ allVal: unit -> (string*values) list,
++ allType: unit -> (string*typeConstrs) list,
++ allFix: unit -> (string*fixStatus) list,
++ allStruct: unit -> (string*structVals) list,
++ allSig: unit -> (string*signatures) list,
++ allFunct: unit -> (string*functors) list
++ }
+
+ val gEnvAsEnv : gEnv -> env
+ val gEnvAsNameSpace: gEnv -> nameSpace
+
+ val useIntoEnv : gEnv -> string -> unit
+
++ type location =
++ { file: string, startLine: int, startPosition: int, endLine: int, endPosition: int }
++
++ type exportTree = EXPORTTREE.exportTree
++
+ val compiler :
+- nameSpace * (unit->char option) * Universal.universal list -> unit ->
+- { fixes: (string * fixStatus) list, values: (string * values) list,
+- structures: (string * structVals) list, signatures: (string * signatures) list,
+- functors: (string * functors) list, types: (string* typeConstrs) list };
++ nameSpace * (unit->char option) * Universal.universal list ->
++ exportTree option * ( unit ->
++ { fixes: (string * fixStatus) list, values: (string * values) list,
++ structures: (string * structVals) list, signatures: (string * signatures) list,
++ functors: (string * functors) list, types: (string * typeConstrs) list }) option
+ end;
+
+-(*****************************************************************************)
+-(* ADDRESS *)
+-(*****************************************************************************)
+ structure ADDRESS :
+ sig
+ type machineWord
+ val toMachineWord : 'a -> machineWord;
+ end;
+
+-(*****************************************************************************)
+-(* DEBUG *)
+-(*****************************************************************************)
+ structure DEBUG :
+ sig
+- val errorMessageProcTag: (string * bool * int -> unit) Universal.tag
+- val compilerOutputTag: (string->unit) Universal.tag
+ val lineNumberTag: (unit->int) Universal.tag
++ val offsetTag: (unit->int) Universal.tag
+ val fileNameTag: string Universal.tag
+ val profilingTag : int Universal.tag;
+ val timingTag : bool Universal.tag;
+@@ -297,15 +116,10 @@
+ val traceCompilerTag : bool Universal.tag;
+ val inlineFunctorsTag : bool Universal.tag;
+ val maxInlineSizeTag : int Universal.tag;
+- val ml90Tag : bool Universal.tag;
+ val debugTag : bool Universal.tag;
+-
+- val printStringTag : (string->unit) Universal.tag;
++ val reportUnreferencedIdsTag: bool Universal.tag;
+ end;
+
+-(*****************************************************************************)
+-(* MISC *)
+-(*****************************************************************************)
+ structure MISC :
+ sig
+ type 'a iter
+@@ -315,100 +129,17 @@
+ exception Conversion of string; (* string to int conversion failure *)
+ end;
+
+-(*****************************************************************************)
+-(* DEBUGGER *)
+-(*****************************************************************************)
+-structure DEBUGGER :
+-sig
+- type values;
+- type nameSpace;
+-
+- (* The debugger function supplied to the compiler. *)
+- type debugger = int * values * int * string * string * nameSpace -> unit
+-
+- val debuggerFunTag : debugger Universal.tag
+-end;
+-
+-(*****************************************************************************)
+-(* PRETTYPRINTER *)
+-(*****************************************************************************)
+-structure PRETTYPRINTER :
+-sig
+- type prettyPrinter
+- val prettyPrint : int * (string -> unit) -> prettyPrinter;
+- val uglyPrint : (string -> unit) -> prettyPrinter;
+- val ppAddString : prettyPrinter -> string -> unit
+- val ppBeginBlock : prettyPrinter -> int * bool -> unit
+- val ppEndBlock : prettyPrinter -> unit -> unit
+- val ppBreak : prettyPrinter -> int * int -> unit
+-end;
++structure DEBUGGER : DEBUGGERSIG
++structure PRETTY : PRETTYSIG
+
+ structure VERSION:
+ sig
+ val compilerVersion: string
++ val versionNumber: int
+ end;
+
+-(*****************************************************************************)
+-(* INITIALISE sharing constraints *)
+-(*****************************************************************************)
+-
+-sharing type
+- ADDRESS.machineWord
+-= CODETREE.machineWord
+-
+-sharing type
+- CODETREE.codetree
+-= VALUEOPS.codetree
+-= STRUCTVALS.codetree
+-
+-sharing type
+- STRUCTVALS.values
+-= VALUEOPS.values
+-= MAKE.values
+-
+-sharing type
+- TYPETREE.types
+-= STRUCTVALS.types
+-= VALUEOPS.types
+-
+-sharing type
+- TYPETREE.typeConstrs
+-= STRUCTVALS.typeConstrs
+-= MAKE.typeConstrs
+-= VALUEOPS.typeConstrs
+-
+-sharing type
+- STRUCTVALS.env
+-= MAKE.env
+-
+-sharing type
+- STRUCTVALS.functors
+-= MAKE.functors
+-= VALUEOPS.functors
+-
+-sharing type
+- STRUCTVALS.structVals
+-= MAKE.structVals
+-= VALUEOPS.structVals
+-
+-sharing type
+- STRUCTVALS.signatures
+-= MAKE.signatures
+-= VALUEOPS.signatures
+-
+-sharing type
+- STRUCTVALS.fixStatus
+-= MAKE.fixStatus
+-= VALUEOPS.fixStatus
+-
+-sharing type
+- VALUEOPS.prettyPrinter
+-= TYPETREE.prettyPrinter
+-= PRETTYPRINTER.prettyPrinter
+-
+-sharing type
+- MAKE.nameSpace
+-= VALUEOPS.nameSpace
++sharing STRUCTVALS.Sharing = VALUEOPS.Sharing = TYPETREE.Sharing = EXPORTTREE.Sharing
++ = PRETTY.Sharing = CODETREE.Sharing = MAKE = ADDRESS
+
+ ) :
+
+@@ -432,11 +163,14 @@
+ open MAKE;
+ open MISC;
+ open RuntimeCalls; (* for POLY_SYS calls *)
++ open EXPORTTREE
++
++ val declInBasis = [DeclaredAt inBasis]
+
+ (*****************************************************************************)
+ (* Untility functions *)
+ (*****************************************************************************)
+- fun applyList f [] = ()
++ fun applyList _ [] = ()
+ | applyList f (h :: t) = (f h : unit; applyList f t);
+
+ (*****************************************************************************)
+@@ -451,8 +185,6 @@
+ (*****************************************************************************)
+ (* shouldn't these be imported from somewhere? *)
+ fun ioOp (x: int) : 'a = RunCall.run_call1 POLY_SYS_io_operation x;
+- val intZero = mkConst (toMachineWord 0);
+- val realZero = mkConst (toMachineWord 0.0);
+
+ fun loadArg n = mkLoad (~ n, 0);
+ fun mkEntry n = mkConst (ioOp n);
+@@ -466,9 +198,9 @@
+ open TYPETREE;
+ in
+ (* Make some type variables *)
+- fun makeEqTV () = mkTypeVar (generalisable, true, false, false);
+- fun makeTV () = mkTypeVar (generalisable, false, false, false);
+- fun makeImpTV () = mkTypeVar (generalisable, false, false, true);
++ fun makeEqTV () = mkTypeVar (generalisable, true, false);
++ fun makeTV () = mkTypeVar (generalisable, false, false);
++ fun makeTypeVariable() = makeTv (emptyType, generalisable, false, false)
+
+ (* Make some functions *)
+ infixr 5 ->>
+@@ -482,36 +214,57 @@
+ val String = stringType;
+ val Bool = boolType;
+ val Unit = unitType;
+- val Char = charType;
++ val Char = charType;
+ val Word = wordType;
+
+ val mkTypeConstruction = mkTypeConstruction;
+- val mkTypeVar = mkTypeVar;
+ end;
++
++ (* Function to make a type identifier with a pretty printer that just prints "?"
++ and the structural equality function. Most of the types we use this for
++ don't admit equality but it's simpler to have a single function here. *)
++ local
++ fun defaultPrinter _ _ _ = PRETTY.PrettyString "?"
++ val defaultEqCode =
++ mkInlproc(
++ mkInlproc(
++ mkEval(mkConst(toMachineWord structureEq),
++ [mkTuple[mkLoad(~1, 0), mkLoad(~2, 0)]], true), 1, 2, "eq-helper"),
++ 0, 0, "eq-helper()")
++ in
++ fun defaultEqAndPrintCode() =
++ let
++ (* The structure equality function takes a pair of arguments. We need a
++ function that takes two Poly-style arguments. *)
++ val code =
++ mkTuple[
++ defaultEqCode,
++ mkConst (toMachineWord (ref defaultPrinter))
++ ]
++ in
++ Global (genCode(code, []) ())
++ end
++ end
+
+ (* List of something *)
+ fun List (base : types) : types =
+- mkTypeConstruction ("list", listType, [base]);
++ mkTypeConstruction ("list", listType, [base], declInBasis);
+
+ (* ref something *)
+ fun Ref (base : types) : types =
+- mkTypeConstruction ("ref", refType, [base]);
+-
+- (* option something *)
+- val optionType =
+- makeTypeConstrs("option", [makeTV()], emptyType, makeFreeId (), true, 0);
++ mkTypeConstruction ("ref", refType, [base], declInBasis);
+
+ fun Option (base : types) : types =
+- mkTypeConstruction ("option", optionType, [base]);
++ mkTypeConstruction ("option", optionType, [base], declInBasis);
+
+
+ (* Type-dependent functions. *)
+- fun mkSpecialFun (name:string) (typeof:types) (opn: typeDependent) : values =
++ fun mkSpecialFun (name:string, typeof:types, opn: typeDependent) : values =
+ makeOverloaded (name, typeof, opn);
+
+ (* Overloaded functions. *)
+ fun mkOverloaded (name:string) (typeof: types)
+- : values = mkSpecialFun name typeof TypeDep;
++ : values = mkSpecialFun(name, typeof, TypeDep);
+
+ (*****************************************************************************)
+ (* unit *)
+@@ -524,10 +277,10 @@
+ local
+ val falseCons =
+ mkGconstr ("false", Bool,
+- createNullaryConstructor(EnumForm 0, "false"), true);
++ createNullaryConstructor(EnumForm 0, "false"), true, 2, declInBasis);
+ val trueCons =
+ mkGconstr ("true", Bool,
+- createNullaryConstructor(EnumForm 1, "true"), true);
++ createNullaryConstructor(EnumForm 1, "true"), true, 2, declInBasis);
+ in
+ val () = enterGlobalType ("bool", boolType);
+ val () = enterGlobalValue ("true", trueCons);
+@@ -559,7 +312,7 @@
+ local
+ val chrCode = identityFunction "chr";
+ val chrType = Int ->> String;
+- val chrVal = mkGvar ("chr", chrType, chrCode);
++ val chrVal = mkGvar ("chr", chrType, chrCode, declInBasis);
+ in
+ val () = enterGlobalValue ("chr", chrVal);
+ end;
+@@ -572,39 +325,18 @@
+ (*****************************************************************************)
+ (* 'a list *)
+ (*****************************************************************************)
++ val () = (* Enter :: and nil. *)
++ List.app(fn(tv as Value{name, ...}) => enterGlobalValue(name, tv))
++ (tcConstructors listType)
+ val () = enterGlobalType ("list", listType);
+- val () = enterGlobalValue ("::", consConstructor);
+- val () = enterGlobalValue ("nil", nilConstructor);
+-
+- (* Put these constructors onto the list type. *)
+- val () = tcSetConstructors (listType, [consConstructor, nilConstructor]);
+
+ (*****************************************************************************)
+ (* 'a option *)
+ (*****************************************************************************)
+- local
+- val optionTypeVars = tcTypeVars optionType;
+- val alpha = hd optionTypeVars;
+- val alphaOption = mkTypeConstruction ("option", optionType, optionTypeVars);
+- val someType = TYPETREE.mkFunctionType (alpha, alphaOption);
+- (* These two representations are built into the RTS. *)
+- val NoneForm = EnumForm 0;
+- val SomeForm = BoxedForm;
+- val noneConstructor =
+- mkGconstr ("NONE", alphaOption,
+- createNullaryConstructor(NoneForm, "NONE"), true);
+- val someConstructor =
+- mkGconstr ("SOME", someType,
+- createUnaryConstructor(SomeForm, "SOME"), false);
+- in
+- val () = enterGlobalType ("option", optionType);
+- val () = enterGlobalValue ("SOME", someConstructor);
+- val () = enterGlobalValue ("NONE", noneConstructor);
+- (* Put these constructors onto the option type. N.B. as with all
+- value constructors these need to be in alphabetical order. *)
+- val () = tcSetConstructors (optionType, [noneConstructor, someConstructor]);
+- end;
+-
++ val () = (* Enter NONE and SOME. *)
++ List.app(fn(tv as Value{name, ...}) => enterGlobalValue(name, tv))
++ (tcConstructors optionType)
++ val () = enterGlobalType ("option", optionType);
+
+ (*****************************************************************************)
+ (* ref *)
+@@ -612,10 +344,10 @@
+ local
+ val refCons =
+ let
+- val a : types = makeImpTV ();
++ val a : types = makeTV ();
+ in
+ mkGconstr ("ref", a ->> Ref a,
+- createUnaryConstructor(RefForm, "ref"), false)
++ createUnaryConstructor(RefForm, "ref"), false, 1, declInBasis)
+ end
+ in
+ val () = enterGlobalType ("ref", refType);
+@@ -634,7 +366,7 @@
+ false) (* NOT early *), 0, 1, "!(1)");
+
+ val plingType = let val a = makeTV () in Ref a ->> a end;
+- val plingVal = mkGvar ("!", plingType, plingCode);
++ val plingVal = mkGvar ("!", plingType, plingCode, declInBasis);
+ in
+ val () = enterGlobalValue ("!", plingVal);
+ end;
+@@ -649,18 +381,6 @@
+ (*****************************************************************************)
+ val () = enterGlobalType ("word", wordType);
+
+-(*****************************************************************************)
+-(* 'a vector *)
+-(*****************************************************************************)
+-(* The only reason we have vector here is to get equality right. We need
+- vector to be an equality type and to use structure equality. We can't
+- add an overload for "=" as we do with arrays because that causes the
+- type to have a ref-style equality i.e. 'a vector would permit equality
+- even if 'a did not. *)
+- val vectorType =
+- makeFrozenTypeConstrs("vector", [makeTV()], emptyType, makeFreeId (), true, 0);
+- val () = enterGlobalType ("vector", vectorType);
+-
+
+ (*****************************************************************************)
+ (* System functions (in structure RunCall) *)
+@@ -669,12 +389,12 @@
+ val runCall = makeEmptyGlobal "RunCall";
+ in
+ val () = #enterStruct globalEnv ("RunCall", runCall);
+- val (Env runCallEnv) = makeEnv (structSignat runCall);
++ val (Env runCallEnv) = makeEnv (sigTab(structSignat runCall));
+ end;
+
+ fun enterRunCall (name : string, entry : codetree, typ : types) : unit =
+ let
+- val value = mkGvar (name, typ, entry);
++ val value = mkGvar (name, typ, entry, declInBasis);
+ in
+ #enterVal runCallEnv (name, value)
+ end;
+@@ -823,6 +543,55 @@
+ val () = enterRunCall ("run_call4", runCall4Entry, runCall4Type);
+ val () = enterRunCall ("run_call5", runCall5Entry, runCall5Type);
+ end;
++
++(*****************************************************************************)
++(* Run-time exceptions in RunCall *)
++(*****************************************************************************)
++
++ local
++ (* Create nullary exception. *)
++ fun makeException0(name, id) =
++ let
++ val exc =
++ Value{ name = name, typeOf = TYPETREE.exnType,
++ access = Global(mkConst(toMachineWord id)),
++ class = Exception, locations = declInBasis,
++ references = NONE }
++ in
++ #enterVal runCallEnv (name, exc)
++ end
++ (* Create exception with parameter. *)
++ and makeException1(name, id, exType) =
++ let
++ val exc =
++ Value{ name = name, typeOf = exType ->> TYPETREE.exnType,
++ access = Global(mkConst(toMachineWord id)),
++ class = Exception, locations = declInBasis,
++ references = NONE }
++ in
++ #enterVal runCallEnv (name, exc)
++ end
++ in
++ val () = List.app makeException0
++ [
++ ("Interrupt", EXC_interrupt),
++ ("Size", EXC_size),
++ ("Bind", EXC_Bind),
++ ("Div", EXC_divide),
++ ("Match", EXC_Match),
++ ("Overflow", EXC_overflow),
++ ("Subscript", EXC_subscript)
++ ]
++ val () = List.app makeException1
++ [
++ ("Fail", EXC_Fail, String),
++ ("Conversion", EXC_conversion, String),
++ ("XWindows", EXC_XWindows, String),
++ ("Foreign", EXC_foreign, String),
++ ("Thread", EXC_thread, String),
++ ("SysErr", EXC_syserr, String ** Option Int)
++ ]
++ end
+
+ (*****************************************************************************)
+ (* Bootstrapping functions (in structure Bootstrap) *)
+@@ -831,12 +600,12 @@
+ val bootstrap = makeEmptyGlobal "Bootstrap";
+ in
+ val () = #enterStruct globalEnv ("Bootstrap", bootstrap);
+- val (Env bootstrapEnv) = makeEnv (structSignat bootstrap);
++ val (Env bootstrapEnv) = makeEnv (sigTab(structSignat bootstrap));
+ end;
+
+ fun enterBootstrap (name : string, entry : codetree, typ : types) : unit =
+ let
+- val value = mkGvar (name, typ, entry);
++ val value = mkGvar (name, typ, entry, declInBasis);
+ in
+ #enterVal bootstrapEnv (name, value)
+ end;
+@@ -885,6 +654,26 @@
+ end;
+
+ (*****************************************************************************)
++(* eqtypes *)
++(*****************************************************************************)
++ (* The only reason we have vector here is to get equality right. We need
++ vector to be an equality type and to use structure equality. *)
++ local
++ in
++ val vectorType =
++ makeFrozenTypeConstrs("vector", [makeTypeVariable()],
++ makeFreeId(defaultEqAndPrintCode(), true, basisDescription "vector"), 0, declInBasis);
++ val () = enterGlobalType ("vector", vectorType);
++ end
++
++
++ (* We also need array and Array2.array to be passed through here so that
++ they have the special property of being eqtypes even if their argument
++ is not. "array" is defined to be in the global environment. *)
++ val () = enterGlobalType ("array", arrayType);
++ val () = #enterType bootstrapEnv ("array", array2Type)
++
++(*****************************************************************************)
+ (* Polymorphic functions *)
+ (*****************************************************************************)
+ (* "=', '<>', PolyML.print etc are type-specific function which appear
+@@ -899,14 +688,14 @@
+ That's important to allow the prelude code to expand the PolyML structure. *)
+ local
+ val eqType = let val a = makeEqTV () in a ** a ->> Bool end;
+- val eqVal = mkSpecialFun "=" eqType Equal;
++ val eqVal = mkSpecialFun("=", eqType, Equal);
+ in
+ val () = enterGlobalValue ("=", eqVal);
+ end;
+
+ local
+ val neqType = let val a = makeEqTV () in a ** a ->> Bool end;
+- val neqVal = mkSpecialFun "<>" neqType NotEqual;
++ val neqVal = mkSpecialFun("<>", neqType, NotEqual);
+ in
+ val () = enterGlobalValue ("<>", neqVal);
+ end;
+@@ -918,7 +707,7 @@
+ val polyml = makeEmptyGlobal "PolyML";
+ in
+ val () = #enterStruct globalEnv ("PolyML", polyml);
+- val (Env polyMLEnv) = makeEnv (structSignat polyml);
++ val (Env polyMLEnv) = makeEnv (sigTab(structSignat polyml));
+ val enterPolyMLVal = #enterVal polyMLEnv;
+ end;
+
+@@ -932,15 +721,17 @@
+ (* Create a new structure for them. *)
+ val nameSpace = makeEmptyGlobal "NameSpace";
+ val _ = #enterStruct polyMLEnv ("NameSpace", nameSpace);
+- val (Env nameSpaceEnv) = makeEnv (structSignat nameSpace);
++ val (Env nameSpaceEnv) = makeEnv (sigTab(structSignat nameSpace));
+
+ (* Types for the basic values. These are opaque. *)
+ fun createType typeName =
+ let
+- val typeconstr = makeTypeConstrs(typeName, [], emptyType, makeFreeId (), false, 0);
++ val typeconstr =
++ makeFrozenTypeConstrs(typeName, [],
++ makeFreeId(defaultEqAndPrintCode(), false, basisDescription("PolyML.NameSpace." ^ typeName)), 0, declInBasis);
+ in
+ #enterType nameSpaceEnv (typeName, typeconstr);
+- mkTypeConstruction (typeName, typeconstr, [])
++ mkTypeConstruction (typeName, typeconstr, [], declInBasis)
+ end;
+
+ val valueVal = createType "valueVal"
+@@ -971,15 +762,8 @@
+ val fields = List.foldl (fn (p,l) => createFields p @ l) [] valTypes
+
+ val recordType =
+- makeTypeConstrs("nameSpace", [],
+- mkLabelled(sortLabels(fields, fn _ => ()), true), makeFreeId (), false, 0);
++ makeTypeAbbreviation("nameSpace", [], mkLabelled(sortLabels fields, true), declInBasis);
+ val () = #enterType nameSpaceEnv ("nameSpace", recordType);
+-
+- val debugFields =
+- List.map (fn (n,v) => mkLabelEntry("lookup" ^ n, String ->> Option v)) valTypes
+- val debugRecord = mkLabelled(sortLabels(debugFields, fn _ => ()), true);
+- val debugType = (debugRecord ** (Unit ->> Bool)) ->> Unit
+- val setDbtype = debugType ->> Unit
+
+ (* The result type of the compiler includes valueVal etc. *)
+ val resultFields = List.map TYPETREE.mkLabelEntry
+@@ -990,8 +774,8 @@
+ ("signatures", List(String ** signatureVal)),
+ ("functors", List(String ** functorVal))]
+ in
+- val nameSpaceType = mkTypeConstruction ("nameSpace", recordType, [])
+- val execResult = mkLabelled(sortLabels(resultFields, fn _ => ()), true)
++ val nameSpaceType = mkTypeConstruction ("nameSpace", recordType, [], declInBasis)
++ val execResult = mkLabelled(sortLabels resultFields, true)
+
+ val valueVal = valueVal
+ val typeVal = typeVal
+@@ -999,41 +783,123 @@
+ val signatureVal = signatureVal
+ val structureVal = structureVal
+ val functorVal = functorVal
++
++ val nameSpaceEnv = nameSpaceEnv
+ end
++
++ local
++ open TYPETREE
++
++ val fields =
++ [
++ mkLabelEntry("file", String), mkLabelEntry("startLine", Int),
++ mkLabelEntry("startPosition", Int), mkLabelEntry("endLine", Int),
++ mkLabelEntry("endPosition", Int)
++ ]
++ val typeconstr =
++ makeTypeAbbreviation("location", [], mkLabelled(sortLabels fields, true), declInBasis);
++ val () = #enterType polyMLEnv ("location", typeconstr);
++ in
++ val Location = mkTypeConstruction ("location", typeconstr, [], declInBasis)
++ end
+
+ (*****************************************************************************)
+-(* Funny polymorphic functions (in structure PolyML) *)
++(* context type *)
+ (*****************************************************************************)
+ local
+- val printType = let val a = makeTV () in a ->> a end;
+- val printVal = mkSpecialFun "print" printType Print;
++ open TYPETREE
++ (* Pretty print context information. *)
++ fun makeConstructors typeconstr =
++ let
++ val contextType = mkTypeConstruction ("context", typeconstr, [], declInBasis)
++ val constrs =
++ [ ("ContextLocation", Location),
++ ("ContextParentStructure", String ** List contextType),
++ ("ContextProperty", String ** String)];
++ (* We rely on chooseConstrRepr giving us the same representation for the
++ constructors as when context was compiled by the previous compiler. *)
++ val numConstrs = List.length constrs
++ in
++ ListPair.map (fn ((s,t), code) =>
++ mkGconstr(s, t ->> contextType, code, false, numConstrs, declInBasis))
++ (constrs, chooseConstrRepr constrs)
++ end
++ val typeconstr =
++ buildBasisDatatype("context", "PolyML.context", [], false, makeConstructors)
+ in
+- val () = enterPolyMLVal ("print", printVal);
+- end;
++ val () = #enterType polyMLEnv ("context", typeconstr);
++ val () = List.app(fn(tv as Value{name, ...}) => #enterVal polyMLEnv(name, tv))
++ (tcConstructors typeconstr)
++ val Context = mkTypeConstruction ("context", typeconstr, [], declInBasis)
++ end
++
++(*****************************************************************************)
++(* pretty datatype (for printing) *)
++(*****************************************************************************)
++ local
++ open TYPETREE
++ fun makeConstructors typeconstr =
++ let
++ val prettyType = mkTypeConstruction ("pretty", typeconstr, [], declInBasis)
++ val constrs =
++ [ ("PrettyBlock", mkProductType[Int, Bool, List Context, List prettyType]),
++ ("PrettyBreak", Int ** Int),
++ ("PrettyString", String)];
++ (* We rely on chooseConstrRepr giving us the same representation for the
++ constructors as when PrettyPrint was compiled by the previous compiler. *)
++ val numConstrs = List.length constrs
++ in
++ ListPair.map (fn ((s,t), code) =>
++ mkGconstr(s, t ->> prettyType, code, false, numConstrs, declInBasis))
++ (constrs, chooseConstrRepr constrs)
++ end
++ val typeconstr =
++ buildBasisDatatype("pretty", "PolyML.pretty", [], false, makeConstructors)
++ in
++ val () = #enterType polyMLEnv ("pretty", typeconstr);
++ val () = List.app(fn(tv as Value{name, ...}) => #enterVal polyMLEnv(name, tv))
++ (tcConstructors typeconstr)
++ val PrettyType = mkTypeConstruction ("pretty", typeconstr, [], declInBasis)
++ end
++
+
++(*****************************************************************************)
++(* Funny polymorphic functions (in structure PolyML) *)
++(*****************************************************************************)
+ local
+- val printType =
+- let val a = makeTV () in TYPETREE.mkProductType[a, nameSpaceType, String ->> Unit, Int] ->> Unit end;
+- val printVal = mkSpecialFun "printInNameSpace" printType PrintSpace;
++ val printType = let val a = makeTV () in a ->> a end;
++ val printVal = mkSpecialFun("print", printType, Print);
+ in
+- val () = enterPolyMLVal ("printInNameSpace", printVal);
++ val () = enterPolyMLVal ("print", printVal);
+ end;
+
+ local
+ val makeStringType = let val a = makeTV () in a ->> String end;
+- val makeStringVal = mkSpecialFun "makestring" makeStringType MakeString;
++ val makeStringVal = mkSpecialFun("makestring", makeStringType, MakeString);
+ in
+ val () = enterPolyMLVal ("makestring", makeStringVal);
+ end;
+
+ local
+- val makeStringType = let val a = makeTV () in a ** nameSpaceType ->> String end;
+- val makeStringVal = mkSpecialFun "makestringInNameSpace" makeStringType MakeStringSpace;
++ val prettyType = let val a = makeTV () in a ** Int ->> PrettyType end;
++ val prettyVal = mkSpecialFun("prettyRepresentation", prettyType, GetPretty);
+ in
+- val () = enterPolyMLVal ("makestringInNameSpace", makeStringVal);
++ val () = enterPolyMLVal ("prettyRepresentation", prettyVal);
+ end;
++
++ local
++ (* addPrettyPrinter is the new function to install a pretty printer. *)
++ val a = makeTV ();
++ val b = makeTV ();
+
++ val addPrettyType = (Int ->> b ->> a ->> PrettyType) ->> Unit;
++ val addPrettyVal = mkSpecialFun("addPrettyPrinter", addPrettyType, AddPretty);
++ in
++ val () = enterPolyMLVal ("addPrettyPrinter", addPrettyVal);
++ end;
++
+ local
++ (* Old install_pp function to install a pretty-printer. *)
+ val a = makeTV ();
+ val b = makeTV ();
+
+@@ -1046,7 +912,7 @@
+ Unit ->> Unit (* endBracket *)
+ ];
+ val installPPType = (printTupleType ->> Int ->> b ->> a ->> Unit) ->> Unit;
+- val installPPVal = mkSpecialFun "install_pp" installPPType InstallPP;
++ val installPPVal = mkSpecialFun("install_pp", installPPType, InstallPP);
+ in
+ val () = enterPolyMLVal ("install_pp", installPPVal);
+ end;
+@@ -1055,11 +921,17 @@
+ local
+ val addOverloadType =
+ let val a = makeTV () and b = makeTV () in (a ->> b) ->> String ->> Unit end;
+- val addOverloadVal = mkSpecialFun "addOverload" addOverloadType AddOverload;
++ val addOverloadVal = mkSpecialFun("addOverload", addOverloadType, AddOverload);
+ in
+ val () = #enterVal runCallEnv ("addOverload", addOverloadVal);
+ end;
+
++ local
++ val sourceLocVal = mkSpecialFun("sourceLocation", Unit ->> Location, GetLocation);
++ in
++ val () = enterPolyMLVal ("sourceLocation", sourceLocVal);
++ end;
++
+ (*****************************************************************************)
+ (* Bootstrap.Universal *)
+ (*****************************************************************************)
+@@ -1068,25 +940,29 @@
+ open TYPETREE
+ val uniStruct = makeEmptyGlobal "Universal";
+ val _ = #enterStruct bootstrapEnv ("Universal", uniStruct);
+- val (Env uniStructEnv) = makeEnv (structSignat uniStruct);
++ val (Env uniStructEnv) = makeEnv (sigTab(structSignat uniStruct));
+
+ fun enterUniversal (name : string, entry : codetree, typ : types) : unit =
+ let
+- val value = mkGvar (name, typ, entry);
++ val value = mkGvar (name, typ, entry, declInBasis);
+ in
+ #enterVal uniStructEnv (name, value)
+ end;
+
+ (* type 'a tag *)
+- val tagConstr = makeTypeConstrs("tag", [makeTV()], emptyType, makeFreeId (), false, 0);
++ val tagConstr =
++ makeFrozenTypeConstrs("tag", [makeTypeVariable()],
++ makeFreeId(defaultEqAndPrintCode(), false, basisDescription "tag"), 0, declInBasis);
+ val () = #enterType uniStructEnv ("tag", tagConstr);
+
+ (* type universal *)
+- val univConstr = makeTypeConstrs("universal", [], emptyType, makeFreeId (), false, 0);
++ val univConstr =
++ makeFrozenTypeConstrs("universal", [],
++ makeFreeId(defaultEqAndPrintCode(), false, basisDescription "universal"), 0, declInBasis);
+ val () = #enterType uniStructEnv ("universal", univConstr);
+
+- fun Tag base = mkTypeConstruction ("tag", tagConstr, [base])
+- val Universal = mkTypeConstruction ("universal", univConstr, [])
++ fun Tag base = mkTypeConstruction ("tag", tagConstr, [base], declInBasis)
++ val Universal = mkTypeConstruction ("universal", univConstr, [], declInBasis)
+
+ (* val tagInject : 'a tag -> 'a -> universal *)
+ val injectType = let val a = makeTV() in Tag a ->> a ->> Universal end
+@@ -1100,21 +976,58 @@
+ in
+ val Tag = Tag and Universal = Universal
+ end
+-
++
+ (*****************************************************************************)
+-(* Bootstrap.ExnMessage *)
++(* parseTree type *)
+ (*****************************************************************************)
+-(* This wraps PolyML.makestring to allow it to be used in General.exnMessage
+- without capturing the environment at that point. *)
+ local
+ open TYPETREE
+- val exnStruct = makeEmptyGlobal "ExnMessage";
+- val _ = #enterStruct bootstrapEnv ("ExnMessage", exnStruct);
+- val (Env exnStructEnv) = makeEnv (structSignat exnStruct);
+- in
+- val () = #enterVal exnStructEnv
+- ("exnMessage", makeOverloaded("exnMessage", exnType ->> String, MakeString))
+- end
++ (* Parsetree properties datatype. *)
++ val propConstr =
++ makeDatatypeConstr("ptProperties", [],
++ makeFreeId(defaultEqAndPrintCode(), false, basisDescription "PolyML.ptProperties"), 0, declInBasis);
++ val () = #enterType polyMLEnv ("ptProperties", propConstr);
++ val PtProperties = mkTypeConstruction ("ptProperties", propConstr, [], declInBasis)
++
++ (* Parsetree type. *)
++ val parseTreeConstr =
++ makeTypeAbbreviation("parseTree", [], Location ** List PtProperties, declInBasis);
++ val ParseTree = mkTypeConstruction ("parseTree", parseTreeConstr, [], declInBasis)
++ val () = #enterType polyMLEnv ("parseTree", parseTreeConstr);
++
++ (* Representation of the type of a value. *)
++ val typesConstr =
++ makeFrozenTypeConstrs("typeExpression", [],
++ makeFreeId(defaultEqAndPrintCode(), false, basisDescription "PolyML.typeExpression"), 0, declInBasis);
++ val Types = mkTypeConstruction ("typeExpression", typesConstr, [], declInBasis)
++ val () = #enterType polyMLEnv ("typeExpression", typesConstr);
++
++ val constrs = (* Order is significant. *)
++ [ ("PTdeclaredAt", Location),
++ ("PTfirstChild", Unit ->> ParseTree),
++ ("PTnextSibling", Unit ->> ParseTree),
++ ("PTopenedAt", Location),
++ ("PTparent", Unit ->> ParseTree),
++ ("PTpreviousSibling", Unit ->> ParseTree),
++ ("PTprint", Int ->> PrettyType),
++ ("PTreferences", Bool ** List Location),
++ ("PTstructureAt", Location),
++ ("PTtype", Types)
++ ];
++ (* We rely on chooseConstrRepr giving us the same representation for the
++ constructors as when context was compiled by the previous compiler. *)
++ val numConstrs = List.length constrs
++ val constructors =
++ ListPair.map (fn ((s,t), code) =>
++ mkGconstr(s, t ->> PtProperties, code, false, numConstrs, declInBasis))
++ (constrs, chooseConstrRepr constrs)
++ val () = List.app (fn c => #enterVal polyMLEnv(valName c, c)) constructors
++ (* Put these constructors onto the type. *)
++ val () = tcSetConstructors (propConstr, constructors);
++
++ in
++ val ParseTree = ParseTree and Types = Types
++ end
+
+ (*****************************************************************************)
+ (* PolyML.compiler etc *)
+@@ -1124,10 +1037,11 @@
+ open TYPETREE
+
+ val compilerType : types =
+- mkProductType[nameSpaceType, Unit ->> Option Char, List Universal] ->> Unit ->> execResult;
++ mkProductType[nameSpaceType, Unit ->> Option Char, List Universal] ->>
++ mkProductType[Option ParseTree, Option (Unit ->> execResult)];
+ in
+ val () = enterBootstrap ("use", mkConst (toMachineWord (useIntoEnv globalTable)), String ->> Unit)
+- val () = enterPolyMLVal("compiler", mkGvar ("compiler", compilerType, mkConst (toMachineWord compiler)));
++ val () = enterPolyMLVal("compiler", mkGvar ("compiler", compilerType, mkConst (toMachineWord compiler), declInBasis));
+ val () = enterBootstrap("globalSpace", mkConst (toMachineWord(gEnvAsNameSpace globalTable)), nameSpaceType)
+ end;
+
+@@ -1155,109 +1069,6 @@
+ val () = enterGlobalValue ("mod", mkOverloaded "mod" addType);
+ val () = enterGlobalValue ("/", mkOverloaded "/" addType);
+ end;
+-
+-
+-(*****************************************************************************)
+-(* Funny functor PolyML.Run_exception0 *)
+-(*****************************************************************************)
+- (* "Run_exception0" and "Run_exception1" allow exceptions in the run-time
+- system to be passed into ML. Run_exception0 is used for exceptions without
+- arguments, and Run_exception1 for exceptions that have arguments. *)
+- (* functor Run_exception0(val ex_iden: int end) : sig exception ex end *)
+-
+- local
+- (* Argument signature. *)
+- local
+- (* make an anonymous, empty signature *)
+- val sig0 : signatures = makeSignatures "";
+- val (Env argEnv) = makeEnv sig0;
+- val exIdenVal : values = makeFormalV ("ex_iden", Int, 0);
+- val () = #enterVal argEnv ("ex_iden", exIdenVal);
+-
+- in
+- val argSig0 = makeCopy ("", sig0, 0, 0)
+- end
+-
+- (* Result signature. *)
+- local
+- (* make an anonymous, empty signature *)
+- val sig0 = makeSignatures ""
+- val (Env resEnv) = makeEnv sig0;
+- val exType = emptyType;
+- val exVal = makeFormalEx ("ex", exType, 0);
+- val () = #enterVal resEnv ("ex", exVal);
+- in
+- val resSig0 = makeCopy ("", sig0, 0, 0);
+- end
+-
+- (* The functor turns the value into an exception by returning the argument. *)
+- val Run_exception0 =
+- makeFunctor
+- (
+- "Run_exception0",
+- makeLocalStruct ("", argSig0),
+- resSig0,
+- makeGlobal (identityFunction "Run_exception0")
+- );
+- in
+- val () = #enterFunct runCallEnv ("Run_exception0", Run_exception0);
+- end;
+-
+-
+-(*****************************************************************************)
+-(* Funny functor RunCall.Run_exception1 *)
+-(*****************************************************************************)
+- (* functor Run_exception1(sig type exType; val ex_iden: int end) :
+- sig exception ex of exType end *)
+- local
+- (* Make a nullary type constructor (the type of the exception) *)
+- val exTypeConstr =
+- makeFrozenTypeConstrs ("ex_type", [], emptyType, makeBoundId 0, false, 0);
+-
+- (* Argument signature. *)
+- local
+- (* make an anonymous, empty signature *)
+- val sig1 = makeSignatures "";
+-
+- val (Env argEnv) = makeEnv sig1;
+-
+- val exIdenVal = makeFormalV ("ex_iden", Int, 0);
+-
+- val () = #enterType argEnv ("ex_type", exTypeConstr);
+- val () = #enterVal argEnv ("ex_iden", exIdenVal);
+- in
+- (* Contains 1 bound type *)
+- val argSig1 = makeCopy ("", sig1, 0, 1);
+- end
+-
+- (* Result signature. *)
+- local
+- (* make an anonymous, empty signature *)
+- val sig1 = makeSignatures "";
+- val (Env resEnv) = makeEnv sig1;
+-
+- (* get the actual type from the nullary type constructor *)
+- val exType = mkTypeConstruction ("ex_type", exTypeConstr, []);
+- val exVal = makeFormalEx ("ex", exType, 0);
+-
+- val () = #enterVal resEnv ("ex", exVal);
+- in
+- (* 1 bound type inherited from argument sig *)
+- val resSig1 = makeCopy ("", sig1, 0, 1);
+- end
+-
+- (* The functor turns the value into an exception by returning the argument. *)
+- val Run_exception1 =
+- makeFunctor
+- (
+- "Run_exception1",
+- makeLocalStruct ("", argSig1),
+- resSig1,
+- makeGlobal (identityFunction "Run_exception1")
+- );
+- in
+- val () = #enterFunct runCallEnv ("Run_exception1", Run_exception1);
+- end;
+
+ (*****************************************************************************)
+ (* Bootstrap entries copied from DEBUG *)
+@@ -1266,16 +1077,39 @@
+ open DEBUG;
+ val debuggerType =
+ TYPETREE.mkProductType[Int, valueVal, Int, String, String, nameSpaceType] ->> Unit
++
++ val errorMessageProcType =
++ let
++ open TYPETREE
++ val fields =
++ [
++ mkLabelEntry("location", Location), mkLabelEntry("hard", Bool),
++ mkLabelEntry("message", PrettyType), mkLabelEntry("context", Option PrettyType)
++ ]
++ in
++ mkLabelled(sortLabels fields, true) ->> Unit
++ end
++ val navigationType =
++ let
++ open TYPETREE
++ val optNav = Option(Unit->>ParseTree)
++ val fields =
++ [
++ mkLabelEntry("parent", optNav),
++ mkLabelEntry("next", optNav),
++ mkLabelEntry("previous", optNav)
++ ]
++ in
++ mkLabelled(sortLabels fields, true)
++ end
+ in
+ val () = applyList (fn (name, v, t) => enterBootstrap(name, mkConst v, t))
+ [
+ ("compilerVersion", toMachineWord VERSION.compilerVersion, String),
+-
+- ("errorMessageProcTag", toMachineWord errorMessageProcTag,
+- Tag (TYPETREE.mkProductType[String, Bool, Int] ->> Unit)),
+- ("compilerOutputTag", toMachineWord compilerOutputTag, Tag (String->>Unit)),
+- ("lineNumberTag", toMachineWord lineNumberTag, Tag (Unit->>Int)),
+- ("fileNameTag", toMachineWord fileNameTag, Tag String),
++ ("compilerVersionNumber", toMachineWord VERSION.versionNumber, Int),
++ ("lineNumberTag", toMachineWord lineNumberTag, Tag (Unit->>Int)),
++ ("offsetTag", toMachineWord offsetTag, Tag (Unit->>Int)),
++ ("fileNameTag", toMachineWord fileNameTag, Tag String),
+ ("maxInlineSizeTag", toMachineWord maxInlineSizeTag, Tag Int),
+ ("assemblyCodeTag", toMachineWord assemblyCodeTag, Tag Bool),
+ ("parsetreeTag", toMachineWord parsetreeTag, Tag Bool),
+@@ -1284,71 +1118,89 @@
+ ("codetreeAfterOptTag", toMachineWord codetreeAfterOptTag, Tag Bool),
+ ("traceCompilerTag", toMachineWord traceCompilerTag, Tag Bool),
+ ("inlineFunctorsTag", toMachineWord inlineFunctorsTag, Tag Bool),
+- ("ml90Tag", toMachineWord ml90Tag, Tag Bool),
+ ("debugTag", toMachineWord debugTag, Tag Bool),
+ ("profilingTag", toMachineWord DEBUG.profilingTag, Tag Int),
+ ("timingTag", toMachineWord DEBUG.timingTag, Tag Bool),
+ ("printDepthFunTag", toMachineWord DEBUG.printDepthFunTag, Tag (Unit->>Int)),
+ ("errorDepthTag", toMachineWord DEBUG.errorDepthTag, Tag Int),
+ ("lineLengthTag", toMachineWord DEBUG.lineLengthTag, Tag Int),
+- ("printStringTag", toMachineWord DEBUG.printStringTag, Tag (String->>Unit)),
+- ("printEnvironTag", toMachineWord VALUEOPS.printSpaceTag, Tag nameSpaceType),
+- ("debuggerTag", toMachineWord DEBUGGER.debuggerFunTag, Tag debuggerType)
++ ("debuggerTag", toMachineWord DEBUGGER.debuggerFunTag, Tag debuggerType),
++ ("printOutputTag", toMachineWord PRETTY.printOutputTag, Tag (PrettyType->>Unit)) ,
++ ("compilerOutputTag", toMachineWord PRETTY.compilerOutputTag, Tag (PrettyType->>Unit)),
++ ("errorMessageProcTag", toMachineWord LEX.errorMessageProcTag, Tag errorMessageProcType),
++ ("rootTreeTag", toMachineWord EXPORTTREE.rootTreeTag, Tag navigationType),
++ ("reportUnreferencedIdsTag", toMachineWord reportUnreferencedIdsTag, Tag Bool)
+ ]
+ end;
+
+ (*****************************************************************************)
+-(* Bootstrap entries for printing *)
++(* Entries for printing *)
+ (*****************************************************************************)
+ local
+- open TYPETREE PRETTYPRINTER
+- fun displayFix((name: string, f: fixStatus), stream: string->unit) =
++ open TYPETREE
++ (* These are used to display the declarations made. *)
++ fun displayFix((name: string, f: fixStatus)): pretty =
+ let
+- val pstream = prettyPrint (77, stream)
++ open PRETTY
+ in
+- ppBeginBlock pstream (0, false);
+- displayFixStatus (f, 999 (* Actually unused. *), pstream);
+- ppBreak pstream (1, 0);
+- ppAddString pstream name;
+- ppEndBlock pstream ()
++ PrettyBlock (0, false, [],
++ [displayFixStatus f, PrettyBreak (1, 0), PrettyString name])
+ end
++
++ fun getValue (Value{access = Global code, class = SimpleValue, ...}) = evalue code
++ | getValue _ = raise Fail "Not a global value"
+
+- and displaySig(s: signatures, depth: int, space: nameSpace, withStruct: bool, stream: string->unit) =
+- displaySignatures(s, depth, prettyPrint (77, stream), space, withStruct)
+-
+- and displayStruct(s: structVals, depth: int, space: nameSpace, withStruct: bool, stream: string->unit) =
+- displayStructures(s, depth, prettyPrint (77, stream), space, withStruct)
+-
+- and displayFunct(f: functors, depth: int, space: nameSpace, withStruct: bool, stream: string->unit) =
+- displayFunctors(f, depth, prettyPrint (77, stream), space, withStruct)
+-
+- and displayVal(v: values, depth: int, space: nameSpace, withStruct: bool, stream: string->unit) =
+- displayValues(v, depth, prettyPrint (77, stream), space, withStruct)
+-
+- and displayType(t: typeConstrs, depth: int, withStruct: bool, stream: string->unit) =
+- displayTypeConstrs(t, depth, prettyPrint (77, stream), withStruct)
+-
+- (* Used to print values in the debugger. Use uglyPrint here to keep it
+- simple and on one line. *)
+- and printVal(v: values, depth: int, space: nameSpace, stream: string->unit) =
+- printValues(v, depth, uglyPrint stream, space)
+- in
+- val () = applyList (fn (name, v, t) => enterBootstrap(name, mkConst v, t))
++ (* The exported versions expect full name spaces as arguments. Because we convert
++ the exported versions to machineWord and give them types as data structures the
++ compiler can't actually check that the type we give matched the internal type. *)
++ fun makeTypeEnv(nameSpace: nameSpace): printTypeEnv =
++ {
++ lookupType = fn s => case #lookupType nameSpace s of NONE => NONE | SOME t => SOME(t, NONE),
++ lookupStruct = fn s => case #lookupStruct nameSpace s of NONE => NONE | SOME t => SOME(t, NONE)
++ }
++ fun exportedDisplayTypeConstr(tyCons, depth, nameSpace: nameSpace) =
++ TYPETREE.displayTypeConstrs(tyCons, depth, makeTypeEnv nameSpace)
++ and exportedDisplayTypeExp(ty, depth, nameSpace: nameSpace) =
++ TYPETREE.display(ty, depth, makeTypeEnv nameSpace)
++ and exportedDisplaySigs(sign, depth, nameSpace: nameSpace) =
++ displaySignatures(sign, depth, makeTypeEnv nameSpace)
++ and exportedDisplayFunctors(funct, depth, nameSpace: nameSpace) =
++ displayFunctors(funct, depth, makeTypeEnv nameSpace)
++ and exportedDisplayValues(valu, depth, nameSpace: nameSpace) =
++ displayValues(valu, depth, makeTypeEnv nameSpace)
++ and exportedDisplayStructs(str, depth, nameSpace: nameSpace) =
++ displayStructures(str, depth, makeTypeEnv nameSpace)
++ in
++ (* Add these to the PolyML.NameSpace structure. *)
++ val () = applyList (fn (name, v, t) =>
++ #enterVal nameSpaceEnv (name, mkGvar (name, t, mkConst v, declInBasis)))
+ [
+- ("displayFix", toMachineWord displayFix, (String ** fixityVal) ** (String ->> Unit) ->>Unit),
+- ("displaySig", toMachineWord displaySig,
+- mkProductType[signatureVal, Int, nameSpaceType, Bool, (String ->> Unit)] ->> Unit),
+- ("displayStruct", toMachineWord displayStruct,
+- mkProductType[structureVal, Int, nameSpaceType, Bool, (String ->> Unit)] ->> Unit),
+- ("displayFunct", toMachineWord displayFunct,
+- mkProductType[functorVal, Int, nameSpaceType, Bool, (String ->> Unit)] ->> Unit),
+- ("displayVal", toMachineWord displayVal,
+- mkProductType[valueVal, Int, nameSpaceType, Bool, (String ->> Unit)] ->> Unit),
+- ("printVal", toMachineWord printVal,
+- mkProductType[valueVal, Int, nameSpaceType, (String ->> Unit)] ->> Unit),
+- ("displayType", toMachineWord displayType,
+- mkProductType[typeVal, Int, Bool, (String ->> Unit)] ->> Unit)
++ ("displayFix", toMachineWord displayFix, String ** fixityVal ->> PrettyType),
++ ("displaySig", toMachineWord exportedDisplaySigs,
++ mkProductType[signatureVal, Int, nameSpaceType] ->> PrettyType),
++ ("displayStruct", toMachineWord exportedDisplayStructs,
++ mkProductType[structureVal, Int, nameSpaceType] ->> PrettyType),
++ ("displayFunct", toMachineWord exportedDisplayFunctors,
++ mkProductType[functorVal, Int, nameSpaceType] ->> PrettyType),
++ ("displayVal", toMachineWord exportedDisplayValues,
++ mkProductType[valueVal, Int, nameSpaceType] ->> PrettyType),
++ ("displayType", toMachineWord exportedDisplayTypeConstr,
++ mkProductType[typeVal, Int, nameSpaceType] ->> PrettyType),
++ (* displayTypeExpression doesn't really belong here since it's used
++ as part of the parse tree rather the name space. *)
++ ("displayTypeExpression", toMachineWord exportedDisplayTypeExp,
++ mkProductType[Types, Int, nameSpaceType] ->> PrettyType)
+ ]
++ (* Put this in Bootstrap, at least for the moment.
++ Used to print values in the debugger without the "val", "=" and the type. *)
++ val () = applyList (fn (name, v, t) => enterBootstrap(name, mkConst v, t))
++ [("printValue", toMachineWord printValues,
++ mkProductType[valueVal, Int, nameSpaceType] ->> PrettyType),
++ (* This is used to get the actual value out of a global "value".
++ It's currently used only in the debugger to get the exception
++ packet out of a global exception value. *)
++ ("getValue", toMachineWord getValue,
++ valueVal ->> mkTypeVar (generalisable, false, false))]
+ end;
+
+ in
+diff -u -r mlsource/MLCompiler/Initialise.ML mlsource/MLCompiler/Initialise.ML
+--- mlsource/MLCompiler/Initialise.ML 2008-04-21 13:36:11.000000000 +0200
++++ mlsource/MLCompiler/Initialise.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -19,6 +19,7 @@
+
+ structure Initialise =
+ INITIALISE_ (
++ structure LEX = Lex
+ structure TYPETREE = TypeTree
+ structure STRUCTVALS = StructVals
+ structure VALUEOPS = ValueOps
+@@ -29,5 +30,6 @@
+ structure MISC = Misc
+ structure DEBUGGER = Debugger
+ structure VERSION = CompilerVersion
+- structure PRETTYPRINTER = PrettyPrinter
++ structure PRETTY = Pretty
++ structure EXPORTTREE = ExportTreeStruct
+ );
+Only in mlsource/MLCompiler: LEXSIG.sml
+diff -u -r mlsource/MLCompiler/LEX_.ML mlsource/MLCompiler/LEX_.ML
+--- mlsource/MLCompiler/LEX_.ML 2008-04-21 13:36:11.000000000 +0200
++++ mlsource/MLCompiler/LEX_.ML 2009-09-15 08:56:47.000000000 +0200
+@@ -28,28 +28,9 @@
+
+ functor LEX_ (
+ (*****************************************************************************)
+-(* PRETTYPRINTER *)
++(* PRETTY *)
+ (*****************************************************************************)
+-structure PRETTYPRINTER:
+-sig
+- type prettyPrinter
+-
+- val ppAddString : prettyPrinter -> string -> unit
+- val ppBeginBlock : prettyPrinter -> int * bool -> unit
+- val ppEndBlock : prettyPrinter -> unit -> unit
+- val ppBreak : prettyPrinter -> int * int -> unit
+- val ppLineBreak : prettyPrinter -> unit -> unit
+-
+- val prettyPrint : int * (string -> unit) -> prettyPrinter;
+-end;
+-
+-(*****************************************************************************)
+-(* MISC exports signature *)
+-(*****************************************************************************)
+-structure MISC :
+-sig
+- exception InternalError of string; (* compiler error *)
+-end
++structure PRETTY: PRETTYSIG;
+
+ (*****************************************************************************)
+ (* SYMBOLS *)
+@@ -86,74 +67,46 @@
+
+ structure DEBUG:
+ sig
+- val errorMessageProcTag: (string * bool * int -> unit) Universal.tag
+ val lineNumberTag: (unit -> int) Universal.tag
++ val offsetTag: (unit->int) Universal.tag
++ val fileNameTag: string Universal.tag
+ val getParameter :
+ 'a Universal.tag -> Universal.universal list -> 'a
+ end
+
+-) :
+-
+-
+-(*****************************************************************************)
+-(* LEX export signature *)
+-(*****************************************************************************)
+-sig
+- type lexan;
+- type sys;
+- type prettyPrinter;
+-
+- val insymbol: lexan -> unit;
+-
+- (* insymbol sets sy and id which are exported as "read-only" *)
+-
+- val sy: lexan -> sys;
+- val id: lexan -> string;
+- val lineno: lexan -> int;
+- val pushBackSymbol: lexan * sys -> unit;
+-
+- val initial: (unit -> char option) * Universal.universal list -> lexan;
+-
+- (* Error handling *)
+-
+- val errorProc: lexan * int * (prettyPrinter -> unit) -> unit;
+- val errorMessage: lexan * int * string -> unit;
+- val warningProc: lexan * int * (prettyPrinter -> unit) -> unit;
+- val warningMessage: lexan * int * string -> unit;
+-
+- val errorOccurred: lexan -> bool;
+- val resetLexan: lexan -> unit;
+- val flushLexan: lexan -> unit;
+-
+- val nullLex: lexan; (* Used when no errors are expected - streams raise exceptions. *)
+-
+- (* To save passing an extra argument to many functions we include the
+- debug/control parameters here. *)
+- val debugParams: lexan -> Universal.universal list
+-end (* LEX export signature *) =
++) : LEXSIG =
+
+ (*****************************************************************************)
+ (* LEX functor body *)
+ (*****************************************************************************)
+ struct
+
+- open MISC;
+- open PRETTYPRINTER;
++ open Misc;
++ open PRETTY;
+ open SYMBOLS; infix 8 eq neq;
+-
+
++ type location = { file: string, startLine: int, startPosition: int, endLine: int, endPosition: int }
++
+ type lexan =
+ {
+- stream: unit -> char option,
+- lineno: unit -> int,
+- ch: char ref,
+- sy: sys ref,
+- id: string ref,
+- messageOut: string * bool * int -> unit,
+- errors: bool ref,
+- pushedSym: sys ref,
+- extraChars: char list ref,
+- debugParams: Universal.universal list
++ stream: unit -> char option,
++ ch: char ref,
++ sy: sys ref,
++ id: string ref,
++ messageOut:
++ { location: location, hard: bool, message: pretty, context: pretty option } -> unit,
++ errors: bool ref,
++ pushedSym: sys ref,
++ extraChars: char list ref,
++ debugParams: Universal.universal list,
++ (* Location information. *)
++ getLineNo: unit -> int,
++ getOffset: unit -> int,
++ fileName: string,
++ startLine: int ref,
++ endLine: int ref,
++ startPosition: int ref,
++ endPosition: int ref
+ };
+
+ (* The lexical analyser reads characters from the stream and updates the
+@@ -161,36 +114,55 @@
+ but the lexical analyser can be a hot-spot in the compiler unless it's
+ made as fast as possible. *)
+
+- val eofChar = Char.chr 4; (* ctrl/D *)
+-
+- val isNumeric = Char.isDigit
+- and isAlphabetic = Char.isAlpha
+- and isWhiteSpace = Char.isSpace
+- and isHexadecimal = Char.isHexDigit
++ val eofChar = Char.chr 4; (* ctrl/D *)
+
+- (* For our purposes we include quote and underscore. *)
+- fun isAlphaNumeric c = Char.isAlphaNum c orelse c = #"'" orelse c = #"_"
++ val isNumeric = Char.isDigit
++ and isAlphabetic = Char.isAlpha
++ and isWhiteSpace = Char.isSpace
++ and isHexadecimal = Char.isHexDigit
++
++ (* For our purposes we include quote and underscore. *)
++ fun isAlphaNumeric c = Char.isAlphaNum c orelse c = #"'" orelse c = #"_"
++
++ (* Print error and warning messages. *)
++ val errorMessageProcTag:
++ ({ location: location, hard: bool, message: pretty, context: pretty option } -> unit)
++ Universal.tag =
++ Universal.tag()
+
+- val isOperator = Char.contains ":=<>+*!^/|&%~-?`@\\$#";
++ val isOperator = Char.contains ":=<>+*!^/|&%~-?`@\\$#";
+
+ (* The initial state looks like we've just processed a complete ML declaration *)
+ fun initial (stream, parameters) : lexan =
+ let
+ open DEBUG
+- val errorMessageProc = getParameter errorMessageProcTag parameters
++ val errorMessageProc =
++ case List.find (Universal.tagIs errorMessageProcTag) parameters of
++ SOME f => Universal.tagProject errorMessageProcTag f
++ | NONE => fn _ => raise Fail "Error in source code"
+ val lineno = getParameter lineNumberTag parameters
++ val offset = getParameter offsetTag parameters
++ val filename = getParameter fileNameTag parameters
++ val initialLine = lineno() (* Before the first char. *)
++ and initialOffset = offset()
+ in
+ {
+- stream = stream,
+- lineno = lineno,
+- ch = ref #" ", (* " " - we've just "clobbered the ";" *)
+- sy = ref semicolon, (* ";" *)
+- id = ref "",
+- messageOut = errorMessageProc,
+- errors = ref false,
+- pushedSym = ref othersy,
+- extraChars = ref [],
+- debugParams = parameters
++ stream = stream,
++ ch = ref #" ", (* " " - we've just "clobbered the ";" *)
++ sy = ref semicolon, (* ";" *)
++ id = ref "",
++ messageOut = errorMessageProc,
++ errors = ref false,
++ pushedSym = ref othersy,
++ extraChars = ref [],
++ debugParams = parameters,
++ getLineNo = lineno,
++ getOffset = offset,
++ fileName = filename,
++ startLine = ref initialLine,
++ endLine = ref initialLine,
++ startPosition = ref initialOffset,
++ endPosition = ref initialOffset
+ }
+ end
+
+@@ -198,53 +170,76 @@
+
+ (* Error messages *)
+
+- fun errorOccurred ({errors, ...}: lexan) = ! errors;
++ fun errorOccurred ({errors, ...}: lexan) = ! errors;
+
+- (* Reset lexer following bad parse *)
+- fun resetLexan ({errors, ...} : lexan) = (errors := false);
++ fun location ({fileName, startLine, endLine, startPosition, endPosition,...}:lexan) =
++ { file = fileName, startLine = !startLine, endLine = !endLine,
++ startPosition = !startPosition, endPosition = !endPosition}
+
+- (* Flush lexer state following user interrupt *)
+- fun flushLexan ({errors, ch, sy, pushedSym, extraChars, ...} : lexan) =
+- (errors := false;
+- ch := #" ";
+- sy := semicolon;
+- pushedSym := othersy;
+- extraChars := []);
+-
+- fun lineno ({lineno,...}:lexan) = lineno();
+-
+- fun ewProc ({messageOut,errors,...} : lexan) hardError line eproc =
+- let
+- val message = ref [] (* Build up the context in here. *)
+- val pprint = prettyPrint(77, fn s => message := s :: !message);
+- in
+- (* If this is a hard error we have to set the flag
+- to prevent further passes. *)
+- if hardError then errors := true else ();
+- (* Print out the message *)
+- ppBeginBlock pprint (0, false);
+- eproc pprint;
+- ppEndBlock pprint ();
++ fun reportError ({messageOut,errors,...} : lexan) (report as { hard, ...}) =
++ (
++ (* If this is a hard error we have to set the flag
++ to prevent further passes. *)
++ if hard then errors := true else ();
++ messageOut report
++ )
++
++ (* Record the position of the current symbol.
++ This sets the start for the current symbol to the last recorded
++ end and sets the new end to the current position. *)
++ fun setSymbolStart {getLineNo, getOffset, startLine, endLine, startPosition, endPosition, ...} =
++ let
++ val line = getLineNo() and offset = getOffset()
++ in
++ startLine := ! endLine; endLine := line;
++ startPosition := ! endPosition; endPosition := offset
++ end
++
++ fun setSymbolEnd {getLineNo, getOffset, endLine, endPosition, ...} =
++ let
++ val line = getLineNo() and offset = getOffset()
++ in
++ endLine := line;
++ endPosition := offset
++ end
+
+- messageOut(concat(List.rev (!message)), hardError, line)
+- end;
+-
+- (* General purpose error messages typically including
+- pretty-printed parse tree. *)
+- fun errorProc (state, lineno, eproc) =
+- ewProc state true (*hard*) lineno eproc;
+-
+- (* Simple strings. *)
+- fun errorMessage (state, lineno, str) =
+- ewProc state true (*hard*) lineno (fn pp => ppAddString pp str);
+-
+- (* Warnings are non-fatal errors. i.e. errors is not set. *)
+- fun warningProc (state, lineno, eproc) =
+- ewProc state false (*soft*) lineno eproc;
++ (* Convert a piece of text into a series of words so that the
++ pretty printing can break it into lines. *)
++ fun breakWords str =
++ let
++ val words = String.tokens Char.isSpace str
++ fun addBreaks [] = [PrettyString ""] (* Shouldn't happen *)
++ | addBreaks [last] = [PrettyString last]
++ | addBreaks (hd :: tl) =
++ PrettyString hd :: PrettyBreak(1, 0) :: addBreaks tl
++ in
++ addBreaks words
++ end
+
+- fun warningMessage (state, lineno, str) =
+- ewProc state false (*soft*) lineno (fn pp => ppAddString pp str);
++ (* Simple string error messages. *)
++ fun errorMessage (lexan, location, message) =
++ reportError lexan
++ {
++ location = location,
++ message = PrettyBlock(3, false, [], breakWords message),
++ hard = true,
++ context = NONE
++ }
++ and warningMessage (lexan, location, message) =
++ reportError lexan
++ {
++ location = location,
++ message = PrettyBlock(3, false, [], breakWords message),
++ hard = false, (* Just a warning *)
++ context = NONE
++ }
+
++ (* Errors within the lexer. *)
++ fun lexError(state, text) =
++ (
++ setSymbolEnd state;
++ errorMessage (state, location state, text)
++ )
+
+ exception EndOfLine;
+
+@@ -253,35 +248,27 @@
+ but actually isn't. *)
+ fun nextCh({ch, stream, extraChars = ref [], ...}) = ch := getOpt(stream(), eofChar)
+ | nextCh({ch, extraChars = extra as ref(c::l), ...}) = (extra := l; ch := c)
++
++ (* Skip over white space. If we have to skip we record this as the END of
++ the previous symbol. If it turns out that the character is actually
++ the start of a symbol then this will be set as the START by setSymbolStart. *)
++ fun skipWhiteSpace (state as {ch = ref c, ...}:lexan) : char =
++ if isWhiteSpace c
++ then (setSymbolEnd state; nextCh state; skipWhiteSpace state)
++ else c
+
+- and skipWhiteSpace (state as {ch = ref c, ...}:lexan) : char =
+- if isWhiteSpace c
+- then (nextCh state; skipWhiteSpace state)
+- else c
+-
+- (* If a character has been read which is its own terminator (e.g.";")
+- then don't read the next character, just clobber the current one. (The
+- only place this matters is when the user types x;y; at the terminal
+- when the compiler is called first to process the x; and then it is
+- called again (with reinitialisation) to process the y;.
+- Replacing it with a space means that the next character will be read
+- from the input stream since leading spaces are skipped.
+- Many symbols (e.g. identifiers) are not self-terminating so the
+- terminating character is remembered in ch. *)
+- and chRead({ch, ...}:lexan) = ch := #" " (* " " *);
+-
+ (* Leave string construction until we have all the characters. Since
+ Single character strings are the same as single characters it doesn't
+ cost anything to apply "str" but it allows us to conatenate with any
+ prefix string in one go. *)
+- fun readChars (state as { stream, ch, ... }) (isOk: char -> bool) (s: string) : string =
++ fun readChars (state as { ch, ... }) (isOk: char -> bool) (s: string) : string =
+ let
+ fun loop (): string list =
+ let
+ val theChar = ! ch;
+ in
+ if isOk theChar
+- then (nextCh state; str theChar :: loop ())
++ then (setSymbolEnd state; nextCh state; str theChar :: loop ())
+ else []
+ end;
+ in
+@@ -309,15 +296,11 @@
+ nextCh state;
+ if isHexadecimal (!ch)
+ then id := readChars state isHexadecimal "0wx"
+- else
+- errorMessage (state, lineno state,
+- "malformed word constant: " ^ !id ^ str(!ch))
++ else lexError(state, "malformed word constant: " ^ !id ^ str(!ch))
+ )
+ else if isNumeric (!ch)
+ then id := readChars state isNumeric "0w"
+- else
+- errorMessage (state, lineno state,
+- "malformed word constant: " ^ !id ^ str(!ch))
++ else lexError(state, "malformed word constant: " ^ !id ^ str(!ch))
+ )
+ else if !ch = #"x" andalso !id = "0"
+ then (* Hexadecimal integer constant. *)
+@@ -325,9 +308,7 @@
+ nextCh state;
+ if isHexadecimal (!ch)
+ then id := readChars state isHexadecimal "0x"
+- else
+- errorMessage (state, lineno state,
+- "malformed integer constant: " ^ !id ^ str(!ch))
++ else lexError(state, "malformed integer constant: " ^ !id ^ str(!ch))
+ )
+ else if !ch = #"." orelse
+ !ch = #"E" orelse !ch = #"e" (* "e" is allowed in ML97 *)
+@@ -342,9 +323,7 @@
+ nextCh state;
+ (* Must be followed by at least one digit. *)
+ if not (isNumeric (!ch))
+- then
+- errorMessage (state, lineno state,
+- "malformed real number: " ^ !id ^ str(!ch))
++ then lexError(state, "malformed real number: " ^ !id ^ str(!ch))
+ else id := readChars state isNumeric (!id)
+ )
+ else ();
+@@ -394,9 +373,9 @@
+ fun getString (soFar: char list) =
+ (
+ case !ch of
+- #"\"" (* double-quote. *) => (* Finished - return result. *) (chRead state; soFar)
++ #"\"" (* double-quote. *) => (* Finished - return result. *) (setSymbolEnd state; nextCh state; soFar)
+
+- | #"\n" => (nextCh state; raise EndOfLine)
++ | #"\n" => (setSymbolEnd state; nextCh state; raise EndOfLine)
+
+ | #"\\" => (* Escape *)
+ let
+@@ -415,8 +394,7 @@
+ if skipWhiteSpace state = #"\\" then ()
+ else
+ (
+- errorMessage (state, lineno state,
+- "unexpected character " ^
++ lexError(state, "unexpected character " ^
+ String.toString (str (!ch)) ^" in \\ ... \\");
+ while !ch <> #"\\" andalso !ch <> #"\"" andalso !ch <> eofChar
+ do nextCh state
+@@ -424,13 +402,13 @@
+ nextCh state;
+ getString soFar
+ )
+- else if next = #"^" (* \^c escape sequence for Control+c *)
+- then let
+- val next2 = !ch;
+- val _ = nextCh state;
+- in getString (next2 :: #"^" :: #"\\" :: soFar)
+- end
+- else getString (next :: #"\\" :: soFar)
++ else if next = #"^" (* \^c escape sequence for Control+c *)
++ then let
++ val next2 = !ch;
++ val _ = nextCh state;
++ in getString (next2 :: #"^" :: #"\\" :: soFar)
++ end
++ else getString (next :: #"\\" :: soFar)
+ end
+
+ | ch => (* Anything else *)
+@@ -441,8 +419,7 @@
+ then getString (ch :: soFar)
+ else (* Report unprintable characters. *)
+ (
+- errorMessage (state, lineno state,
+- "unprintable character " ^ Char.toString ch ^ " found in string");
++ lexError(state, "unprintable character " ^ Char.toString ch ^ " found in string");
+ getString soFar
+ )
+ )
+@@ -452,9 +429,8 @@
+ nextCh state; (* Skip the opening quote. *)
+
+ id := String.implode(List.rev(getString []))
+- handle EndOfLine =>
+- errorMessage (state, lineno state,
+- "no matching quote found on this line")
++ handle EndOfLine =>
++ lexError(state, "no matching quote found on this line")
+
+ end (* parseString *)
+
+@@ -467,19 +443,16 @@
+ and returns the first chararacter AFTER the comment. *)
+ fun skipComment () : char =
+ let
+- val startLine : int = lineno state;
+-
+ (* Returns the first chararacter AFTER the comment *)
+ fun skipCommentBody (firstCh : char) : char =
+- if firstCh = eofChar
+- then
+- (
+- errorMessage (state, lineno state,
+- "end of file found in comment (starts at line " ^
+- Int.toString startLine ^ ")");
++ if firstCh = eofChar
++ then
++ (
++ setSymbolEnd state;
++ lexError(state, "end of file found in comment");
+ firstCh
+- )
+- else case (firstCh, getOpt(stream (), eofChar)) of
++ )
++ else case (firstCh, getOpt(stream (), eofChar)) of
+ (#"*", #")") => getOpt(stream (), eofChar) (* End of comment - return next ch. *)
+ | (#"(", #"*") => skipCommentBody (skipComment ()) (* Nested comment. *)
+ | (_, nextCh) => skipCommentBody nextCh
+@@ -512,8 +485,7 @@
+ else if isOperator c
+ then parseIdent state isOperator (idVal ^ ".")
+
+- else errorMessage (state, lineno state,
+- "invalid identifer - "^ idVal ^ "." ^ str c)
++ else lexError(state, "invalid identifer - "^ idVal ^ "." ^ str c)
+ end
+ else
+ (
+@@ -527,8 +499,12 @@
+
+ (* Main lexical analyser loop. *)
+ fun parseToken (state as { ch, id, sy, ... }) =
+- (
+- case skipWhiteSpace state (* remove leading spaces *) of
++ let
++ val nextSym = skipWhiteSpace state (* remove leading spaces *)
++ in
++ setSymbolStart state; (* Set the start to the previous end and the end to after this. *)
++
++ case nextSym of
+ #"~" => (* Either an operator or part of a number. *)
+ (
+ nextCh state;(* get next character *)
+@@ -562,9 +538,18 @@
+
+ | #"\"" (* double quote. *) => (parseString state; sy := stringConst)
+
+- | #";" => (sy := semicolon; chRead state)
++ | #";" =>
++ (
++ sy := semicolon;
++ (* This is a special case. If this is the final semicolon
++ in the top-dec we mustn't read the next character because
++ that will be put into "ch" field of this lex object and will
++ then be discarded. Instead we clobber this with a space so that
++ the normal space-skipping case will apply. *)
++ ch := #" "
++ )
+
+- | #"," => (sy := comma; chRead state)
++ | #"," => (sy := comma; nextCh state)
+
+ | #"(" =>
+ (
+@@ -572,33 +557,32 @@
+ if !ch <> #"*" then sy := leftParen else parseComment state
+ )
+
+- | #")" => (sy := rightParen; chRead state)
++ | #")" => (sy := rightParen; nextCh state)
+
+- | #"[" => (sy := leftBrack; chRead state)
++ | #"[" => (sy := leftBrack; nextCh state)
+
+- | #"]" => (sy := rightBrack; chRead state)
++ | #"]" => (sy := rightBrack; nextCh state)
+
+- | #"_" => (sy := underline; chRead state)
++ | #"_" => (sy := underline; nextCh state)
+
+- | #"{" => (sy := leftCurly; chRead state)
++ | #"{" => (sy := leftCurly; nextCh state)
+
+- | #"}" => (sy := rightCurly; chRead state)
++ | #"}" => (sy := rightCurly; nextCh state)
+
+ | #"." => (* "..." *)
+- (
++ (
+ nextCh state;
+ if !ch <> #"."
+- then errorMessage (state, lineno state,
+- "unknown symbol ." ^ str(!ch))
++ then lexError(state, "unknown symbol ." ^ str(!ch))
+ else
+ (
+- nextCh state;
+- if !ch <> #"."
+- then errorMessage (state, lineno state,
+- "unknown symbol .." ^ str(!ch))
+- else (sy := threeDots; chRead state)
++ nextCh state;
++ setSymbolEnd state;
++ if !ch <> #"."
++ then lexError(state, "unknown symbol .." ^ str(!ch))
++ else (sy := threeDots; nextCh state; setSymbolEnd state)
+ )
+- )
++ )
+
+ | firstCh =>
+ (* These can't be so easily incorporated into a "case". *)
+@@ -619,13 +603,12 @@
+ val printableFirstCh = Char.toString firstCh
+ in
+ (* Report the character. *)
+- errorMessage (state, lineno state,
+- "unknown character \"" ^ printableFirstCh ^ "\"");
+- chRead state
++ lexError(state, "unknown character \"" ^ printableFirstCh ^ "\"");
++ nextCh state
+ end;
+ (* Read another token if this wasn't recognised. *)
+ if (!sy eq othersy) then parseToken state else ()
+- ); (* parseToken *)
++ end; (* parseToken *)
+
+ (* Insymbol - exported interface to lexical analyser. *)
+ fun insymbol (state as {sy,pushedSym,...}:lexan) =
+@@ -640,8 +623,9 @@
+ if (! sy) eq abortParse (* already end-of-file? *)
+ then
+ (
+- errorMessage (state, lineno state, "unexpected end of file encountered");
+- raise InternalError "end of file"
++ setSymbolStart state;
++ lexError(state, "unexpected end of file encountered");
++ raise InternalError "end of file"
+ )
+ else ();
+
+@@ -662,5 +646,25 @@
+ fun id ({id=ref id,...}:lexan) = id;
+
+ val debugParams = #debugParams
++
++ val nullLocation: location =
++ { file="", startLine=0, startPosition=0, endLine=0, endPosition=0 }
++
++ (* Construct the location that includes all the locations in
++ the list. Used to combine the locations of individual lexical
++ units into a location for a larger syntactic unit. *)
++ fun locSpan ({ file, startLine, startPosition, ... }: location,
++ { endLine, endPosition, ... }: location) =
++ {
++ file=file, startLine=startLine, startPosition=startPosition,
++ endLine=endLine, endPosition=endPosition
++ }
++
++ structure Sharing =
++ struct
++ type pretty = pretty
++ and lexan = lexan
++ and sys = sys
++ end
+
+ end (* LEX functor body *);
+diff -u -r mlsource/MLCompiler/Lex.ML mlsource/MLCompiler/Lex.ML
+--- mlsource/MLCompiler/Lex.ML 2008-04-21 13:36:11.000000000 +0200
++++ mlsource/MLCompiler/Lex.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -20,8 +20,7 @@
+ structure Lex =
+ LEX_
+ (
++ structure PRETTY = Pretty
+ structure SYMBOLS = Symbols
+- structure MISC = Misc
+- structure PRETTYPRINTER = PrettyPrinter
+ structure DEBUG = Debug
+ );
+diff -u -r mlsource/MLCompiler/MAKE_.ML mlsource/MLCompiler/MAKE_.ML
+--- mlsource/MLCompiler/MAKE_.ML 2008-04-21 13:36:11.000000000 +0200
++++ mlsource/MLCompiler/MAKE_.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -2,7 +2,7 @@
+ Copyright (c) 2000
+ Cambridge University Technical Services Limited
+
+- Modified David C.J. Matthews 2008.
++ Modified David C.J. Matthews 2008-9.
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+@@ -25,7 +25,10 @@
+ Copyright Cambridge University 1985
+ *)
+
+-(* This code is now only used during the bootstrap process. *)
++(* This previously contained PolyML.make which was passed through to
++ the basis. It has now been reduced to just "use" and is
++ only used during the bootstrap process to compile the basis
++ library itself. *)
+
+ functor MAKE_ (
+
+@@ -66,12 +69,19 @@
+ allFunct: unit -> (string*functors) list
+ };
+
++ type location =
++ { file: string, startLine: int, startPosition: int, endLine: int, endPosition: int }
++
++ (* Export tree. *)
++ type exportTree
++
+ (* The completed compiler. *)
+ val compiler :
+- nameSpace * (unit->char option) * Universal.universal list -> unit ->
+- { fixes: (string * fixStatus) list, values: (string * values) list,
+- structures: (string * structVals) list, signatures: (string * signatures) list,
+- functors: (string * functors) list, types: (string * typeConstrs) list };
++ nameSpace * (unit->char option) * Universal.universal list ->
++ exportTree option * ( unit ->
++ { fixes: (string * fixStatus) list, values: (string * values) list,
++ structures: (string * structVals) list, signatures: (string * signatures) list,
++ functors: (string * functors) list, types: (string * typeConstrs) list }) option
+
+ end;
+
+@@ -110,64 +120,32 @@
+ (*****************************************************************************)
+ (* STRUCTVALS *)
+ (*****************************************************************************)
+-structure STRUCTVALS :
+-sig
+- type 'a tag = 'a Universal.tag;
+-
+- type types;
+- type values;
+- type typeConstrs;
+- type fixStatus;
+- type structVals;
+- type signatures;
+- type functors;
+-
+- datatype env =
+- Env of
+- {
+- lookupVal: string -> values option,
+- lookupType: string -> typeConstrs option,
+- lookupFix: string -> fixStatus option,
+- lookupStruct: string -> structVals option,
+- lookupSig: string -> signatures option,
+- lookupFunct: string -> functors option,
+-
+- enterVal: string * values -> unit,
+- enterType: string * typeConstrs -> unit,
+- enterFix: string * fixStatus -> unit,
+- enterStruct: string * structVals -> unit,
+- enterSig: string * signatures -> unit,
+- enterFunct: string * functors -> unit
+- };
+-
+- val valueVar: values tag;
+- val typeConstrVar: typeConstrs tag;
+- val fixVar: fixStatus tag;
+- val structVar: structVals tag;
+- val signatureVar: signatures tag;
+- val functorVar: functors tag;
+-end;
++structure STRUCTVALS : STRUCTVALSIG;
+
+ structure MISC :
+ sig
+- type 'a iter
+- exception InternalError of string; (* compiler bugs *)
+-
+- val revfoldIterator : ('a -> 'b -> 'b) -> 'b -> 'a iter -> 'b
+- val mapIterator : ('a -> 'b) -> 'a iter -> 'b list
+-
+- val quickSort : ('a -> 'a -> bool) -> 'a list -> 'a list
++ type 'a iter
+ val iterList : 'a iter -> 'a list
+ end;
+
+ structure DEBUG:
+ sig
+- val errorMessageProcTag: (string * bool * int -> unit) Universal.tag
+- val compilerOutputTag: (string->unit) Universal.tag
+ val lineNumberTag: (unit->int) Universal.tag
+ val maxInlineSizeTag: int Universal.tag
++ val traceCompilerTag: bool Universal.tag
++ val fileNameTag: string Universal.tag
++ val reportUnreferencedIdsTag: bool Universal.tag
+ end
+
++structure PRETTY: PRETTYSIG (* For compilerOutputTag *)
++
++structure LEX: LEXSIG (* For errorMessageProcTag *)
++
++structure VERSION:
++ sig
++ val versionSuffix: string
++ end
++
+ (*****************************************************************************)
+ (* MAKE sharing constraints *)
+ (*****************************************************************************)
+@@ -200,6 +178,11 @@
+ sharing type
+ STRUCTVALS.functors
+ = COMPILERBODY.functors
++
++sharing type
++ LEX.pretty
++= PRETTY.pretty
++
+ )
+ :
+
+@@ -240,16 +223,23 @@
+ allSig: unit -> (string*signatures) list,
+ allFunct: unit -> (string*functors) list
+ };
++
++ type location =
++ { file: string, startLine: int, startPosition: int, endLine: int, endPosition: int }
++
++ type exportTree
+
+- val compiler : nameSpace * (unit->char option) * Universal.universal list -> unit ->
+- { fixes: (string * fixStatus) list, values: (string * values) list,
+- structures: (string * structVals) list, signatures: (string * signatures) list,
+- functors: (string * functors) list, types: (string * typeConstrs) list };
++ val compiler : nameSpace * (unit->char option) * Universal.universal list ->
++ exportTree option * ( unit ->
++ { fixes: (string * fixStatus) list, values: (string * values) list,
++ structures: (string * structVals) list, signatures: (string * signatures) list,
++ functors: (string * functors) list, types: (string * typeConstrs) list }) option
+
+ val makeGEnv : unit -> gEnv
+ val gEnvAsEnv : gEnv -> env
+ val gEnvAsNameSpace: gEnv -> nameSpace
+- val useIntoEnv : gEnv -> string -> unit
++ val useIntoEnv : gEnv -> string -> unit
++ val useStringIntoEnv: gEnv -> string -> unit
+ val shellProc : gEnv -> unit -> unit (* The command processor *)
+ end =
+
+@@ -271,8 +261,6 @@
+ type env = STRUCTVALS.env
+
+ open COMPILERBODY
+-
+- val eofChar = Char.chr 4; (* ctrl/D *)
+
+ local
+ open UNIVERSALTABLE
+@@ -310,10 +298,6 @@
+ fun dbEnvLookup (DbEnv(mutx, db)) (t : 'a tag) (s : string) : 'a option =
+ protect mutx(fn () => univLookup (db, t, s))
+
+- (* delete an entry, but only from the top-level table *)
+- fun dbEnvForget (DbEnv(mutx, db)) (s : string, t : 'a tag) : unit =
+- protect mutx (fn () => univDelete (db, t, s))
+-
+ fun dbEnvAll (DbEnv(mutx, db)) (t : 'a tag) () : (string * 'a) list =
+ protect mutx (fn () => iterList (univOverSpecific (db, t)))
+
+@@ -363,9 +347,8 @@
+ (*****************************************************************************)
+ (* useIntoEnv (runcompiler with ML compiler bound in) *)
+ (*****************************************************************************)
+- fun useIntoEnv (globalEnv : gEnv) : string -> unit =
++ fun compileIntoEnv (globalEnv : gEnv) : (string * TextIO.instream) -> unit =
+ let
+-
+ val useEnv : nameSpace =
+ {
+ lookupFix = dbEnvLookup globalEnv STRUCTVALS.fixVar,
+@@ -388,16 +371,8 @@
+ allFunct = dbEnvAll globalEnv STRUCTVALS.functorVar
+ };
+
+- (*****************************************************************************)
+- (* use *)
+- (*****************************************************************************)
+- fun use (fileName : string) =
+- let
+- val inStream =
+- if fileName = ""
+- then TextIO.stdIn
+- else TextIO.openIn fileName;
+-
++ fun use (fileName, inStream) =
++ let
+ val lineNo = ref 1;
+ val eof = ref false;
+
+@@ -411,33 +386,37 @@
+ | NONE => (eof := true; NONE)
+ | c => c
+
+- fun errorProc (message, hard, line) =
++ fun errorProc {message, hard, location={ file, startLine=line, ... }, ...} =
+ TextIO.print(concat
+ [if hard then "Error-" else "Warning-",
+- " in '", fileName, "', line ", Int.toString line, ".\n",
+- message])
++ " in '", file, "', line ", Int.toString line, ".\n",
++ PRETTY.uglyPrint message, "\n"])
+ in
+ (
+ while not (! eof) do
+ let
+ open DEBUG Universal
+
+- (* Compile the code *)
+- val code = COMPILERBODY.compiler
+- (useEnv, getChar,
+- [
+- tagInject compilerOutputTag print,
+- tagInject lineNumberTag (fn () => !lineNo),
+- tagInject errorMessageProcTag errorProc,
+- (* Set the debug level to 50 while compiling the basis. This makes
+- sure that String.foldr can be expanded inline which reduces the
+- garbage in the hashValue function. *)
+- tagInject maxInlineSizeTag 50
+- (* Need printer environment so that when we compile General.exnMessage
+- it all works. *)
+- ] )
++ (* Compile the code *)
++ val code =
++ case COMPILERBODY.compiler
++ (useEnv, getChar,
++ [
++ tagInject traceCompilerTag true,
++ tagInject PRETTY.compilerOutputTag (print o PRETTY.uglyPrint),
++ tagInject lineNumberTag (fn () => !lineNo),
++ tagInject fileNameTag fileName,
++ tagInject LEX.errorMessageProcTag errorProc,
++ (* Set the debug level to 50 while compiling the basis. This makes
++ sure that String.foldr can be expanded inline which reduces the
++ garbage in the hashValue function. *)
++ tagInject maxInlineSizeTag 50,
++ tagInject reportUnreferencedIdsTag true
++ ] ) of
++ (_, NONE) => raise Fail "Static Errors"
++ | (_, SOME c) => c
+ (* execute the code and get the resulting declarations. *)
+- val { fixes, values, structures, signatures, functors, types } = code ()
++ val { fixes, values, structures, signatures, functors, types } = PolyML.exception_trace code
+ in
+ (* Just enter the values in the environment without printing. *)
+ List.app (#enterFix useEnv) fixes;
+@@ -458,15 +437,50 @@
+ print ("Exception- " ^ General.exnName exn ^ " raised\n");
+ TextIO.closeIn inStream;
+ raise exn
+- );
+-
+- TextIO.closeIn inStream
++ )
+ end (* use *)
+ in
+ use
+- end; (* scope of useIntoEnv *)
++ end; (* scope of compileIntoEnv *)
+
+-fun shellProc (globalEnv : gEnv) () : unit = useIntoEnv (globalEnv : gEnv) ""
++ fun useIntoEnv globalEnv baseName =
++ let
++ val () = print ("Use: " ^ baseName ^ "\n")
++ (* See if there is a path given as a command line argument. *)
++ val args = CommandLine.arguments();
++ (* If we have -o filename use that as the output name.
++ N.B. polyImport takes the first argument that is not recognised as
++ an RTS argument and treats that as the file name so any -o must occur
++ AFTER the import file. *)
++ fun getPath [] = "." (* Default path *)
++ | getPath ("-I" :: path :: _) = path
++ | getPath (_::tl) = getPath tl
++ open OS.Path
++ val filePath = joinDirFile { dir = getPath args, file = baseName }
++ open VERSION
++ (* See if we have a version of the file specific to this
++ version of the compiler. For x.ML see if x.VER.ML exists.
++ When bootstrapping from one version of the compiler to
++ another we need to compile the basis library in both the
++ old and new compiler. If the interface has changed we may
++ need version-specific files. *)
++ val { base, ext } = splitBaseExt filePath
++ val versionName =
++ joinBaseExt {
++ base = joinBaseExt{base = base, ext = SOME versionSuffix},
++ ext = ext }
++ val (inStream, fileName) =
++ (TextIO.openIn versionName, versionName)
++ handle IO.Io _ => (TextIO.openIn filePath, filePath)
++ in
++ compileIntoEnv globalEnv (fileName, inStream);
++ TextIO.closeIn inStream
++ end
++
++ fun shellProc globalEnv () = compileIntoEnv globalEnv ("<stdin>", TextIO.stdIn)
++
++ fun useStringIntoEnv globalEnv str =
++ compileIntoEnv globalEnv (str, TextIO.openString str)
+
+ end (* MAKE *)
+
+diff -u -r mlsource/MLCompiler/Make.ML mlsource/MLCompiler/Make.ML
+--- mlsource/MLCompiler/Make.ML 2008-04-21 13:36:11.000000000 +0200
++++ mlsource/MLCompiler/Make.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -26,4 +26,6 @@
+ structure MISC = Misc;
+ structure UNIVERSALTABLE = UniversalTable
+ structure DEBUG = Debug
++ structure PRETTY = Pretty
++ structure VERSION = CompilerVersion
+ );
+Only in mlsource/MLCompiler: PARSETREESIG.sml
+diff -u -r mlsource/MLCompiler/PARSE_DEC.ML mlsource/MLCompiler/PARSE_DEC.ML
+--- mlsource/MLCompiler/PARSE_DEC.ML 2008-04-21 13:36:11.000000000 +0200
++++ mlsource/MLCompiler/PARSE_DEC.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -1,20 +1,22 @@
+ (*
+- Copyright (c) 2000-7
+- Cambridge University Technical Services Limited
++ Copyright (c) 2000-7
++ Cambridge University Technical Services Limited
+
+- This library is free software; you can redistribute it and/or
+- modify it under the terms of the GNU Lesser General Public
+- License as published by the Free Software Foundation; either
+- version 2.1 of the License, or (at your option) any later version.
+-
+- This library is distributed in the hope that it will be useful,
+- but WITHOUT ANY WARRANTY; without even the implied warranty of
+- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+- Lesser General Public License for more details.
+-
+- You should have received a copy of the GNU Lesser General Public
+- License along with this library; if not, write to the Free Software
+- Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
++ Further Development Copyright 2009 David C.J. Matthews.
++
++ This library is free software; you can redistribute it and/or
++ modify it under the terms of the GNU Lesser General Public
++ License as published by the Free Software Foundation; either
++ version 2.1 of the License, or (at your option) any later version.
++
++ This library is distributed in the hope that it will be useful,
++ but WITHOUT ANY WARRANTY; without even the implied warranty of
++ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
++ Lesser General Public License for more details.
++
++ You should have received a copy of the GNU Lesser General Public
++ License along with this library; if not, write to the Free Software
++ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+ *)
+
+ (*
+@@ -25,10 +27,7 @@
+
+
+ functor PARSE_DEC (
+-
+-(*****************************************************************************)
+-(* SYMBOLS *)
+-(*****************************************************************************)
++
+ structure SYMBOLS :
+ sig
+ type sys
+@@ -81,8 +80,8 @@
+ val realConst: sys
+ val stringConst: sys
+ val integerConst: sys
+- val charConst: sys
+- val wordConst: sys
++ val charConst: sys
++ val wordConst: sys
+ val asterisk: sys
+ val arrow: sys
+ val leftCurly: sys
+@@ -99,15 +98,12 @@
+ val withtypeSy: sys
+ val eqtypeSy: sys
+ val includeSy: sys
+- val whereSy: sys;
++ val whereSy: sys;
+
+ val eq: sys * sys -> bool
+ val neq: sys * sys -> bool
+ end;
+
+-(*****************************************************************************)
+-(* SYMSET *)
+-(*****************************************************************************)
+ structure SYMSET :
+ sig
+ type symset
+@@ -167,319 +163,98 @@
+ val startTopSys: symset
+ end;
+
+-(*****************************************************************************)
+-(* LEX *)
+-(*****************************************************************************)
+-structure LEX :
+-sig
+- type lexan
+- type sys
+-
+- val insymbol: lexan -> unit
+-
+- (* insymbol sets sy and id which are exported as "read-only" *)
+-
+- val sy: lexan -> sys
+- val id: lexan -> string
+- val lineno: lexan -> int
+-
+- (* pushBackSymbol is a hack. It pushes a symbol back into
+- the lexical analysis stream. *)
+- val pushBackSymbol: lexan * sys -> unit;
+-
+- (* Error handling *)
+- val errorMessage: lexan * int * string -> unit
+- val warningMessage: lexan * int * string -> unit
+-
+- val debugParams: lexan -> Universal.universal list
+-end;
++structure LEX : LEXSIG
+
+-(*****************************************************************************)
+-(* SKIPS *)
+-(*****************************************************************************)
+ structure SKIPS :
+ sig
+ type sys
+ type lexan
+ type symset
++ type location =
++ { file: string, startLine: int, startPosition: int, endLine: int, endPosition: int }
+
+ val testfor: sys * symset * lexan -> bool
+ val getsym: sys * lexan -> unit
+ val badsyms: sys * lexan -> unit
+ val notfound: string * lexan -> unit
+ val skipon: symset * symset * string * lexan -> unit
+- val getid: symset * symset * lexan -> string
+- val getLabel: symset * lexan -> string
+- val getList: sys * symset * lexan * (unit -> 'a) -> 'a list
+-end;
+-
+-(*****************************************************************************)
+-(* STRUCTVALS *)
+-(*****************************************************************************)
+-structure STRUCTVALS :
+-sig
+- type types
+-
+- type values;
+- type typeConstrs;
+- type structVals;
+-
+- val badType: types
+- val emptyType: types
+-
+- val generalisable: int
+-
+- (* Infix status *)
+-
+- datatype fixStatus =
+- Infix of int
+- | InfixR of int
+- | Nonfix;
+-
+- val undefinedValue: values;
+- val undefinedStruct: structVals;
++ val getid: symset * symset * lexan -> string * location
++ val getLabel: symset * lexan -> string * location
++ val getList: sys * symset * lexan * (unit -> 'a * location) -> 'a list * location;
+ end;
+-
+-(*****************************************************************************)
+-(* TYPETREE *)
+-(*****************************************************************************)
+-structure TYPETREE :
+-sig
+- type types
+
+- val unitType: types
+- val mkTypeVar: int * bool * bool * bool -> types
+- val mkLabelled: {name: string, typeof: types } list * bool -> types;
+- val mkLabelEntry: string * types -> {name: string, typeof: types };
+- val mkFunctionType: types * types -> types;
+-
+- (* added 6/12/95 SPS *)
+- val badType: types;
+-end;
+-
+-(*****************************************************************************)
+-(* PARSETREE *)
+-(*****************************************************************************)
+-structure PARSETREE :
+-sig
+- type types
+- type fixStatus
+-
+- (********* parsetree definition copied here to reduce garbage ***************)
++structure STRUCTVALS : STRUCTVALSIG;
+
+- type typeConstrs;
+- type values;
+- type structVals;
+-
+- (* An identifier is just a name. In the second pass it is associated
+- with a particular declaration and the type is assigned into the
+- type field. The type of this identifier is needed to deal with
+- overloaded operators. If we have an occurence of ``='', say, the
+- type of the value will be 'a * 'a -> bool but the type of a particular
+- occurence, i.e. the type of the identifier must be int * int -> bool,
+- say, after all the unification has been done. *)
+-
+- type parsetree and valbind and fvalbind and fvalclause and typebind
+- and datatypebind and exbind and structureIdentForm;
+-
+- val isIdent : parsetree -> bool;
++structure TYPETREE : TYPETREESIG;
+
+- val mkIdent : string -> parsetree;
+- val mkString : string -> parsetree;
+- val mkInt : string -> parsetree;
+- val mkReal : string -> parsetree;
+- val mkChar : string -> parsetree;
+- val mkWord : string -> parsetree;
+- val mkApplic : parsetree * parsetree -> parsetree;
+-
+- val mkCond : parsetree * parsetree * parsetree -> parsetree;
+- val mkTupleTree : parsetree list -> parsetree;
+-
+- val mkValDeclaration :
+- valbind list *
+- {
+- lookup: string -> types option,
+- apply: (string * types -> unit) -> unit
+- } *
+- {
+- lookup: string -> types option,
+- apply: (string * types -> unit) -> unit
+- } -> parsetree;
+-
+- val mkFunDeclaration :
+- fvalbind list *
+- {
+- lookup: string -> types option,
+- apply: (string * types -> unit) -> unit
+- } *
+- {
+- lookup: string -> types option,
+- apply: (string * types -> unit) -> unit
+- } -> parsetree;
+-
+- val mkOpenTree : structureIdentForm list -> parsetree;
+- val mkStructureIdent : string -> structureIdentForm;
+- val mkValBinding : parsetree * parsetree * int -> valbind;
+- val recValbind: valbind;
+- val mkClausal : fvalclause list -> fvalbind;
+- val mkClause : parsetree * parsetree * int -> fvalclause;
+- val mkList : parsetree list -> parsetree;
+- val mkConstraint : parsetree * types -> parsetree;
+- val mkLayered : parsetree * parsetree -> parsetree;
+- val mkFn : parsetree list -> parsetree;
+- val mkMatchTree : parsetree * parsetree * int -> parsetree;
+- val mkLocalDeclaration :
+- (parsetree * int) list * (parsetree * int) list * bool -> parsetree;
+- val mkTypeDeclaration : typebind list -> parsetree;
+- val mkDatatypeDeclaration : datatypebind list * typebind list -> parsetree;
+- val mkDatatypeReplication : string * string -> parsetree;
+- val mkAbstypeDeclaration :
+- datatypebind list * typebind list * (parsetree * int) list -> parsetree;
+- val mkTypeBinding : string * types list * types * bool -> typebind;
+- val mkDatatypeBinding : string * types list * (string*types) list -> datatypebind;
+- val mkExBinding : string * parsetree * types -> exbind;
+- val mkLabelledTree : (string * parsetree) list * bool -> parsetree;
+- val mkSelector : string -> parsetree;
+- val mkRaise : parsetree -> parsetree;
+- val mkHandleTree : parsetree * parsetree list -> parsetree;
+- val mkWhile : parsetree * parsetree -> parsetree;
+- val mkCase : parsetree * parsetree list -> parsetree;
+- val mkAndalso : parsetree * parsetree -> parsetree;
+- val mkOrelse : parsetree * parsetree -> parsetree;
+- val mkDirective : string list * fixStatus -> parsetree;
+- val mkExpseq : (parsetree * int) list -> parsetree;
+- val mkExDeclaration : exbind list -> parsetree;
+- val unit : parsetree;
+- val wildCard : parsetree;
+- val emptyTree : parsetree;
+-end;
++structure PARSETREE : PARSETREESIG
+
+-(*****************************************************************************)
+-(* STRUCTURES *)
+-(*****************************************************************************)
+-structure STRUCTURES :
+-sig
+- (* Structures form the global name spaces. *)
+- type structs
+- type types
+- type parsetree
+- type sigBind and functorBind and structBind
+-
+- val emptyStruct: structs (* added SPF 6/2/94 *)
+- val mkStructureDec: structBind list -> structs
+- val mkStruct: structs list -> structs
+- val mkSignatureDec: sigBind list -> structs
+- val mkSig: structs list -> structs
+- val mkFunctorDec: functorBind list -> structs
+- val mkInclude: structs list -> structs
+- val mkLocaldec: structs list * structs list * bool * int -> structs
+- val mkTopLevel: parsetree * int -> structs
+- val mkStructureBinding: string * structs * bool * structs * int -> structBind
+- val mkStructIdent: string -> structs
+- val mkSigIdent: string -> structs
+- val mkSignatureBinding: string * structs * int -> sigBind
+- val mkValSig: string * types * int -> structs
+- val mkExSig: string * types * int -> structs
+- val mkFunctorAppl: string * structs -> structs
+- val mkFormalArg: string * structs -> structs
+- val mkFunctorBinding: string * structs * bool * structs * structs * int -> functorBind
+- val mkSharing: bool * string list * int -> structs
+- val mkWhereType: structs * types list * string * types * int -> structs
+- val mkSigConstraint: structs * structs * bool -> structs
+-end; (* STRUCTURES *)
++structure STRUCTURES : STRUCTURESSIG
++structure SIGNATURES: SIGNATURESSIG
+
+-(*****************************************************************************)
+-(* PARSETYPE *)
+-(*****************************************************************************)
+ structure PARSETYPE :
+ sig
+- type symset
+- type lexan
+- type types
++ type symset;
++ type lexan;
++ type types;
++ type typeParsetree;
++ type typeVarForm
++ type location =
++ { file: string, startLine: int, startPosition: int, endLine: int, endPosition: int }
+
+- val parseType: symset * lexan * {lookupTvar:string -> types} -> types
++ val parseType: symset * lexan * {lookupTvar:string -> typeVarForm} -> typeParsetree * location;
+ end;
+
+-(*****************************************************************************)
+-(* UTILITIES *)
+-(*****************************************************************************)
+ structure UTILITIES :
+ sig
+- type lexan
++ type lexan
++ type location =
++ { file: string, startLine: int, startPosition: int, endLine: int, endPosition: int }
+
+- val searchList: unit -> { apply: (string * 'a -> unit) -> unit,
++ val searchList: unit -> { apply: (string * 'a -> unit) -> unit,
+ enter: string * 'a -> unit,
+ lookup: string -> 'a option }
+
+- val checkForDots: string * lexan * int -> unit
++ val checkForDots: string * lexan * location -> unit
++
++ val noDuplicates: (string * 'a * 'a -> unit) ->
++ { apply: (string * 'a -> unit) -> unit,
++ enter: string * 'a -> unit,
++ lookup: string -> 'a option };
+
+ end;
+
+-(*****************************************************************************)
+-(* MISC *)
+-(*****************************************************************************)
+ structure MISC :
+ sig
+ val lookupDefault : ('a -> 'b option) -> ('a -> 'b option) -> 'a -> 'b option
+ end;
+
+-(*****************************************************************************)
+-(* DEBUG *)
+-(*****************************************************************************)
+-structure DEBUG :
+-sig
+- val ml90Tag: bool Universal.tag
+- val getParameter :
+- 'a Universal.tag -> Universal.universal list -> 'a
+-end;
+-
+-(*****************************************************************************)
+-(* PARSEDEC sharing constraints *)
+-(*****************************************************************************)
+-
+-sharing type
+- SYMBOLS.sys
+-= SYMSET.sys
+-= SKIPS.sys
+-= LEX.sys
++sharing STRUCTVALS.Sharing = TYPETREE.Sharing = PARSETREE.Sharing = STRUCTURES.Sharing
++ = LEX.Sharing = SIGNATURES.Sharing
++ = UTILITIES
+
+-sharing type
+- SYMSET.symset
+-= SKIPS.symset
+-= PARSETYPE.symset
++sharing SYMBOLS = SYMSET = SKIPS = LEX.Sharing
+
+-sharing type
+- LEX.lexan
+-= SKIPS.lexan
+-= PARSETYPE.lexan
+-= UTILITIES.lexan
+
+ sharing type
+- STRUCTVALS.types
+-= TYPETREE.types
+-= PARSETREE.types
+-= PARSETYPE.types
+-= STRUCTURES.types
++ PARSETYPE.types =
++ STRUCTVALS.Sharing.types
+
+ sharing type
+- STRUCTVALS.fixStatus
+-= PARSETREE.fixStatus
+-
+-sharing type
+- PARSETREE.parsetree
+-= STRUCTURES.parsetree
++ PARSETYPE.typeVarForm =
++ STRUCTVALS.Sharing.typeVarForm
+
+ sharing type
+- STRUCTVALS.values
+-= PARSETREE.values
++ PARSETYPE.typeParsetree =
++ TYPETREE.typeParsetree
+
+ sharing type
+- STRUCTVALS.structVals
+-= PARSETREE.structVals
++ SYMSET.symset
++= PARSETYPE.symset
+
+ sharing type
+- STRUCTVALS.typeConstrs
+-= PARSETREE.typeConstrs
++ LEX.lexan
++= PARSETYPE.lexan
+ ) :
+
+ (*****************************************************************************)
+@@ -489,10 +264,10 @@
+ type lexan;
+ type symset;
+ type fixStatus;
+- type structs;
++ type program
+
+ val parseDec: symset * lexan * { enterFix: string * fixStatus -> unit,
+- lookupFix: string -> fixStatus option } -> structs list;
++ lookupFix: string -> fixStatus option } -> program;
+ end =
+
+ (*****************************************************************************)
+@@ -515,7 +290,7 @@
+ open STRUCTURES;
+ open PARSETYPE;
+ open UTILITIES;
+- open DEBUG;
++ open SIGNATURES
+
+ (* constant sets defined here to reduce run-time garbage SPF 24/9/94 *)
+ val structureLocalSy = structureSy ++ localSy;
+@@ -532,7 +307,7 @@
+ val rightParenCommaSy = rightParen ++ comma;
+ val rightParenSemicolonSy = rightParen ++ semicolon;
+ val rightParenSemicolonCommaSy = rightParenSemicolonSy ++ comma;
+- val rightParenEqualsSignAndSy = rightParen ++ equalsSign ++ andSy;
++ val rightParenEqualsSignSy = rightParen ++ equalsSign;
+ val colonAsSy = colon ++ asSy;
+ val colonEqualsSignSy = colon ++ colonGt ++ equalsSign;
+ val thenStartExpressionSy = thenSy ++ startExpressionSys;
+@@ -546,12 +321,11 @@
+ val startSigEndSy = startSigSys ++ endSy;
+ val startSigEndAndSy = startSigEndSy ++ andSy;
+ val endAndSy = endSy ++ andSy;
+- val semicolonStartSigSys = startSigSys ++ semicolon;
++ val semicolonStartSigSys = startSigSys ++ semicolon;
+
+ val topdecStartSy = functorSy ++ signatureSy ++ structureLocalStartDecSy;
+
+- (* added SPF 6/2/94 *)
+- fun mkLocalFixEnv {enterFix,lookupFix,lookupTvar} =
++ fun mkLocalFixEnv {lookupFix,lookupTvar, ...} =
+ let
+ val newFixEnv = searchList ();
+ in
+@@ -562,153 +336,151 @@
+ }
+ end;
+
+- (* added SPF 6/2/94 *)
+ fun mkLocalBodyFixEnv {enterFix,lookupFix,lookupTvar} outerEnterFix =
+ {
+- enterFix = fn (p as (n, v)) => (enterFix p; outerEnterFix p),
++ enterFix = fn p => (enterFix p; outerEnterFix p),
+ lookupFix = lookupFix,
+ lookupTvar = lookupTvar
+ }
+
+- (* added SPF 17/4/96 *)
+- fun getLongId (kind, fsys, lex) =
++ fun getLongId (kind, fsys, lex): string * location =
+ getid (kind, fsys, lex);
+
+- (* added SPF 17/4/96 *)
+- fun getShortId (kind, fsys, lex) =
++ fun getShortId (kind, fsys, lex): string * location =
+ let
+- val iden = getid (kind, fsys, lex);
+- val U : unit = checkForDots (iden, lex, lineno lex);
++ val idLoc as (iden, location) = getid (kind, fsys, lex);
++ val () = checkForDots (iden, lex, location);
+ in
+- iden
++ idLoc
+ end;
+
+ (* Attributes of type variables. *)
+
+ fun isEqtype name =
+- size name > 1 andalso String.str(String.sub(name, 1)) = "'";
+-
+- (* All explicit type variables are weak in ML97. This provides
+- compatibility with ML90. *)
+- fun isWeak (name, lex) =
+- not (getParameter ml90Tag (debugParams lex)) orelse
+- (size name > 1 andalso String.str(String.sub(name, 1)) = "_") orelse
+- (isEqtype name andalso size name > 2
+- andalso String.str(String.sub(name, 2)) = "_");
+-
++ size name > 1 andalso String.str(String.sub(name, 1)) = "'";
+
+ (* Global declarations *)
+
+- fun parseDec (fsys, lex, {enterFix,lookupFix}) : structs list =
++ fun parseDec (fsys, lex, {enterFix,lookupFix}) : program =
+ let
+ (* These procedures to parse type declarations are used in both
+ signature and expression parsing. *)
+
+- fun getTypeVars (isDatatype, {apply,enter,lookup}) =
++ fun getTypeVars (isDatatype, {apply,enter,...}) =
+ let
+- (* Optional type identifier or sequence of type identifiers. Used
+- in type and datatype declarations and also in val and fun
+- declarations. *)
+- (* The type identifiers must be remembered since they will occur
+- subsequently in the components. This is the only case where type
+- variables are actually bound. *)
+- fun getTypeVar () : types =
++ (* Optional type identifier or sequence of type identifiers. Used
++ in type and datatype declarations and also in val and fun
++ declarations. *)
++ (* The type identifiers must be remembered since they will occur
++ subsequently in the components. This is the only case where type
++ variables are actually bound. *)
++ fun getTypeVar (): typeVarForm * location =
+ (* Read a type variable and return it. *)
+- if (sy lex) neq SYMBOLS.typeIdent
+- then (badsyms (SYMBOLS.typeIdent, lex); badType) (* SPF 6/12/95 *)
+- else let
+- val iden = id lex;
+-
+- (* Each type variable must be distinct. *)
+- val U : unit =
+- apply
+- (fn (nm,_) =>
+- if nm = iden (* Same name ? *)
+- then errorMessage (lex, lineno lex,
+- nm ^ " has already been used.")
+- else ()
+- );
+- (* Construct a type variable and enter it. Equality and weakness
+- are only set if this is a datatype (or abstype). The type variable
+- should be non-unifiable to get value-constructor signature
+- checking right.*)
+- (* DCJM 11/2/00. isDatatype is now true for tyvarseqs in fun and val.
+- I don't think it matters what it is set to in datatypes. *)
+- val isEqtype = isDatatype andalso isEqtype iden;
+- val isWeak = isDatatype andalso isWeak (iden, lex);
+- val tyVar = mkTypeVar (generalisable, isEqtype, true, isWeak);
+- in
+- enter (iden, tyVar);
+- insymbol lex;
+- tyVar
+- end; (* getTypeVar *)
++ if (sy lex) neq SYMBOLS.typeIdent
++ then (badsyms (SYMBOLS.typeIdent, lex); (makeTv (emptyType, generalisable, true, true), location lex))
++ else
++ let
++ val iden = id lex;
++ val locn = location lex
++
++ (* Each type variable must be distinct. *)
++ val () =
++ apply
++ (fn (nm,_) =>
++ if nm = iden (* Same name ? *)
++ then errorMessage (lex, location lex,
++ nm ^ " has already been used.")
++ else ()
++ );
++ (* Construct a type variable and enter it. Equality is
++ only set if this is a datatype (or abstype). The type variable
++ should be non-unifiable to get value-constructor signature
++ checking right.*)
++ (* DCJM 11/2/00. isDatatype is now true for tyvarseqs in fun and val.
++ I don't think it matters what it is set to in datatypes. *)
++ val isEqtype = isDatatype andalso isEqtype iden;
++ val tyVar = makeTv (emptyType, generalisable, isEqtype, true)
++ in
++ enter (iden, tyVar);
++ insymbol lex;
++ (tyVar, locn)
++ end; (* getTypeVar *)
+ in
+ (* May be one type variable or a bracketed sequence. *)
+ if (sy lex) eq SYMBOLS.typeIdent
+- then [getTypeVar()] (* One type var. *)
++ then [#1(getTypeVar())] (* One type var. *)
+ else if (sy lex) eq SYMBOLS.leftParen
+ then (* Sequence. *)
+- (
+- insymbol lex;
+- (* There is an awkward parsing problem here if we have either
+- val (a, b) = ... or fun (a X b) = ... We only know that we
+- haven't got a tyvarseq once we find a symbol that isn't a
+- tyvar. The easiest way round this is to push the parenthesis
+- back into the lex stream and return an empty tyvarseq. *)
+- if (sy lex) neq SYMBOLS.typeIdent
+- then (pushBackSymbol(lex, SYMBOLS.leftParen); [] )
+- else
+- let
+- val t = getList (SYMBOLS.comma, typeIdent, lex, getTypeVar);
+- in
+- getsym (SYMBOLS.rightParen, lex);
+- t
+- end
+- )
++ (
++ insymbol lex;
++ (* There is an awkward parsing problem here if we have either
++ val (a, b) = ... or fun (a X b) = ... We only know that we
++ haven't got a tyvarseq once we find a symbol that isn't a
++ tyvar. The easiest way round this is to push the parenthesis
++ back into the lex stream and return an empty tyvarseq. *)
++ if (sy lex) neq SYMBOLS.typeIdent
++ then (pushBackSymbol(lex, SYMBOLS.leftParen); [] )
++ else
++ let
++ val (t, _) = getList (SYMBOLS.comma, typeIdent, lex, getTypeVar);
++ in
++ getsym (SYMBOLS.rightParen, lex);
++ t
++ end
++ )
+ else [] (* None at all. *)
+ end; (* getTypeVars *)
+
+- fun getShortNonInfix opThere sys fsys lex {enterFix,lookupFix,lookupTvar} =
++ fun getShortNonInfix opThere sys fsys lex {lookupFix, ...} =
+ let
+ (* op followed by a (short) constructor *)
+- val id = getShortId (sys, fsys, lex);
++ val idLoc as (id, location) = getShortId (sys, fsys, lex);
+
+ val isInfix =
+ case lookupFix id of SOME (Infix _) => true | SOME (InfixR _) => true | _ => false
+ (* It is infix if we find it and it has been declared
+ as infix. If it hasn't been declared then it isn't infix.*)
+
+- val U : unit =
++ val () =
+ if isInfix andalso not opThere
+- then warningMessage (lex, lineno lex,
++ then warningMessage (lex, location,
+ "(" ^ id ^") has infix status but was not preceded by op.")
+ else ();
+ in
+- id
++ idLoc
+ end;
+
+- fun getLongNonInfix opThere sys fsys lex {enterFix,lookupFix,lookupTvar} =
++ fun getLongNonInfix opThere sys fsys lex {lookupFix,...} =
+ let
+ (* op followed by a (long) variable *)
+- val id = getLongId (sys, fsys, lex);
++ val idLoc as (id, location) = getLongId (sys, fsys, lex);
+ val isInfix =
+ case lookupFix id of SOME (Infix _) => true | SOME (InfixR _) => true | _ => false
+ in
+ if isInfix andalso not opThere
+- then warningMessage (lex, lineno lex,
++ then warningMessage (lex, location,
+ "(" ^ id ^") has infix status but was not preceded by op.")
+ else ();
+- id
++ idLoc
+ end;
+
+- fun andBindings fsys p =
+- (* Handles a sequence of non-recursive declarations separated by "and". *)
+- p (fsys ++ andSy) ::
+- (if testfor (SYMBOLS.andSy, empty, lex)
+- then andBindings fsys p
+- else []);
++ fun andBindings(fsys, p: symset -> 'a * location) : 'a list * location =
++ (* Handles a sequence of non-recursive declarations separated by "and".
++ Returns the list plus the spanning location. *)
++ let
++ val (item, itemLocn) = p (fsys ++ andSy)
++ in
++ if testfor (SYMBOLS.andSy, empty, lex)
++ then
++ let
++ val (rest, restLocn) = andBindings(fsys, p)
++ in
++ (item::rest, locSpan(itemLocn, restLocn))
++ end
++ else ([item], itemLocn)
++ end
+
+- fun genTypeVarEnv {lookup,enter,apply} =
++ fun genTypeVarEnv {lookup,...} =
+ {
+ (* All type variables used on the right-hand side of the type
+ binding must have been declared before the new type constructor *)
+@@ -718,150 +490,167 @@
+ SOME t => t
+ | NONE =>
+ (
+- errorMessage (lex, lineno lex,
++ errorMessage (lex, location lex,
+ name ^ " has not been declared in type declaration");
+- badType
++ makeTv (emptyType, generalisable, false, true)
+ )
+ )
+ } (* genTypeVarEnv *);
+
+- fun typeBinding isSpec isEqtype {enterFix,lookupFix,lookupTvar} fsys =
+- let
+- val newTVenv = searchList ();
+- val typeVars = getTypeVars (false, newTVenv);
+- (* The name of the type *)
+- val typeName = getShortId (ident, fsys ++ equalsSign, lex);
+- (*
+- val typeVarEnv =
+- { lookupTvar = lookupDefault (#lookup newTVenv) lookupTvar }
+- *)
+- val typeVarEnv = genTypeVarEnv newTVenv;
+- val matchedType =
+- (* If this is part of a signature we do not need to have an
+- "= ty" after it. If it is an eqtype we must not have one. *)
+- if (isSpec andalso (sy lex) neq SYMBOLS.equalsSign) orelse isEqtype
+- then emptyType
+- else
+- (
+- getsym (SYMBOLS.equalsSign, lex);
+- (* Followed by a type or a sequence of constructors *)
+- skipon (startTypeSys, fsys, "type", lex);
+- parseType (fsys, lex, typeVarEnv)
+- )
+-
+- in
+- mkTypeBinding (typeName, typeVars, matchedType, isEqtype)
+-
+- end (* typeBinding *);
++ fun typeBinding (isSpec, isEqtype, _) fsys =
++ let
++ val newTVenv = searchList ();
++ val typeVars = getTypeVars (false, newTVenv);
++ (* The name of the type *)
++ val (typeName, idLocn) = getShortId (ident, fsys ++ equalsSign, lex);
++ (*
++ val typeVarEnv =
++ { lookupTvar = lookupDefault (#lookup newTVenv) lookupTvar }
++ *)
++ val typeVarEnv = genTypeVarEnv newTVenv;
++ val (matchedType, endLocn) =
++ (* If this is part of a signature we do not need to have an
++ "= ty" after it. If it is an eqtype we must not have one. *)
++ if (isSpec andalso (sy lex) neq SYMBOLS.equalsSign) orelse isEqtype
++ then (NONE, idLocn)
++ else
++ let
++ val () = getsym (SYMBOLS.equalsSign, lex);
++ (* Followed by a type or a sequence of constructors *)
++ val () = skipon (startTypeSys, fsys, "type", lex);
++ val (t, l) = parseType (fsys, lex, typeVarEnv)
++ in
++ (SOME t, l)
++ end
++ val bindLocn = locSpan(idLocn, endLocn)
++ in
++ (mkTypeBinding (typeName, typeVars, matchedType, isEqtype, idLocn, bindLocn), bindLocn)
++ end (* typeBinding *);
+
+
+- fun datatypeDecOrRepl fsys env isSpecification =
++ fun datatypeDecOrRepl(fsys, env, isSpecification, startLocn) =
+ (* "datatype" has been read. This may be followed by tycon = datatype ...
+ if it is a datatype replication or by tyvarseq tycon = vid ... if it
+- is a datatype binding. We can only distinguish the two when we reach
+- either the second datatype or an identifier.
+- This is used both for declarations and for specifications. *)
+- let
+- val U = insymbol lex;
+- val newTVenv = searchList ();
+- (* The type variables will be empty if this is a replication. *)
+- val typeVars = getTypeVars (true, newTVenv);
+- (* The name of the type *)
+- val typeName = getShortId (ident, fsys ++ equalsSign, lex);
+-
+- val U : unit = getsym (SYMBOLS.equalsSign, lex);
+- in
+- if (sy lex) eq SYMBOLS.datatypeSy
+- then (* Replication *)
+- let
+- (* Check that the type var sequence was empty. *)
+- val U: unit =
+- case typeVars of
+- [] => ()
+- | _ => errorMessage (lex, lineno lex,
+- "Datatype replication must not contain type variables");
+- val U = insymbol lex;
+- val originalTypeName = getLongId (ident, fsys, lex);
+- in
+- mkDatatypeReplication(typeName, originalTypeName)
+- end
+- else (* Binding *)
+- let
+- (* Process the rest of this binding. *)
+- val db =
+- datatypeBind (fsys ++ withtypeSy ++ andSy)
+- env typeName typeVars newTVenv isSpecification;
+- (* Process any others *)
+- val dbs =
+- if testfor (SYMBOLS.andSy, empty, lex)
+- then andBindings (fsys ++ withtypeSy)
+- (fn fsys => datatypeBinding fsys env isSpecification)
+- else []
+- val withtypes =
+- if testfor (SYMBOLS.withtypeSy, empty, lex)
+- then andBindings fsys (typeBinding false false env)
+- else [];
+- in
+- mkDatatypeDeclaration (db :: dbs, withtypes)
+- end
+- end
+-
+- and datatypeBind fsys env typeName typeVars newTVenv isSpecification =
+- (* Process the rest of a binding. *)
+- let
+- (* Followed by a type or a sequence of constructors *)
+- val U = skipon (startTypeDeclarableVarOpSy, fsys, "type", lex);
+-
+- (* In ML 90 all type variables on the right hand side of a datbind
+- had to appear in the tyvarseq on the left. That restriction
+- appears to have been removed for declarations, but not specifications,
+- in ML97. This appears, though, to have been a mistake so I'm
+- reinstating the old behaviour. *)
+- (*
+- val typeVarEnv =
+- { lookupTvar = lookupDefault (#lookup newTVenv) (#lookupTvar env) }
+- *)
+- val typeVarEnv = genTypeVarEnv newTVenv;
+-
+- fun constrs fsys =
+- let
+- val opThere = (sy lex) eq SYMBOLS.opSy;
+- val U = if opThere then insymbol lex else ();
+- (* Identifier - name of constructor *)
+- val constrName = getShortNonInfix (opThere orelse isSpecification) declarableVarSys
+- (fsys ++ ofVerticalBarSy) lex env;
+-
+- (* If there is an "of" after this then the constructor is
+- a function from the type following the "of" to the type
+- being declared. Otherwise it is a constant of the type
+- being declared. *)
+- val component =
+- if (sy lex) eq SYMBOLS.ofSy
+- then (insymbol lex;(* Followed by a type. *)
+- (constrName, parseType (fsys ++ verticalBar, lex, typeVarEnv)))
+- else (constrName, emptyType);
+- in
+- component ::
+- (if testfor (SYMBOLS.verticalBar, empty, lex)
+- then constrs fsys
+- else [])
+- end
+- in
+- mkDatatypeBinding (typeName, typeVars, constrs fsys)
+- end
++ is a datatype binding. We can only distinguish the two when we reach
++ either the second datatype or an identifier.
++ This is used both for declarations and for specifications. *)
++ let
++ val () = insymbol lex;
++ val newTVenv = searchList ();
++ (* The type variables will be empty if this is a replication. *)
++ val typeVars = getTypeVars (true, newTVenv);
++ (* The name of the type *)
++ val (typeName, idLocn) = getShortId (ident, fsys ++ equalsSign, lex);
++
++ val () = getsym (SYMBOLS.equalsSign, lex);
++ in
++ if (sy lex) eq SYMBOLS.datatypeSy
++ then (* Replication *)
++ let
++ (* Check that the type var sequence was empty. *)
++ val () =
++ case typeVars of
++ [] => ()
++ | _ => errorMessage (lex, location lex,
++ "Datatype replication must not contain type variables");
++ val () = insymbol lex;
++ val (originalTypeName, repLocn) = getLongId (ident, fsys, lex);
++ val fullLocn = locSpan(startLocn, repLocn)
++ in
++ (mkDatatypeReplication{newType=typeName, oldType=originalTypeName,
++ newLoc=idLocn, oldLoc=repLocn, location=fullLocn}, fullLocn)
++ end
++ else (* Binding *)
++ let
++ (* Process the rest of this binding. *)
++ val (db, dbLocn) =
++ datatypeBind (fsys ++ withtypeSy ++ andSy,
++ env, typeName, typeVars, newTVenv, idLocn, isSpecification);
++ (* Process any others *)
++ val (dbs, dbsLocn) =
++ if testfor (SYMBOLS.andSy, empty, lex)
++ then andBindings
++ (fsys ++ withtypeSy, datatypeBinding(env, isSpecification))
++ else ([], dbLocn)
++ val (withtypes, lastLocn) =
++ if testfor (SYMBOLS.withtypeSy, empty, lex)
++ then andBindings(fsys, typeBinding(false, false, env))
++ else ([], dbsLocn);
++ val fullLocn = locSpan(startLocn, lastLocn)
++ in
++ (mkDatatypeDeclaration (db :: dbs, withtypes, fullLocn), fullLocn)
++ end
++ end
++
++ and datatypeBind (fsys, env, typeName, typeVars, newTVenv, idLocn, isSpecification) =
++ (* Process the rest of a binding. *)
++ let
++ (* Followed by a type or a sequence of constructors *)
++ val () = skipon (startTypeDeclarableVarOpSy, fsys, "type", lex);
+
+- and datatypeBinding fsys env isSpecification =
+- (* Datatype and abstype declarations and datatype specifications. *)
+- let
+- val newTVenv = searchList ();
+- val typeVars = getTypeVars (true, newTVenv);
+- (* The name of the type *)
+- val typeName = getShortId (ident, fsys ++ equalsSign, lex);
+-
+- val U : unit = getsym (SYMBOLS.equalsSign, lex);
+- in
+- datatypeBind fsys env typeName typeVars newTVenv isSpecification
+- end;
++ (* In ML 90 all type variables on the right hand side of a datbind
++ had to appear in the tyvarseq on the left. That restriction
++ appears to have been removed for declarations, but not specifications,
++ in ML97. This appears, though, to have been a mistake so I'm
++ reinstating the old behaviour. *)
++ (*
++ val typeVarEnv =
++ { lookupTvar = lookupDefault (#lookup newTVenv) (#lookupTvar env) }
++ *)
++ val typeVarEnv = genTypeVarEnv newTVenv;
++
++ fun constrs fsys =
++ let
++ val opThere = (sy lex) eq SYMBOLS.opSy;
++ val () = if opThere then insymbol lex else ();
++ (* Identifier - name of constructor *)
++ val (constrName, idLocn) =
++ getShortNonInfix (opThere orelse isSpecification) declarableVarSys
++ (fsys ++ ofVerticalBarSy) lex env;
++
++ (* If there is an "of" after this then the constructor is
++ a function from the type following the "of" to the type
++ being declared. Otherwise it is a constant of the type
++ being declared. *)
++ val (component, componentLoc) =
++ if (sy lex) eq SYMBOLS.ofSy
++ then
++ let
++ val () = insymbol lex;(* Followed by a type. *)
++ val (theType,typeLocn) = parseType (fsys ++ verticalBar, lex, typeVarEnv)
++ in
++ ({constrName=constrName, constrArg=SOME theType, idLocn=idLocn}, locSpan(idLocn, typeLocn))
++ end
++ else ({constrName=constrName, constrArg=NONE, idLocn=idLocn}, idLocn);
++ in
++ if testfor (SYMBOLS.verticalBar, empty, lex)
++ then
++ let
++ val (tail, locn) = constrs fsys
++ in
++ (component :: tail, locSpan(componentLoc, locn))
++ end
++ else ([component], componentLoc)
++ end
++
++ val (constrs, constrsLocn) = constrs fsys
++ val bindLocn = locSpan(idLocn, constrsLocn)
++ in
++ (mkDatatypeBinding (typeName, typeVars, constrs, idLocn, bindLocn), bindLocn)
++ end
++
++ and datatypeBinding(env, isSpecification) fsys =
++ (* Datatype and abstype declarations and datatype specifications. *)
++ let
++ val newTVenv = searchList ();
++ val typeVars = getTypeVars (true, newTVenv);
++ (* The name of the type *)
++ val (typeName, idLocn) = getShortId (ident, fsys ++ equalsSign, lex);
++
++ val () = getsym (SYMBOLS.equalsSign, lex);
++ in
++ datatypeBind (fsys, env, typeName, typeVars, newTVenv, idLocn, isSpecification)
++ end;
+
+
+ fun makeTypeVarEnv() =
+@@ -877,9 +666,9 @@
+ let
+ (* These type variables are not unifiable until they are generalised. *)
+ val newTypeVar =
+- mkTypeVar (generalisable, isEqtype name, true, isWeak(name, lex));
++ makeTv (emptyType, generalisable, isEqtype name, true);
+
+- val U : unit = enter (name, newTypeVar);
++ val () = enter (name, newTypeVar);
+ in
+ newTypeVar
+ end;
+@@ -887,1409 +676,1604 @@
+ { lookupTvar = fn s => case lookup s of SOME t => t | NONE => lookupT s,
+ lookup = lookup,
+ apply = apply,
+- enter = enter }
++ enter = enter }
+ end (* makeTypeVarEnv *);
+
+
+- fun dec fsys lex decOnly (env as {enterFix,lookupFix,lookupTvar}) =
+- let
+- (* Sequence of declarations optionally separated by semicolons. *)
+- fun decSequence fsys env : (parsetree * int) list=
+- if (sy lex) eq SYMBOLS.semicolon
+- then (* Semicolons are optional. *)
+- (insymbol lex; decSequence fsys env)
+- else if (sy lex) inside startDecSys
+- then
+- let
+- val lno = lineno lex
+- in
+- (dec (fsys ++ semicolonStartDecSy) lex true env, lno) ::
+- decSequence fsys env
+- end
+- else (* May be empty *) [];
+-
+- (* Constraints *)
+- fun constraint exp fsys (env as {enterFix,lookupFix,lookupTvar}) =
+- if testfor (SYMBOLS.colon, empty, lex)
+- then constraint
+- (mkConstraint (exp,
+- parseType (fsys ++ colon, lex, {lookupTvar=lookupTvar})))
+- fsys
+- env
+- else exp;
+-
+- fun getConstant mkConst =
+- let
+- (* Return the string. *)
+- val data = id lex; (* Save it before insymbol. *)
+- val U : unit = insymbol lex;
+- in
+- mkConst data
+- end;
+-
+- fun parseInfix fsys opSys startSys atomic
+- {enterFix: string * fixStatus -> unit,
+- lookupFix: string -> fixStatus option,
+- lookupTvar: string -> types } =
+- let
+- (* Infix operators have a precedence value associated with them,
+- the larger the value the more tightly they bind. *)
+-
+- val opStartSy = opSy ++ startSys;
+-
+- fun parseApplication fsys pproc =
+- (* Applies a function to an argument and then tries to apply
+- that to the next expression/pattern. *)
++ fun dec (fsys, lex, decOnly, env as {enterFix,...}): parsetree * location =
++ let
++ (* Sequence of declarations optionally separated by semicolons. *)
++ fun decSequence(fsys, env) : parsetree list =
++ if (sy lex) eq SYMBOLS.semicolon
++ then (* Semicolons are optional. *)
++ (insymbol lex; decSequence(fsys, env))
++ else if (sy lex) inside startDecSys
++ then
++ #1(dec(fsys ++ semicolonStartDecSy, lex, true, env)) :: decSequence(fsys, env)
++ else (* May be empty *) [];
++
++ (* Constraints *)
++ fun constraint (exp, expLoc) fsys (env as {lookupTvar, ...}) =
++ if testfor (SYMBOLS.colon, empty, lex)
++ then
++ let
++ val (constrType, typeLoc) = parseType (fsys ++ colon, lex, {lookupTvar=lookupTvar})
++ val locs = locSpan(expLoc, typeLoc)
++ in
++ constraint (mkConstraint (exp, constrType, locs), locs) fsys env
++ end
++ else (exp, expLoc);
++
++ fun getConstant mkConst =
++ let
++ (* Return the string. *)
++ val data = id lex; (* Save it before insymbol. *)
++ val loc = location lex
++ in
++ insymbol lex;
++ mkConst(data, loc)
++ end;
++
++ fun parseInfix fsys opSys startSys atomic{lookupFix: string -> fixStatus option, ... } =
++ let
++ (* Infix operators have a precedence value associated with them,
++ the larger the value the more tightly they bind. *)
++
++ val opStartSy = opSy ++ startSys;
++
++ fun parseApplication fsys (funExp, funLoc) : parsetree * location =
++ (* Applies a function to an argument and then tries to apply
++ that to the next expression/pattern. *)
+ if (sy lex) inside startSys
+ then (* Read an argument and apply the constructor *)
+- if (sy lex) inside opSys andalso
+- (
+- (* It is infix if we find it and it has been declared
+- as infix. If it hasn't been declared then it isn't
+- infix. *)
+- case lookupFix(id lex) of SOME (Infix _) => true | SOME (InfixR _) => true | _ => false
+- )
+- then (* it's an infix operator - don't treat it as an arg. *)
+- pproc
+- else let
+- val arg = atomic (fsys ++ startSys)
+- in
+- parseApplication fsys (mkApplic (pproc, arg))
+- end
+- else pproc; (* end parseApplication *)
++ if (sy lex) inside opSys andalso
++ (
++ (* It is infix if we find it and it has been declared
++ as infix. If it hasn't been declared then it isn't
++ infix. *)
++ case lookupFix(id lex) of SOME (Infix _) => true | SOME (InfixR _) => true | _ => false
++ )
++ then (* it's an infix operator - don't treat it as an arg. *)
++ (funExp, funLoc)
++ else
++ let
++ val (arg, argLoc) = atomic (fsys ++ startSys)
++ val appLoc = locSpan(funLoc, argLoc)
++ in
++ parseApplication fsys (mkApplic (funExp, arg, appLoc, false), appLoc)
++ end
++ else (funExp, funLoc); (* end parseApplication *)
+
+
+- fun readNextOps () =
+- (* Gets the operand and the following operator (if any) *)
+- let
+- val express = (* Procedure applications *)
+- parseApplication (fsys ++ opSys) (atomic (fsys ++ opStartSy));
++ fun readNextOps () =
++ (* Gets the operand and the following operator (if any) *)
++ let
++ val express = (* function applications *)
++ parseApplication (fsys ++ opSys) (atomic (fsys ++ opStartSy));
+
+- val operator =
+- if (sy lex) inside opSys
+- then getLongId (opSys, fsys, lex)
+- else "";
+-
+- val fix =
+- if operator = ""
+- then Nonfix
+- else valOf(lookupFix operator);
+-
+- val preclevl = (* ~1 if not infix or infixr *)
+- case fix of
+- Infix prec => prec
+- | InfixR prec => prec
+- | Nonfix => ~1 (* Not infix *);
+-
+- val right =
+- case fix of InfixR _ => true | _ => false; (* undefined if not infix or infixr *)
+- in
+- {express=express,operator=operator,fix=fix,preclevl=preclevl,right=right}
+- end;
+-
+-
+- fun nextLevel {express,operator,fix,preclevl,right}
+- returnLevel (* if we get an operator with this level then we must return. *)
+- rightOperator (* except if we have this operator (ml90 only). *) =
+- let
+- val next = readNextOps(); (* get the next operator and operand.*)
+-
+- val U: unit =
+- (* In ML97 two operators of the same precedence must both be
+- left associative or both right associative. *)
+- if getParameter ml90Tag (debugParams lex) then ()
+- else if #preclevl next = preclevl andalso right <> #right next
+- then errorMessage (lex, lineno lex,
+- "Mixed right and left associative operators of the same precedence.")
+- else ();
+-
+- val rightOp =
+- if #preclevl next > preclevl orelse
+- (* next operator is more binding-it must be processed first *)
+- right andalso
+- (if getParameter ml90Tag (debugParams lex)
+- then #operator next = operator
+- else #preclevl next = preclevl)
+- (* next operator is same as previous and right assoc.
+- The ML standard (ML90) says that different operators of the same
+- precedence are always associate to the left (even if they
+- are both right associative operators). *)
+- (* This has changed in ML97. Now right operators of the
+- same precedence associate to the right. *)
+- then nextLevel next (preclevl+1) (if right then operator else ".")
+- else next;
+-
+- (* At this point we are either at the end of the expression or
+- ``rightOp'' contains an operator which is as weak or weaker
+- than the ``previous''. We can therefore apply the previous
+- operator to the previous operand and the ``rightOp''
+- operand. *)
+-
+- val oper = mkIdent operator;
+-
+- val applied =
+- { express = mkApplic (oper, mkTupleTree [express,#express rightOp]),
+- operator = #operator rightOp,
+- fix = #fix rightOp,
+- preclevl = #preclevl rightOp,
+- right = #right rightOp };
+- (* If the right operator is stronger than the ``returnLimit''
+- (i.e. stronger than the operator before this series) then
+- repeat else return this result. *)
+- in
+- if #preclevl rightOp >= returnLevel orelse
+- #operator rightOp = rightOperator
+- then nextLevel applied returnLevel rightOperator
+- else applied
+- end (* nextLevel *);
+-
+- (* parseInfix *)
+- val ops = readNextOps (); (* Get the first item. *)
+- in
+- if #preclevl ops < 0 (* no operator *)
+- then #express ops
+- else #express (nextLevel ops 0 ".")
+- end (* parseInfix *);
+-
+- fun pattern fsys lex (env as {enterFix,lookupFix,lookupTvar}) =
+- (* Parse a pattern or a fun name apat ... apat sequence. *)
+- let
+- fun constraintOrLayered pat fsys =
+- let
+- val isVar = isIdent pat;
+- val constr = constraint pat (fsys ++ asSy) env;
+- in
+- if testfor (SYMBOLS.asSy, empty, lex)
+- then
+- ( (* Layered pattern *)
+- if not isVar
+- then errorMessage (lex, lineno lex,
+- "Expected id or id:ty before `as'")
+- else ();
+- mkLayered (constr, pattern fsys lex env)
+- )
+- else constr
+- end;
++ val (operator, loc, fix) =
++ if (sy lex) inside opSys
++ then
++ let
++ val (id, loc) = getLongId (opSys, fsys, lex)
++ in
++ (id, loc, valOf(lookupFix id))
++ end
++ else ("", nullLocation, Nonfix);
++
++ val (preclevl, right) = (* ~1 if not infix or infixr *)
++ case fix of
++ Infix prec => (prec, false)
++ | InfixR prec => (prec, true)
++ | Nonfix => (~1, false) (* Not infix *);
++ in
++ {express=express,operator=(operator,loc),preclevl=preclevl,right=right}
++ end;
+
+- fun atomicPattern fsys =
+- let
+- val sym = sy lex;
+- in
+- if sym eq SYMBOLS.underline (* wild card *)
+- then let
+- val U : unit = insymbol lex;
+- in
+- wildCard
+- end
+-
+- else if sym eq SYMBOLS.leftBrack (* list - may be empty *)
+- then let
+- val U : unit = insymbol lex;
+- val p = if (sy lex) neq SYMBOLS.rightBrack (* may be empty *)
+- then
+- let
+- fun varsList() =
+- pattern (fsys ++ commaRightBrackSy) lex env ::
+- (if testfor (SYMBOLS.comma, empty, lex)
+- then varsList()
+- else []);
+- in
+- varsList()
+- end
+- else [];
+- val U : unit = getsym (SYMBOLS.rightBrack, lex);
+- in
+- mkList p
+- end
++
++ fun nextLevel {express: parsetree*location,operator: string*location,preclevl,right}
++ (returnLevel, lastRight, lastOp) =
++ let
++ val next = readNextOps(); (* get the next operator and operand.*)
++
++ val rightOp =
++ if #preclevl next > preclevl orelse
++ (* next operator is more binding-it must be processed first *)
++ right andalso #preclevl next = preclevl
++ then nextLevel next (preclevl, right, #1 operator)
++ else next;
++
++ (* At this point we are either at the end of the expression or
++ ``rightOp'' contains an operator which is as weak or weaker
++ than the ``previous''. We can therefore apply the previous
++ operator to the previous operand and the ``rightOp''
++ operand. *)
++
++ val oper = mkIdent operator;
++ val appLocn = locSpan(#2 express, #2 (#express rightOp))
++
++ val applied =
++ { express = (mkApplic (oper, mkTupleTree([#1 express, #1 (#express rightOp)], appLocn), appLocn, true), appLocn),
++ operator = #operator rightOp,
++ preclevl = #preclevl rightOp,
++ right = #right rightOp };
++ (* If the right operator is stronger than the ``returnLimit''
++ (i.e. stronger than the operator before this series) then
++ repeat else return this result. *)
++ in
++ (* In ML97 two operators of the same precedence must both be
++ left associative or both right associative. *)
++ if #preclevl rightOp = returnLevel andalso #right rightOp <> lastRight
++ then errorMessage (lex, location lex,
++ concat["Operators \"", lastOp, "\" and \"", #1 (#operator rightOp),
++ "\" have the same precedence but \"", lastOp, "\" is ",
++ if lastRight then "right" else "left", "-associative while \"",
++ #1 (#operator rightOp), "\" is ",
++ if #right rightOp then "right" else "left", "-associative."])
++ else ();
++
++ if #preclevl rightOp > returnLevel orelse
++ #preclevl rightOp = returnLevel andalso lastRight
++ then nextLevel applied (returnLevel, lastRight, lastOp)
++ else applied
++ end (* nextLevel *);
++
++ (* parseInfix *)
++ val ops = readNextOps (); (* Get the first item. *)
++ in
++ if #preclevl ops < 0 (* no operator *)
++ then #express ops
++ else #express (nextLevel ops (~1, false, ""))
++ end (* parseInfix *);
++
++ fun pattern fsys lex env =
++ (* Parse a pattern or a fun name apat ... apat sequence. *)
++ let
++ fun constraintOrLayered (pat, patLoc) fsys =
++ let
++ val isVar = isIdent pat;
++ val (constr, constrLoc) = constraint (pat, patLoc) (fsys ++ asSy) env;
++ in
++ if testfor (SYMBOLS.asSy, empty, lex)
++ then
++ let (* Layered pattern *)
++ val () =
++ if not isVar
++ then errorMessage (lex, location lex,
++ "Expected id or id:ty before `as'")
++ else ();
++ val (lPatt, lPattLoc) = pattern fsys lex env
++ val layeredLoc = locSpan(patLoc, lPattLoc)
++ in
++ (mkLayered (constr, lPatt, layeredLoc), layeredLoc)
++ end
++ else (constr, constrLoc)
++ end;
++
++ fun atomicPattern fsys: parsetree * location =
++ let
++ val sym = sy lex;
++ val startLocn = location lex
++ in
++ if sym eq SYMBOLS.underline (* wild card *)
++ then ( insymbol lex; (wildCard startLocn, startLocn) )
+
+- (* bracketed pattern or unit value. *)
+- else if sym eq SYMBOLS.leftParen
+- then let
+- val U = insymbol lex;
+- val p = if (sy lex) neq SYMBOLS.rightParen
+- then
+- let
+- val first = pattern (fsys ++ rightParenCommaSy) lex env;
+- (* May be a tuple *)
+- in
+- if testfor (SYMBOLS.comma, empty, lex)
+- then
+- let
+- (* It is a tuple - read the other patterns
+- and make the tuple. *)
+- fun tuples () =
+- pattern (fsys ++ rightParenCommaSy) lex env ::
+- (if testfor (SYMBOLS.comma, empty, lex)
+- then tuples ()
+- else []);
+- in
+- mkTupleTree (first :: tuples())
+- end
+- else first (* just one *)
+- end
+- else unit;
+- val U : unit = getsym (SYMBOLS.rightParen, lex);
+- in
+- p
+- end
++ else if sym eq SYMBOLS.leftBrack (* list - may be empty *)
++ then
++ let
++ val () = insymbol lex;
++ val p = if (sy lex) neq SYMBOLS.rightBrack (* may be empty *)
++ then
++ let
++ fun varsList() =
++ let
++ val (p, _) = pattern (fsys ++ commaRightBrackSy) lex env
++ in
++ if testfor (SYMBOLS.comma, empty, lex)
++ then p :: varsList()
++ else [p]
++ end
++ in
++ varsList()
++ end
++ else [];
++ val locs = locSpan(startLocn, location lex)
++ val () = getsym (SYMBOLS.rightBrack, lex);
++ in
++ (mkList(p, locs), locs)
++ end
++
++ (* bracketed pattern or unit value. *)
++ else if sym eq SYMBOLS.leftParen
++ then
++ let
++ val () = insymbol lex;
++ val p = if (sy lex) neq SYMBOLS.rightParen
++ then
++ let
++ val (first,_) = pattern (fsys ++ rightParenCommaSy) lex env;
++ (* May be a tuple *)
++ in
++ if testfor (SYMBOLS.comma, empty, lex)
++ then
++ let
++ (* It is a tuple - read the other patterns
++ and make the tuple. *)
++ fun tuples () =
++ let
++ val (p, _) = pattern (fsys ++ rightParenCommaSy) lex env
++ in
++ if testfor (SYMBOLS.comma, empty, lex)
++ then p :: tuples()
++ else [p]
++ end
++ in
++ mkTupleTree (first :: tuples(), locSpan(startLocn, location lex))
++ end
++ else (* just one *)
++ mkParenthesised(first, locSpan(startLocn, location lex))
++ end
++ else unit(locSpan(startLocn, location lex));
++ val locs = locSpan(startLocn, location lex)
++ val () = getsym (SYMBOLS.rightParen, lex);
++ in
++ (p, locs)
++ end
+
+- (* Either a labelled record or unit. *)
+- else if (sy lex) eq SYMBOLS.leftCurly
+- then let
+- val U : unit = insymbol lex;
+- in
+- if testfor (SYMBOLS.rightCurly, empty, lex)
+- then unit (* Empty parentheses denote unit *)
+- else
+- let (* lab1 = pat1, __ , labn = patn <<, ... >>*)
+- fun getLabels () =
+- if testfor (SYMBOLS.threeDots, empty, lex)
+- then
+- {frozen = false,result = []}
+- else let
+- val fsys = fsys ++ commaRightCurlySy;
+- val ident = getLabel (fsys ++ equalsSign, lex);
+- val patt =
+- if testfor (SYMBOLS.equalsSign, empty, lex)
+- (* Simple case -- lab = pat *)
+- then pattern fsys lex env
+- else (* sugared form - label is also identifier *)
+- (
+- (* Sugared form not allowed for numeric labels. *)
+- if 0 < size ident
+- andalso String.str(String.sub(ident, 0)) >= "1"
+- andalso String.str(String.sub(ident, 0)) <= "9"
+- then errorMessage (lex, lineno lex,
+- " = pat expected after numeric label")
+- else ();
+- (* May have constraint and/or be layered. *)
+- constraintOrLayered (mkIdent ident) fsys
+- );
+- val this = (ident, patt);
+- in
+- if testfor (SYMBOLS.comma, declarableVarSys, lex)
+- then let
+- val getRest = getLabels ();
+- in
+- {frozen = #frozen getRest,
+- result = this :: #result getRest}
+- end
+- else (* Finished. *)
+- {frozen = true,result = [this]}
+- end (* getLabels *);
+-
+- val {frozen, result} = getLabels ();
+- val U : unit = getsym (SYMBOLS.rightCurly, lex);
++ (* Either a labelled record or unit. *)
++ else if (sy lex) eq SYMBOLS.leftCurly
++ then
++ let
++ val () = insymbol lex;
++ val posEnd = location lex
+ in
+- mkLabelledTree (result, frozen)
+- end
+- end
++ if testfor (SYMBOLS.rightCurly, empty, lex)
++ then (* Empty brackets denote unit *)
++ let val locs = locSpan(startLocn, posEnd) in (unit locs, locs) end
++ else
++ let (* lab1 = pat1, __ , labn = patn <<, ... >>*)
++ (* The same label name should not be used more than once. *)
++ fun reportDup (name, newLoc, _) =
++ errorMessage(lex, newLoc, "Label (" ^ name ^ ") appears more than once.")
++ val dupCheck = noDuplicates reportDup
++
++ fun getLabels () =
++ if testfor (SYMBOLS.threeDots, empty, lex)
++ then {frozen = false, result = []}
++ else
++ let
++ val fsys = fsys ++ commaRightCurlySy;
++ val (ident, idLoc) = getLabel (fsys ++ equalsSign, lex);
++ val () = #enter dupCheck (ident, idLoc) (* Check for dups. *)
++ val (patt, pattLoc) =
++ if testfor (SYMBOLS.equalsSign, empty, lex)
++ (* Simple case -- lab = pat *)
++ then pattern fsys lex env
++ else (* sugared form - label is also identifier *)
++ (
++ (* Sugared form not allowed for numeric labels. *)
++ if 0 < size ident
++ andalso String.str(String.sub(ident, 0)) >= "1"
++ andalso String.str(String.sub(ident, 0)) <= "9"
++ then errorMessage (lex, location lex,
++ " = pat expected after numeric label")
++ else ();
++ (* May have constraint and/or be layered. *)
++ constraintOrLayered (mkIdent (ident, idLoc), idLoc) fsys
++ );
++ val labEntry = mkLabelRecEntry(ident, idLoc, patt, locSpan(idLoc, pattLoc))
++ in
++ if testfor (SYMBOLS.comma, declarableVarSys, lex)
++ then
++ let
++ val getRest = getLabels ();
++ in
++ {frozen = #frozen getRest, result = labEntry :: #result getRest}
++ end
++ else (* Finished. *)
++ {frozen = true, result = [labEntry]}
++ end (* getLabels *);
++
++ val {frozen, result} = getLabels ();
++ val locs = locSpan(startLocn, location lex)
++ val () = getsym (SYMBOLS.rightCurly, lex);
++ in
++ (mkLabelledTree (result, frozen, locs), locs)
++ end
++ end
+
+- (* Constants *)
++ (* Constants *)
+
+- else if sym eq SYMBOLS.stringConst
+- then getConstant mkString
++ else if sym eq SYMBOLS.stringConst
++ then (getConstant mkString, startLocn)
+
+- else if sym eq SYMBOLS.integerConst
+- then getConstant mkInt
++ else if sym eq SYMBOLS.integerConst
++ then (getConstant mkInt, startLocn)
+
+- else if sym eq SYMBOLS.realConst
+- then
+- (
+- (* Real literals were allowed in patterns in ML90. *)
+- if getParameter ml90Tag (debugParams lex) then ()
+- else errorMessage (lex, lineno lex,
+- "Real constants not allowed in patterns");
+- getConstant mkReal
+- )
++ else if sym eq SYMBOLS.realConst
++ then
++ (
++ (* Real literals were allowed in patterns in ML90. *)
++ errorMessage (lex, location lex,
++ "Real constants not allowed in patterns");
++ (getConstant mkReal, startLocn)
++ )
+
+- else if sym eq SYMBOLS.charConst
+- then getConstant mkChar
++ else if sym eq SYMBOLS.charConst
++ then (getConstant mkChar, startLocn)
+
+- else if sym eq SYMBOLS.wordConst
+- then getConstant mkWord
++ else if sym eq SYMBOLS.wordConst
++ then (getConstant mkWord, startLocn)
+
+- else if (sy lex) inside declarableVarOpSy (* Identifiers *)
+- then
+- let
+- val opThere = (sy lex) eq SYMBOLS.opSy;
+- val U : unit = if opThere then insymbol lex else ();
+- in
+- mkIdent (getLongNonInfix opThere declarableVarSys fsys lex env)
+- end
++ else if (sy lex) inside declarableVarOpSy (* Identifiers *)
++ then
++ let
++ val opThere = (sy lex) eq SYMBOLS.opSy;
++ val () = if opThere then insymbol lex else ();
++ val idLoc as (_, endLoc) = getLongNonInfix opThere declarableVarSys fsys lex env
++ in
++ (mkIdent idLoc, locSpan(startLocn, endLoc))
++ end
+
+- else
+- (skipon (empty, fsys, "Pattern", lex); emptyTree)
++ else (skipon (empty, fsys, "Pattern", lex); (emptyTree, startLocn))
+
+- end (* atomicPattern *);
++ end (* atomicPattern *);
+
+- (* pattern *)
++ (* pattern *)
+
+- val U = skipon (startPatternSys, fsys, "Pattern", lex);
++ val () = skipon (startPatternSys, fsys, "Pattern", lex);
+
+- val pat =
+- constraintOrLayered
+- (parseInfix (fsys ++ colonAsSy) declarableVarSys
+- startPatternSys atomicPattern env)
+- fsys;
++ val patAndLoc =
++ constraintOrLayered
++ (parseInfix (fsys ++ colonAsSy) declarableVarSys
++ startPatternSys atomicPattern env)
++ fsys;
+
+- val U : unit = skipon (fsys, empty, "End of pattern", lex);
+- in
+- pat
+- end;
+-
+- fun expression fsys (env as {enterFix,lookupFix,lookupTvar}) =
+- (* Parse an expression *)
+- let
+-
+- fun expressions fsys separator env =
+- (* Sequence of expressions separated by semicolons or commas. Returns the list. *)
+- getList (separator, empty, lex, fn () => expression fsys env);
+-
+- fun expressionLineList fsys separator env : (parsetree * int) list =
+- (* Similar to "expressions" except it returns parsetree X line pairs. *)
+- let
+- fun getExpLine () =
+- let
+- val lno = lineno lex
+- in
+- (expression fsys env, lno)
+- end
+- in
+- getList (separator, empty, lex, getExpLine)
+- end;
+-
+- fun match fsys =
+- (* vs1.exp1 | .. | vsn.expn *)
+- let
+- val U : unit = skipon (startMatchSys, fsys, "Match", lex);
+- val lno = lineno lex;
+-
+- (* Read the pattern. *)
+- val vars = pattern (fsys ++ thickArrow) lex env;
+-
+- val U : unit =
+- (* We expect to get a => here but a common problem is to confuse
+- matches with fun declarations and use a = here. We report it as
+- an error but swallow it as though it was what we wanted. *)
+- if (sy lex) eq SYMBOLS.thickArrow then insymbol lex
+- else
+- (
+- notfound ("=>", lex);
+- if (sy lex) eq SYMBOLS.equalsSign then insymbol lex else ()
+- )
+-
+- (* And now the expression. *)
+- val exp = expression (fsys ++ verticalBar) env;
++ val () = skipon (fsys, empty, "End of pattern", lex);
++ in
++ patAndLoc
++ end (* pattern *);
+
+- (* Deal with any other alternatives by recursing. *)
++ fun expression fsys env: parsetree * location =
++ (* Parse an expression *)
++ let
+
+- (* Construct this node, and append any more. *)
+- val res =
+- mkMatchTree (vars, exp, lno) ::
+- (if testfor (SYMBOLS.verticalBar, empty, lex)
+- then match fsys
+- else []);
+- in
+- skipon (fsys, empty, "End of match", lex);
+- res
+- end;
+-
+- fun atomicExpression fsys =
+- if (sy lex) eq SYMBOLS.leftBrack
+- then let
+- val U : unit = insymbol lex;
+- val p =
+- if (sy lex) neq SYMBOLS.rightBrack (* may be empty *)
+- then expressions (fsys ++ commaRightBrackSy) SYMBOLS.comma env
+- else [];
+- val U : unit = getsym (SYMBOLS.rightBrack, lex);
+- in
+- mkList p
+- end
+-
+- (* A parenthesised expression, a tuple,
+- a sequence or a unit value *)
+- else if (sy lex) eq SYMBOLS.leftParen
+- then let
+- val U : unit = insymbol lex;
+- in
+- if testfor (SYMBOLS.rightParen, empty, lex)
+- then unit (* Empty parentheses denote unit *)
+- else let
+- val firstLine = lineno lex;
+- val firstExp = expression (fsys ++ rightParenSemicolonCommaSy) env;
+-
+- val exps =
+- if testfor (SYMBOLS.comma, empty, lex)
+- then
+- (* It is a tuple - read the other expressions
+- and make the tuple. *)
+- mkTupleTree (firstExp :: expressions (fsys ++ rightParenCommaSy) SYMBOLS.comma env)
+- else if testfor (SYMBOLS.semicolon, empty, lex)
+- then
+- mkExpseq ((firstExp, firstLine) ::
+- expressionLineList (fsys ++ rightParenSemicolonSy) SYMBOLS.semicolon env)
+- else (* Only one *) firstExp;
+-
+- val U : unit = getsym (SYMBOLS.rightParen, lex);
+- in
+- exps
+- end
+- end
+-
+- (* Either a labelled record or unit. *)
+- else if (sy lex) eq SYMBOLS.leftCurly
+- then let
+- val U : unit = insymbol lex;
+- in
+- if testfor (SYMBOLS.rightCurly, empty, lex)
+- then unit (* Empty parentheses denote unit *)
+- else
+- let (* lab1 = exp1, __ , labn = expn *)
+- val labelled =
+- mkLabelledTree
+- (getList (SYMBOLS.comma, empty, lex,
+- fn () =>
+- let
+- val ident = getLabel (fsys ++ equalsSign, lex);
+- in
+- getsym (SYMBOLS.equalsSign, lex);
+- (ident,
+- expression (fsys ++ commaRightCurlySy) env)
+- end),
+- true) (* expressions cannot contain ``...'' *);
+- val U : unit = getsym (SYMBOLS.rightCurly, lex);
+- in
+- labelled
+- end
+- end
++ fun expressionList(fsys, separator, env): parsetree list =
++ (* Sequence of expressions separated by semicolons or commas. Returns the list and strips
++ the locations. *)
++ #1 (getList (separator, empty, lex, fn () => expression fsys env));
+
+- (* local declaration *)
+- else if (sy lex) eq SYMBOLS.letSy
+- then let
+- val U : unit = insymbol lex;
+- val newEnv = mkLocalFixEnv env
+- val decs = decSequence (fsys ++ inSy) newEnv;
+- val U : unit = getsym (SYMBOLS.inSy, lex);
+- val exp = expressionLineList (fsys ++ semicolonEndSy) SYMBOLS.semicolon newEnv;
+- val U : unit = getsym (SYMBOLS.endSy, lex);
+- val U : unit = skipon (fsys, empty, "End of let expression", lex);
+- in
+- mkLocalDeclaration (decs, exp, false) (* "let" rather than "local"*)
+- end
+-
+- (* ordinary expression - qualified names allowed *)
+- else let
+- val opThere = (sy lex) eq SYMBOLS.opSy;
+- val U = if opThere then insymbol lex else ();
+- val sym = sy lex;
+- in
+- if sym inside variableSys
+- then mkIdent (getLongNonInfix opThere variableSys fsys lex env)
+-
+- else if sym eq SYMBOLS.hashSign (* Selector. *)
+- then
+- (
+- insymbol lex;
+- mkSelector (getLabel (fsys, lex))
+- )
+-
+- else if sym eq SYMBOLS.stringConst
+- then getConstant mkString
+-
+- else if sym eq SYMBOLS.integerConst
+- then getConstant mkInt
+-
+- else if sym eq SYMBOLS.realConst
+- then getConstant mkReal
+-
+- else if sym eq SYMBOLS.wordConst
+- then getConstant mkWord
+-
+- else if sym eq SYMBOLS.charConst
+- then getConstant mkChar
+-
+- else (* Expected something e.g. an identifier. *)
+- (badsyms (SYMBOLS.ident, lex); emptyTree)
+- end
+-
+- (* end atomicExpression *);
+-
+-
+- fun keyWordExp fsys =
+- (* Expressions introduced by keywords, atomic expressions or
+- infixed expressions. Expressions introduced by keywords (e.g. if)
+- swallow all of the rest of the expression but they can appear
+- within other keyword expressions or after "andalso" and "orelse". *)
+- let
+- val sym = (sy lex);
+- in
+- (* if expression *)
+- if sym eq SYMBOLS.ifSy
+- then let
+- val U : unit = insymbol lex;
+- val test = expression (fsys ++ thenStartExpressionSy) env;
+- val U : unit = getsym (SYMBOLS.thenSy, lex);
+- val thenPt = expression (fsys ++ elseStartExpressionSy) env;
+- val U : unit = getsym (SYMBOLS.elseSy, lex);
+- val elsePt = expression fsys env;
+- in
+- mkCond (test, thenPt, elsePt)
+- end
++ fun match fsys: matchtree list * location =
++ (* vs1.exp1 | .. | vsn.expn *)
++ let
++ val () = skipon (startMatchSys, fsys, "Match", lex);
+
+- (* while expression *)
+- else if sym eq SYMBOLS.whileSy
+- then let
+- val U : unit = insymbol lex;
+- val test = expression (fsys ++ doSy) env;
+- in
+- if (sy lex) eq SYMBOLS.doSy
+- then let
+- val U : unit = insymbol lex;
+- in
+- mkWhile (test, expression fsys env)
+- end
+- else
+- (badsyms (SYMBOLS.doSy, lex); emptyTree)
+- end
++ (* Read the pattern. *)
++ val (vars, varLoc) = pattern (fsys ++ thickArrow) lex env;
+
+- (* case expression *)
+- else if sym eq SYMBOLS.caseSy
+- then let
+- val U : unit = insymbol lex;
+- val exp = expression (fsys ++ ofStartMatchSy) env;
+- val U : unit = getsym (SYMBOLS.ofSy, lex);
+- in
+- mkCase (exp, match fsys)
+- end
+-
+- (* raise exception *)
+- else if sym eq SYMBOLS.raiseSy
+- then let
+- val U : unit = insymbol lex;
+- in
+- mkRaise (expression fsys env)
+- end
++ val () =
++ (* We expect to get a => here but a common problem is to confuse
++ matches with fun declarations and use a = here. We report it as
++ an error but swallow it as though it was what we wanted. *)
++ if (sy lex) eq SYMBOLS.thickArrow then insymbol lex
++ else
++ (
++ notfound ("=>", lex);
++ if (sy lex) eq SYMBOLS.equalsSign then insymbol lex else ()
++ )
++
++ (* And now the expression. *)
++ val (exp, expLoc) = expression (fsys ++ verticalBar) env;
+
+- (* fn expression *)
+- else if (sy lex) eq SYMBOLS.fnSy
+- then let
+- val U : unit = insymbol lex;
++ (* Construct this node, and append any more. *)
++ val thisLocn = locSpan(varLoc, expLoc)
++ val thisMatch = mkMatchTree (vars, exp, thisLocn)
++ val res =
++ if testfor (SYMBOLS.verticalBar, empty, lex)
++ then
++ let
++ val (m, mloc) = match fsys
++ in
++ (thisMatch :: m, locSpan(thisLocn, mloc))
++ end
++ else ([thisMatch], thisLocn)
+ in
+- mkFn (match (fsys ++ semicolon))
+- end
++ skipon (fsys, empty, "End of match", lex);
++ res
++ end (* end match *);
+
+- (* type constraint, or similar *)
+- else let
+- val exp = parseInfix (fsys ++ andalsoColonSy) variableSys startAtomicSys atomicExpression env
++ fun atomicExpression fsys: parsetree * location =
++ let
++ val startSym = sy lex and startLocn = location lex
+ in
+- constraint exp (fsys ++ andalsoSy) env
+- end
+- end (* keyWordExp *);
++ if startSym eq SYMBOLS.leftBrack
++ then
++ let
++ val () = insymbol lex;
++ val p =
++ if sy lex neq SYMBOLS.rightBrack (* may be empty *)
++ then expressionList (fsys ++ commaRightBrackSy, SYMBOLS.comma, env)
++ else [];
++ val locs = locSpan(startLocn, location lex)
++ val () = getsym (SYMBOLS.rightBrack, lex);
++ in
++ (mkList(p, locs), locs)
++ end
+
+- fun parseAndalso fsys =
+- (* EXP1 andalso EXP2 = if EXP1 then EXP2 else false *)
+- let
+- val first = keyWordExp (fsys ++ andalsoSy);
+- (* N.B. If the expression had been introduced by a keyword (e.g. if)
+- then the "else" part would have swallowed any "andalso". *)
+- in
+- if (sy lex) eq SYMBOLS.andalsoSy
+- then
+- (insymbol lex; mkAndalso (first, parseAndalso fsys))
+- else first
+- end;
+-
+- fun parseOrelse fsys =
+- (* EXP1 orelse EXP2 = if EXP1 then true else EXP2 *)
+- let
+- val first = parseAndalso (fsys ++ orelseSy);
+- in
+- if (sy lex) eq SYMBOLS.orelseSy
+- then
+- (insymbol lex; mkOrelse (first, parseOrelse fsys))
+- else first
+- end;
++ (* A parenthesised expression, a tuple, a sequence or a unit value *)
++ else if startSym eq SYMBOLS.leftParen
++ then
++ let
++ val () = insymbol lex;
++ val posEnd = location lex
++ in
++ if testfor (SYMBOLS.rightParen, empty, lex)
++ then (* Empty parentheses denote unit *)
++ let val locs = locSpan(startLocn, posEnd) in (unit locs, locs) end
++ else
++ let
++ val (firstExp, _) = expression (fsys ++ rightParenSemicolonCommaSy) env;
++
++ val (exps, fullLocn) =
++ if testfor (SYMBOLS.comma, empty, lex)
++ then (* Tuple *)
++ let
++ val expressions =
++ firstExp :: expressionList (fsys ++ rightParenCommaSy, SYMBOLS.comma, env)
++ val locs = locSpan(startLocn, location lex)
++ in
++ (mkTupleTree (expressions, locs), locs)
++ end
++ else if testfor (SYMBOLS.semicolon, empty, lex)
++ then (* Expression sequence. *)
++ let
++ val expressions =
++ firstExp :: expressionList (fsys ++ rightParenSemicolonSy, SYMBOLS.semicolon, env)
++ val locs = locSpan(startLocn, location lex)
++ in
++ (mkExpseq (expressions, locs), locs)
++ end
++ else (* Only one *)
++ let
++ val locs = locSpan(startLocn, location lex)
++ in
++ (mkParenthesised(firstExp, locs), locs)
++ end;
++
++ val () = getsym (SYMBOLS.rightParen, lex);
++ in
++ (exps, fullLocn)
++ end
++ end
+
+- in
+- skipon (startExpressionSys, fsys, "Expression", lex);
++ (* Either a labelled record or unit. *)
++ else if startSym eq SYMBOLS.leftCurly
++ then
++ let
++ val () = insymbol lex;
++ val posEnd = location lex
++ in
++ if testfor (SYMBOLS.rightCurly, empty, lex)
++ then (* Empty brackets denote unit *)
++ let val locs = locSpan(startLocn, posEnd) in (unit locs, locs) end
++ else
++ let (* lab1 = exp1, __ , labn = expn *)
++ (* The same label name should not be used more than once. *)
++ fun reportDup (name, newLoc, _) =
++ errorMessage(lex, newLoc, "Label (" ^ name ^ ") appears more than once.")
++ val dupCheck = noDuplicates reportDup
++
++ fun getEntry () =
++ let
++ val (ident, idLoc) = getLabel (fsys ++ equalsSign, lex);
++ val () = #enter dupCheck (ident, idLoc) (* Check for dups. *)
++ val () = getsym (SYMBOLS.equalsSign, lex);
++ val (labExp, labLoc) = expression (fsys ++ commaRightCurlySy) env
++ val locs = locSpan(idLoc, labLoc)
++ in
++ (mkLabelRecEntry(ident, idLoc, labExp, locs), locs)
++ end
++ val (labs, _) = getList (SYMBOLS.comma, empty, lex, getEntry)
++ val locs = locSpan(startLocn, location lex) (* Include brackets. *)
++ val labelled = mkLabelledTree (labs, true (* always frozen *), locs)
++ val () = getsym (SYMBOLS.rightCurly, lex);
++ in
++ (labelled, locs)
++ end
++ end
+
+- if (sy lex) inside startExpressionSys
+- then
+- let
+- val exp = parseOrelse (fsys ++ handleSy);
+- in
+- if (sy lex) eq SYMBOLS.handleSy
+- then
+- (insymbol lex; (* Remove "handle" *) mkHandleTree (exp, match fsys))
+- else exp
+- end
+- else emptyTree (* No expression *)
++ (* local declaration *)
++ else if startSym eq SYMBOLS.letSy
++ then
++ let
++ val () = insymbol lex;
++ val newEnv = mkLocalFixEnv env
++ val decs = decSequence (fsys ++ inSy, newEnv);
++ val () = getsym (SYMBOLS.inSy, lex);
++ val exp = expressionList (fsys ++ semicolonEndSy, SYMBOLS.semicolon, newEnv);
++ val locs = locSpan(startLocn, location lex)
++ val () = getsym (SYMBOLS.endSy, lex);
++ val () = skipon (fsys, empty, "End of let expression", lex);
++ in
++ (mkLocalDeclaration (decs, exp, locs, false) (* "let" rather than "local"*), locs)
++ end
+
+- end; (* expression *)
+- in
+- (* One declaration. "decOnly" is true if the derived form exp => val it = exp is not allowed here. *)
+- if decOnly orelse (sy lex) inside startDecSys
+- then let
+- val sym = (sy lex);
+- in
+- if sym eq SYMBOLS.valSy
+- then let
+- val U : unit = insymbol lex;
+- (* Create two different scopes, for explicitly declared
+- type variables and those implicitly declared. *)
+- val implicitTvars = makeTypeVarEnv()
+- and explicitTvars = makeTypeVarEnv();
+- val newEnv = {enterFix = #enterFix env,
+- lookupFix = #lookupFix env,
+- lookupTvar =
+- (* Look up type variables in the explicit
+- environment, otherwise look them up and
+- add them to the implicit environment. *)
+- fn s => case #lookup explicitTvars s of
+- SOME t => t | NONE => #lookupTvar implicitTvars s};
+-
+- (* Tyvarseq *)
+- val U = getTypeVars(true,
+- { enter = #enter explicitTvars,
+- lookup = #lookup explicitTvars,
+- apply = #apply explicitTvars});
+-
+- (* Processes a value binding. *)
+- (* We check for qualified names in the second pass *)
+- fun valB fsys =
+- let
+- val recursive = (sy lex) eq SYMBOLS.recSy
+- in
+- while (sy lex) eq SYMBOLS.recSy
+- do insymbol lex; (* Could be more than one *)
+- if recursive then recValbind :: valB fsys
+- else
+- let
+- val lno = lineno lex;
+- (* Pattern *)
+- val vars = pattern (fsys ++ equalsSign) lex newEnv;
+- (* = *)
+- val U : unit = getsym (SYMBOLS.equalsSign, lex);
+- (* expression *)
+- val exp = expression fsys newEnv;
+- in
+- mkValBinding (vars, exp, lno) ::
+- (if testfor (SYMBOLS.andSy, empty, lex)
+- then valB fsys
+- else [])
+- end
+- end;
+-
+- val bindings = valB (fsys ++ andSy)
+- in
+- mkValDeclaration (bindings,
+- {lookup= #lookup explicitTvars, apply= #apply explicitTvars},
+- {lookup= #lookup implicitTvars, apply= #apply implicitTvars})
+- end
++ (* ordinary expression - qualified names allowed *)
++ else
++ let
++ val opThere = startSym eq SYMBOLS.opSy;
++ val () = if opThere then insymbol lex else ();
++ val sym = sy lex;
++ val symLoc = location lex
++ in
++ if sym inside variableSys
++ then
++ let
++ val (ident, idLoc) = getLongNonInfix opThere variableSys fsys lex env
++ in
++ (mkIdent (ident, idLoc), locSpan(startLocn, idLoc))
++ end
++
++ else if sym eq SYMBOLS.hashSign (* Selector. *)
++ then
++ let
++ val () = insymbol lex;
++ val (lab, labLoc) = getLabel (fsys, lex)
++ val locs = locSpan(startLocn, labLoc)
++ in
++ (mkSelector(lab, locs), locs)
++ end
++
++ else if sym eq SYMBOLS.stringConst
++ then (getConstant mkString, locSpan(startLocn, symLoc))
++
++ else if sym eq SYMBOLS.integerConst
++ then (getConstant mkInt, locSpan(startLocn, symLoc))
++
++ else if sym eq SYMBOLS.realConst
++ then (getConstant mkReal, locSpan(startLocn, symLoc))
+
+- else if sym eq SYMBOLS.funSy
+- then let
+- val U = insymbol lex;
+- (* Create two different scopes, for explicitly declared
+- type variables and those implicitly declared. *)
+- val implicitTvars = makeTypeVarEnv()
+- and explicitTvars = makeTypeVarEnv();
+- val newEnv = {enterFix = #enterFix env,
+- lookupFix = #lookupFix env,
+- lookupTvar =
+- fn s => case #lookup explicitTvars s of
+- SOME t => t | NONE => #lookupTvar implicitTvars s};
+-
+- (* Tyvarseq *)
+- val U = getTypeVars(true,
+- { enter = #enter explicitTvars,
+- lookup = #lookup explicitTvars,
+- apply = #apply explicitTvars});
+-
+- fun funB fsys =
+- (* Processes a fun binding. *)
+- (* We check for qualified names in the second pass *)
+- let
+- fun bindings() =
+- let
+- val lno = lineno lex;
+- (* Pattern - This isn't really a pattern but we can parse it as
+- that and sort it out later. *)
+- val vars = pattern (fsys ++ equalsSign) lex newEnv;
+- (* = *)
+- (* We expect an equals sign here but a common problem is
+- to confuse fun declarations with matches and use a =>
+- here. Report the error but swallow the =>. *)
+- val U : unit =
+- if (sy lex) eq SYMBOLS.equalsSign then insymbol lex
+- else
+- (
+- notfound ("=", lex);
+- if (sy lex) eq SYMBOLS.thickArrow then insymbol lex else ()
+- );
+- (* expression *)
+- val exp = expression (fsys ++ verticalBar) newEnv;
+- val bind = mkClause (vars, exp, lno);
+- (* Followed by a vertical bar and another binding ? *)
+- val rest =
+- if testfor (SYMBOLS.verticalBar, empty, lex)
+- then bindings ()
+- else []
+- in
+- bind :: rest
+- end;
+- in
+- mkClausal (bindings ())
+- end (* funB *);
+-
+- val bindings = andBindings fsys funB;
+- in
+- mkFunDeclaration (bindings,
+- {lookup= #lookup explicitTvars, apply= #apply explicitTvars},
+- {lookup= #lookup implicitTvars, apply= #apply implicitTvars})
+- end
++ else if sym eq SYMBOLS.wordConst
++ then (getConstant mkWord, locSpan(startLocn, symLoc))
+
+- else if sym eq SYMBOLS.typeSy
+- then
+- (
+- insymbol lex;
+- mkTypeDeclaration (andBindings fsys (typeBinding false false env))
+- )
+-
+- else if sym eq SYMBOLS.datatypeSy
+- then datatypeDecOrRepl fsys env false
+-
+- else if sym eq SYMBOLS.abstypeSy
+- then let
+- val U = insymbol lex;
+- val tb =
+- andBindings (fsys ++ withTypeWithSy)
+- (fn fsys => datatypeBinding fsys env false);
+-
+- val withtypes =
+- if testfor (SYMBOLS.withtypeSy, empty, lex)
+- then andBindings (fsys ++ withSy) (typeBinding false false env)
+- else [];
+-
+- val U : unit = getsym (SYMBOLS.withSy, lex);
+- val decs = decSequence (fsys ++ endSy) env;
+- in
+- getsym (SYMBOLS.endSy, lex);
+- mkAbstypeDeclaration (tb, withtypes, decs)
+- end
++ else if sym eq SYMBOLS.charConst
++ then (getConstant mkChar, locSpan(startLocn, symLoc))
+
+- else if sym eq SYMBOLS.exceptionSy
+- then let
+- (* Declares exception identifiers and their types. *)
+- val U = insymbol lex;
+-
+- (* Get an exception binding. Qualified names prohibited. *)
+- fun exceptionBinding fsys =
+- let
+- (* First the identifier. *)
+- val iden = getShortId (variableSys, fsys ++ ofEqualsSignSy, lex);
+- in
+- (* Either excon of ty or excon = excon' *)
+- if testfor (SYMBOLS.ofSy, empty, lex)
+- then
+- mkExBinding (iden, emptyTree,
+- parseType (fsys ++ equalsSign, lex,
+- {lookupTvar= #lookupTvar env}))
+- else if testfor (SYMBOLS.equalsSign, empty, lex)
+- then
+- let (* Must be = excon' *)
+- val oldIden = getLongId (variableSys, fsys, lex);
+- in
+- mkExBinding (iden, mkIdent oldIden, emptyType)
++ else (* Expected something e.g. an identifier. *)
++ (badsyms (SYMBOLS.ident, lex); (emptyTree, symLoc))
+ end
+- else mkExBinding (iden, emptyTree, emptyType)
+- end;
+- in
+- mkExDeclaration (andBindings fsys exceptionBinding)
+- end
++ end(* end atomicExpression *);
+
+- else if sym eq SYMBOLS.localSy
+- then let
+- val U = insymbol lex;
+- (* Infix status have this scope. Type-variables have the scope of the enclosing val or fun. *)
+- val newEnv = mkLocalFixEnv env
+- (* The local declaration *)
+- val ins = decSequence (fsys ++ inEndSy) newEnv;
+- val U : unit = getsym (SYMBOLS.inSy, lex);
+- (* Decs are added to both the local and surrounding environment. *)
+- val resultEnv = mkLocalBodyFixEnv newEnv enterFix
+
+- val body = decSequence (fsys ++ endSy) resultEnv;
+- in
+- getsym (SYMBOLS.endSy, lex);
+- mkLocalDeclaration (ins, body, true) (*"local" rather than "let"*)
+- end
++ fun keyWordExp fsys: parsetree * location =
++ (* Expressions introduced by keywords, atomic expressions or
++ infixed expressions. Expressions introduced by keywords (e.g. if)
++ swallow all of the rest of the expression but they can appear
++ within other keyword expressions or after "andalso" and "orelse". *)
++ let
++ val sym = sy lex;
++ val startLocn = location lex
++ in
++ (* if expression *)
++ if sym eq SYMBOLS.ifSy
++ then
++ let
++ val () = insymbol lex;
++ val (test, _) = expression (fsys ++ thenStartExpressionSy) env;
++ val () = getsym (SYMBOLS.thenSy, lex);
++ val (thenPt, _) = expression (fsys ++ elseStartExpressionSy) env;
++ val () = getsym (SYMBOLS.elseSy, lex);
++ val (elsePt, elseLocn) = expression fsys env;
++ val locs = locSpan(startLocn, elseLocn)
++ in
++ (mkCond (test, thenPt, elsePt, locs), locs)
++ end
+
+- else if sym eq SYMBOLS.infixSy orelse
+- sym eq SYMBOLS.infixrSy orelse
+- sym eq SYMBOLS.nonfixSy
+- then let
+- val U = insymbol lex;
+-
+- val fixForm =
+- if sym eq SYMBOLS.nonfixSy
+- then Nonfix
+- else
+- let
+- val precNo =
+- if (sy lex) eq SYMBOLS.integerConst
+- then (* Read a precedence number *)
+- let
+- val num = valOf(Int.fromString (id lex))
+- in
+- if num < 0 orelse num > 9
+- then errorMessage (lex, lineno lex,
++ (* while expression *)
++ else if sym eq SYMBOLS.whileSy
++ then
++ let
++ val () = insymbol lex;
++ val (test, testLocn) = expression (fsys ++ doSy) env;
++ in
++ if (sy lex) eq SYMBOLS.doSy
++ then
++ let
++ val () = insymbol lex;
++ val (doExp, doLocn) = expression fsys env
++ val locs = locSpan(startLocn, doLocn)
++ in
++ (mkWhile (test, doExp, locs), locs)
++ end
++ else (badsyms (SYMBOLS.doSy, lex); (test, testLocn))
++ end
++
++ (* case expression *)
++ else if sym eq SYMBOLS.caseSy
++ then
++ let
++ val () = insymbol lex;
++ val (exp, _) = expression (fsys ++ ofStartMatchSy) env;
++ val () = getsym (SYMBOLS.ofSy, lex);
++ val (m, matchLoc) = match (fsys ++ semicolon)
++ val locs = locSpan(startLocn, matchLoc)
++ in
++ (mkCase (exp, m, locs, matchLoc), locs)
++ end
++
++ (* raise exception *)
++ else if sym eq SYMBOLS.raiseSy
++ then
++ let
++ val () = insymbol lex;
++ val (exp, expLoc) = expression fsys env
++ val locs = locSpan(startLocn, expLoc)
++ in
++ (mkRaise (exp, locs), locs)
++ end
++
++ (* fn expression *)
++ else if (sy lex) eq SYMBOLS.fnSy
++ then
++ let
++ val () = insymbol lex;
++ val (m, matchLoc) = match (fsys ++ semicolon)
++ val locs = locSpan(startLocn, matchLoc)
++ in
++ (mkFn (m, locs), locs)
++ end
++
++ (* type constraint, or similar *)
++ else
++ let
++ val exp = parseInfix (fsys ++ andalsoColonSy) variableSys startAtomicSys atomicExpression env
++ in
++ constraint exp (fsys ++ andalsoSy) env
++ end
++ end (* keyWordExp *);
++
++ fun parseAndalso fsys =
++ (* EXP1 andalso EXP2 = if EXP1 then EXP2 else false *)
++ let
++ val (first, firstLoc) = keyWordExp (fsys ++ andalsoSy);
++ (* N.B. If the expression had been introduced by a keyword (e.g. if)
++ then the "else" part would have swallowed any "andalso". *)
++ in
++ if (sy lex) eq SYMBOLS.andalsoSy
++ then
++ let
++ val () = insymbol lex;
++ val (right, rightLoc) = parseAndalso fsys
++ val locs = locSpan(firstLoc, rightLoc)
++ in
++ (mkAndalso (first, right, locs), locs)
++ end
++ else (first, firstLoc)
++ end;
++
++ fun parseOrelse fsys =
++ (* EXP1 orelse EXP2 = if EXP1 then true else EXP2 *)
++ let
++ val (first, firstLoc) = parseAndalso (fsys ++ orelseSy);
++ in
++ if (sy lex) eq SYMBOLS.orelseSy
++ then
++ let
++ val () = insymbol lex;
++ val (right, rightLoc) = parseOrelse fsys
++ val locs = locSpan(firstLoc, rightLoc)
++ in
++ (mkOrelse (first, right, locs), locs)
++ end
++ else (first, firstLoc)
++ end;
++
++ in
++ skipon (startExpressionSys, fsys, "Expression", lex);
++
++ if (sy lex) inside startExpressionSys
++ then
++ let
++ val (exp, expLoc) = parseOrelse (fsys ++ handleSy);
++ in
++ if (sy lex) eq SYMBOLS.handleSy
++ then
++ let
++ val () = insymbol lex; (* Remove "handle" *)
++ val (m, mLoc) = match fsys
++ val locs = locSpan(expLoc, mLoc)
++ in
++ (mkHandleTree (exp, m, locs, mLoc), locs)
++ end
++ else (exp, expLoc)
++ end
++ else (emptyTree (* No expression *), location lex)
++
++ end; (* expression *)
++
++ in
++ (* One declaration. "decOnly" is true if the derived form exp => val it = exp is not allowed here. *)
++ if decOnly orelse (sy lex) inside startDecSys
++ then
++ let
++ val sym = sy lex;
++ val startLocn = location lex
++ in
++ if sym eq SYMBOLS.valSy
++ then
++ let
++ val () = insymbol lex;
++ (* Create two different scopes, for explicitly declared
++ type variables and those implicitly declared. *)
++ val implicitTvars = makeTypeVarEnv()
++ and explicitTvars = makeTypeVarEnv();
++ val newEnv = {enterFix = #enterFix env,
++ lookupFix = #lookupFix env,
++ lookupTvar =
++ (* Look up type variables in the explicit
++ environment, otherwise look them up and
++ add them to the implicit environment. *)
++ fn s => case #lookup explicitTvars s of
++ SOME t => t | NONE => #lookupTvar implicitTvars s};
++
++ (* Tyvarseq *)
++ val _ = getTypeVars(true,
++ { enter = #enter explicitTvars,
++ lookup = #lookup explicitTvars,
++ apply = #apply explicitTvars});
++
++ (* Processes a value binding. *)
++ (* We check for qualified names in the second pass *)
++ fun valB fsys =
++ let
++ val recursive = (sy lex) eq SYMBOLS.recSy
++ in
++ while (sy lex) eq SYMBOLS.recSy
++ do insymbol lex; (* Could be more than one *)
++ if recursive
++ then
++ let
++ val (valb, valbLocn) = valB fsys
++ in
++ (recValbind :: valb, valbLocn)
++ end
++ else
++ let
++ (* Pattern *)
++ val (vars, varLoc) = pattern (fsys ++ equalsSign) lex newEnv;
++ (* = *)
++ val () = getsym (SYMBOLS.equalsSign, lex);
++ (* expression *)
++ val (exp, expLoc) = expression fsys newEnv;
++ (* Other declarations. *)
++ val (tail, tailLocn) =
++ if testfor (SYMBOLS.andSy, empty, lex)
++ then valB fsys
++ else ([], expLoc)
++ in
++ (mkValBinding (vars, exp, locSpan(varLoc, expLoc)) :: tail, tailLocn)
++ end
++ end;
++
++ val (bindings, bindLocns) = valB (fsys ++ andSy)
++ val fullLocn = locSpan(startLocn, bindLocns)
++ in
++ (mkValDeclaration (bindings,
++ {lookup= #lookup explicitTvars, apply= #apply explicitTvars},
++ {lookup= #lookup implicitTvars, apply= #apply implicitTvars},
++ fullLocn),
++ fullLocn)
++ end
++
++ else if sym eq SYMBOLS.funSy
++ then
++ let
++ val () = insymbol lex;
++ (* Create two different scopes, for explicitly declared
++ type variables and those implicitly declared. *)
++ val implicitTvars = makeTypeVarEnv()
++ and explicitTvars = makeTypeVarEnv();
++ val newEnv = {enterFix = #enterFix env,
++ lookupFix = #lookupFix env,
++ lookupTvar =
++ fn s => case #lookup explicitTvars s of
++ SOME t => t | NONE => #lookupTvar implicitTvars s};
++
++ (* Tyvarseq *)
++ val _ = getTypeVars(true,
++ { enter = #enter explicitTvars,
++ lookup = #lookup explicitTvars,
++ apply = #apply explicitTvars});
++
++ fun funB fsys =
++ (* Processes a fun binding. *)
++ (* We check for qualified names in the second pass *)
++ let
++ fun bindings soFar =
++ let
++ (* Pattern - This isn't really a pattern but we can parse it as
++ that initially. That results in accepting some invalid syntax
++ so we need to check the parsed code. *)
++ val (vars, varLoc) = pattern (fsys ++ equalsSign) lex newEnv;
++ (* Get the name and number of args. *)
++ val (funPattern, funName, argCount) = mkFunPattern(vars, lex)
++ val () =
++ case soFar of
++ SOME(prevName, prevCount) =>
++ (
++ if prevName = funName
++ then ()
++ else errorMessage (lex, location lex,
++ "This clause defines function ``" ^ funName ^
++ "'' but previous clause(s) defined ``" ^
++ prevName ^ "''");
++ if prevCount = argCount
++ then ()
++ else errorMessage (lex, location lex,
++ "This clause has " ^ Int.toString argCount ^
++ " arguments but previous clause(s) had " ^
++ Int.toString prevCount)
++ )
++ | NONE => () (* This was first. *)
++ (* = *)
++ (* We expect an equals sign here but a common problem is
++ to confuse fun declarations with matches and use a =>
++ here. Report the error but swallow the =>. *)
++ val () =
++ if (sy lex) eq SYMBOLS.equalsSign then insymbol lex
++ else
++ (
++ notfound ("=", lex);
++ if (sy lex) eq SYMBOLS.thickArrow then insymbol lex else ()
++ );
++ (* expression *)
++ val (exp, expLoc) = expression (fsys ++ verticalBar) newEnv;
++ val bind = mkClause (funPattern, exp, locSpan(varLoc, expLoc));
++ (* Followed by a vertical bar and another binding ? *)
++ val (rest, endLoc) =
++ if testfor (SYMBOLS.verticalBar, empty, lex)
++ then bindings(SOME(funName, argCount))
++ else ([], expLoc)
++ in
++ (bind :: rest, locSpan(varLoc, endLoc))
++ end;
++
++ val (bindings, bindLocns) = bindings NONE
++ in
++ (mkClausal (bindings, bindLocns), bindLocns)
++ end (* funB *);
++
++ val (bindings, bindLocns) = andBindings(fsys, funB);
++ val fullLocn = locSpan(startLocn, bindLocns)
++ in
++ (mkFunDeclaration (bindings,
++ {lookup= #lookup explicitTvars, apply= #apply explicitTvars},
++ {lookup= #lookup implicitTvars, apply= #apply implicitTvars},
++ fullLocn),
++ fullLocn)
++ end
++
++ else if sym eq SYMBOLS.typeSy
++ then
++ let
++ val () = insymbol lex;
++ val (bindings, bindLocns) = andBindings(fsys, typeBinding(false, false, env))
++ val fullLocn = locSpan(startLocn, bindLocns)
++ in
++ (mkTypeDeclaration (bindings, fullLocn), fullLocn)
++ end
++
++ else if sym eq SYMBOLS.datatypeSy
++ then datatypeDecOrRepl(fsys, env, false, startLocn)
++
++ else if sym eq SYMBOLS.abstypeSy
++ then
++ let
++ val () = insymbol lex;
++ val (tb, _) =
++ andBindings (fsys ++ withTypeWithSy, datatypeBinding(env, false));
++
++ val (withtypes, _) =
++ if testfor (SYMBOLS.withtypeSy, empty, lex)
++ then andBindings (fsys ++ withSy, typeBinding(false, false, env))
++ else ([], startLocn);
++
++ val () = getsym (SYMBOLS.withSy, lex);
++ val decs = decSequence (fsys ++ endSy, env);
++ val fullLocn = locSpan(startLocn, location lex)
++ in
++ getsym (SYMBOLS.endSy, lex);
++ (mkAbstypeDeclaration (tb, withtypes, decs, fullLocn), fullLocn)
++ end
++
++ else if sym eq SYMBOLS.exceptionSy
++ then
++ let
++ (* Declares exception identifiers and their types. *)
++ val () = insymbol lex;
++
++ (* Get an exception binding. Qualified names prohibited. *)
++ fun exceptionBinding fsys =
++ let
++ (* First the identifier. *)
++ val (iden, idLoc) = getShortId (variableSys, fsys ++ ofEqualsSignSy, lex);
++ in
++ (* Either excon of ty or excon = excon' *)
++ if testfor (SYMBOLS.ofSy, empty, lex)
++ then
++ let
++ val (theType, typeLocn) =
++ parseType (fsys ++ equalsSign, lex, {lookupTvar= #lookupTvar env})
++ val fullLoc = locSpan(idLoc, typeLocn)
++ in
++ (mkExBinding (iden, emptyTree, SOME theType, idLoc, fullLoc), fullLoc)
++ end
++ else if testfor (SYMBOLS.equalsSign, empty, lex)
++ then
++ let (* Must be = excon' *)
++ val (oldIden, oldIdenLoc) = getLongId (variableSys, fsys, lex);
++ val fullLoc = locSpan(idLoc, oldIdenLoc)
++ in
++ (mkExBinding (iden, mkIdent(oldIden, oldIdenLoc), NONE, idLoc, fullLoc), fullLoc)
++ end
++ else (mkExBinding (iden, emptyTree, NONE, idLoc, idLoc), idLoc)
++ end;
++ val (bindings, bindLocns) = andBindings(fsys, exceptionBinding)
++ val fullLocn = locSpan(startLocn, bindLocns)
++ in
++ (mkExDeclaration (bindings, fullLocn), fullLocn)
++ end
++
++ else if sym eq SYMBOLS.localSy
++ then let
++ val () = insymbol lex;
++ (* Infix status have this scope. Type-variables have the scope of the enclosing val or fun. *)
++ val newEnv = mkLocalFixEnv env
++ (* The local declaration *)
++ val ins = decSequence (fsys ++ inEndSy, newEnv);
++ val () = getsym (SYMBOLS.inSy, lex);
++ (* Decs are added to both the local and surrounding environment. *)
++ val resultEnv = mkLocalBodyFixEnv newEnv enterFix
++
++ val body = decSequence (fsys ++ endSy, resultEnv)
++
++ val locs = locSpan(startLocn, location lex)
++ in
++ getsym (SYMBOLS.endSy, lex);
++ (mkLocalDeclaration (ins, body, locs, true), (*"local" rather than "let"*) locs)
++ end
++
++ else if sym eq SYMBOLS.infixSy orelse
++ sym eq SYMBOLS.infixrSy orelse
++ sym eq SYMBOLS.nonfixSy
++ then
++ let
++ val () = insymbol lex;
++
++ val fixForm =
++ if sym eq SYMBOLS.nonfixSy
++ then Nonfix
++ else
++ let
++ val precNo =
++ if (sy lex) eq SYMBOLS.integerConst
++ then (* Read a precedence number *)
++ let
++ val num = valOf(Int.fromString (id lex))
++ in
++ if num < 0 orelse num > 9
++ then errorMessage (lex, location lex,
+ "Precedence " ^ id lex ^
+ " not allowed, must be between 0 and 9")
+- else ();
+- insymbol lex;
+- num
+- end
+- else 0 (* default is zero *);
+- in
+- if sym eq SYMBOLS.infixSy
+- then Infix precNo (* infix *)
+- else InfixR precNo (* infixr *)
+- end;
+-
+- (* Should now be at least one variable. *)
+- val U = skipon (variableSys, fsys, "Variable", lex);
+-
+- (* Read the variables and put them in the environ
+- with their fix status. Qualified names prohibited. *)
+- fun vars() =
+- if (sy lex) inside variableSys
+- then
+- let
+- val iden = getShortId (variableSys, fsys, lex);
+- val U : unit = #enterFix env (iden, fixForm);
+- in
+- iden :: vars()
+- end
+- else [];
+- in
+- mkDirective (vars (), fixForm)
+- end
++ else ();
++ insymbol lex;
++ num
++ end
++ else 0 (* default is zero *);
++ in
++ if sym eq SYMBOLS.infixSy
++ then Infix precNo (* infix *)
++ else InfixR precNo (* infixr *)
++ end;
++
++ (* Should now be at least one variable. *)
++ val () = skipon (variableSys, fsys, "Variable", lex);
++
++ (* Read the variables and put them in the environ
++ with their fix status. Qualified names prohibited. *)
++ fun vars endLoc =
++ if (sy lex) inside variableSys
++ then
++ let
++ val (iden, idLoc) = getShortId (variableSys, fsys, lex);
++ val () = #enterFix env (iden, fixForm);
++ val (tail, endLoc) = vars idLoc
++ in
++ (iden :: tail, endLoc)
++ end
++ else ([], endLoc);
++
++ val (variables, endLoc) = vars startLocn
++ val fullLocn = locSpan(startLocn, endLoc)
++ in
++ (mkDirective (variables, fixForm, fullLocn), fullLocn)
++ end
+
+- (* "open" declaration - qualified names allowed *)
+- else if testfor (SYMBOLS.openSy, empty, lex)
+- then let
+- fun vars() =
+- if (sy lex) inside variableSys
+- then
+- let
+- val iden = getLongId (variableSys, fsys, lex);
+- in
+- mkStructureIdent iden :: vars()
+- end
+- else [];
+- in
+- if (sy lex) inside variableSys
+- then mkOpenTree (vars())
+- else (* Identifier missing. *)
+- (badsyms (SYMBOLS.ident, lex); emptyTree)
++ (* "open" declaration - qualified names allowed *)
++ else if testfor (SYMBOLS.openSy, empty, lex)
++ then
++ let
++ fun vars endLoc =
++ if (sy lex) inside variableSys
++ then
++ let
++ val (id, idLoc) = getLongId (variableSys, fsys, lex);
++ val (tail, tailLoc) = vars idLoc
++ in
++ (mkStructureIdent(id, idLoc) :: tail, tailLoc)
++ end
++ else ([], endLoc);
++ in
++ if (sy lex) inside variableSys
++ then
++ let
++ val (vars, varLocns) = vars startLocn
++ in
++ (mkOpenTree(vars, varLocns), varLocns)
++ end
++ else (* Identifier missing. *)
++ (badsyms (SYMBOLS.ident, lex); (emptyTree, startLocn))
+ end
+
+- else emptyTree (* Empty declaration. *)
++ else (emptyTree, startLocn) (* Empty declaration. *)
++
++ end
+
+- end
++ else
++ let (* Single expression allowed - short for val it = exp *)
++ val newTvars = makeTypeVarEnv();
++ val explicitTvars = makeTypeVarEnv();(* This will always be empty. *)
++ val newEnv = {enterFix = #enterFix env,
++ lookupFix = #lookupFix env,
++ lookupTvar = #lookupTvar newTvars};
++ val (exp, expLoc) = expression fsys newEnv
++ in
++ (mkValDeclaration ([mkValBinding (mkIdent ("it", nullLocation), exp, expLoc)],
++ {lookup= #lookup explicitTvars,apply= #apply explicitTvars},
++ {lookup= #lookup newTvars,apply= #apply newTvars},
++ expLoc), expLoc)
++ end
++ end (* dec *);
+
+- else let (* Single expression allowed - short for val it = exp *)
+- val newTvars = makeTypeVarEnv();
+- val explicitTvars = makeTypeVarEnv();(* This will always be empty. *)
+- val newEnv = {enterFix = #enterFix env,
+- lookupFix = #lookupFix env,
+- lookupTvar = #lookupTvar newTvars};
+- val lno = lineno lex;
+- val exp = expression fsys newEnv
+- in
+- mkValDeclaration ([mkValBinding (mkIdent "it", exp, lno)],
+- {lookup= #lookup explicitTvars,apply= #apply explicitTvars},
+- {lookup= #lookup newTvars,apply= #apply newTvars})
+- end
+- end (* dec *);
+-
+- (* Parses a signature. *)
+- fun parseSignature (fsys : symset) (lex : lexan) (env as {enterFix,lookupFix,lookupTvar}) : structs =
+- let (* May be either a signature name or a sig spec .. spec end seq
++ (* Parses a signature. *)
++ fun parseSignature (fsys : symset) (lex : lexan) env : sigs * location =
++ let (* May be either a signature name or a sig spec .. spec end seq
+ followed by multiple where type expressions. *)
+- val U : unit = skipon (declarableVarSys ++ sigSy, fsys, "Start of signature", lex)
++ val () = skipon (declarableVarSys ++ sigSy, fsys, "Start of signature", lex)
+
+- val sigexp : structs =
+- if testfor (SYMBOLS.sigSy, empty, lex)
+- then let (* sig *)
+- val sgn = mkSig (signatureSpec (fsys ++ endSy ++ whereSy ++ semicolon) lex env)
+- in
+- getsym (SYMBOLS.endSy, lex);
+- sgn
+- end
+-
+- else if (sy lex) eq SYMBOLS.ident
+- then mkSigIdent (getShortId (declarableVarSys, fsys ++ whereSy, lex))
+-
+- else (* Only if parse error which will have been reported in skipon. *)
+- emptyStruct;
+-
+- fun getWhereTypes sigexp =
+- let
+- (* This is similar to a type binding but with the possibility
+- that the type is a longtycon. *)
+- val U: unit = getsym(SYMBOLS.typeSy, lex);
+- val lno = lineno lex
+- val newTVenv = searchList ();
+- val typeVars = getTypeVars (false, newTVenv);
+- val typeName = getLongId (ident, fsys ++ equalsSign, lex);
+- val typeVarEnv = genTypeVarEnv newTVenv;
+- val _ = getsym (SYMBOLS.equalsSign, lex);
+- (* Followed by a type or a sequence of constructors *)
+- val _ = skipon (startTypeSys, fsys, "type", lex);
+- val constrainedSig = mkWhereType(sigexp, typeVars, typeName,
+- parseType (fsys ++ whereSy ++ andSy, lex, typeVarEnv),
+- lno)
+- in
+- if testfor (SYMBOLS.whereSy, empty, lex)
+- (* Recurse to handle any other wheres. *)
+- then getWhereTypes constrainedSig
+-
+- else if testfor (SYMBOLS.andSy, empty, lex)
+- then
+- (* There are two possibilities here. It may be the start of another
+- type abbreviation or it may be the start of another signature. *)
+- if sy lex eq SYMBOLS.typeSy
+- then getWhereTypes constrainedSig
+- else (* Push the "and" back into the lexer so it can be picked out later. *)
+- (
+- pushBackSymbol(lex, SYMBOLS.andSy);
+- constrainedSig
+- )
+- else constrainedSig
+- end
+- in
+- if testfor (SYMBOLS.whereSy, empty, lex)
+- then getWhereTypes sigexp
+- else sigexp
+- end (* parseSignature *)
++ val startLocn = location lex
++
++ val sigexp : sigs * location =
++ if testfor (SYMBOLS.sigSy, empty, lex)
++ then
++ let (* sig *)
++ val sigs = signatureSpec (fsys ++ endSy ++ whereSy ++ semicolon) lex env
++ val locs = locSpan(startLocn, location lex)
++ in
++ getsym (SYMBOLS.endSy, lex);
++ (mkSig (sigs, locs), locs)
++ end
++
++ else if (sy lex) eq SYMBOLS.ident
++ then
++ let
++ val ident as (_, locs) = getShortId (declarableVarSys, fsys ++ whereSy, lex)
++ in
++ (mkSigIdent ident, locs)
++ end
++
++ else (* Only if parse error which will have been reported in skipon. *)
++ (mkSigIdent("error", location lex), location lex);
++
++ fun getWhereTypes(sigexp, sigLoc) =
++ let
++ (* This is similar to a type binding but with the possibility
++ that the type is a longtycon. *)
++ val () = getsym(SYMBOLS.typeSy, lex);
++ val newTVenv = searchList ();
++ val typeVars = getTypeVars (false, newTVenv);
++ val (typeName, nameLoc) = getLongId (ident, fsys ++ equalsSign, lex);
++ val typeVarEnv = genTypeVarEnv newTVenv;
++ val () = getsym (SYMBOLS.equalsSign, lex);
++ (* Followed by a type or a sequence of constructors *)
++ val () = skipon (startTypeSys, fsys, "type", lex);
++ val (theType, typeLoc) = parseType (fsys ++ whereSy ++ andSy, lex, typeVarEnv)
++ val constrainedSig =
++ (mkWhereType(sigexp, typeVars, typeName, typeFromTypeParse theType, nameLoc),
++ locSpan(sigLoc, typeLoc))
++ in
++ if testfor (SYMBOLS.whereSy, empty, lex)
++ (* Recurse to handle any other wheres. *)
++ then getWhereTypes constrainedSig
++
++ else if testfor (SYMBOLS.andSy, empty, lex)
++ then
++ (* There are two possibilities here. It may be the start of another
++ type abbreviation or it may be the start of another signature. *)
++ if sy lex eq SYMBOLS.typeSy
++ then getWhereTypes constrainedSig
++ else (* Push the "and" back into the lexer so it can be picked out later. *)
++ (
++ pushBackSymbol(lex, SYMBOLS.andSy);
++ constrainedSig
++ )
++ else constrainedSig
++ end
++ in
++ if testfor (SYMBOLS.whereSy, empty, lex)
++ then getWhereTypes sigexp
++ else sigexp
++ end (* parseSignature *)
+
+
+ (* Sequence of "specs" *)
+- and signatureSpec (fsys : symset) (lex : lexan) (env as {enterFix,lookupFix,lookupTvar}) : structs list =
++ and signatureSpec (fsys : symset) (lex : lexan) (env as {lookupTvar, ...}) : specs list =
+ let
+ val signatureTvars = makeTypeVarEnv();
+
+- fun parseSigEntries () : structs list =
++ fun parseSigEntries () : specs list =
+ let
+- val U : unit = skipon (fsys ++ semicolonStartSigSys, fsys, "Signature", lex)
+- val sym = sy lex;
++ val () = skipon (fsys ++ semicolonStartSigSys, fsys, "Signature", lex)
++ val sym = sy lex and startLocn = location lex
+ val thisSig =
+ if sym eq SYMBOLS.datatypeSy
+ then
+- let
+- val lno = lineno lex
+- val sys = fsys ++ startSigEndSy
+- val newenv =
+- {enterFix = #enterFix env, lookupFix = #lookupFix env,
+- (* All type variables on the right hand side of a datatype
+- specification must appear on the left. *)
+- lookupTvar =
+- fn name =>
+- (
+- errorMessage (lex, lineno lex,
+- name ^ " has not been declared in type declaration");
+- badType
+- )
+- }
+- in
+- [mkTopLevel (datatypeDecOrRepl sys newenv true, lno)]
+- end
++ let
++ val startLocn = location lex
++ val sys = fsys ++ startSigEndSy
++ val newenv =
++ {enterFix = #enterFix env, lookupFix = #lookupFix env,
++ (* All type variables on the right hand side of a datatype
++ specification must appear on the left. *)
++ lookupTvar =
++ fn name =>
++ (
++ errorMessage (lex, location lex,
++ name ^ " has not been declared in type declaration");
++ badType
++ )
++ }
++ in
++ [mkCoreType (datatypeDecOrRepl(sys, newenv, true, startLocn))]
++ end
+
+ else if sym eq SYMBOLS.typeSy
+- then
+- (* It isn't obvious whether specifications of the form
+- type s and t = int * int (i.e. mixed specifications and
+- abbreviations) are allowed. For the moment allow them. *)
+- let
+- val lno = lineno lex
+- val sys = fsys ++ startSigEndSy
+- in
+- insymbol lex;
+- [mkTopLevel (mkTypeDeclaration
+- (andBindings sys (typeBinding true false env)), lno)]
+- end
++ then
++ (* It isn't obvious whether specifications of the form
++ type s and t = int * int (i.e. mixed specifications and
++ abbreviations) are allowed. For the moment allow them. *)
++ let
++ val sys = fsys ++ startSigEndSy
++ val () = insymbol lex;
++ val (bindings, bindLocns) = andBindings(sys, typeBinding(true, false, env))
++ in
++ [mkCoreType (mkTypeDeclaration(bindings, bindLocns), locSpan(startLocn, bindLocns))]
++ end
+
+ else if sym eq SYMBOLS.eqtypeSy
+- then
+- let
+- val lno = lineno lex
+- val sys = fsys ++ startSigEndSy
+- in
+- insymbol lex;
+- [mkTopLevel (mkTypeDeclaration
+- (andBindings sys (typeBinding true true env)), lno)]
+- end
++ then
++ let
++ val sys = fsys ++ startSigEndSy
++ val () = insymbol lex;
++ val (bindings, bindLocns) = andBindings(sys, typeBinding(true, true, env))
++ in
++ [mkCoreType (mkTypeDeclaration(bindings, bindLocns), locSpan(startLocn, bindLocns))]
++ end
++
+ else if sym eq SYMBOLS.valSy
+- then let
+- val UUU = insymbol lex
++ then
++ let
++ val () = insymbol lex
+
+- fun doVal () =
+- let
+- val lno = lineno lex;
+- val id = getShortId (declarableVarSys, fsys ++ colon, lex);
+- val U : unit = getsym (SYMBOLS.colon, lex);
+- val ty =
+- parseType (fsys ++ startSigEndAndSy, lex,
+- {lookupTvar = #lookupTvar signatureTvars});
+- (* bugfixed SPF 19/2/94 - was #lookup signatureTvars *)
++ fun doVal () =
++ let
++ val idAndLoc as (_, idLoc) = getShortId (declarableVarSys, fsys ++ colon, lex);
++ val () = getsym (SYMBOLS.colon, lex);
++ val (ty, tyLoc) =
++ parseType (fsys ++ startSigEndAndSy, lex,
++ {lookupTvar = #lookupTvar signatureTvars});
++ val locs = locSpan(idLoc, tyLoc)
+ in
+- mkValSig (id, ty, lno)
++ (mkValSig (idAndLoc, ty, locs), locs)
+ end
+ in
+- getList (SYMBOLS.andSy, empty, lex, doVal)
++ #1 (getList (SYMBOLS.andSy, empty, lex, doVal))
+ end (* val *)
+
+ else if sym eq SYMBOLS.exceptionSy
+- then let(* exception id1 of ty1 and _ and idn of tyn *)
+- val U : unit = insymbol lex
++ then
++ let(* exception id1 of ty1 and _ and idn of tyn *)
++ val () = insymbol lex
+
+- fun doEx () =
+- let
+- val lno = lineno lex
+- val id = getShortId (variableSys, fsys ++ ofSy, lex)
+- val ty =
+- if testfor (SYMBOLS.ofSy, empty, lex)
+- then parseType (fsys ++ startSigEndAndSy, lex,
+- {lookupTvar = lookupTvar})
+- else (* Nullary *) emptyType;
++ fun doEx () =
++ let
++ val idAndLoc as (_, idLoc) = getShortId (variableSys, fsys ++ ofSy, lex)
++ val (ty, locs) =
++ if testfor (SYMBOLS.ofSy, empty, lex)
++ then
++ let
++ val (types, tyLoc) =
++ parseType (fsys ++ startSigEndAndSy, lex, {lookupTvar = lookupTvar})
++ in
++ (SOME types, locSpan(idLoc, tyLoc))
++ end
++ else (* Nullary *) (NONE, idLoc);
+ in
+- mkExSig (id, ty, lno)
++ (mkExSig (idAndLoc, ty, locs), locs)
+ end
+- in
+- getList (SYMBOLS.andSy, empty, lex, doEx)
+- end (* exception *)
++ in
++ #1 (getList (SYMBOLS.andSy, empty, lex, doEx))
++ end (* exception *)
+
+ else if sym eq SYMBOLS.structureSy
+- then let
+- val U : unit = insymbol lex
++ then
++ let
++ val () = insymbol lex
+
+- fun doStructure () =
+- let
+- val lno = lineno lex
+- val id = getShortId (variableSys, empty, lex)
+- val U : unit = getsym (SYMBOLS.colon, lex)
+- val sgn = parseSignature (fsys ++ startSigEndAndSy) lex env
+- in
+- mkStructureBinding (id, sgn, false, emptyStruct, lno)
+- end
+- in
+- [mkStructureDec (getList (SYMBOLS.andSy, empty, lex, doStructure))]
+- end
++ fun doStructure () =
++ let
++ val idAndLoc as (_, idLoc) = getShortId (variableSys, empty, lex)
++ val () = getsym (SYMBOLS.colon, lex)
++ val (sgn, sgnLoc) = parseSignature (fsys ++ startSigEndAndSy) lex env
++ val locs = locSpan(idLoc, sgnLoc)
++ in
++ (mkStructureSigBinding (idAndLoc, (sgn, false, sgnLoc), locs), locs)
++ end
++ in
++ [mkStructureSig(getList(SYMBOLS.andSy, empty, lex, doStructure))]
++ end
+
+ else if sym eq SYMBOLS.includeSy
+- then let
+- (* In ML 97 we can have "include sigexp" but in addition as
+- a derived form we can have "include ident...ident".
+- Presumably this is for backwards compatibility.
+- sigexp may be a single identifier but could
+- also be an identifier with a "where type" constraint.
+- I hate this sort of inconsistency.
+- The simplest way to deal with this is to parse the
+- first one as a general signature and then allow multiple
+- identifiers. That is rather more general than the syntax
+- allows and perhaps we should check that the first signature
+- was simply an identifier. *)
+- val UUU = insymbol lex
+- val U : unit =
+- skipon (declarableVarSys ++ sigSy, fsys, "Start of signature", lex)
+-
+- val firstSig =
+- parseSignature (fsys ++ startSigEndSy ++ declarableVarSys)
+- lex env
+-
+- fun sigids () =
+- if (sy lex) eq SYMBOLS.ident
+- then mkSigIdent (getShortId (declarableVarSys, fsys, lex))
+- :: sigids()
+- else []
++ then
++ let
++ (* In ML 97 we can have "include sigexp" but in addition as
++ a derived form we can have "include ident...ident".
++ Presumably this is for backwards compatibility.
++ sigexp may be a single identifier but could
++ also be an identifier with a "where type" constraint.
++ I hate this sort of inconsistency.
++ The simplest way to deal with this is to parse the
++ first one as a general signature and then allow multiple
++ identifiers. That is rather more general than the syntax
++ allows and perhaps we should check that the first signature
++ was simply an identifier. *)
++ val () = insymbol lex
++ val () =
++ skipon (declarableVarSys ++ sigSy, fsys, "Start of signature", lex)
++
++ val (firstSig, firstLoc) =
++ parseSignature (fsys ++ startSigEndSy ++ declarableVarSys) lex env
++
++ fun sigids locs =
++ if (sy lex) eq SYMBOLS.ident
++ then
++ let
++ val nameLoc as (_, loc) = getShortId (declarableVarSys, fsys, lex)
++ val (rest, lastLoc) = sigids loc
++ in
++ (mkSigIdent nameLoc :: rest, lastLoc)
++ end
++ else ([], locs)
+
+- in
+- [mkInclude (firstSig :: sigids())]
+- end
++ val (otherSigs, finalLoc) = sigids firstLoc
++ in
++ [mkInclude (firstSig :: otherSigs, locSpan(startLocn, finalLoc))]
++ end
+
+ else if sym eq SYMBOLS.sharingSy
+- then let (* sharing *)
+- val UUU = insymbol lex
+- (* Now the types or structures. *)
+- fun doSharing () : structs =
+- let
+- val lno = lineno lex
+- val isType = testfor (SYMBOLS.typeSy, empty, lex)
+- fun getShare () : string =
+- (getLongId (declarableVarSys,
+- fsys ++ rightParenEqualsSignAndSy,
+- lex));
+- val shares = getShare ()
+- val U : unit = getsym (SYMBOLS.equalsSign, lex)
+- val share: structs =
+- mkSharing
+- (isType,
+- shares :: getList (SYMBOLS.equalsSign, ident, lex, getShare),
+- lno)
+- in
+- if (sy lex) eq SYMBOLS.andSy andalso not (getParameter ml90Tag (debugParams lex))
+- then errorMessage (lex, lineno lex,
+- "sharing ... and ... is not allowed in ML97")
+- else ();
+- share
+- end (* doSharing *)
+- in
+- getList (SYMBOLS.andSy, declarableVarSys, lex, doSharing)
+- end
++ then
++ let (* sharing *)
++ val startLocn = location lex
++ val () = insymbol lex
++ val isType = testfor (SYMBOLS.typeSy, empty, lex)
++ fun getShare () =
++ let
++ val (id, loc) = getLongId (declarableVarSys, fsys ++ rightParenEqualsSignSy, lex)
++ in
++ (* We want to include the location in the list as well as in the result here. *)
++ ((id, loc), loc)
++ end
++ val (shares, _) = getShare ()
++ val () = getsym (SYMBOLS.equalsSign, lex)
++ val (shareRest, shareLocn) = getList (SYMBOLS.equalsSign, ident, lex, getShare)
++ val fullLoc = locSpan(startLocn, shareLocn)
++ val share = mkSharing (isType, shares :: shareRest, fullLoc)
++ in
++ [share]
++ end
+
+- else [] (* Empty. *)
++ else [] (* Empty. *)
+ (* end of parse of thisSig *)
+
+ (* continue until the `end' *)
+- val UUU = if (sy lex) eq SYMBOLS.semicolon then insymbol lex else ();
++ val () = if (sy lex) eq SYMBOLS.semicolon then insymbol lex else ();
+ in
+- if (sy lex) inside semicolonStartSigSys
++ if (sy lex) inside semicolonStartSigSys
+ then thisSig @ parseSigEntries ()
+- else thisSig
++ else thisSig
+ end (* parseSigEntries *)
+ in
+ parseSigEntries ()
+ end (* signatureSpec *);
+
+
+- fun signatureDec (fsys : symset) (lex : lexan) (env as {enterFix,lookupFix,lookupTvar}) : structs =
+- let
+- val UUU = insymbol lex
+- fun doSigDec () =
+- let
+- val lno = lineno lex
+- val id = getShortId (variableSys, empty, lex);
+- val U : unit = getsym (SYMBOLS.equalsSign, lex)
+- val sgn = parseSignature (fsys ++ endAndSy) lex env
+- in
+- mkSignatureBinding (id, sgn, lno)
+- end
+- in
+- mkSignatureDec (getList (SYMBOLS.andSy, empty, lex, doSigDec))
+- end
++ fun signatureDec (fsys : symset) (lex : lexan) env : topdec =
++ let
++ val startLocn = location lex
++ val () = insymbol lex
++ fun doSigDec () =
++ let
++ val idAndLoc as (_, idLoc) = getShortId (variableSys, empty, lex);
++ val () = getsym (SYMBOLS.equalsSign, lex)
++ val (sgn, sigLoc) = parseSignature (fsys ++ endAndSy) lex env
++ val locs = locSpan(idLoc, sigLoc)
++ in
++ (mkSignatureBinding (idAndLoc, sgn, locs), locs)
++ end
++
++ val (sigs, sigLoc) = getList (SYMBOLS.andSy, empty, lex, doSigDec)
++ in
++ mkSignatureDec (sigs, locSpan(startLocn, sigLoc))
++ end
+
+
+- fun structVal (fsys : symset) (lex : lexan) (env as {enterFix,lookupFix,lookupTvar}) : structs =
++ fun structVal (fsys : symset) (lex : lexan) env : structs * location =
+ let
+ (* Series of declarations inside struct...end or (...) in functor
+ application. *)
+- fun structEnd (fsys: symset) : structs =
+- let
+- (* Infix declarations are local to struct ... end. *)
+- val structEnv = mkLocalFixEnv env
+- in
+- mkStruct (strDec (fsys ++ endSy) lex structEnv)
+- end (* structEnd *)
+
+- val UUU = skipon (structSy ++ declarableVarLetSy,
++ val () = skipon (structSy ++ declarableVarLetSy,
+ fsys, "struct or functor application", lex);
+
+ val fsysPcolon = fsys ++ colon ++ colonGt
++ val startLocn = location lex
+
+ val strExp =
+ if testfor (SYMBOLS.structSy, empty, lex)
+- then let(* It's a new structure *)
+- val str = structEnd fsysPcolon
+- val U : unit = getsym (SYMBOLS.endSy, lex)
++ then
++ let(* It's a new structure *)
++ (* Infix declarations are local to struct ... end. *)
++ val structEnv = mkLocalFixEnv env
++ val str = strDec (fsysPcolon ++ endSy) lex structEnv
++ val locs = locSpan(startLocn, location lex)
++ val () = getsym (SYMBOLS.endSy, lex)
+ in
+- str
++ (mkStruct(str, locs), locs)
+ end
+
+ else if testfor (SYMBOLS.letSy, empty, lex)
+ then let
+ (* Fixity is local. *)
+- val lno = lineno lex;
+ val newEnv = mkLocalFixEnv env
+ (* The local declaration *)
+ val ins = strDec (fsysPcolon ++ inEndSy) lex newEnv
+- val U : unit = getsym (SYMBOLS.inSy, lex)
+- val body = [structVal (fsysPcolon ++ endSy) lex newEnv]
+- val U : unit = getsym (SYMBOLS.endSy, lex)
++ val () = getsym (SYMBOLS.inSy, lex)
++ val body = [#1 (structVal (fsysPcolon ++ endSy) lex newEnv)]
++ val endLoc = location lex
++ val () = getsym (SYMBOLS.endSy, lex)
++ val locs = locSpan(startLocn, endLoc)
+ in
+- mkLocaldec (ins, body, (* "let" rather than "local" *) false, lno)
++ (mkLocaldec (ins, body, (* "let" rather than "local" *) false, locs), locs)
+ end
+
+- else let (* Either a structure path or a functor application *)
+- val iden = getLongId (declarableVarSys, fsysPcolon ++ leftParen, lex);
++ else
++ let (* Either a structure path or a functor application *)
++ val (iden, idLoc) = getLongId (declarableVarSys, fsysPcolon ++ leftParen, lex);
++ val startLoc = location lex
+ in
+- if testfor (SYMBOLS.leftParen, empty, lex)
+- then let (* functor application *)
+- (* Functor names shouldn't be qualified, so we ought to
+- check this here using:
+- checkForDots (iden, lex, lineno lex)
+- Unfortunately, this breaks the Poly/ML prelude, which
+- needs the functor RunCall.Run_exception1, so I've
+- taken this check out again! SPF 17/4/96
+- *)
+- val parameter =
+- if (sy lex) eq SYMBOLS.rightParen (* Empty parameter list *)
+- then mkStruct []
+- else let
+- val tsys = fsysPcolon ++ rightParenCommaSy
+- in
+- (* May be either a structure value or a sequence
+- of declarations. *)
+- if (sy lex) inside startDecStructureSy
+- then structEnd tsys (* implied struct...end *)
+- else structVal tsys lex env
+- end
+- val U : unit = getsym (SYMBOLS.rightParen, lex)
+- in
+- mkFunctorAppl (iden, parameter)
+- end
+- else mkStructIdent iden
++ if testfor (SYMBOLS.leftParen, empty, lex)
++ then
++ let (* functor application *)
++ (* Functor names must not be qualified. *)
++ val () = checkForDots (iden, lex, idLoc);
++ val parameter =
++ if (sy lex) eq SYMBOLS.rightParen (* Empty parameter list *)
++ then mkStruct([], locSpan(startLoc, location lex))
++ else
++ let
++ val tsys = fsysPcolon ++ rightParenCommaSy
++ in
++ (* May be either a structure value or a sequence
++ of declarations. *)
++ if (sy lex) inside startDecStructureSy
++ then (* implied struct...end *)
++ let
++ val structEnv = mkLocalFixEnv env
++ val str = strDec tsys lex structEnv
++ val locs = locSpan(startLoc, location lex)
++ in
++ mkStruct(str, locs)
++ end
++ else #1 (structVal tsys lex env)
++ end
++ val endPos = location lex
++ val () = getsym (SYMBOLS.rightParen, lex)
++ val locs = locSpan(idLoc, endPos)
++ in
++ (mkFunctorAppl (iden, parameter, idLoc, locs), locs)
++ end
++ else (mkStructIdent (iden, idLoc), idLoc)
+ end
+
+- (* We may have one or more constraints. *)
+- fun doConstraints strExp =
+- if testfor (SYMBOLS.colon, empty, lex)
+- then doConstraints(mkSigConstraint(strExp, parseSignature fsysPcolon lex env, false))
+- else if testfor (SYMBOLS.colonGt, empty, lex)
+- then doConstraints(mkSigConstraint(strExp, parseSignature fsysPcolon lex env, true))
+- else strExp
++ (* We may have one or more constraints. *)
++ fun doConstraints (strExp, strExpLoc) =
++ let
++ val isOpaque = (sy lex) eq SYMBOLS.colonGt;
++ in
++ if testfor (SYMBOLS.colon, empty, lex) orelse testfor (SYMBOLS.colonGt, empty, lex)
++ then
++ let
++ val (sign, sigLoc) = parseSignature fsysPcolon lex env
++ in
++ doConstraints(mkSigConstraint(strExp, sign, isOpaque, sigLoc), locSpan(strExpLoc, sigLoc))
++ end
++ else (strExp, strExpLoc)
++ end
+ in
+ doConstraints strExp
+ end (* structVal *)
+
+- and structureDec (fsys : symset) (lex : lexan) (env as {enterFix,lookupFix,lookupTvar}) : structs =
+-
+- if testfor (SYMBOLS.structureSy, empty, lex)
+- then let
+- fun doStrDec () =
+- let (* Read strId <<: sig>> = str *)
+- val lno = lineno lex
+- (* First the identifier *)
+- val strId = getShortId (declarableVarSys, fsys ++ colonEqualsSignSy, lex);
+- (* Next the signature if there is one. *)
+- val isOpaque = (sy lex) eq SYMBOLS.colonGt;
+- val sgn =
+- if testfor (SYMBOLS.colon, empty, lex) orelse testfor (SYMBOLS.colonGt, empty, lex)
+- then parseSignature (fsys ++ equalsSign) lex env
+- else emptyStruct
+- (* Now the equals sign *)
+- val U : unit = getsym (SYMBOLS.equalsSign, lex)
+- in
+- (* And finally the structure value. *)
+- mkStructureBinding (strId, sgn, isOpaque, structVal fsys lex env, lno)
+- end
+- in
+- mkStructureDec (getList (SYMBOLS.andSy, structSy, lex, doStrDec))
+- end
+-
+- else if testfor (SYMBOLS.localSy, empty, lex)
+- then let
+- val lno = lineno lex
+- val newEnv = mkLocalFixEnv env
+- (* The local declaration *)
+- val ins = strDec (fsys ++ inEndSy) lex newEnv
+- val U : unit = getsym (SYMBOLS.inSy, lex)
+- (* Decs are added to both the local and surrounding environment. *)
+- val resultEnv = mkLocalBodyFixEnv newEnv enterFix
+- val body = strDec (fsys ++ endSy) lex resultEnv
+- val U : unit = getsym (SYMBOLS.endSy, lex)
++ and structureDec (fsys : symset) (lex : lexan) (env as {enterFix, ...}) : structs =
++ let
++ val startLocn = location lex
+ in
+- mkLocaldec (ins, body, true, lno)
+- end
++ if testfor (SYMBOLS.structureSy, empty, lex)
++ then
++ let
++ fun doStrDec () =
++ let (* Read strId <<: sig>> = str *)
++ (* First the identifier *)
++ val idAndLoc as (_, idLoc) = getShortId (declarableVarSys, fsys ++ colonEqualsSignSy, lex);
++ (* Next the signature if there is one. *)
++ val isOpaque = (sy lex) eq SYMBOLS.colonGt;
++ val sgn =
++ if testfor (SYMBOLS.colon, empty, lex) orelse testfor (SYMBOLS.colonGt, empty, lex)
++ then
++ let
++ val (sign, sigLoc) = parseSignature (fsys ++ equalsSign) lex env
++ in
++ SOME (sign, isOpaque, sigLoc)
++ end
++ else NONE
++ (* Now the equals sign *)
++ val () = getsym (SYMBOLS.equalsSign, lex)
++ val (strVal, strLoc) = structVal fsys lex env
++ val locs = locSpan(idLoc, strLoc)
++ in
++ (* And finally the structure value. *)
++ (mkStructureBinding (idAndLoc, sgn, strVal, locs), locs)
++ end
++ val (strs, strLocs) = getList (SYMBOLS.andSy, structSy, lex, doStrDec)
++ in
++ mkStructureDec (strs, locSpan(startLocn, strLocs))
++ end
++
++ else if testfor (SYMBOLS.localSy, empty, lex)
++ then
++ let
++ val startLoc = location lex
++ val newEnv = mkLocalFixEnv env
++ (* The local declaration *)
++ val ins = strDec (fsys ++ inEndSy) lex newEnv
++ val () = getsym (SYMBOLS.inSy, lex)
++ (* Decs are added to both the local and surrounding environment. *)
++ val resultEnv = mkLocalBodyFixEnv newEnv enterFix
++ val body = strDec (fsys ++ endSy) lex resultEnv
++ val endLoc = location lex
++ val () = getsym (SYMBOLS.endSy, lex)
++ in
++ mkLocaldec (ins, body, true, locSpan(startLoc, endLoc))
++ end
+
+- else emptyStruct
+- (* end of structureDec *)
++ else emptyStruct
++ end (* end of structureDec *)
+
+- (* Functor declarations. *)
+- and functorDec (fsys : symset) (lex : lexan) (env as {enterFix,lookupFix,lookupTvar}) : structs =
+- let
+- val UUU = insymbol lex; (* remove ``functor'' *)
+- fun doFunctDec () : functorBind =
+- let (* Read fncId (<<paramSpec>> ) <<: sig>> = str *)
+- (* First the identifier *)
+- val lno = lineno lex
+- val strId = getShortId (declarableVarSys, fsys ++ colonEqualsSignSy, lex);
+- val U : unit = getsym (SYMBOLS.leftParen, lex);
+- (* Now the parameters *)
+- val tsys = fsys ++ rightParenCommaSy;
+-
+- val parameter = (* empty | name:sigexp | spec *)
+- if (sy lex) eq SYMBOLS.rightParen
+- (* empty *)
+- then mkFormalArg ("", mkSig [])
++ (* Functor declarations. *)
++ and functorDec (fsys : symset) (lex : lexan) env : topdec =
++ let
++ val startLocn = location lex
++ val () = insymbol lex; (* remove ``functor'' *)
++
++ fun doFunctDec () : functorBind * location =
++ let (* Read fncId (<<paramSpec>> ) <<: sig>> = str *)
++ (* First the identifier *)
++ val (strId, idLocn) = getShortId (declarableVarSys, fsys ++ colonEqualsSignSy, lex);
++ val () = getsym (SYMBOLS.leftParen, lex);
++ (* Now the parameters *)
++ val tsys = fsys ++ rightParenCommaSy;
++
++ val parameter = (* empty | name:sigexp | spec *)
++ if (sy lex) eq SYMBOLS.rightParen
++ (* empty *)
++ then mkFormalArg ("", mkSig([], location lex))
+
+- else if (sy lex) inside startSigSys
+- (* spec *)
+- then mkFormalArg ("", mkSig (signatureSpec tsys lex env))
++ else if (sy lex) inside startSigSys
++ (* spec *)
++ then
++ let
++ val startLocn = location lex
++ val sigs = signatureSpec tsys lex env
++ in
++ mkFormalArg ("", mkSig (sigs, locSpan(startLocn, location lex)))
++ end
+
+- (* name : sigexp *)
+- else let
+- val strId = getShortId (declarableVarSys, tsys ++ colon, lex);
+- val U : unit = getsym (SYMBOLS.colon, lex)
++ (* name : sigexp *)
++ else
++ let
++ val (strId, _) = getShortId (declarableVarSys, tsys ++ colon, lex);
++ val () = getsym (SYMBOLS.colon, lex)
+
+- (* Next the signature. *)
+- val sgn = parseSignature (tsys ++ sharingSy) lex env
+- in
+- mkFormalArg (strId, sgn)
+- end (* parameter *)
++ (* Next the signature. *)
++ val (sgn, _) = parseSignature (tsys ++ sharingSy) lex env
++ in
++ mkFormalArg (strId, sgn)
++ end (* parameter *)
+
+- val U : unit = getsym (SYMBOLS.rightParen, lex)
++ val () = getsym (SYMBOLS.rightParen, lex)
++
++ (* Next the signature if there is one. *)
++ val isOpaque = (sy lex) eq SYMBOLS.colonGt;
+
+- (* Next the signature if there is one. *)
+- val isOpaque = (sy lex) eq SYMBOLS.colonGt;
+-
+- val sgn =
+- if testfor (SYMBOLS.colon, empty, lex) orelse testfor (SYMBOLS.colonGt, empty, lex)
+- then parseSignature (fsys ++ equalsSign) lex env
+- else emptyStruct
++ val sigOpt =
++ if testfor (SYMBOLS.colon, empty, lex) orelse testfor (SYMBOLS.colonGt, empty, lex)
++ then
++ let
++ val (sign, sigLoc) = parseSignature (fsys ++ equalsSign) lex env
++ in
++ SOME(sign, isOpaque, sigLoc)
++ end
++ else NONE
+
+- (* Now the equals sign *)
+- val U : unit = getsym (SYMBOLS.equalsSign, lex)
+- in
+- (* And finally the functor value. *)
+- mkFunctorBinding (strId, sgn, isOpaque, structVal fsys lex env, parameter, lno)
+- end (* doFunctDec *)
+- in
+- mkFunctorDec (getList (SYMBOLS.andSy, structSy, lex, doFunctDec))
+- end (* functorDec *)
++ (* Now the equals sign *)
++ val () = getsym (SYMBOLS.equalsSign, lex)
++ (* And finally the functor value. *)
++ val (strVal, strLoc) = structVal fsys lex env
++ val locs = locSpan(idLocn, strLoc)
++ in
++ (mkFunctorBinding (strId, idLocn, sigOpt, strVal, parameter, locs), locs)
++ end (* doFunctDec *)
++
++ val (functs, functLoc) = getList (SYMBOLS.andSy, structSy, lex, doFunctDec)
++ in
++ mkFunctorDec (functs, locSpan(startLocn, functLoc))
++ end (* functorDec *)
+
+
+- and strDec (fsys : symset) (lex : lexan) (env as {enterFix,lookupFix,lookupTvar}) : structs list =
+- (* A sequence of declarations, optionally separated by semicolons. *)
+- let
+- fun getDecs () : structs list =
+- let
+- val tsys = fsys ++ semicolonStartDecStructureSy;
++ and strDec (fsys : symset) (lex : lexan) env : structs list =
++ (* A sequence of declarations, optionally separated by semicolons. *)
++ let
++ fun getDecs () : structs list =
++ let
++ val tsys = fsys ++ semicolonStartDecStructureSy;
++ in
++ (* Semicolons are optional. *)
++ if (sy lex) eq SYMBOLS.semicolon
++ then
++ let
++ val () = insymbol lex
++ in
++ getDecs ()
++ end
++ else if (sy lex) inside structureLocalSy
++ then (structureDec tsys lex env) :: getDecs()
++ else if (sy lex) inside startDecSys
++ then (mkCoreLang (dec(tsys, lex, true, env))) :: getDecs()
++ else (* May be empty *) []
++ end (* getDecs *)
+ in
+- (* Semicolons are optional. *)
+- if (sy lex) eq SYMBOLS.semicolon
+- then let
+- val UUU = insymbol lex
+- in
++ (* Return the declarations. *)
+ getDecs ()
+- end
+- else if (sy lex) inside structureLocalSy
+- then (structureDec tsys lex env) :: getDecs()
+- else if (sy lex) inside startDecSys
+- then let
+- val lno = lineno lex
+- in
+- (mkTopLevel (dec tsys lex true env, lno)) :: getDecs()
+- end
+- else (* May be empty *) []
+- end (* getDecs *)
+- in
+- (* Return the declarations. *)
+- getDecs ()
+- end (* strDec *);
++ end (* strDec *);
+
+ val globalEnv =
+ (* Extend the fixity environment with a type var environment which traps
+@@ -2297,106 +2281,80 @@
+ { enterFix = enterFix,
+ lookupFix = lookupFix,
+ lookupTvar =
+- fn (s : string) =>
++ fn _ =>
+ let
+- val U : unit =
+- errorMessage (lex, lineno lex, "Free type variables not allowed");
++ val () =
++ errorMessage (lex, location lex, "Free type variables not allowed");
+ in
+- mkTypeVar (generalisable, false, true, true)
++ makeTv (emptyType, generalisable, false, true)
+ end}
+
+- (* May be structure/functor dec, signature dec or top-level dec. Treat
++ (* May be structure/functor dec, signature dec or top-level dec. Treat
+ "local" as a structure dec even if it is actually declaring a value
+ or type. *)
+- val tsys = fsys ++ startTopSys;
+-
+- fun doStrDecs () =
+- if (sy lex) eq SYMBOLS.structureSy orelse
+- (sy lex) eq SYMBOLS.localSy
+- (* Structure or local declarations. Treat all local
+- declarations as strDecs since this includes the case of
+- local dec in dec. *)
+- then structureDec tsys lex globalEnv
+- else let
+- val lno = lineno lex
+- in
+- mkTopLevel (dec tsys lex true globalEnv, lno)
+- end
++ val tsys = fsys ++ startTopSys;
+
+- fun parseTopDecs (okStartSet : symset) : structs list =
+- let
+- val startSym = sy lex;
+- in
+- if startSym eq SYMBOLS.semicolon orelse
+- startSym eq SYMBOLS.abortParse
+- then []
++ fun parseTopDecs (_ : symset) : topdec list * location =
++ let
++ val startSym = sy lex and startLoc = location lex;
++ in
++ if startSym eq SYMBOLS.semicolon orelse
++ startSym eq SYMBOLS.abortParse
++ then ([], startLoc)
+
+- else if startSym inside topdecStartSy
+- then let
+- (* Is this the same kind of topdec as the previous one?
+- This is no longer required in ML97. *)
+- val U : unit =
+- if not (startSym inside okStartSet) andalso getParameter ml90Tag (debugParams lex)
+- then warningMessage (lex, lineno lex,
+- "ML Standard requires ';' between different kinds of top-level declaration.")
+- else ();
+-
+- val (aDec : structs, newOkStartSet : symset) =
+- if startSym eq SYMBOLS.functorSy
+- then (functorDec tsys lex globalEnv, functorSy)
++ else if startSym inside topdecStartSy
++ then
++ let
++ val (aDec : topdec, newOkStartSet : symset) =
++ if startSym eq SYMBOLS.functorSy
++ then (functorDec tsys lex globalEnv, functorSy)
+
+- else if startSym eq SYMBOLS.signatureSy
+- then (signatureDec tsys lex globalEnv, signatureSy)
++ else if startSym eq SYMBOLS.signatureSy
++ then (signatureDec tsys lex globalEnv, signatureSy)
+
+- else if startSym eq SYMBOLS.structureSy
+- then (structureDec tsys lex globalEnv, structureLocalStartDecSy)
++ else if startSym eq SYMBOLS.structureSy
++ then (mkTopDec(structureDec tsys lex globalEnv), structureLocalStartDecSy)
+
+- (* Local declarations are ambiguous; we treat them as strDecs *)
+- else if startSym eq SYMBOLS.localSy
+- then (structureDec tsys lex globalEnv, structureLocalStartDecSy)
++ (* Local declarations are ambiguous; we treat them as strDecs *)
++ else if startSym eq SYMBOLS.localSy
++ then (mkTopDec(structureDec tsys lex globalEnv), structureLocalStartDecSy)
+
+- (* let, val, fun etc. *)
+- else let
+- val lno : int = lineno lex;
++ (* let, val, fun etc. *)
++ else (mkTopDec(mkCoreLang (dec(tsys, lex, true, globalEnv))), structureLocalStartDecSy);
++
++ val (rest, locRest) = parseTopDecs newOkStartSet
+ in
+- (mkTopLevel (dec tsys lex true globalEnv, lno), structureLocalStartDecSy)
+- end;
+-
+- in
+- aDec :: parseTopDecs newOkStartSet
+- end
++ (aDec :: rest, locSpan(startLoc, locRest))
++ end
+
+- else let
+- val U : unit = notfound (";", lex);
+- in
+- []
+- end
+- end; (* parseTopDecs *)
++ else (notfound (";", lex); ([], startLoc))
++ end; (* parseTopDecs *)
+
+ in (* body of parseDec *)
+- (* topdecs are either fundecs, sigdecs, strDecs (including decs) or a
+- single expression.
++ (* topdecs are either fundecs, sigdecs, strDecs (including decs) or a
++ single expression.
+
+- We now handle everything except the single expression in "parseTopDecs".
+- This makes it easier to produce warning messages for missing semi-colons
+- that the ML Standard requires between different kinds of topdec.
+- SPF 18/7/96
+- *)
++ We now handle everything except the single expression in "parseTopDecs".
++ This makes it easier to produce warning messages for missing semi-colons
++ that the ML Standard requires between different kinds of topdec.
++ SPF 18/7/96
++ *)
+
+- if (sy lex) inside topdecStartSy
+- then parseTopDecs topdecStartSy
++ if (sy lex) inside topdecStartSy
++ then mkProgram(parseTopDecs topdecStartSy)
+
+- else let (* expression - only one allowed. *)
+- val lno : int = lineno lex;
+- val aDec : structs = mkTopLevel (dec tsys lex false globalEnv, lno);
+- val U : unit =
+- if (sy lex) neq SYMBOLS.semicolon andalso
+- (sy lex) neq SYMBOLS.abortParse
+- then notfound (";", lex)
+- else ()
+- in
+- [aDec]
+- end
++ else
++ let (* expression - only one allowed. *)
++ val startLoc = location lex;
++ val aDec = mkCoreLang (dec(tsys, lex, false, globalEnv));
++ val () =
++ if (sy lex) neq SYMBOLS.semicolon andalso
++ (sy lex) neq SYMBOLS.abortParse
++ then notfound (";", lex)
++ else ()
++ in
++ mkProgram([mkTopDec aDec], locSpan(startLoc, location lex))
++ end
+ end; (* parseDec *)
+
+ end (* PARSEDEC *);
+diff -u -r mlsource/MLCompiler/PARSE_TREE.ML mlsource/MLCompiler/PARSE_TREE.ML
+--- mlsource/MLCompiler/PARSE_TREE.ML 2008-05-14 13:44:15.000000000 +0200
++++ mlsource/MLCompiler/PARSE_TREE.ML 2009-09-15 08:56:47.000000000 +0200
+@@ -1,23 +1,23 @@
+ (*
+- Copyright (c) 2000
+- Cambridge University Technical Services Limited
++ Copyright (c) 2000
++ Cambridge University Technical Services Limited
+
+ Further development:
+- Copyright (c) 2000-8 David C.J. Matthews
++ Copyright (c) 2000-9 David C.J. Matthews
+
+- This library is free software; you can redistribute it and/or
+- modify it under the terms of the GNU Lesser General Public
+- License as published by the Free Software Foundation; either
+- version 2.1 of the License, or (at your option) any later version.
+-
+- This library is distributed in the hope that it will be useful,
+- but WITHOUT ANY WARRANTY; without even the implied warranty of
+- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+- Lesser General Public License for more details.
+-
+- You should have received a copy of the GNU Lesser General Public
+- License along with this library; if not, write to the Free Software
+- Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
++ This library is free software; you can redistribute it and/or
++ modify it under the terms of the GNU Lesser General Public
++ License as published by the Free Software Foundation; either
++ version 2.1 of the License, or (at your option) any later version.
++
++ This library is distributed in the hope that it will be useful,
++ but WITHOUT ANY WARRANTY; without even the implied warranty of
++ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
++ Lesser General Public License for more details.
++
++ You should have received a copy of the GNU Lesser General Public
++ License along with this library; if not, write to the Free Software
++ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+ *)
+
+ (*
+@@ -28,331 +28,24 @@
+
+ functor PARSE_TREE (
+
+-(*****************************************************************************)
+-(* LEX *)
+-(*****************************************************************************)
+-structure LEX :
+-sig
+- type lexan;
+- type prettyPrinter;
+-
+- val errorProc: lexan * int * (prettyPrinter -> unit) -> unit;
+- val warningProc: lexan * int * (prettyPrinter -> unit) -> unit;
+-
+- val debugParams: lexan -> Universal.universal list
+-end;
+-
+-(*****************************************************************************)
+-(* CODETREE *)
+-(*****************************************************************************)
+-
+-(* This tree represents the intermediate code between the parse tree and
+- the final machine code *)
+-
+-structure CODETREE :
+-sig
+- type machineWord
+- type codetree
+-
+- val CodeNil: codetree
+- val CodeZero: codetree
+- val Ldexc: codetree
+- val MatchFail: codetree
+- val mkAltMatch: codetree * codetree -> codetree
+- val mkConst: machineWord -> codetree
+- val mkLoad: int * int -> codetree
+- val mkInd: int * codetree -> codetree
+- val mkProc: codetree * int * int * string -> codetree
+- val mkInlproc: codetree * int * int * string -> codetree
+- val mkEval: codetree * codetree list * bool -> codetree
+- val mkStr: string -> codetree
+- val mkNot: codetree -> codetree
+- val mkCand: codetree * codetree -> codetree
+- val mkCor: codetree * codetree -> codetree
+- val mkRaise: codetree -> codetree
+- val mkDec: int * codetree -> codetree
+- val mkIf: codetree * codetree * codetree -> codetree
+- val mkWhile: codetree * codetree -> codetree
+- val mkEnv: codetree list -> codetree
+- val mkTuple: codetree list -> codetree
+- val mkHandle: codetree * codetree list * codetree -> codetree
+- val mkMutualDecs: codetree list -> codetree
+- val mkContainer: int -> codetree
+- val mkSetContainer: codetree * codetree * int -> codetree
+- val mkTupleFromContainer: codetree * int -> codetree
+-
+- val multipleUses: codetree * (unit -> int) * int -> {load: int -> codetree, dec: codetree list}
+- val evalue: codetree -> machineWord;
+- val structureEq: machineWord * machineWord -> bool
+-end;
+-
+-
+-(*****************************************************************************)
+-(* STRUCTVALS *)
+-(*****************************************************************************)
+-structure STRUCTVALS :
+-sig
+- (* Structures *)
+-
+- type structVals;
+- type signatures;
+- type functors;
+- type fixStatus;
+- type typeId;
+- type typeConstrs;
+- type typeDependent;
+- type codetree
+-
+- val undefinedStruct: structVals;
+- val isUndefinedStruct: structVals -> bool;
+- val makeSelectedStruct: structVals * structVals -> structVals;
+- val structSignat: structVals -> signatures;
+-
+- (* Signatures *)
+- type univTable
+- val sigTab: signatures -> univTable;
+-
+- (* Types *)
+- val makeVariableId: unit -> typeId;
+- val isVariableId: typeId -> bool;
+- val unifyTypeIds: typeId * typeId -> bool;
+- val sameTypeId: typeId * typeId -> bool;
+-
+- type 'a possRef
+-
+- (* A type is the union of these different cases. *)
+- type typeVarForm
+- datatype types =
+- TypeVar of typeVarForm
+-
+- | TypeConstruction of (* typeConstructionForm *)
+- {
+- name: string,
+- value: typeConstrs possRef,
+- args: types list
+- }
+-
+- | FunctionType of (* functionTypeForm *)
+- {
+- arg: types,
+- result: types
+- }
+-
+- | LabelledType of (* labelledRecForm *)
+- {
+- recList: { name: string, typeof: types } list,
+- frozen: bool,
+- genericInstance: typeVarForm list
+- }
+-
+- | OverloadSet of (* overloadSetForm *)
+- {
+- typeset: typeConstrs list
+- }
+-
+- | BadType
+-
+- | EmptyType
+- ;
+-
+- datatype valAccess =
+- Global of codetree
+- | Local of { addr: int ref, level: int ref }
+- | Selected of { addr: int, base: structVals }
+- | Formal of int
+- | Overloaded of typeDependent (* Values only. *)
+-
+- and values =
+- Value of {
+- name: string,
+- typeOf: types,
+- access: valAccess,
+- class: valueClass }
+-
+- (* Classes of values. *)
+- and valueClass =
+- SimpleValue
+- | Exception
+- | Constructor of { nullary: bool }
+-
+- val tcName: typeConstrs -> string;
+- val tcEquivalent: typeConstrs -> types;
+- val tcSetConstructors: typeConstrs * values list -> unit;
+- val tcTypeVars: typeConstrs -> types list;
+- val tcSetEquality: typeConstrs * bool -> unit;
+- val tcConstructors: typeConstrs -> values list;
+- val makeTypeConstrs:
+- string * types list * types * typeId * bool * int -> typeConstrs;
+-
+- val isConstructor: values -> bool;
+- val isUndefinedValue: values -> bool;
+-
+- val listType: typeConstrs;
+- val undefType: typeConstrs;
+-
+- val generalisable: int;
+-
+- (* Values. *)
+-
+- val undefinedValue: values;
+- val valName: values -> string
+- val valTypeOf: values -> types
+-
+- val TypeDep: typeDependent
+- val makeOverloaded: string * types * typeDependent -> values;
++structure LEX : LEXSIG
++structure CODETREE : CODETREESIG
++structure STRUCTVALS : STRUCTVALSIG;
++structure EXPORTTREE: EXPORTTREESIG;
++structure TYPETREE : TYPETREESIG
++structure VALUEOPS : VALUEOPSSIG;
++structure PRETTY : PRETTYSIG
++structure DEBUGGER : DEBUGGERSIG
++structure COPIER: COPIERSIG
++structure TYPEIDCODE: TYPEIDCODESIG
+
+- datatype env = Env of
+- {
+- lookupVal: string -> values option,
+- lookupType: string -> typeConstrs option,
+- lookupFix: string -> fixStatus option,
+- lookupStruct: string -> structVals option,
+- lookupSig: string -> signatures option,
+- lookupFunct: string -> functors option,
+- enterVal: string * values -> unit,
+- enterType: string * typeConstrs -> unit,
+- enterFix: string * fixStatus -> unit,
+- enterStruct: string * structVals -> unit,
+- enterSig: string * signatures -> unit,
+- enterFunct: string * functors -> unit
+- };
+-
+- type 'a tag;
+- val structVar: structVals tag;
+- val valueVar: values tag;
+- val typeConstrVar: typeConstrs tag;
+-
+-end;
+-
+-(*****************************************************************************)
+-(* TYPETREE *)
+-(*****************************************************************************)
+-structure TYPETREE :
+-sig
+- type types;
+- type values;
+- type lexan;
+- type prettyPrinter;
+- type typeConstrs;
+-
+- val unify: types * types * lexan * int * (prettyPrinter -> unit) -> unit;
+- val apply: types * types * lexan * int * (prettyPrinter -> unit) -> types;
+-
+- val allowGeneralisation: types * int * bool * lexan *
+- int * (prettyPrinter -> unit) -> unit;
+- val generalise: types * bool -> types;
+- (* Check for a local datatype "escaping". Added for ML97. *)
+- val checkForLocalDatatypes: types * int * (string -> unit) -> unit;
+-
+- val mkProductType: types list -> types;
+- val mkTypeVar: int * bool * bool * bool -> types;
+- val mkTypeConstruction: string * typeConstrs * types list -> types;
+- val mkFunctionType: types * types -> types;
+- val mkLabelled: {name: string, typeof: types } list * bool -> types;
+- val mkLabelEntry: string * types -> {name: string, typeof: types };
+- val sortLabels: {name: string, typeof: types } list * (string -> unit) ->
+- {name: string, typeof: types } list;
+- val entryNumber: string * types -> int;
+- val recordNotFrozen: types -> bool;
+- val recordWidth: types -> int;
+-
+- (* Unify two type variables which would otherwise be non-unifiable. *)
+- val linkTypeVars: types * types -> unit;
+- val setTvarLevel: types * int -> unit;
+-
+- (* Gets the lists of constructors from a type. *)
+- val getConstrList: types -> values list;
+-
+- (* Second pass on type identifiers which associates type constructors with names. *)
+- val assignTypes: types * (string -> typeConstrs) * lexan * int -> unit;
+-
+- (* Print out a type structure. *)
+- val display: types * int * prettyPrinter * bool -> unit;
+-
+- (* A list of type variables. *)
+- val displayTypeVariables: types list * int * prettyPrinter * bool -> unit;
+-
+- (* Standard types. *)
+- val boolType: types;
+- val intType: types;
+- val charType: types; (* added 22/8/96 SPF *)
+- val stringType: types;
+- val realType: types;
+- val unitType: types;
+- val exnType: types;
+- val mkOverloadSet: typeConstrs list -> types;
+-
+- val genEqualityFunctions: typeConstrs list * (string -> unit) * bool -> unit;
+-
+-end;
+-
+-(*****************************************************************************)
+-(* VALUEOPS *)
+-(*****************************************************************************)
+-structure VALUEOPS :
+-sig
+- type machineWord;
+- type types;
+- type codetree
+- type values;
+- type structVals;
+- type lexan;
+- type prettyPrinter;
+- type typeConstrs;
+- type fixStatus;
+-
+- val chooseConstrRepr : (string*types) list -> codetree list
+-
+- val overloadType: values * bool -> types
+-
+- (* Construction functions. *)
+- val mkVar: string * types -> values;
+- val mkSelectedVar: values * structVals -> values;
+- val mkGconstr: string * types * codetree * bool -> values;
+- val mkEx: string * types -> values;
+-
+- val mkSelectedType: typeConstrs * string * structVals option -> typeConstrs
+-
+- (* Standard values *)
+- val nilConstructor: values;
+- val consConstructor: values;
+-
+- (* Print values. *)
+- val displayFixStatus: fixStatus * int * prettyPrinter -> unit;
+-
+- (* Code-generate. *)
+- val mkExIden: unit -> codetree
+- val codeVal: values * int * types * lexan * int -> codetree
+- val codeExFunction: values * int * types * lexan * int -> codetree
+- val applyFunction: values * codetree * int * types * lexan * int -> codetree
+- val getOverloadInstance: string * types * bool * lexan * int -> codetree*string
+- val isTheSameException: values * values -> bool
+- val raiseBind: codetree;
+- val raiseMatch: codetree;
+- val makeGuard: values * codetree * int -> codetree
+- val makeInverse: values * codetree * int -> codetree;
+-
+- (* Look-up functions. *)
+-
+- val lookupStructure: string * {lookupStruct: string -> structVals option} *
+- string * (string -> unit) -> structVals
+-
+- val lookupValue: string * {lookupVal: string -> values option, lookupStruct: string -> structVals option} *
+- string * (string -> unit) -> values
+-
+- val lookupTyp: {lookupType: string -> typeConstrs option,
+- lookupStruct: string -> structVals option} *
+- string * (string -> unit) -> typeConstrs
+-end;
+-
+-(*****************************************************************************)
+-(* UTILITIES *)
+-(*****************************************************************************)
+ structure UTILITIES :
+ sig
+ type lexan;
++ type location =
++ { file: string, startLine: int, startPosition: int, endLine: int, endPosition: int }
+
+- val noDuplicates: (string -> unit) ->
++ val noDuplicates: (string * 'a * 'a -> unit) ->
+ { apply: (string * 'a -> unit) -> unit,
+ enter: string * 'a -> unit,
+ lookup: string -> 'a option};
+@@ -361,38 +54,34 @@
+ enter: string * 'a -> unit,
+ lookup: string -> 'a option };
+
+- val checkForDots: string * lexan * int -> unit;
++ val checkForDots: string * lexan * location -> unit;
+
+ val splitString: string -> { first:string,second:string }
++
++ structure Sharing:
++ sig
++ type lexan = lexan
++ end
+ end;
+
+-(*****************************************************************************)
+-(* UNIVERSALTABLE *)
+-(*****************************************************************************)
+ structure UNIVERSALTABLE:
+ sig
+- type universal;
++ type universal = Universal.universal;
+ type univTable;
+
+ val univFold: univTable * (string * universal * 'a -> 'a) * 'a -> 'a;
+ end;
+
+-(*****************************************************************************)
+-(* DEBUG *)
+-(*****************************************************************************)
+ structure DEBUG :
+ sig
+- val ml90Tag: bool Universal.tag
+ val debugTag: bool Universal.tag
+ val errorDepthTag : int Universal.tag
+ val fileNameTag: string Universal.tag
++ val reportUnreferencedIdsTag: bool Universal.tag
+ val getParameter :
+ 'a Universal.tag -> Universal.universal list -> 'a
+ end;
+
+-(*****************************************************************************)
+-(* MISC *)
+-(*****************************************************************************)
+ structure MISC :
+ sig
+ (* These are handled in the compiler *)
+@@ -406,34 +95,6 @@
+ val lookupDefault : ('a -> 'b option) -> ('a -> 'b option) -> 'a -> 'b option
+ end (* MISC *);
+
+-(*****************************************************************************)
+-(* PRETTYPRINTER *)
+-(*****************************************************************************)
+-structure PRETTYPRINTER :
+-sig
+- type prettyPrinter
+-
+- val ppAddString : prettyPrinter -> string -> unit
+- val ppBeginBlock : prettyPrinter -> int * bool -> unit
+- val ppEndBlock : prettyPrinter -> unit -> unit
+- val ppBreak : prettyPrinter -> int * int -> unit
+-end;
+-
+-(*****************************************************************************)
+-(* UNIVERSAL *)
+-(*****************************************************************************)
+-structure UNIVERSAL :
+-sig
+- type universal
+- type 'a tag
+-
+- val tagIs : 'a tag -> universal -> bool
+- val tagProject : 'a tag -> universal -> 'a
+-end;
+-
+-(*****************************************************************************)
+-(* ADDRESS *)
+-(*****************************************************************************)
+ structure ADDRESS :
+ sig
+ type machineWord; (* any legal bit-pattern (tag = 0 or 1) *)
+@@ -441,210 +102,15 @@
+ end;
+
+ (*****************************************************************************)
+-(* DEBUGGER *)
+-(*****************************************************************************)
+-structure DEBUGGER :
+-sig
+- type types
+- type machineWord
+-
+- datatype environEntry =
+- EnvValue of string * types
+- | EnvException of string * types
+- | EnvVConstr of string * types * bool
+- | EnvStaticLevel
+-
+- type debugger;
+- val nullDebug: debugger
+-
+- val debuggerFunTag : debugger Universal.tag
+-
+- datatype debugReason =
+- DebugEnter of machineWord * types
+- | DebugLeave of machineWord * types
+- | DebugException of exn
+- | DebugStep
+-
+- (* Functions inserted into the compiled code. *)
+- val debugFunction:
+- debugger * debugReason * string * string * int -> environEntry list -> machineWord list -> unit
+-end;
+-
+-(*****************************************************************************)
+ (* PARSETREE sharing constraints *)
+ (*****************************************************************************)
+
+-sharing type
+- LEX.lexan
+-= UTILITIES.lexan
+-= TYPETREE.lexan
+-= VALUEOPS.lexan
+-= UTILITIES.lexan
+-
+-sharing type
+- STRUCTVALS.typeConstrs
+-= TYPETREE.typeConstrs
+-= VALUEOPS.typeConstrs
+-
+-sharing type
+- STRUCTVALS.structVals
+-= VALUEOPS.structVals
+-
+-sharing type
+- STRUCTVALS.types
+-= VALUEOPS.types
+-= DEBUGGER.types
+-= TYPETREE.types
+-
+-sharing type
+- STRUCTVALS.values
+-= VALUEOPS.values
+-= TYPETREE.values
+-
+-sharing type
+- CODETREE.codetree
+-= VALUEOPS.codetree
+-
+-sharing type
+- LEX.prettyPrinter
+-= TYPETREE.prettyPrinter
+-= VALUEOPS.prettyPrinter
+-= PRETTYPRINTER.prettyPrinter
+-
+-sharing type
+- ADDRESS.machineWord
+-= CODETREE.machineWord
+-= DEBUGGER.machineWord
+-= VALUEOPS.machineWord
+-
+-sharing type
+- UNIVERSALTABLE.univTable
+-= STRUCTVALS.univTable
+-
+-sharing type
+- STRUCTVALS.tag
+-= UNIVERSAL.tag;
+-
+-sharing type
+- UNIVERSALTABLE.universal
+-= UNIVERSAL.universal;
+-
+-sharing type
+- STRUCTVALS.fixStatus
+-= VALUEOPS.fixStatus
+-
+-) :
+-
+-(*****************************************************************************)
+-(* PARSETREE export signature *)
+-(*****************************************************************************)
+-sig
+- type machineWord;
+- type types;
+- type fixStatus;
+- type lexan;
+- type prettyPrinter;
+- type typeId;
+- type codetree;
+- type env;
+-
+- type typeConstrs;
+- type values;
+- type structVals;
+- type environEntry;
+- type structureIdentForm;
+-
+- (* An identifier is just a name. In the second pass it is associated
+- with a particular declaration and the type is assigned into the
+- type field. The type of this identifier is needed to deal with
+- overloaded operators. If we have an occurence of ``='', say, the
+- type of the value will be 'a * 'a -> bool but the type of a particular
+- occurence, i.e. the type of the identifier must be int * int -> bool,
+- say, after all the unification has been done. *)
+-
+- type parsetree and valbind and fvalbind and fvalclause and typebind
+- and datatypebind and exbind;
+-
+- val isIdent : parsetree -> bool;
+-
+- val mkIdent : string -> parsetree;
+- val mkString : string -> parsetree;
+- val mkInt : string -> parsetree;
+- val mkReal : string -> parsetree;
+- val mkChar : string -> parsetree;
+- val mkWord : string -> parsetree;
+- val mkApplic : parsetree * parsetree -> parsetree;
+-
+- val mkCond : parsetree * parsetree * parsetree -> parsetree;
+- val mkTupleTree : parsetree list -> parsetree;
+-
+- val mkValDeclaration :
+- valbind list *
+- {
+- lookup: string -> types option,
+- apply: (string * types -> unit) -> unit
+- } *
+- {
+- lookup: string -> types option,
+- apply: (string * types -> unit) -> unit
+- } -> parsetree;
+-
+- val mkFunDeclaration :
+- fvalbind list *
+- {
+- lookup: string -> types option,
+- apply: (string * types -> unit) -> unit
+- } *
+- {
+- lookup: string -> types option,
+- apply: (string * types -> unit) -> unit
+- } -> parsetree;
+-
+- val mkOpenTree : structureIdentForm list -> parsetree;
+- val mkStructureIdent : string -> structureIdentForm;
+- val mkValBinding : parsetree * parsetree * int -> valbind;
+- val recValbind: valbind;
+- val mkClausal : fvalclause list -> fvalbind;
+- val mkClause : parsetree * parsetree * int -> fvalclause;
+- val mkList : parsetree list -> parsetree;
+- val mkConstraint : parsetree * types -> parsetree;
+- val mkLayered : parsetree * parsetree -> parsetree;
+- val mkFn : parsetree list -> parsetree;
+- val mkMatchTree : parsetree * parsetree * int -> parsetree;
+- val mkLocalDeclaration : (parsetree * int) list * (parsetree * int) list * bool -> parsetree;
+- val mkTypeDeclaration : typebind list -> parsetree;
+- val mkDatatypeDeclaration : datatypebind list * typebind list -> parsetree;
+- val mkDatatypeReplication : string * string -> parsetree;
+- val mkAbstypeDeclaration :
+- datatypebind list * typebind list * (parsetree * int) list -> parsetree;
+- val mkTypeBinding : string * types list * types * bool -> typebind;
+- val mkDatatypeBinding : string * types list * (string*types) list -> datatypebind;
+- val mkExBinding : string * parsetree * types -> exbind;
+- val mkLabelledTree : (string * parsetree) list * bool -> parsetree;
+- val mkSelector : string -> parsetree;
+- val mkRaise : parsetree -> parsetree;
+- val mkHandleTree : parsetree * parsetree list -> parsetree;
+- val mkWhile : parsetree * parsetree -> parsetree;
+- val mkCase : parsetree * parsetree list -> parsetree;
+- val mkAndalso : parsetree * parsetree -> parsetree;
+- val mkOrelse : parsetree * parsetree -> parsetree;
+- val mkDirective : string list * fixStatus -> parsetree;
+- val mkExpseq : (parsetree * int) list -> parsetree;
+- val mkExDeclaration : exbind list -> parsetree;
+- val unit : parsetree;
+- val wildCard : parsetree;
+- val emptyTree : parsetree;
+-
+- val pass2: parsetree * (unit -> typeId) * env * lexan * int * string -> types;
+-
+- type debugenv = environEntry list * (int->codetree)
+-
+- val gencode: parsetree * lexan * debugenv * int * int ref * string * int -> codetree list * debugenv;
+-
+- (* only used for debugging and error messages! *)
+- val ptDisplay: parsetree * int * prettyPrinter -> unit;
++sharing LEX.Sharing = TYPETREE.Sharing = STRUCTVALS.Sharing = COPIER.Sharing
++ = VALUEOPS.Sharing = EXPORTTREE.Sharing = UTILITIES.Sharing
++ = DEBUGGER.Sharing = PRETTY.Sharing = TYPEIDCODE.Sharing
++ = ADDRESS = CODETREE.Sharing
+
+-end (* PARSETREE export signature *) =
++) : PARSETREESIG =
+
+ (*****************************************************************************)
+ (* PARSETREE functor body *)
+@@ -659,12 +125,12 @@
+ open UTILITIES;
+ open DEBUG;
+ open UNIVERSALTABLE;
+- open UNIVERSAL;
+- open PRETTYPRINTER;
++ open Universal;
++ open PRETTY;
+ open ADDRESS;
++ open EXPORTTREE
++ open TYPEIDCODE
+ open RuntimeCalls; (* for POLY_SYS numbers *)
+-
+- val ioOp : int -> machineWord = RunCall.run_call1 POLY_SYS_io_operation;
+
+ infix 9 sub;
+
+@@ -672,210 +138,222 @@
+ val emptyType = EmptyType;
+ val badType = BadType;
+
+- fun isEmpty EmptyType = true
+- | isEmpty _ = false;
+-
+ (************************************************************)
+
+ val makeRaise = CODETREE.mkRaise; (* to avoid confusion! *)
+ val makeWhile = CODETREE.mkWhile; (* to avoid confusion! *)
+-
+- abstype parsetree =
+- Ident of identForm
+- | Literal of literalForm
+- | Applic of applicForm
+- | Cond of condForm
+- | TupleTree of parsetree list
+- | ValDeclaration of valDecForm
+- | FunDeclaration of funDecForm
+- | OpenDec of { decs: structureIdentForm list, variables: values list ref }
+- | Constraint of constraintForm
+- | Layered of layeredForm
+- | Fn of parsetree list
+- | MatchTree of matchForm
+- | Localdec of localdecForm
+- | TypeDeclaration of typebind list
+- | AbstypeDeclaration of abstypeDeclarationForm
+- | DatatypeDeclaration of abstypeDeclarationForm
+- | DatatypeReplication of datatypeReplicationForm
+- | ExpSeq of (parsetree * int) list
+- | Directive of directiveForm
+- | ExDeclaration of exbind list
+- | Raise of parsetree
+- | HandleTree of handleTreeForm
+- | While of whileForm
+- | Case of caseForm
+- | Andalso of andOrForm
+- | Orelse of andOrForm
+- | Labelled of labelledForm
+- | Selector of selectorForm
+- | List of parsetree list
+- | EmptyTree
+- | WildCard
+- | Unit
++
++ datatype parsetree =
++ Ident of
++ (* An identifier is just a name. In the second pass it is associated
++ with a particular declaration and the type is assigned into the
++ type field. The type of this identifier is needed to deal with
++ overloaded operators. If we have an occurence of ``='', say, the
++ type of the value will be 'a * 'a -> bool but the type of a particular
++ occurence, i.e. the type of the identifier must be int * int -> bool,
++ say, after all the unification has been done. *)
++ { name: string, expType: types ref, value: values ref, location: location }
++
++ | Literal of
++ (* Literal constants may be overloaded on more than one type. The
++ types are specified by installing appropriate conversion functions:
++ convInt, convReal, convChar, convString and convWord. *)
++ { converter: values, expType: types ref, literal: string, location: location }
++
++ | Applic of
++ (* Function application *)
++ { f: parsetree, arg: parsetree, location: location, isInfix: bool, expType: types ref }
++
++ | Cond of
++ (* Conditional *)
++ { test: parsetree, thenpt: parsetree, elsept: parsetree, location: location }
++
++ | TupleTree of parsetree list * location
++
++ | ValDeclaration of valDecForm
++
++ | FunDeclaration of funDecForm
++
++ | OpenDec of
++ (* Open a structure. *)
++ { decs: structureIdentForm list, variables: values list ref, location: location }
++
++ | Constraint of
++ (* Constraint (explicit type given) *)
++ (* A constraint has a value and a type. The actual type, will, however
++ be the unification of these two and not necessarily the given type. *)
++ { value: parsetree, given: typeParsetree, location: location }
++
++ | Layered of
++ (* Layered pattern. Equivalent to an ordinary pattern except that the
++ variable is given the name of the object which is to be matched. *)
++ { var: parsetree, pattern: parsetree, location: location }
++
++ | Fn of
++ { matches: matchtree list, location: location, expType: types ref }
++
++ | Localdec of localdecForm
++ | TypeDeclaration of typebind list * location
++ | AbstypeDeclaration of abstypeDeclarationForm
++ | DatatypeDeclaration of abstypeDeclarationForm
++ | DatatypeReplication of datatypeReplicationForm
++ | ExpSeq of parsetree list * location
++
++ | Directive of
++ (* Directives are infix, infixr and nonfix. They are processed by the
++ parser itself and only appear in the parse tree for completeness. *)
++ { tlist: string list, fix: fixStatus, location: location }
++
++ | ExDeclaration of exbind list * location
++
++ | Raise of parsetree * location
++
++ | HandleTree of
++ (* Execute an expression and catch any exceptions. *)
++ { exp: parsetree, hrules: matchtree list, location: location, listLocation: location }
++
++ | While of
++ (* Ordinary while-loop *)
++ { test: parsetree, body: parsetree, location: location }
++
++ | Case of
++ (* Case-statement *)
++ { test: parsetree, match: matchtree list, location: location, listLocation: location, expType: types ref }
++
++ | Andalso of { first: parsetree, second: parsetree, location: location }
++
++ | Orelse of { first: parsetree, second: parsetree, location: location }
++
++ | Labelled of
++ (* Labelled record & the entry in the list. "frozen" is false if it's
++ a pattern with "...". *)
++ { recList: labelRecEntry list, frozen: bool, expType: types ref, location: location }
++
++ | Selector of
++ { name: string, labType: types, typeof: types, location: location }
++
++ | List of
++ { elements: parsetree list, location: location, expType: types ref }
++ | EmptyTree
++ | WildCard of location
++ | Unit of location
++ | Parenthesised of parsetree * location
+
+ and valbind = (* Value bindings are either a binding or a list
+- of recursive bindings.*)
+- ValBind of (* Consists of a declaration part (pattern) and an expression. *)
+- {
+- dec: parsetree,
+- exp: parsetree,
+- line: int
+- }
+- | RecValBind
+-
++ of recursive bindings.*)
++ ValBind of (* Consists of a declaration part (pattern) and an expression. *)
++ {
++ dec: parsetree,
++ exp: parsetree,
++ line: location
++ }
++ | RecValBind
++
+ and fvalbind = (* Function binding *)
+ (* `Fun' bindings *)
+- (* A function binding is a list of clauses, each of which uses a
+- valBinding to hold the list of patterns and the corresponding function
+- body. The second pass extracts the function variable and the number of
+- patterns in each clause. It checks that they are the same in each
+- clause. *)
+- FValBind of
+- {
+- clauses: fvalclause list,
+- numOfPatts: int ref,
+- functVar: values ref,
++ (* A function binding is a list of clauses, each of which uses a
++ valBinding to hold the list of patterns and the corresponding function
++ body. The second pass extracts the function variable and the number of
++ patterns in each clause. It checks that they are the same in each
++ clause. *)
++ FValBind of
++ {
++ clauses: fvalclause list,
++ numOfPatts: int ref,
++ functVar: values ref,
+ argType: types ref,
+- resultType: types ref
+- }
++ resultType: types ref,
++ location: location
++ }
+
+- and fvalclause = (* Clause within a function binding. *)
+- FValClause of { dec: parsetree, exp: parsetree, line: int }
+-
+- and typebind = (* Non-generative type binding *)
+- TypeBind of
+- {
+- name: string,
+- typeVars: types list,
+- decType: types,
+- isEqtype: bool (* True if this was an eqtype in a signature. *)
+- }
+-
+- and datatypebind = (* Generative type binding *)
+- DatatypeBind of
+- {
+- name: string,
+- typeVars: types list,
+- constrs: (string*types) list,
+- tcon: typeConstrs ref,
+- valueConstrs: values list ref
+- }
++ and fvalclause = (* Clause within a function binding. *)
++ FValClause of { dec: funpattern, exp: parsetree, line: location }
++
++ and typebind = (* Non-generative type binding *)
++ TypeBind of
++ {
++ name: string,
++ typeVars: typeVarForm list,
++ decType: typeParsetree option,
++ isEqtype: bool, (* True if this was an eqtype in a signature. *)
++ nameLoc: location,
++ fullLoc: location
++ }
++
++ and datatypebind = (* Generative type binding *)
++ DatatypeBind of
++ {
++ name: string,
++ typeVars: typeVarForm list,
++ constrs: {constrName: string, constrArg: typeParsetree option, idLocn: location} list,
++ tcon: typeConstrs ref,
++ valueConstrs: values list ref,
++ nameLoc: location,
++ fullLoc: location
++ }
+
+ and exbind = (* An exception declaration. It has a name and
+- optionally a previous exception and a type. *)
+- ExBind of
+- {
+- name: string,
+- previous: parsetree,
+- typeof: types,
+- value: values ref
+- }
+-
+-
+-
+- (* An identifier is just a name. In the second pass it is associated
+- with a particular declaration and the type is assigned into the
+- type field. The type of this identifier is needed to deal with
+- overloaded operators. If we have an occurence of ``='', say, the
+- type of the value will be 'a * 'a -> bool but the type of a particular
+- occurence, i.e. the type of the identifier must be int * int -> bool,
+- say, after all the unification has been done. *)
+- withtype identForm =
+- {
+- name: string,
+- typeof: types ref,
+- value: values ref
+- }
+-
+- (* Literal constants may be overloaded on more than one type. The
+- types are specified by installing appropriate conversion functions:
+- convInt, convReal, convChar, convString and convWord. *)
+- and literalForm =
+- {
+- converter: values,
+- typeof: types ref,
+- literal: string
+- }
+-
+- (* Function application *)
+- and applicForm =
+- {
+- f: parsetree,
+- arg: parsetree
+- }
+-
+- (* Conditional *)
+- and condForm =
+- {
+- test: parsetree,
+- thenpt: parsetree,
+- elsept: parsetree
++ optionally a previous exception and a type. *)
++ ExBind of
++ {
++ name: string,
++ previous: parsetree,
++ ofType: typeParsetree option,
++ value: values ref,
++ nameLoc: location,
++ fullLoc: location
++ }
++
++ and matchtree =
++ (* A match is a pattern and an expression. If the pattern matches then
++ the expression is evaluated in the environment of the pattern. *)
++ MatchTree of {
++ vars: parsetree,
++ exp: parsetree,
++ location: location,
++ argType: types ref,
++ resType: types ref
+ }
+
+ (* Val and fun declarations. *)
+- and valDecForm =
++ withtype valDecForm =
+ {
+ dec: valbind list,
+- explicit: {lookup: string -> types option,
+- apply: (string * types -> unit) -> unit },
+- implicit: {lookup: string -> types option,
+- apply: (string * types -> unit) -> unit },
+- variables: values list ref (* list of variables declared *)
++ explicit: {lookup: string -> typeVarForm option,
++ apply: (string * typeVarForm -> unit) -> unit },
++ implicit: {lookup: string -> typeVarForm option,
++ apply: (string * typeVarForm -> unit) -> unit },
++ variables: values list ref, (* list of variables declared *)
++ location: location
+ }
+
+ and funDecForm =
+ {
+ dec: fvalbind list,
+- explicit: {lookup: string -> types option,
+- apply: (string * types -> unit) -> unit },
+- implicit: {lookup: string -> types option,
+- apply: (string * types -> unit) -> unit }
++ explicit: {lookup: string -> typeVarForm option,
++ apply: (string * typeVarForm -> unit) -> unit },
++ implicit: {lookup: string -> typeVarForm option,
++ apply: (string * typeVarForm -> unit) -> unit },
++ location: location
+ }
+
+ (* Name of a structure. Used only in an ``open'' declaration. *)
+ and structureIdentForm =
+ {
+ name: string,
+- value: structVals ref
+- }
+-
+- (* Constraint (explicit type given) *)
+- (* A constraint has a value and a type. The actual type, will, however
+- be the unification of these two and not necessarily the given type. *)
+- and constraintForm =
+- {
+- value: parsetree,
+- given: types
+- }
+-
+- (* Layered pattern. Equivalent to an ordinary pattern except that the
+- variable is given the name of the object which is to be matched. *)
+- and layeredForm =
+- {
+- var: parsetree,
+- pattern: parsetree
+- }
+-
+- (* A match is a pattern and an expression. If the pattern matches then
+- the expression is evaluated in the environment of the pattern. *)
+- and matchForm =
+- {
+- vars: parsetree,
+- exp: parsetree,
+- line: int,
+- argType: types ref,
+- resType: types ref
++ value: structVals ref,
++ location: location
+ }
+
+ (* Used for local dec in dec and let dec in exp. *)
+ and localdecForm =
+ {
+- decs: (parsetree * int) list,
+- body: (parsetree * int) list,
+- loc: bool,
+- varsInBody: values list ref (* Variables in the in..dec part
+- of a local declaration. *)
++ decs: parsetree list,
++ body: parsetree list,
++ isLocal: bool,
++ varsInBody: values list ref, (* Variables in the in..dec part
++ of a local declaration. *)
++ location: location
+ }
+
+ (* Datatype and Abstract Type declarations *)
+@@ -883,162 +361,135 @@
+ {
+ typelist: datatypebind list,
+ withtypes: typebind list,
+- declist: (parsetree * int) list
++ declist: parsetree list,
++ location: location,
++ equalityStatus: bool list ref
+ }
+-
++
+ and datatypeReplicationForm =
+- {
+- newType: string,
+- oldType: string
+- }
+-
+- (* Directives are infix, infixr and nonfix. They are processed by the
+- parser itself and only appear in the parse tree for completeness. *)
+- and directiveForm =
+- {
+- tlist: string list,
+- fix: fixStatus
+- }
+-
+- (* Execute an expression and catch any exceptions. *)
+- and handleTreeForm =
+- {
+- exp: parsetree,
+- hrules: parsetree list
+- }
+-
+- (* Ordinary while-loop *)
+- and whileForm =
+- {
+- test: parsetree,
+- body: parsetree
+- }
+-
+- (* Case-statement *)
+- and caseForm =
+- {
+- test: parsetree,
+- match: parsetree list
+- }
+-
+- (* andalso/orelse *)
+- and andOrForm =
+- {
+- first: parsetree,
+- second: parsetree
+- }
+-
+- and labelledForm =
+- {
+- recList: (string * parsetree) list,
+- frozen: bool,
+- typeof: types ref
+- }
++ {
++ newType: string,
++ oldType: string,
++ oldLoc: location,
++ newLoc: location,
++ location: location
++ }
+
+- (* Labelled record & the entry in the list. "frozen" is false if it's
+- a pattern with "...". *)
+-
+- and selectorForm =
+- {
+- name: string,
+- labType: types,
+- typeof: types
+- }
+-
+- with
++ (* An entry in a label record in an expression or a pattern. *)
++ and labelRecEntry =
++ {
++ name: string,
++ nameLoc: location,
++ valOrPat: parsetree,
++ fullLocation: location,
++ expType: types ref
++ }
++
++ and funpattern = (* The declaration part of a fun binding. *)
++ { ident: { name: string, expType: types ref, location: location },
++ isInfix: bool, args: parsetree list, constraint: typeParsetree option }
+
+ (*****************************************************************************
+- Pretty Printing
++ Pretty Printing
+ ******************************************************************************)
+
+ fun isIdent (Ident _) = true | isIdent _ = false;
+
+- fun isApplic (Applic _) = true | isApplic _ = false;
+- fun isTupleTree (TupleTree _) = true | isTupleTree _ = false;
+- fun isAbstypeDeclaration (AbstypeDeclaration _) = true | isAbstypeDeclaration _ = false;
+ fun isEmptyTree EmptyTree = true | isEmptyTree _ = false;
+
+ val unit = Unit;
+ val wildCard = WildCard;
+ val emptyTree = EmptyTree;
++
++ (* A general type variable for an expression. This is used to record the type. *)
++ fun makeGeneralTypeVar() = mkTypeVar(generalisable, false, false)
+
+- fun mkIdent name : parsetree =
++ fun mkIdent (name, loc) : parsetree =
+ Ident
+ {
+ name = name,
+- typeof = ref badType,
+- value = ref undefinedValue
++ expType = ref EmptyType,
++ value = ref undefinedValue,
++ location = loc
+ };
+
+- local
+- (* Make overloaded functions for the conversions. *)
+- (* For the moment we make the type string->t and raise an exception
+- if the constant cannot be converted. *)
+- val ty = mkOverloadSet[]
+- val funType = mkFunctionType (stringType, ty);
+- fun mkOverloaded name : values = makeOverloaded (name, funType, TypeDep)
+- in
+- val convString = mkOverloaded "convString"
+- and convInt = mkOverloaded "convInt"
+- and convWord = mkOverloaded "convWord"
+- and convChar = mkOverloaded "convChar"
+- and convReal = mkOverloaded "convReal"
+- end;
+-
+- fun mkString(s: string): parsetree =
+- Literal{converter=convString, literal=s, typeof=ref badType};
+-
+- fun mkInt (i : string) : parsetree =
+- Literal{converter=convInt, literal=i, typeof=ref badType};
+-
+- fun mkReal (r : string) : parsetree =
+- Literal{converter=convReal, literal=r, typeof=ref badType};
+-
+- fun mkChar (c : string) : parsetree =
+- Literal{converter=convChar, literal=c, typeof=ref badType};
+-
+- fun mkWord (w : string) : parsetree =
+- Literal{converter=convWord, literal=w, typeof=ref badType};
+-
+- fun mkApplic (f, arg) : parsetree =
++ local
++ (* Make overloaded functions for the conversions. *)
++ (* For the moment we make the type string->t and raise an exception
++ if the constant cannot be converted. *)
++ val ty = mkOverloadSet[]
++ val funType = mkFunctionType (stringType, ty);
++ fun mkOverloaded name : values = makeOverloaded (name, funType, TypeDep)
++ in
++ val convString = mkOverloaded "convString"
++ and convInt = mkOverloaded "convInt"
++ and convWord = mkOverloaded "convWord"
++ and convChar = mkOverloaded "convChar"
++ and convReal = mkOverloaded "convReal"
++ end;
++
++ fun mkString(s: string, loc): parsetree =
++ Literal{converter=convString, literal=s, expType=ref EmptyType, location=loc};
++
++ fun mkInt (i : string, loc) : parsetree =
++ Literal{converter=convInt, literal=i, expType=ref EmptyType, location=loc};
++
++ fun mkReal (r : string, loc) : parsetree =
++ Literal{converter=convReal, literal=r, expType=ref EmptyType, location=loc};
++
++ fun mkChar (c : string, loc) : parsetree =
++ Literal{converter=convChar, literal=c, expType=ref EmptyType, location=loc};
++
++ fun mkWord (w : string, loc) : parsetree =
++ Literal{converter=convWord, literal=w, expType=ref EmptyType, location=loc};
++
++ fun mkApplic (f, arg, loc, isInfix) : parsetree =
+ Applic
+ {
+ f = f,
+- arg = arg
++ arg = arg,
++ location = loc,
++ isInfix = isInfix,
++ expType = ref EmptyType
+ };
+
+- fun mkCond (test, thenpt, elsept) : parsetree =
++ fun mkCond (test, thenpt, elsept, location) : parsetree =
+ Cond
+ { test = test,
+ thenpt = thenpt,
+- elsept = elsept
++ elsept = elsept,
++ location = location
+ };
+
+- val mkTupleTree : parsetree list -> parsetree = TupleTree;
++ val mkTupleTree : parsetree list * location -> parsetree = TupleTree;
+
+- fun mkValDeclaration (dec, explicit, implicit) : parsetree =
++ fun mkValDeclaration (dec, explicit, implicit, location) : parsetree =
+ ValDeclaration
+ {
+- dec = dec,
+- explicit = explicit,
+- implicit = implicit,
+- variables = ref []
++ dec = dec,
++ explicit = explicit,
++ implicit = implicit,
++ variables = ref [],
++ location = location
+ };
+
+- fun mkFunDeclaration (dec, explicit, implicit) : parsetree =
++ fun mkFunDeclaration (dec, explicit, implicit, location) : parsetree =
+ FunDeclaration
+ {
+- dec=dec,
+- explicit = explicit,
+- implicit = implicit
++ dec=dec,
++ explicit = explicit,
++ implicit = implicit,
++ location = location
+ };
+
+- fun mkOpenTree(ptl : structureIdentForm list): parsetree = OpenDec{decs=ptl, variables=ref []};
++ fun mkOpenTree(ptl : structureIdentForm list, location): parsetree =
++ OpenDec{decs=ptl, variables=ref [], location = location};
+
+- fun mkStructureIdent name : structureIdentForm =
++ fun mkStructureIdent (name, location) : structureIdentForm =
+ {
+ name = name,
+- value = ref undefinedStruct
++ value = ref undefinedStruct,
++ location = location
+ };
+
+ fun mkValBinding (dec, exp, line) : valbind =
+@@ -1051,125 +502,240 @@
+
+ val recValbind = RecValBind;
+
+- fun mkClausal clauses : fvalbind =
++ fun mkClausal(clauses, location) : fvalbind =
+ FValBind
+ {
+ clauses = clauses,
+ numOfPatts = ref 0,
+ functVar = ref undefinedValue,
+- argType = ref badType,
+- resultType = ref badType
++ argType = ref badType,
++ resultType = ref badType,
++ location = location
+ };
+
+- fun mkClause (dec, exp, line) : fvalclause =
+- FValClause
++ (* A clause for a clausal function is initially parsed as a pattern because that is
++ the easiest way to handle it but that's actually more general than the syntax allows.
++ Process it at this point to check for some validity. *)
++ fun mkFunPattern (fPat, lex): funpattern * string * int =
++ let
++ fun makeId(name, loc) =
++ {name = name, expType = ref EmptyType, location = loc }
++
++ fun unpick (Applic{ f, arg, isInfix, ... }) =
++ (* "Application" of function to a parameter. *)
++ let
++ val () =
++ (* This could be an infixed application and since it has been parsed using the
++ normal infix handler the arguments could be prefixed constructor applications
++ or infixed constructor applications with a higher precedence. These are not
++ allowed because the arguments are supposed to just be "atpats". Any
++ applications should have been parenthesised. *)
++ case (isInfix, arg) of
++ (true, TupleTree([Applic _, _], location)) =>
++ errorMessage(lex, location,
++ "Constructor applications in fun bindings must be parenthesised.")
++ | (true, TupleTree([_, Applic _], location)) =>
++ errorMessage(lex, location,
++ "Constructor applications in fun bindings must be parenthesised.")
++ | _ => ();
++ val { ident, isInfix, args, ... } = unpick f
++ in
++ { ident=ident, isInfix=isInfix, args = args @ [arg], constraint = NONE }
++ end
++
++ | unpick (Ident{ name, location, ...}) =
++ {
++ ident={ name = name, location = location, expType = ref EmptyType},
++ isInfix=false, args = [], constraint = NONE
++ }
++
++ | unpick (Parenthesised(Applic{ f = Ident { name, location, ...}, isInfix=true, arg, ... }, _)) =
++ {
++ ident={ name = name, location = location, expType = ref EmptyType},
++ isInfix=true, args = [arg], constraint = NONE
++ }
++
++ | unpick (Parenthesised(_, location)) =
++ (* Only the bottom (i.e. first) application may be parenthesised and then
++ only if the application is infixed. *)
++ (
++ errorMessage(lex, location,
++ "Parentheses are only allowed for infixed applications in fun bindings.");
++ { ident=makeId("", location), isInfix=false, args = [], constraint = NONE }
++ )
++
++ | unpick _ =
++ (
++ errorMessage(lex, location lex,
++ "Syntax error: fun binding is not an identifier applied to one or more patterns.");
++ { ident=makeId("", location lex), isInfix=false, args = [], constraint = NONE }
++ )
++
++ val unpicked as { ident = { name, ...}, args, ...} =
++ (* The "pattern" may have a single constraint giving the result
++ type of the function. Otherwise it must be a set of one or more,
++ possibly infixed, applications. *)
++ case fPat of
++ Constraint { value = value as Applic _, given, ... } =>
++ let
++ val { ident, isInfix, args, ... } = unpick value
++ in
++ { ident = ident, isInfix = isInfix, args = args, constraint = SOME given }
++ end
++
++ | Constraint { value = value as Parenthesised(Applic _, _), given, ... } =>
++ let
++ val { ident, isInfix, args, ... } = unpick value
++ in
++ { ident = ident, isInfix = isInfix, args = args, constraint = SOME given }
++ end
++
++ | fPat as Parenthesised(Applic _, _) =>
++ unpick fPat
++
++ | fPat as Applic _ =>
++ unpick fPat
++
++ | _ =>
++ (
++ errorMessage(lex, location lex,
++ "Syntax error: fun binding is not an identifier applied to one or more patterns.");
++ { ident=makeId("", location lex), isInfix=false, args = [], constraint = NONE }
++ )
++ in
++ (unpicked, name, List.length args)
++ end;
++
++ fun mkClause (dec, exp, line) : fvalclause =
++ FValClause
+ {
+ dec = dec,
+ exp = exp,
+ line = line
+- };
++ }
+
+- val mkList : parsetree list -> parsetree = List;
++ fun mkList(elem, loc) = List{ elements = elem, location = loc, expType = ref EmptyType }
+
+- fun mkConstraint (value, given) : parsetree =
++ fun mkConstraint (value, given, location) : parsetree =
+ Constraint
+ {
+ value = value,
+- given = given
++ given = given,
++ location = location
+ };
+
+- fun mkLayered (var, pattern) : parsetree =
++ fun mkLayered (var, pattern, location) : parsetree =
+ Layered
+ {
+ var = var,
+- pattern = pattern
++ pattern = pattern,
++ location = location
+ };
+
+- val mkFn : parsetree list -> parsetree = Fn;
++ fun mkFn(matches, location) =
++ Fn { matches = matches, location = location, expType = ref EmptyType }
+
+- fun mkMatchTree (vars, exp, line) : parsetree =
++ fun mkMatchTree (vars, exp, location) : matchtree =
+ MatchTree
+ {
+ vars = vars,
+ exp = exp,
+- line = line,
++ location = location,
+ argType = ref badType,
+- resType = ref badType
++ resType = ref badType
+ };
+
+- fun mkLocalDeclaration (decs, body, loc) : parsetree =
++ fun mkLocalDeclaration (decs, body, location, isLocal) : parsetree =
+ Localdec
+ {
+ decs = decs,
+ body = body,
+- loc = loc,
+- varsInBody = ref []
++ isLocal = isLocal,
++ varsInBody = ref [],
++ location = location
+ };
+
+- val mkTypeDeclaration : typebind list -> parsetree = TypeDeclaration;
++ val mkTypeDeclaration : typebind list * location -> parsetree = TypeDeclaration;
+
+- fun mkDatatypeDeclaration (typelist, withtypes) : parsetree =
++ fun mkDatatypeDeclaration (typelist, withtypes, location) : parsetree =
+ DatatypeDeclaration
+ {
+- typelist = typelist,
+- withtypes = withtypes,
+- declist = []
++ typelist = typelist,
++ withtypes = withtypes,
++ declist = [],
++ location = location,
++ equalityStatus = ref []
+ };
+
+- fun mkAbstypeDeclaration (typelist, withtypes, declist) : parsetree =
++ fun mkAbstypeDeclaration (typelist, withtypes, declist, location) : parsetree =
+ AbstypeDeclaration
+ {
+- typelist = typelist,
+- withtypes = withtypes,
+- declist = declist
++ typelist = typelist,
++ withtypes = withtypes,
++ declist = declist,
++ location = location,
++ equalityStatus = ref []
+ };
+
+- fun mkDatatypeReplication (newType, oldType) : parsetree =
+- DatatypeReplication
+- {
+- oldType = oldType,
+- newType = newType
+- };
++ val mkDatatypeReplication = DatatypeReplication
+
+- fun mkTypeBinding (name, typeVars, decType, isEqtype) : typebind =
++ fun mkTypeBinding (name, typeVars, decType, isEqtype, nameLoc, fullLoc) : typebind =
+ TypeBind
+ {
+ name = name,
+ typeVars = typeVars,
+ decType = decType,
+- isEqtype = isEqtype
++ isEqtype = isEqtype,
++ nameLoc = nameLoc,
++ fullLoc = fullLoc
+ };
+
+- fun mkDatatypeBinding (name, typeVars, constrs) : datatypebind =
++ fun mkDatatypeBinding (name, typeVars, constrs, typeNameLoc, fullLoc) : datatypebind =
+ DatatypeBind
+ {
+ name = name,
+ typeVars = typeVars,
+ constrs = constrs,
+ tcon = ref undefType,
+- valueConstrs = ref []
++ valueConstrs = ref [],
++ nameLoc = typeNameLoc,
++ fullLoc = fullLoc
+ };
+
+- fun mkExBinding (name, previous, typeof) : exbind =
++ fun mkExBinding (name, previous, typeof, nameLoc, fullLoc) : exbind =
+ ExBind
+ {
+ name = name,
+ previous = previous,
+- typeof = typeof,
+- value = ref undefinedValue
++ ofType = typeof,
++ value = ref undefinedValue,
++ nameLoc = nameLoc,
++ fullLoc = fullLoc
+ };
+
+- fun mkLabelledTree (recList, frozen) : parsetree =
++ fun mkLabelledTree (recList, frozen, location) : parsetree =
+ Labelled
+ {
+ recList = recList,
+ frozen = frozen,
+- typeof = ref emptyType
++ expType = ref EmptyType,
++ location = location
+ };
++
++ fun mkLabelRecEntry (name, nameLoc, valOrPat, fullLocation) =
++ {
++ name = name,
++ nameLoc = nameLoc,
++ valOrPat = valOrPat,
++ fullLocation = fullLocation,
++ expType = ref EmptyType
++ }
+
+- fun mkSelector name : parsetree =
++ fun mkSelector(name, location) : parsetree =
+ let
+- val resType = mkTypeVar (generalisable, false, false, false);
++ (* Make a type for this. It's equivalent to
++ fn { name = exp, ...} => exp. *)
++ val resType = makeGeneralTypeVar();
+ val entryType = mkLabelEntry (name, resType);
+ val labType = mkLabelled ([entryType], false) (* Not frozen*);
+ in
+@@ -1177,625 +743,1091 @@
+ {
+ name = name,
+ labType = labType,
+- typeof = mkFunctionType (labType, resType)
++ typeof = mkFunctionType (labType, resType),
++ location = location
+ }
+ end;
+
+- val mkRaise : parsetree -> parsetree = Raise;
++ val mkRaise : parsetree * location -> parsetree = Raise;
+
+- fun mkHandleTree (exp, hrules) : parsetree =
++ fun mkHandleTree (exp, hrules, location, listLocation) : parsetree =
+ HandleTree
+ {
+ exp = exp,
+- hrules = hrules
++ hrules = hrules,
++ location = location,
++ listLocation = listLocation
+ };
+
+- fun mkWhile (test, body) : parsetree =
++ fun mkWhile (test, body, location) : parsetree =
+ While
+ {
+- test = test,
+- body = body
++ test = test,
++ body = body,
++ location = location
+ };
+
+- fun mkCase (test, match) : parsetree =
++ fun mkCase (test, match, location, listLocation) : parsetree =
+ Case
+ {
+- test = test,
+- match = match
++ test = test,
++ match = match,
++ location = location,
++ listLocation = listLocation,
++ expType = ref EmptyType
+ };
+
+- fun mkAndalso (first, second) : parsetree =
++ fun mkAndalso (first, second, location) : parsetree =
+ Andalso
+ {
+ first = first,
+- second = second
++ second = second,
++ location = location
+ };
+
+- fun mkOrelse (first, second) : parsetree =
++ fun mkOrelse (first, second, location) : parsetree =
+ Orelse
+ {
+ first = first,
+- second = second
++ second = second,
++ location = location
+ };
+
+- fun mkDirective (tlist, fix) : parsetree =
++ fun mkDirective (tlist, fix, location) : parsetree =
+ Directive
+ {
+ tlist = tlist,
+- fix = fix
++ fix = fix,
++ location = location
+ };
+
+- val mkExpseq : (parsetree * int) list -> parsetree = ExpSeq;
++ val mkExpseq : parsetree list * location -> parsetree = ExpSeq;
+
+- val mkExDeclaration : exbind list -> parsetree = ExDeclaration;
+-
++ val mkExDeclaration : exbind list * location -> parsetree = ExDeclaration;
++
++ val mkParenthesised = Parenthesised
+
+- (* We actually have 2 separate pretty printers! This one is
+- only used for debugging and error messages. The proper
+- top-level pretty-printer is the collection of "display"
+- functions in VALUEOPS.ML. This needs sorting!
+- DCJM: The reason for that is that this pretty printer prints
+- the parse tree whereas the one in Valueops prints values.
+- *)
++ (* This pretty printer is used to format the parsetree
++ for error messages (Error near ...) and also for
++ debugging. There is a quite different pretty printer
++ in VALUEOPS that is used to format values produced as
++ a result of compiling and executing an expression or
++ declaration. *)
++
++ fun printList (doPrint: 'a*int->pretty) (c: 'a list, separator, depth): pretty list =
++ if depth <= 0 then [PrettyString "..."]
++ else
++ case c of
++ [] => []
++ | [v] => [doPrint (v, depth)]
++ | (v::vs) =>
++ PrettyBlock (0, false, [],
++ [
++ doPrint (v, depth),
++ PrettyBreak
++ (if separator = "," orelse separator = ";" orelse separator = "" then 0 else 1, 0),
++ PrettyString separator
++ ]
++ ) ::
++ PrettyBreak (1, 0) ::
++ printList doPrint (vs, separator, depth - 1)
+
+ (* Generates a pretty-printed representation of a piece of tree. *)
+ fun ptDisplay (c : parsetree, (* The value to print. *)
+- depth : int, (* The number of levels to display. *)
+- pprint : prettyPrinter) : unit =
++ depth : int) : pretty = (* The number of levels to display. *)
+ let
+- (* Prints a list of items. *)
+- fun printList (doPrint: 'a*int*prettyPrinter->unit) (c: 'a list, separator, depth) =
+- if depth <= 0 then ppAddString pprint "..."
+- else
+- case c of
+- [] => ()
+- | [v] => doPrint (v, depth, pprint)
+- | (v::vs) =>
+- (
+- ppBeginBlock pprint (0, false);
+- doPrint (v, depth, pprint);
+- ppBreak pprint
+- (if separator = "," orelse separator = ";" orelse separator = "" then 0 else 1, 0);
+- ppAddString pprint separator;
+- ppEndBlock pprint ();
+- ppBreak pprint (1, 0);
+- printList doPrint (vs, separator, depth - 1)
+- )
+- (* end printList *);
++ val displayList: parsetree list * string * int -> pretty list = printList ptDisplay
++
++ (* type bindings and datatype bindings are used in several cases *)
++ fun printTypeBind (TypeBind{name, typeVars, decType, ...}, depth) =
++ PrettyBlock (3, true, [],
++ displayTypeVariables (typeVars, depth) @
++ (
++ PrettyString name ::
++ (* The type may be missing if this is a signature. *)
++ (case decType of
++ NONE => []
++ | SOME t =>
++ [
++ PrettyBreak (1, 0),
++ PrettyString "=",
++ PrettyBreak (1, 0),
++ display (typeFromTypeParse t, depth, emptyTypeEnv)
++ ]
++ )
++ )
++ )
+
+- val displayList = printList ptDisplay
+-
+- (* type bindings and datatype bindings are used in several cases *)
+- fun printTypeBind (TypeBind{name, typeVars, decType, ...}, depth, pprint) =
+- (
+- ppBeginBlock pprint (3, true);
+- displayTypeVariables (typeVars, depth, pprint, true);
+- ppAddString pprint name;
+- (* The type may be missing if this is a signature. *)
+- case decType of
+- EmptyType => ()
+- | _ =>
+- (
+- ppBreak pprint (1, 0);
+- ppAddString pprint "=";
+- ppBreak pprint (1, 0);
+- display (decType, depth, pprint, true)
+- );
+- ppEndBlock pprint ()
+- )
+-
+- and printDatatypeBind (DatatypeBind{name, typeVars, constrs, ...}, depth, pprint) =
+- (
+- ppBeginBlock pprint (3, true);
+- displayTypeVariables (typeVars, depth, pprint, true);
+- ppAddString pprint name;
+- ppBreak pprint (1, 0);
+- ppAddString pprint "=";
+- ppBreak pprint (1, 0);
+- printList printConstructor (constrs, "|", depth - 1);
+- ppEndBlock pprint ()
+- )
+- and printConstructor ((name, argtype), depth, pprint) =
+- (
+- ppBeginBlock pprint (2, false);
+- ppAddString pprint name;
+- if isEmpty argtype then ()
+- else
+- (
+- ppBreak pprint (1, 0);
+- ppAddString pprint "of";
+- ppBreak pprint (1, 0);
+- display (argtype, depth, pprint, true)
+- );
+- ppEndBlock pprint ()
+- )
++ and printDatatypeBind (DatatypeBind{name, typeVars, constrs, ...}, depth) =
++ PrettyBlock (3, true, [],
++ displayTypeVariables (typeVars, depth) @
++ (
++ PrettyString name ::
++ PrettyBreak (1, 0) ::
++ PrettyString "=" ::
++ PrettyBreak (1, 0) ::
++ printList printConstructor (constrs, "|", depth - 1)
++ )
++ )
++
++ and printConstructor ({constrName, constrArg, ...}, depth) =
++ PrettyBlock (2, false, [],
++ PrettyString constrName ::
++ (
++ case constrArg of
++ NONE => []
++ | SOME argType =>
++ [
++ PrettyBreak (1, 0),
++ PrettyString "of",
++ PrettyBreak (1, 0),
++ display (typeFromTypeParse argType, depth, emptyTypeEnv)
++ ]
++ )
++ )
++
+ in
+ if depth <= 0 (* elide further text. *)
+- then ppAddString pprint "..."
++ then PrettyString "..."
+
+ else case c of
+
+ Ident {name, ...} =>
+- ppAddString pprint name
++ PrettyString name
+
+ | Literal{literal, converter, ...} =>
+- let
+- val convName = valName converter
+- val lit =
+- if convName = "convString"
+- then concat["\"" , literal, "\""]
+- else literal
+- in
+- ppAddString pprint lit
+- end
+-
+- | Applic {f, arg} =>
+- (
+- ppBeginBlock pprint (0, false);
+-
+- (* No need to parenthesise *)
+- if isApplic f orelse isIdent f
+- then ptDisplay (f, depth - 1, pprint)
+- else
+- ( (* Put parentheses round the function. *)
+- ppAddString pprint "(";
+- ppBreak pprint (0, 0);
+- ptDisplay (f, depth - 1, pprint);
+- ppBreak pprint (0, 0);
+- ppAddString pprint ")"
+- );
+-
+- ppBreak pprint (0, 0);
+-
+- if isTupleTree arg
+- then (* will have parens anyway *)
+- ptDisplay (arg, depth - 1, pprint)
+- else
+- ( (* Put parentheses round the argument. *)
+- ppAddString pprint "(";
+- ppBreak pprint (0, 0);
+- ptDisplay (arg, depth - 1, pprint);
+- ppBreak pprint (0, 0);
+- ppAddString pprint ")"
+- );
+-
+- ppEndBlock pprint ()
+- )
++ let
++ val convName = valName converter
++ val lit =
++ if convName = "convString"
++ then concat["\"" , literal, "\""]
++ else literal
++ in
++ PrettyString lit
++ end
+
+- | Cond {test, thenpt, elsept} =>
+- (
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint "if";
+- ppBreak pprint (1, 0);
+- ptDisplay (test, depth - 1, pprint);
+- ppBreak pprint (1, 0);
+- ppAddString pprint "then";
+- ppBreak pprint (1, 0);
+- ptDisplay (thenpt, depth - 1, pprint);
+- ppBreak pprint (1, 0);
+- ppAddString pprint "else";
+- ppBreak pprint (1, 0);
+- ptDisplay (elsept, depth - 1, pprint);
+- ppEndBlock pprint ()
+- )
++ | Applic { f, arg = TupleTree([left, right], _), isInfix = true, ...} =>
++ (* Infixed application. *)
++ PrettyBlock (0, false, [],
++ [
++ ptDisplay (left, depth - 1),
++ PrettyBreak (1, 0),
++ ptDisplay (f, depth), (* Just an identifier. *)
++ PrettyBreak (1, 0),
++ ptDisplay (right, depth - 1)
++ ]
++ )
++
++ | Applic {f, arg, ...} => (* Function application. *)
++ PrettyBlock (0, false, [],
++ [
++ ptDisplay (f, depth - 1),
++ PrettyBreak (1, 0),
++ ptDisplay (arg, depth - 1)
++ ]
++ )
++
++ | Cond {test, thenpt, elsept, ...} => (* if..then..else.. *)
++ PrettyBlock (0, false, [],
++ [
++ PrettyString "if",
++ PrettyBreak (1, 0),
++ ptDisplay (test, depth - 1),
++ PrettyBreak (1, 0),
++ PrettyString "then",
++ PrettyBreak (1, 0),
++ ptDisplay (thenpt, depth - 1),
++ PrettyBreak (1, 0),
++ PrettyString "else",
++ PrettyBreak (1, 0),
++ ptDisplay (elsept, depth - 1)
++ ]
++ )
++
++ | TupleTree(ptl, _) =>
++ PrettyBlock (3, true, [],
++ (
++ PrettyString "(" ::
++ PrettyBreak (0, 0) ::
++ displayList (ptl, ",", depth - 1)
++ ) @ [PrettyBreak (0, 0), PrettyString ")"]
++ )
+
+- | TupleTree ptl =>
+- (
+- ppBeginBlock pprint (3, true);
+- ppAddString pprint "(";
+- ppBreak pprint (1, 0);
+- displayList (ptl, ",", depth - 1);
+- ppBreak pprint (0, 0);
+- ppAddString pprint ")";
+- ppEndBlock pprint ()
+- )
++ | ValDeclaration {dec, ...} =>
++ let
++ (* We can't use printList here because we don't want an
++ "and" after a "rec". *)
++ fun printValBind ([], _) = []
++
++ | printValBind (RecValBind :: rest, depth) =
++ PrettyString "rec" :: PrettyBreak (1, 0) :: printValBind(rest, depth)
++
++ | printValBind (ValBind{dec, exp, ...} :: rest, depth) =
++ if depth <= 0
++ then [PrettyString "..."]
++ else
++ let
++ val pValBind =
++ PrettyBlock (3, false, [],
++ [
++ ptDisplay (dec, depth - 1),
++ PrettyBreak (1, 0),
++ PrettyString "=",
++ PrettyBreak (1, 0),
++ ptDisplay (exp, depth - 1)
++ ]
++ )
++ in
++ case rest of
++ [] => [pValBind]
++ | _ => PrettyBlock (0, false, [], [pValBind, PrettyBreak(1, 0), PrettyString "and"]) ::
++ PrettyBreak(1, 0) :: printValBind(rest, depth-1)
++ end
++ in
++ PrettyBlock (3, true, [],
++ PrettyString "val" ::
++ PrettyBreak (1, 0) ::
++ (* TODO: Display the explicit type variables. *)
++ (* displayTypeVariables (explicit, depth); *)
++ printValBind (dec, depth - 1)
++ )
++ end
+
+- | ValDeclaration {dec, explicit, ...} =>
+- let
+- fun printValBind (RecValBind, depth, pprint) =
+- (
+- ppAddString pprint "rec";
+- ppBreak pprint (1, 0)
+- )
+- | printValBind (ValBind{dec, exp, ...}, depth, pprint) =
+- (
+- ppBeginBlock pprint (3, true);
+- ptDisplay (dec, depth - 1, pprint);
+- ppBreak pprint (1, 0);
+- ppAddString pprint "=";
+- ppBreak pprint (1, 0);
+- ptDisplay (exp, depth - 1, pprint);
+- ppEndBlock pprint ()
+- )
+- in
+- ppBeginBlock pprint (3, true);
+- ppAddString pprint "val";
+- ppBreak pprint (1, 0);
+- (* TODO: Display the explicit type variables. *)
+- (* displayTypeVariables (explicit, depth, pprint); *)
+- (* TODO: This prints val rec f as "val rec and f". *)
+- printList printValBind (dec, "and", depth - 1);
+- ppEndBlock pprint ()
+- end
+-
+- | FunDeclaration {dec, explicit={apply, ...}, ...} =>
+- let
+- fun printfvalbind (FValBind{clauses, ...}, depth, pprint) =
+- printList printClause (clauses, "|", depth - 1)
+- and printClause (FValClause{dec, exp, ...}, depth, pprint) =
+- (
+- ppBeginBlock pprint (3, true);
+- ptDisplay (dec, depth - 1, pprint);
+- ppBreak pprint (1, 0);
+- ppAddString pprint "=";
+- ppBreak pprint (1, 0);
+- ptDisplay (exp, depth - 1, pprint);
+- ppEndBlock pprint ()
+- )
+- in
+- ppBeginBlock pprint (3, true);
+- ppAddString pprint "fun";
+- ppBreak pprint (1, 0);
+- (* TODO: Display the explicit type variables. *)
+- (* displayTypeVariables (explicit, depth, pprint); *)
+- printList printfvalbind (dec, "and", depth - 1);
+- ppEndBlock pprint ()
+- end
++ | FunDeclaration {dec, ...} =>
++ let
++ fun printfvalbind (FValBind{clauses, ...}, depth) =
++ PrettyBlock(3, true, [], printList printClause (clauses, "|", depth - 1))
++ and printClause (FValClause{dec, exp, ...}, depth) =
++ PrettyBlock (3, true, [],
++ [
++ printDec (dec, depth - 1),
++ PrettyBreak (1, 0),
++ PrettyString "=",
++ PrettyBreak (1, 0),
++ ptDisplay (exp, depth - 1)
++ ]
++ )
++ and printDec(
++ { ident = { name, ... }, isInfix=true, args=[TupleTree([left, right], _)], constraint }, depth) =
++ (* Single infixed application. *)
++ PrettyBlock (0, false, [],
++ [
++ ptDisplay (left, depth - 1),
++ PrettyBreak (1, 0),
++ PrettyString name,
++ PrettyBreak (1, 0),
++ ptDisplay (right, depth - 1)
++ ] @ printConstraint (constraint, depth-1)
++ )
++ | printDec(
++ { ident = { name, ... }, isInfix=true,
++ args=TupleTree([left, right], _) :: args, constraint }, depth) =
++ (* Infixed application followed by other arguments. *)
++ PrettyBlock (0, false, [],
++ [
++ PrettyString "(",
++ PrettyBreak (0, 0),
++ ptDisplay (left, depth - 1),
++ PrettyBreak (1, 0),
++ PrettyString name,
++ PrettyBreak (1, 0),
++ ptDisplay (right, depth - 1),
++ PrettyBreak (0, 0),
++ PrettyString ")"
++ ] @ displayList (args, "", depth - 1) @ printConstraint(constraint, depth-2)
++ )
++ | printDec({ ident = { name, ...}, args, constraint, ... }, depth) =
++ (* Prefixed application. *)
++ PrettyBlock (0, false, [],
++ [ PrettyString name, PrettyBreak (1, 0) ] @
++ displayList (args, "", depth - 1) @ printConstraint(constraint, depth-2)
++ )
++ and printConstraint(NONE, _) = []
++ | printConstraint(SOME given, depth) =
++ [
++ PrettyBreak (1, 0),
++ PrettyString ":",
++ PrettyBreak (1, 0),
++ display (typeFromTypeParse given, depth, emptyTypeEnv)
++ ]
++ in
++ PrettyBlock (3, true, [],
++ PrettyString "fun" ::
++ PrettyBreak (1, 0) ::
++ (* TODO: Display the explicit type variables. *)
++ (* displayTypeVariables (explicit, depth); *)
++ printList printfvalbind (dec, "and", depth - 1)
++ )
++ end
+
+ | OpenDec {decs, ...} =>
+- let
+- fun printStrName ({name, ...}: structureIdentForm, _, pprint) = ppAddString pprint name
+- in
+- ppBeginBlock pprint (3, true);
+- ppAddString pprint "open";
+- ppBreak pprint (1, 0);
+- printList printStrName (decs, "", depth - 1);
+- ppEndBlock pprint ()
+- end
+-
+- | List ptl =>
+- (
+- ppBeginBlock pprint (3, true);
+- ppAddString pprint "[";
+- ppBreak pprint (1, 0);
+- displayList (ptl, ",", depth - 1);
+- ppBreak pprint (0, 0);
+- ppAddString pprint "]";
+- ppEndBlock pprint ()
+- )
+-
+- | Constraint {value, given} =>
+- (
+- ppBeginBlock pprint (3, false);
+- ptDisplay (value, depth - 1, pprint);
+- ppBreak pprint (1, 0);
+- ppAddString pprint ":";
+- ppBreak pprint (1, 0);
+- display (given, depth, pprint, true);
+- ppEndBlock pprint ()
+- )
++ let
++ fun printStrName ({name, ...}: structureIdentForm, _) = PrettyString name
++ in
++ PrettyBlock (3, true, [],
++ PrettyString "open" ::
++ PrettyBreak (1, 0) ::
++ printList printStrName (decs, "", depth - 1)
++ )
++ end
+
+- | Layered {var, pattern} =>
+- (
+- ppBeginBlock pprint (3, true);
+- ptDisplay (var, depth - 1, pprint);
+- ppBreak pprint (1, 0);
+- ppAddString pprint "as";
+- ppBreak pprint (1, 0);
+- ptDisplay (pattern, depth - 1, pprint);
+- ppEndBlock pprint ()
+- )
++ | List {elements, ...} =>
++ PrettyBlock (3, true, [],
++ PrettyString "[" ::
++ PrettyBreak (0, 0) ::
++ displayList (elements, ",", depth - 1) @
++ [PrettyBreak (0, 0), PrettyString "]" ]
++ )
++
++ | Constraint {value, given, ...} =>
++ PrettyBlock (3, false, [],
++ [
++ ptDisplay (value, depth - 1),
++ PrettyBreak (1, 0),
++ PrettyString ":",
++ PrettyBreak (1, 0),
++ display (typeFromTypeParse given, depth, emptyTypeEnv)
++ ]
++ )
++
++ | Layered {var, pattern, ...} =>
++ PrettyBlock (3, true, [],
++ [
++ ptDisplay (var, depth - 1),
++ PrettyBreak (1, 0),
++ PrettyString "as",
++ PrettyBreak (1, 0),
++ ptDisplay (pattern, depth - 1)
++ ]
++ )
++
++ | Fn {matches, ...} =>
++ PrettyBlock (3, true, [],
++ PrettyString "fn" ::
++ PrettyBreak (1, 0) ::
++ printList displayMatch (matches, "|", depth - 1)
++ )
++
++ | Unit _ =>
++ PrettyString "()"
++
++ | WildCard _ =>
++ PrettyString "_"
++
++ | Localdec {isLocal, decs, body, ...} =>
++ PrettyBlock (3, false, [],
++ PrettyString (if isLocal then "local" else "let") ::
++ PrettyBreak (1, 0) ::
++ displayList (decs, ";", depth - 1) @
++ [PrettyBreak (1, 0), PrettyString "in", PrettyBreak (1, 0)] @
++ displayList (body, ";", depth - 1) @
++ [PrettyBreak (1, 0), PrettyString "end"]
++ )
+
+- | MatchTree {vars, exp, ...} =>
+- (
+- ppBeginBlock pprint (0, false);
+- ptDisplay (vars, depth - 1, pprint);
+- ppBreak pprint (1, 0);
+- ppAddString pprint "=>";
+- ppBreak pprint (1, 0);
+- ptDisplay (exp, depth - 1, pprint);
+- ppEndBlock pprint ()
+- )
++ | TypeDeclaration(ptl, _) =>
++ let
++ (* This is used both for type bindings and also in signatures.
++ In a signature we may have "eqtype". *)
++ val typeString =
++ case ptl of
++ TypeBind {isEqtype=true, ...} :: _ => "eqtype"
++ | _ => "type"
++ in
++ PrettyBlock (3, true, [],
++ PrettyString typeString ::
++ PrettyBreak (1, 0) ::
++ printList printTypeBind (ptl, "and", depth - 1)
++ )
++ end
+
+- | Fn ptl =>
+- (
+- ppBeginBlock pprint (3, true);
+- ppAddString pprint "fn";
+- ppBreak pprint (1, 0);
+- displayList (ptl, "|", depth - 1);
+- ppEndBlock pprint ()
+- )
+-
+- | Unit =>
+- ppAddString pprint "()"
+-
+- | WildCard =>
+- ppAddString pprint "_"
+-
+- | Localdec {loc, decs, body, ...} =>
+- (
+- ppBeginBlock pprint (3, false);
+- ppAddString pprint (if loc then "local" else "let");
+- ppBreak pprint (1, 0);
+- displayList (#1(ListPair.unzip decs), ";", depth - 1);
+- ppBreak pprint (1, 0);
+- ppAddString pprint "in";
+- ppBreak pprint (1, 0);
+- displayList (#1(ListPair.unzip body), ";", depth - 1);
+- ppBreak pprint (1, 0);
+- ppAddString pprint "end";
+- ppEndBlock pprint ()
+- )
++ | DatatypeDeclaration {typelist, withtypes, ...} =>
++ PrettyBlock (3, true, [],
++ PrettyString "datatype" ::
++ PrettyBreak (1, 0) ::
++ printList printDatatypeBind (typelist, "and", depth - 1) @
++ (
++ if null withtypes then []
++ else
++ PrettyBreak (1, 0) ::
++ PrettyString "withtype" ::
++ PrettyBreak (1, 0) ::
++ printList printTypeBind (withtypes, "and", depth - 1)
++ )
++ )
++
++ | DatatypeReplication {newType, oldType, ...} =>
++ PrettyBlock (3, true, [],
++ [
++ PrettyString "datatype",
++ PrettyBreak (1, 0),
++ PrettyString newType,
++ PrettyBreak (1, 0),
++ PrettyString "=",
++ PrettyBreak (1, 0),
++ PrettyString "datatype",
++ PrettyBreak (1, 0),
++ PrettyString oldType
++ ]
++ )
++
++ | AbstypeDeclaration {typelist, withtypes, declist, ...} =>
++ PrettyBlock (3, true, [],
++ PrettyString "abstype" ::
++ PrettyBreak (1, 0) ::
++ printList printDatatypeBind (typelist, "and", depth - 1) @
++ [ PrettyBreak (1, 0) ] @
++ (
++ if null withtypes then []
++ else
++ PrettyString "withtype" ::
++ PrettyBreak (1, 0) ::
++ printList printTypeBind (withtypes, "and", depth - 1) @
++ [PrettyBreak (1, 0)]
++ ) @
++ [
++ PrettyString "with",
++ PrettyBreak (1, 0),
++ PrettyBlock (3, true, [],
++ displayList (declist, ";", depth - 1))
++ ]
++ )
++
+
+- | TypeDeclaration ptl =>
+- let
+- (* This is used both for type bindings and also in signatures.
+- In a signature we may have "eqtype". *)
+- val typeString =
+- case ptl of
+- TypeBind {isEqtype=true, ...} :: _ => "eqtype"
+- | _ => "type"
+- in
+- ppBeginBlock pprint (3, true);
+- ppAddString pprint typeString;
+- ppBreak pprint (1, 0);
+- printList printTypeBind (ptl, "and", depth - 1);
+- ppEndBlock pprint ()
+- end
++ | ExpSeq(ptl, _) =>
++ PrettyBlock (3, true, [],
++ PrettyString "(" ::
++ PrettyBreak (0, 0) ::
++ displayList (ptl, ";", depth - 1) @
++ [ PrettyBreak (0, 0), PrettyString ")"]
++ )
++
++ | Directive {fix, tlist, ...} =>
++ PrettyBlock (3, true, [],
++ displayFixStatus fix ::
++ PrettyBreak (1, 0) ::
++ printList (fn (name, _) => PrettyString name) (tlist, "", depth - 1)
++ )
+
+- | DatatypeDeclaration {typelist, withtypes, ...} =>
+- (
+- ppBeginBlock pprint (3, true);
+- ppAddString pprint "datatype";
+- ppBreak pprint (1, 0);
+- printList printDatatypeBind (typelist, "and", depth - 1);
+- if null withtypes then ()
+- else
+- (
+- ppBreak pprint (1, 0);
+- ppAddString pprint "withtype";
+- ppBreak pprint (1, 0);
+- printList printTypeBind (withtypes, "and", depth - 1)
+- );
+- ppEndBlock pprint ()
+- )
++ | ExDeclaration(pt, _) =>
++ let
++ fun printExBind (ExBind {name, ofType, previous, ...}, depth) =
++ PrettyBlock (0, false, [],
++ PrettyString name ::
++ (case ofType of NONE => []
++ | SOME typeof =>
++ [
++ PrettyBreak (1, 0),
++ PrettyString "of",
++ PrettyBreak (1, 0),
++ display (typeFromTypeParse typeof, depth, emptyTypeEnv)
++ ]
++ ) @
++ (if isEmptyTree previous then []
++ else
++ [
++ PrettyBreak (1, 0),
++ PrettyString "=",
++ PrettyBreak (1, 0),
++ ptDisplay (previous, depth - 1)
++ ])
++ )
++ in
++ PrettyBlock (3, true, [],
++ PrettyString "exception" ::
++ PrettyBreak (1, 0) ::
++ printList printExBind (pt, "and", depth - 1)
++ )
++ end
+
+- | DatatypeReplication {newType, oldType} =>
+- (
+- ppBeginBlock pprint (3, true);
+- ppAddString pprint "datatype";
+- ppBreak pprint (1, 0);
+- ppAddString pprint newType;
+- ppBreak pprint (1, 0);
+- ppAddString pprint "=";
+- ppBreak pprint (1, 0);
+- ppAddString pprint "datatype";
+- ppBreak pprint (1, 0);
+- ppAddString pprint oldType;
+- ppEndBlock pprint ()
+- )
++ | Raise (pt, _) =>
++ PrettyBlock (0, false, [],
++ [
++ PrettyString "raise",
++ PrettyBreak (1, 0),
++ ptDisplay (pt, depth - 1)
++ ]
++ )
++
++ | HandleTree {exp, hrules, ...} =>
++ PrettyBlock (0, false, [],
++ [
++ ptDisplay (exp, depth - 1),
++ PrettyBreak (1, 0),
++ PrettyBlock (3, true, [],
++ PrettyString "handle" ::
++ PrettyBreak (1, 0) ::
++ printList displayMatch (hrules, "|", depth - 1)
++ )
++ ]
++ )
+
+- | AbstypeDeclaration {typelist, withtypes, declist} =>
+- (
+- ppBeginBlock pprint (3, true);
+- ppAddString pprint "abstype";
+- ppBreak pprint (1, 0);
+- printList printDatatypeBind (typelist, "and", depth - 1);
+- ppBreak pprint (1, 0);
+- if null withtypes then ()
+- else
+- (
+- ppAddString pprint "withtype";
+- ppBreak pprint (1, 0);
+- printList printTypeBind (withtypes, "and", depth - 1);
+- ppBreak pprint (1, 0)
+- );
+- ppAddString pprint "with";
+- ppBreak pprint (1, 0);
+- ppBeginBlock pprint (3, true);
+- displayList (#1 (ListPair.unzip declist), ";", depth - 1);
+- ppEndBlock pprint ();
+- ppEndBlock pprint ()
+- )
++ | While {test, body, ...} =>
++ PrettyBlock (0, false, [],
++ [
++ PrettyString "while",
++ PrettyBreak (1, 0),
++ ptDisplay (test, depth - 1),
++ PrettyBreak (1, 0),
++ PrettyString "do",
++ PrettyBreak (1, 0),
++ ptDisplay (body, depth - 1)
++ ]
++ )
++
++ | Case {test, match, ...} =>
++ PrettyBlock (3, true, [],
++ PrettyBlock (0, false, [],
++ [
++ PrettyString "case",
++ PrettyBreak (1, 0),
++ ptDisplay (test, depth - 1),
++ PrettyBreak (1, 0),
++ PrettyString "of"
++ ]
++ ) ::
++ PrettyBreak (1, 0) ::
++ printList displayMatch (match, "|", depth - 1)
++ )
++
++ | Andalso {first, second, ...} =>
++ PrettyBlock (3, true, [],
++ [
++ ptDisplay (first, depth - 1),
++ PrettyBreak (1, 0),
++ PrettyString "andalso",
++ PrettyBreak (1, 0),
++ ptDisplay (second, depth - 1)
++ ]
++ )
++
++ | Orelse {first, second, ...} =>
++ PrettyBlock (3, true, [],
++ [
++ ptDisplay (first, depth - 1),
++ PrettyBreak (1, 0),
++ PrettyString "orelse",
++ PrettyBreak (1, 0),
++ ptDisplay (second, depth - 1)
++ ]
++ )
+
+- | ExpSeq ptl =>
+- (
+- ppBeginBlock pprint (3, true);
+- ppAddString pprint "(";
+- ppBreak pprint (0, 0);
+- displayList (#1 (ListPair.unzip ptl), ";", depth - 1);
+- ppBreak pprint (0, 0);
+- ppAddString pprint ")";
+- ppEndBlock pprint ()
+- )
+-
+- | Directive {fix, tlist} =>
+- (
+- ppBeginBlock pprint (3, true);
+- displayFixStatus (fix, depth, pprint);
+- ppBreak pprint (1, 0);
+- printList (fn (name, _, pprint) => ppAddString pprint name) (tlist, "", depth - 1);
+- ppEndBlock pprint ()
+- )
++ | Labelled {recList, frozen, ...} =>
++ let
++ fun displayRecList (c, depth): pretty list =
++ if depth <= 0 then [PrettyString "..."]
++ else
++ case c of
++ [] => []
++ | [{name, valOrPat, ...}] =>
++ [
++ PrettyBlock (0, false, [],
++ [
++ PrettyString (name ^ " ="),
++ PrettyBreak (1, 0),
++ ptDisplay (valOrPat, depth - 1)
++ ]
++ )
++ ]
++ | ({name, valOrPat, ...}::vs) =>
++ PrettyBlock (0, false, [],
++ [
++ PrettyBlock (0, false, [],
++ [
++ PrettyString (name ^ " ="),
++ PrettyBreak (1, 0),
++ ptDisplay (valOrPat, depth - 1)
++ ]
++ ),
++ PrettyBreak (0, 0),
++ PrettyString ","
++ ]
++ ) ::
++ PrettyBreak (1, 0) ::
++ displayRecList (vs, depth - 1)
++ (* end displayRecList *)
++ in
++ PrettyBlock (2, false, [],
++ PrettyString "{" ::
++ displayRecList (recList, depth - 1) @
++ (if frozen then [PrettyString "}"]
++ else [PrettyString (if null recList then "...}" else ", ...}")])
++ )
++ end
+
+- | ExDeclaration pt =>
+- let
+- fun printExBind (ExBind {name, typeof, previous, ...}, depth, pprint) =
+- (
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint name;
+- if isEmpty typeof then ()
+- else
+- (
+- ppBreak pprint (1, 0);
+- ppAddString pprint "of";
+- ppBreak pprint (1, 0);
+- display (typeof, depth, pprint, true)
+- );
+- if isEmptyTree previous then ()
+- else
+- (
+- ppBreak pprint (1, 0);
+- ppAddString pprint "=";
+- ppBreak pprint (1, 0);
+- ptDisplay (previous, depth - 1, pprint)
+- );
+- ppEndBlock pprint ()
+- )
+- in
+- ppBeginBlock pprint (3, true);
+- ppAddString pprint "exception";
+- ppBreak pprint (1, 0);
+- printList printExBind (pt, "and", depth - 1);
+- ppEndBlock pprint ()
+- end
+-
+- | Raise pt =>
+- (
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint "raise";
+- ppBreak pprint (1, 0);
+- ptDisplay (pt, depth - 1, pprint);
+- ppEndBlock pprint ()
+- )
++ | Selector {name, ...} =>
++ PrettyString ("#" ^ name)
+
+- | HandleTree {exp, hrules} =>
+- (
+- ppBeginBlock pprint (0, false);
+- ptDisplay (exp, depth - 1, pprint);
+- ppBreak pprint (1, 0);
+- ppBeginBlock pprint (3, true);
+- ppAddString pprint "handle";
+- ppBreak pprint (1, 0);
+- displayList (hrules, "|", depth - 1);
+- ppEndBlock pprint ();
+- ppEndBlock pprint ()
+- )
++ | EmptyTree =>
++ PrettyString "<Empty>"
++
++ | Parenthesised(p, _) =>
++ PrettyBlock(0, false, [],
++ [
++ PrettyString "(",
++ PrettyBreak (0, 0),
++ ptDisplay (p, depth),
++ PrettyBreak (0, 0),
++ PrettyString ")"
++ ]
++ )
++
++ end (* ptDisplay *)
+
+- | While {test, body} =>
+- (
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint "while";
+- ppBreak pprint (1, 0);
+- ptDisplay (test, depth - 1, pprint);
+- ppBreak pprint (1, 0);
+- ppAddString pprint "do";
+- ppBreak pprint (1, 0);
+- ptDisplay (body, depth - 1, pprint);
+- ppEndBlock pprint ()
++ and displayMatch(MatchTree {vars, exp, ...}, depth) =
++ PrettyBlock (0, false, [],
++ [
++ ptDisplay (vars, depth - 1),
++ PrettyBreak (1, 0),
++ PrettyString "=>",
++ PrettyBreak (1, 0),
++ ptDisplay (exp, depth - 1)
++ ]
+ )
+
+- | Case {test, match} =>
+- (
+- ppBeginBlock pprint (3, true);
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint "case";
+- ppBreak pprint (1, 0);
+- ptDisplay (test, depth - 1, pprint);
+- ppBreak pprint (1, 0);
+- ppAddString pprint "of";
+- ppEndBlock pprint ();
+- ppBreak pprint (1, 0);
+- displayList (match, "|", depth - 1);
+- ppEndBlock pprint ()
+- )
++ fun getExportTree(navigation, p: parsetree) =
++ let
++ (* Common properties for navigation and printing. *)
++ val commonProps = exportNavigationProps navigation @ [PTprint(fn d => ptDisplay(p, d))]
+
+- | Andalso {first, second} =>
+- (
+- ppBeginBlock pprint (3, true);
+- ptDisplay (first, depth - 1, pprint);
+- ppBreak pprint (1, 0);
+- ppAddString pprint "andalso";
+- ppBreak pprint (1, 0);
+- ptDisplay (second, depth - 1, pprint);
+- ppEndBlock pprint ()
+- )
++ fun asParent () = getExportTree(navigation, p)
+
+- | Orelse {first, second} =>
+- (
+- ppBeginBlock pprint (3, true);
+- ptDisplay (first, depth - 1, pprint);
+- ppBreak pprint (1, 0);
+- ppAddString pprint "orelse";
+- ppBreak pprint (1, 0);
+- ptDisplay (second, depth - 1, pprint);
+- ppEndBlock pprint ()
+- )
++ (* Put all these into a common list. That simplifies navigation between
++ the various groups in abstypes and datatypes. *)
++ datatype lType = DataT of datatypebind | TypeB of typebind | Decl of parsetree
++
++ (* Common code for datatypes, abstypes and type bindings. *)
++ fun exportTypeBinding(navigation, this as DataT(DatatypeBind{name, nameLoc, fullLoc, constrs, ...})) =
++ let
++ fun asParent () = exportTypeBinding(navigation, this)
++ (* Ignore any type variables before the type name. *)
++ fun getName () =
++ getStringAsTree({parent=SOME asParent, previous=NONE, next=SOME getConstrs}, name, nameLoc, [])
++ and getConstrs () =
++ let
++ fun exportConstrs(navigation, {constrName, idLocn, ... }) =
++ (* TODO: the constructor type. *)
++ getStringAsTree(navigation, constrName, idLocn, [])
++ in
++ (fullLoc, (* TODO: We need a separate location for the constrs. *)
++ exportList(exportConstrs, SOME asParent) constrs @
++ exportNavigationProps {parent=SOME asParent, previous=SOME getName, next=NONE})
++ end
++ in
++ (fullLoc, PTfirstChild getName :: exportNavigationProps navigation)
++ end
+
+- | Labelled {recList, frozen, ...} =>
++ | exportTypeBinding(navigation,
++ this as TypeB(TypeBind{name, nameLoc, decType = SOME decType, fullLoc, ...})) =
++ let
++ fun asParent () = exportTypeBinding(navigation, this)
++ (* Ignore any type variables before the type name. *)
++ fun getName () =
++ getStringAsTree({parent=SOME asParent, previous=NONE, next=SOME getType}, name, nameLoc, [])
++ and getType () =
++ typeExportTree({parent=SOME asParent, previous=SOME getName, next=NONE}, decType)
++ in
++ (fullLoc, PTfirstChild getName :: exportNavigationProps navigation)
++ end
++
++ (* TypeBind is also used in a signature in which case decType could be NONE. *)
++ | exportTypeBinding(navigation,
++ this as TypeB(TypeBind{name, nameLoc, decType = NONE, fullLoc, ...})) =
++ let
++ fun asParent () = exportTypeBinding(navigation, this)
++ (* Ignore any type variables before the type name. *)
++ (* Retain this as a child entry in case we decide to add the type vars later. *)
++ fun getName () =
++ getStringAsTree({parent=SOME asParent, previous=NONE, next=NONE}, name, nameLoc, [])
++ in
++ (fullLoc, PTfirstChild getName :: exportNavigationProps navigation)
++ end
++
++ | exportTypeBinding(navigation, Decl dec) =
++ (* Value declarations in an abstype. *) getExportTree(navigation, dec)
++
++ fun exportMatch(navigation,
++ p as MatchTree{location, vars, exp, resType = ref rtype, argType = ref atype,...}) =
+ let
+- fun displayRecList (c, depth) =
+- if depth <= 0 then ppAddString pprint "..."
+- else
+- case c of
+- [] => ()
+- | [(name, value)] =>
+- (
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint (name ^ " =");
+- ppBreak pprint (1, 0);
+- ptDisplay (value, depth - 1, pprint);
+- ppEndBlock pprint ()
+- )
+- | ((name, value)::vs) =>
+- (
+- ppBeginBlock pprint (0, false);
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint (name ^ " =");
+- ppBreak pprint (1, 0);
+- ptDisplay (value, depth - 1, pprint);
+- ppEndBlock pprint ();
+- ppBreak pprint (0, 0);
+- ppAddString pprint ",";
+- ppEndBlock pprint ();
+- ppBreak pprint (1, 0);
+- displayRecList (vs, depth - 1)
+- )
+- (* end displayRecList *)
+- in
+- ppBeginBlock pprint (2, false);
+- ppAddString pprint "{";
+- displayRecList (recList, depth - 1);
+- if frozen then ()
+- else ppAddString pprint (if null recList then "..." else ", ...");
+- ppAddString pprint "}";
+- ppEndBlock pprint ()
++ fun asParent () = exportMatch(navigation, p)
++ in
++ (location,
++ [PTprint(fn d => displayMatch(p, d)), PTtype (mkFunctionType (atype, rtype))] @
++ exportList(getExportTree, SOME asParent) [vars, exp] @
++ exportNavigationProps navigation
++ )
+ end
++ in
++ case p of
++ Ident{location, expType=ref expType, value, ...} =>
++ let
++ (* Include the type and declaration properties if these
++ have been set. *)
++ val (decProp, references) =
++ case value of
++ ref (Value{name = "<undefined>", ...}) => ([], NONE)
++ | ref (Value{locations, references, ...}) => (mapLocationProps locations, references)
++ val refProp =
++ case references of
++ NONE => []
++ | SOME {exportedRef=ref exp, localRef=ref locals} => [PTreferences(exp, locals)]
++ in
++ (location, PTtype expType :: decProp @ commonProps @ refProp)
++ end
+
+- | Selector {name, ...} =>
+- ppAddString pprint ("#" ^ name)
++ | Literal {location, expType=ref expType, ...} => (location, PTtype expType :: commonProps)
+
+- | EmptyTree =>
+- ppAddString pprint "<Empty>"
+- end; (* ptDisplay *)
++ (* Infixed application. For the purposes of navigation we treat this as
++ three entries in order. *)
++ | Applic{location, f, arg = TupleTree([left, right], _), isInfix = true, expType=ref expType, ...} =>
++ (location,
++ PTtype expType :: exportList(getExportTree, SOME asParent) [left, f, right] @ commonProps)
++
++ (* Non-infixed application. *)
++ | Applic{location, f, arg, expType=ref expType, ...} =>
++ (location, PTtype expType :: exportList(getExportTree, SOME asParent) [f, arg] @ commonProps)
++
++ | Cond{location, test, thenpt, elsept, ...} =>
++ (location, exportList(getExportTree, SOME asParent) [test, thenpt, elsept] @ commonProps)
++
++ | TupleTree(entries, location) =>
++ (location, exportList(getExportTree, SOME asParent) entries @ commonProps)
++
++ | ValDeclaration{location, dec, ...} =>
++ let
++ (* TODO: This is a mess. "rec" is not really an entry in the list. *)
++ fun exportVB(navigation, vb as ValBind{dec, exp, line}) =
++ let
++ val vbProps = exportNavigationProps navigation
++ (* First child should give the pattern *)
++ (* Second child should give the expression *)
++ fun exportThis () = exportVB(navigation, vb)
++ val asChild = exportList(getExportTree, SOME exportThis) [dec, exp]
++ in
++ (line, asChild @ vbProps)
++ end
++ | exportVB(_, RecValBind) = (nullLocation, [])
++
++ val expChild = exportList(exportVB, SOME asParent) dec
++ in
++ (* We need a special case for a top-level expression. This has been converted
++ by the parser into val it = exp but the "val it = " takes up no space.
++ We need to go directly to the expression in that case. *)
++ case dec of
++ [ValBind{dec=Ident{name="it", location=itLoc, ...}, exp, ...}]
++ => if #startPosition itLoc = #endPosition itLoc andalso
++ #startLine itLoc = #endLine itLoc
++ then getExportTree(navigation, exp)
++ else (location, expChild @ commonProps)
++ | _ => (location, expChild @ commonProps)
++ end
++
++ | FunDeclaration{location, dec, ...} =>
++ let
++ (* It's easiest to put these all together into a single list. *)
++ datatype funEntry =
++ FunIdent of { name: string, expType: types ref, location: location } * references
++ | FunPtree of parsetree
++ | FunConstraint of typeParsetree
++ | FunInfixed of funEntry list * location
++
++ fun exportFunEntry(navigation, FunIdent({expType=ref expType, location, ...}, refs)) =
++ let
++ val refProp =
++ case refs of
++ NONE => []
++ | SOME {exportedRef=ref exp, localRef=ref locals} => [PTreferences(exp, locals)]
++ in
++ (location, refProp @ (PTtype expType :: PTdeclaredAt location :: exportNavigationProps navigation))
++ end
++ | exportFunEntry(navigation, FunPtree pt) = getExportTree(navigation, pt)
++ | exportFunEntry(navigation, FunConstraint typ) = typeExportTree(navigation, typ)
++
++ | exportFunEntry(navigation, this as FunInfixed(inf, location)) =
++ let
++ fun asParent () = exportFunEntry(navigation, this)
++ val expChild = exportList(exportFunEntry, SOME asParent) inf
++ in
++ (location, expChild @ exportNavigationProps navigation)
++ end
++
++ fun exportAClause(
++ FValClause{dec = {ident, isInfix, args, constraint}, exp, ...}, refs, exportThis) =
++ let
++ (* The effect of this is to have all the elements of the clause as
++ a single level except that if we have an infixed application of
++ the function (e.g. fun f o g = ...) then this is a subnode. *)
++ val funAndArgs =
++ case (isInfix, args) of
++ (true, TupleTree([left, right], loc) :: otherArgs) => (* Infixed. *)
++ FunInfixed([FunPtree left, FunIdent(ident, refs), FunPtree right], loc)
++ :: map FunPtree otherArgs
++ | (_, args) => (* Normal prefixed form. *)
++ FunIdent(ident, refs) :: map FunPtree args
++
++ val constraint = case constraint of NONE => [] |SOME typ => [FunConstraint typ]
++ in
++ exportList(exportFunEntry, SOME exportThis) (funAndArgs @ constraint @ [FunPtree exp])
++ end
++
++ fun exportFB(navigation,
++ fb as FValBind{clauses=[clause], location, functVar = ref(Value{references, ...}), ...}) =
++ (* If there's just one clause go straight to it. Otherwise we have an
++ unnecessary level of navigation. *)
++ let
++ val fbProps = exportNavigationProps navigation
++ val asChild = exportAClause(clause, references, fn () => exportFB(navigation, fb))
++ in
++ (location, asChild @ fbProps)
++ end
++
++ | exportFB(navigation, fb as FValBind{clauses, location, functVar = ref(Value{references, ...}), ...}) =
++ let
++ val fbProps = exportNavigationProps navigation
++ (* Each child gives a clause. *)
++ (* First child should give the pattern *)
++ (* Second child should give the expression *)
++ fun exportThis () = exportFB(navigation, fb)
++
++ fun exportClause(navigation, clause as FValClause{ line, ...}) =
++ let
++ val clProps = exportNavigationProps navigation
++ val asChild = exportAClause(clause, references, fn () => exportClause(navigation, clause))
++ in
++ (line, asChild @ clProps)
++ end
++
++ val asChild = exportList(exportClause, SOME exportThis) clauses
++ in
++ (location, asChild @ fbProps)
++ end
++
++ val expChild = exportList(exportFB, SOME asParent) dec
++ in
++ (location, expChild @ commonProps)
++ end
++
++ | OpenDec{location, decs, ...} =>
++ let
++ fun exportStructIdent(navigation, { value=ref value, location, ...} ) =
++ let
++ (* Include the declaration properties if it has been set. *)
++ val siProps = exportNavigationProps navigation @
++ (
++ if isUndefinedStruct value
++ then []
++ else mapLocationProps(structLocations value)
++ )
++ in
++ (location, siProps)
++ end
++
++ val expChild = exportList(exportStructIdent, SOME asParent) decs
++ in
++ (location, expChild @ commonProps)
++ end
++
++ | Constraint{location, value, given, ...} =>
++ let
++ (* The first position is the expression, the second the type *)
++ fun getExpr () =
++ getExportTree({parent=SOME asParent, previous=NONE, next=SOME getType}, value)
++ and getType () =
++ typeExportTree({parent=SOME asParent, previous=SOME getExpr, next=NONE}, given)
++ in
++ (location, PTfirstChild getExpr :: commonProps)
++ end
++
++ | Layered{location, var, pattern, ...} =>
++ (location, exportList(getExportTree, SOME asParent) [var, pattern] @ commonProps)
++
++ | Fn {matches, location, expType = ref expType, ...} =>
++ (location, PTtype expType :: exportList(exportMatch, SOME asParent) matches @ commonProps)
++
++ | Localdec{location, decs, body, ...} =>
++ (location, exportList(getExportTree, SOME asParent) (decs @ body) @ commonProps)
++
++ | TypeDeclaration(tbl, location) =>
++ let
++ val allItems = List.map TypeB tbl
++ in
++ (location, exportList(exportTypeBinding, SOME asParent) allItems @ commonProps)
++ end
++
++ | AbstypeDeclaration { location, typelist, withtypes, declist, ... } =>
++ let
++ val allItems =
++ List.map DataT typelist @ List.map TypeB withtypes @ List.map Decl declist
++ in
++ (location, exportList(exportTypeBinding, SOME asParent) allItems @ commonProps)
++ end
++
++ | DatatypeDeclaration { location, typelist, withtypes, ... } =>
++ let
++ val allItems =
++ List.map DataT typelist @ List.map TypeB withtypes
++ in
++ (location, exportList(exportTypeBinding, SOME asParent) allItems @ commonProps)
++ end
++
++ | DatatypeReplication{location, ...} => (* TODO *) (location, commonProps)
++
++ | ExpSeq(ptl, location) =>
++ (location, exportList(getExportTree, SOME asParent) ptl @ commonProps)
++
++ | Directive{location, ...} =>
++ (* No need to process the individual identifiers. *)
++ (location, commonProps)
+
++ | ExDeclaration(exbinds, location) =>
++ let
++ (* There are three possibilities here. exception exc; exception exc of ty; exception exc = exc' *)
++ fun exportExdec(navigation, ExBind{name, previous=EmptyTree, ofType=NONE, nameLoc, ...}) =
++ (* Simple, generative exception with no type. *)
++ getStringAsTree(navigation, name, nameLoc, [PTtype exnType])
++
++ | exportExdec(navigation,
++ eb as ExBind{name, previous=EmptyTree, ofType=SOME ofType, nameLoc, fullLoc, ...}) =
++ (* exception exc of type. *)
++ let
++ fun asParent () = exportExdec (navigation, eb)
++ fun getName () =
++ getStringAsTree({parent=SOME asParent, next=SOME getOfType, previous=NONE},
++ name, nameLoc, [(* Type could be in here? *)])
++ and getOfType () =
++ typeExportTree({parent=SOME asParent, previous=SOME getName, next=NONE}, ofType)
++ in
++ (fullLoc, PTfirstChild getName :: exportNavigationProps navigation)
++ end
++
++ | exportExdec(navigation,
++ eb as ExBind{name, previous, (* ofType=NONE, *) nameLoc, fullLoc, ...}) =
++ let
++ fun asParent () = exportExdec (navigation, eb)
++ fun getName () =
++ getStringAsTree({parent=SOME asParent, next=SOME getPreviousExc, previous=NONE},
++ name, nameLoc, [(* Type could be in here? *)])
++ and getPreviousExc () =
++ getExportTree({parent=SOME asParent, previous=SOME getName, next=NONE}, previous)
++ in
++ (fullLoc, PTfirstChild getName :: exportNavigationProps navigation)
++ end
++
++ val expChild = exportList(exportExdec, SOME asParent) exbinds
++ in
++ (location, expChild @ commonProps)
++ end
++
++ | Raise(raiseExp, location) =>
++ let
++ fun getExp () = getExportTree({parent=SOME asParent, next=NONE, previous=NONE}, raiseExp)
++ in
++ (location, [PTfirstChild getExp] @ commonProps)
++ end
++
++ | HandleTree{location, exp, hrules, listLocation, ...} =>
++ let
++ (* The first position is the expression, the second the matches *)
++ fun getExpr () = getExportTree({parent=SOME asParent, previous=NONE, next=SOME getMatches}, exp)
++ and getMatches () =
++ (listLocation,
++ exportList(exportMatch, SOME getMatches) hrules @
++ exportNavigationProps{parent=SOME asParent, previous=SOME getExpr, next=NONE})
++ in
++ (location, [PTfirstChild getExpr] @ commonProps)
++ end
++
++ | While{location, test, body, ...} =>
++ (location, exportList(getExportTree, SOME asParent) [test, body] @ commonProps)
++
++ | Case{location, test, match, listLocation, expType=ref expType, ...} =>
++ let
++ (* The first position is the expression, the second the matches *)
++ fun getExpr () = getExportTree({parent=SOME asParent, previous=NONE, next=SOME getMatches}, test)
++ and getMatches () =
++ (listLocation,
++ exportList(exportMatch, SOME getMatches) match @
++ exportNavigationProps{parent=SOME asParent, previous=SOME getExpr, next=NONE})
++ in
++ (location, [PTfirstChild getExpr, PTtype expType] @ commonProps)
++ end
++
++ | Andalso {location, first, second, ...} =>
++ (location, exportList(getExportTree, SOME asParent) [first, second] @ commonProps)
++
++ | Orelse{location, first, second, ...} =>
++ (location, exportList(getExportTree, SOME asParent) [first, second] @ commonProps)
++
++ | Labelled{location, expType=ref expType, recList, ...} =>
++ let
++ (* It's convenient to be able to click on the label part and get
++ the type of the expression or pattern on the right of the '='. *)
++ fun exportField(navigation,
++ label as {name, nameLoc, valOrPat, expType=ref expType, fullLocation, ...}) =
++ let
++ val patTree as (patLocation, _) = getExportTree(navigation, valOrPat)
++ in
++ if patLocation = fullLocation
++ then
++ (* The parser rewrites { name, ...} as { name=name, ... } (more generally
++ { name: ty as pat, ...} as { name = name: ty as pat).
++ To avoid having nodes that overlap we return only the pattern part here. *)
++ patTree
++ else
++ let
++ (* The first position is the label, the second the type *)
++ fun asParent () = exportField (navigation, label)
++ fun getLab () =
++ getStringAsTree({parent=SOME asParent, next=SOME getExp, previous=NONE},
++ name, nameLoc, [PTtype expType])
++ and getExp () =
++ getExportTree({parent=SOME asParent, previous=SOME getLab, next=NONE}, valOrPat)
++ in
++ (fullLocation, PTfirstChild getLab :: exportNavigationProps navigation)
++ end
++ end
++
++ val expChild = exportList(exportField, SOME asParent) recList
++ in
++ (location, PTtype expType :: (expChild @ commonProps))
++ end
++
++ | Selector{location, typeof, ...} => (location, PTtype typeof :: commonProps)
++
++ | List{elements, location, expType = ref expType, ...} =>
++ (location,
++ PTtype expType :: exportList(getExportTree, SOME asParent) elements @ commonProps)
++
++ | EmptyTree => (nullLocation, commonProps)
++
++ | WildCard location => (location, commonProps)
++
++ | Unit location => (location, PTtype unitType :: commonProps)
++
++ | Parenthesised(p, _) => getExportTree(navigation, p)
++ end
++
++ fun getLocation c = #1 (getExportTree({parent=NONE, next=NONE, previous=NONE}, c))
+
+ (* Error message routine. Used in both pass 2 and pass 3. *)
+ fun errorNear (lex, hard, near, line, message) =
+ let
+- val printProc = if hard then errorProc else warningProc;
++ val parameters = debugParams lex
++ val errorDepth = getParameter errorDepthTag parameters
+ in
+- (* Puts out an error message and then prints the piece of tree. *)
+- printProc
+- (lex,
+- line,
+- fn (pprint:prettyPrinter) =>
+- let
+- val parameters = debugParams lex
+- val errorDepth = getParameter errorDepthTag parameters
+- in
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint message;
+- ppBreak pprint (3, 0);
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint "Found near";
+- ppBreak pprint (1, 0);
+- ptDisplay (near, errorDepth, pprint);
+- ppEndBlock pprint ();
+- ppEndBlock pprint ()
+- end)
+- end;
++ (* Puts out an error message and then prints the piece of tree. *)
++ reportError lex
++ {
++ hard = hard,
++ location = line,
++ message = PrettyBlock (0, false, [], [PrettyString message]),
++ context = SOME(ptDisplay (near, errorDepth))
++ }
++ end;
+
++ (* Extract the declaration location from the location list. *)
++ fun declaredAt [] = LEX.nullLocation
++ | declaredAt (DeclaredAt loc :: _) = loc
++ | declaredAt (_::l) = declaredAt l
+
+ (*****************************************************************************
+ PASS 2
+@@ -1811,1537 +1843,1813 @@
+ declarations. It performs the type checking. "makeTypeId" is used
+ to construct unique identifiers for types depending on the context
+ (i.e. in a signature, structure or functor). *)
+- fun pass2 (v, makeTypeId, env, lex, line, strName) =
++ fun pass2 (v, makeTypeId, env, lex) =
+ let
+ (* Returns a function which can be passed to unify or apply to
+ print a bit of context info. *)
+- fun foundNear v (pprint: prettyPrinter) =
+- let
++ fun foundNear v () =
++ let
+ val parameters = debugParams lex
+ val errorDepth = getParameter errorDepthTag parameters
+- in
+- ppAddString pprint "Found near";
+- ppBreak pprint (1, 0);
+- ptDisplay (v, errorDepth, pprint)
+- end;
++ in
++ ptDisplay (v, errorDepth)
++ end;
+
+ (* A simpler error message routine for lookup_... where the message
+ does not involve pretty-printing anything. *)
+ fun giveError (v, lex, line) =
+ fn message => errorNear (lex, true, v, line, message);
+
+- fun checkForBuiltIn (name, v, lex, lineno, isConstr) =
+- (* ML97 does not allow the standard constructors to be rebound and does
+- not allow "it" to become a constructor. *)
+- if getParameter ml90Tag (debugParams lex) then ()
+- else if name = "true" orelse name = "false" orelse name = "nil"
+- orelse name = "::" orelse name = "ref" orelse (isConstr andalso name = "it")
+- then errorNear(lex, true, v, lineno,
+- "Rebinding or specifying \"" ^ name ^ "\" is illegal")
+- else ()
++ fun checkForBuiltIn (name, v, lex, lineno, isConstr) =
++ (* ML97 does not allow the standard constructors to be rebound and does
++ not allow "it" to become a constructor. *)
++ if name = "true" orelse name = "false" orelse name = "nil"
++ orelse name = "::" orelse name = "ref" orelse (isConstr andalso name = "it")
++ then errorNear(lex, true, v, lineno,
++ "Rebinding or specifying \"" ^ name ^ "\" is illegal")
++ else ()
+
+- (* parameters re-ordered SPF 22/10/94 *)
+- fun assignValues level letDepth line env near v =
+- let
++ fun errorDepth lex =
++ let
++ open DEBUG
++ val parameters = LEX.debugParams lex
++ in
++ getParameter errorDepthTag parameters
++ end
++
++ (* Turn a result from unifyTypes into a pretty structure so that it
++ can be included in a message. *)
++ fun unifyErrorReport(lex, typeEnv) = unifyTypesErrorReport(lex, typeEnv, typeEnv, "unify")
++
++ (* Error message for incompatible types. Displays both expressions and their types. *)
++ fun typeMismatch (title, left, right, detail, lex : lexan, location, moreInfo) =
++ let
++ val message =
++ PrettyBlock(3, true, [],
++ [
++ PrettyString title,
++ PrettyBreak(1, 0), left,
++ PrettyBreak(1, 0), right,
++ PrettyBreak(1, 0),
++ PrettyBlock(0, false, [],
++ [PrettyString "Reason:", PrettyBreak(1, 3), detail])
++ ])
++ in
++ reportError lex
++ {
++ location = location,
++ hard = true,
++ message = message,
++ context = SOME (moreInfo ())
++ }
++ end;
++
++ (* Error message for single expressions with the wrong type. e.g. "if" not followed
++ by a "bool". *)
++ fun typeWrong (title, value, detail, lex : lexan, location, moreInfo) =
++ let
++ val message =
++ PrettyBlock(3, true, [],
++ [
++ PrettyString title,
++ PrettyBreak(1, 0), value,
++ PrettyBreak(1, 0),
++ PrettyBlock(0, false, [],
++ [ PrettyString "Reason:", PrettyBreak(1, 3), detail])
++ ])
++ in
++ reportError lex
++ {
++ location = location,
++ hard = true,
++ message = message,
++ context = SOME (moreInfo ())
++ }
++ end;
++
++ (* Display a value and its type as part of an error message. *)
++ fun valTypeMessage (lex, typeEnv) (title, value, valType) =
++ let
++ val errorDepth = errorDepth lex
++ in
++ PrettyBlock(3, false, [],
++ [
++ PrettyString title,
++ PrettyBreak(1, 0),
++ ptDisplay (value, errorDepth),
++ PrettyBreak(1, 0),
++ PrettyString ":",
++ PrettyBreak(1, 0),
++ display(valType, 10000 (* All of it *), typeEnv)
++ ])
++ end
++
++ fun matchTypeMessage (lex, typeEnv) (title, match, valType) =
++ let
++ val errorDepth = errorDepth lex
++ in
++ PrettyBlock(3, false, [],
++ [
++ PrettyString title,
++ PrettyBreak(1, 0),
++ displayMatch (match, errorDepth),
++ PrettyBreak(1, 0),
++ PrettyString ":",
++ PrettyBreak(1, 0),
++ display(valType, 10000 (* All of it *), typeEnv)
++ ])
++ end
++
++ (* Old error message and unification functions. These will eventually be
++ removed. *)
++ fun matchError
++ (error: matchResult, lex : lexan, location : LEX.location, moreInfo : unit -> pretty, typeEnv) : unit =
++ reportError lex
++ {
++ location = location,
++ hard = true,
++ message = unifyErrorReport(lex, typeEnv) error,
++ context = SOME (moreInfo ())
++ }
++
++ fun unify (alpha, beta, lex, location, moreInfo, typeEnv) =
++ case unifyTypes (alpha, beta) of
++ NONE => ()
++ | SOME error =>
++ matchError (error, lex, location, moreInfo, typeEnv)
++
++ fun apply (f, arg, lex, location, moreInfo, typeEnv) =
++ case eventual f of
++ FunctionType {arg=farg, result} =>
++ (
++ unify (farg, arg, lex, location, moreInfo, typeEnv);
++ result
++ )
++ | ef => (* Type variables etc. - Use general case. *)
++ let (* Make arg->'a, and unify with the function. *)
++ val resType = mkTypeVar (generalisable, false, false);
++ val fType = mkFunctionType (arg, resType);
++
++ (* This may involve more than just assigning the type to "ef". *)
++ val () = unify (ef, fType, lex, location, moreInfo, typeEnv);
++ in
++ resType (* The result is the type variable unified to the result. *)
++ end
++
++ (* These cases currently use the "apply" or "unify" and may need to be improved in
++ order to produce better messages.
++ apply:
++ Literals. The conversion functions are applied to the string literal. In effect this produces the set
++ of overloadings of the literal. This should never produce an error message.
++ Constructors in patterns to their args.
++ "case": the patterns are "applied" to the value to be tested.
++
++ unify:
++ Layered patterns, to set the variable. Also checks the pattern against any explicit type.
++ Handlers: the handling patterns are unified against a function from exn -> the result type of the
++ expression being handled.
++ *)
++
++ fun assignValues (level, letDepth, env, near, v) =
++ let
++ val typeEnv =
++ {
++ lookupType = fn s => case #lookupType env s of NONE => NONE | SOME t => SOME(t, NONE),
++ lookupStruct = fn s => case #lookupStruct env s of NONE => NONE | SOME t => SOME(t, NONE)
++ }
+ (* Process each item of the sequence and return the type of the
+ last item. A default item is returned if the list is empty. *)
+- fun assignSeq env depth (l: (parsetree * int) list) =
++ fun assignSeq env depth (l: parsetree list) =
+ let
+ fun applyList last [] = last
+- | applyList last ((h, line) :: t) =
+- applyList (assignValues level depth line env v h) t
++ | applyList _ (h :: t) =
++ applyList (assignValues(level, depth, env, v, h)) t
+ in
+ applyList badType l
+ end;
+
+- fun ptAssignTypes t near line =
+- assignTypes
+- (t,
+- fn s =>
+- lookupTyp
+- ({lookupType = #lookupType env, lookupStruct = #lookupStruct env},
+- s,
+- giveError (near, lex, line)),
+- lex,
+- line);
+-
+- (* Makes a type for an instance of an identifier. In the case of
+- exceptions this means converting the type into a function and
+- in the case of values or other constructors of making a copy
+- of the type to create new instances of type variables.
+- isExp is true if this an expression, false if it is a pattern.
+- Generic imperative type variables are turned into ordinary type
+- variables in patterns. *)
+- fun instanceType (Value{class = Exception, typeOf, ...}) isExp =
+- (* If this is an exception the type is either exn or t -> exn. *)
+- if isEmpty typeOf then exnType else mkFunctionType (typeOf, exnType)
+-
+- | instanceType (v as Value{access=Overloaded _, ...}) isExp =
+- (* Look up the current overloading for this function. *)
+- overloadType(v, false)
++ (* Applies "assignValues" or "processPattern" to every element of a list and unifies the
++ types. Returns a type variable if the list is empty.
++ This is used for lists, function values (fn .. => ...),
++ handlers and case expressions. *)
++ fun assignList _ _ [] = mkTypeVar (generalisable, false, false)
++ | assignList (processValue: 'a->types, _, _) _ [single] = processValue single
++
++ | assignList (processValue: 'a->types, displayValue, typeMsg)
++ (errorMsg, itemName, separator, location, near) (tlist as hd :: tl) =
++ let
++ val firstType = processValue hd
+
+- | instanceType (Value{typeOf, ...}) isExp =
++ fun applyList(ty, _, []) = ty
++ | applyList(ty, n, h::t) =
++ let
++ val typ = processValue h
++ in
++ case unifyTypes (ty, typ) of
++ NONE => applyList(ty, n+1, t)
++ | SOME report =>
++ let
++ (* We have a type error but we don't know which is correct.
++ The previous items must have produced a consistent type
++ otherwise we'd already have reported an error but we
++ can't identify exactly where the error occurred. *)
++ val errorDepth = errorDepth lex
++ val previousValsAndType =
++ PrettyBlock(3, false, [],
++ [
++ PrettyString (
++ if n = 1 then itemName ^ " 1:"
++ else itemName ^ "s 1-" ^ Int.toString n ^ ":"),
++ PrettyBreak(1, 0),
++ PrettyBlock(0, false, [],
++ printList (*ptDisplay*)displayValue (List.take(tlist, n),
++ separator, errorDepth)),
++ PrettyBreak(1, 0),
++ PrettyString ":",
++ PrettyBreak(1, 0),
++ display(ty, 10000 (* All of it *), typeEnv)
++ ])
++ in
++ typeMismatch(errorMsg,
++ previousValsAndType,
++ (*valTypeMessage*)typeMsg(lex, typeEnv) (concat[itemName, " ", Int.toString(n+1), ":"], h, typ),
++ unifyErrorReport(lex, typeEnv) report, lex, location, foundNear near);
++ (* Continue with "bad" which suppresses further error messages
++ and return "bad" as the result. *)
++ applyList(badType, n+1, t)
++ end
++ end
++ in
++ applyList(firstType, 1, tl)
++ end
++
++ fun ptAssignTypes t near =
++ assignTypes
++ (t,
++ fn (s, line) =>
++ lookupTyp
++ ({lookupType = #lookupType env, lookupStruct = #lookupStruct env},
++ s, giveError (near, lex, line)),
++ lex);
++
++ (* Makes a type for an instance of an identifier. *)
++ fun instanceType (v as Value{access=Overloaded _, ...}) =
++ (* Look up the current overloading for this function. *)
++ overloadType(v, false)
++
++ | instanceType v =
+ (* The types of constructors and variables are copied
+ to create new instances of type variables. *)
+- generalise (typeOf, isExp);
++ generalise (valTypeOf v);
+
+- fun processPattern pat enterResult level notConst isRec line =
++ fun processPattern(pat, enterResult, level, notConst, isRec) =
+ let
+- val mapProcessPattern =
+- map (fn x => processPattern x enterResult level notConst isRec line);
++ val mapProcessPattern =
++ map (fn x => processPattern(x, enterResult, level, notConst, isRec));
+ in
+- case pat of
+- Ident {name, value, typeof} => (* Variable or nullary constructor. *)
+- let
+- (* Look up the name. If it is a constructor then use it,
+- otherwise return `undefined'. If it is a qualified name,
+- i.e. it contains a full-stop, we assume it is a constructor
+- and give an error message if it does not exist. *)
+- (* In ML 97 recursive declarations such as val rec f = ...
+- override constructor status. If this is a recursive declaration
+- we don't check for constructor status. *)
+- val names = splitString name;
+- val nameVal =
+- if not (getParameter ml90Tag (debugParams lex)) andalso isRec
+- then undefinedValue
+- else if #first names = ""
+- then (* Not qualified - may be a variable. *)
+- getOpt (#lookupVal env name, undefinedValue)
+-
+- else (* Qualified - cannot be a variable. *)
+- lookupValue
+- ("Constructor",
+- {lookupVal= #lookupVal env, lookupStruct= #lookupStruct env},
+- name,
+- giveError (pat, lex, line));
+-
+-
+- val instanceType =
+- (* If the result is a constructor use it. *)
+- if isConstructor nameVal (* exceptions. *)
+- then
+- (
+- if notConst
+- then errorNear (lex, true, pat, line,
+- "Identifier before `as' must not be a constructor")
+- else ();
+-
+- (* set this value in the record *)
+- value := nameVal;
+-
+- (* Must be a nullary constructor otherwise it should
+- have been applied to something. *)
+- let
+- val isNullary =
+- case nameVal of
+- Value{class=Constructor{nullary}, ...} => nullary
+- | Value{typeOf, ...} => (* exception *) isEmpty typeOf
+- in
+- if isNullary then ()
+- else errorNear (lex, true, pat, line,
+- "Constructor must be applied to something.")
+- end;
+-
+- instanceType nameVal false (* pattern *)
+- )
+-
+- (* If undefined or another variable, construct a new variable. *)
+- else let
+- val var =
+- mkVar (name, mkTypeVar (level, false, false, false));
+- in
+- checkForDots (name, lex, line); (* Must not be qualified *)
+- (* Must not be "true", "false" etc. *)
+- checkForBuiltIn (name, v, lex, line, false);
+- enterResult (name, var);
+- value := var;
+- valTypeOf var (* and return its type *)
+- end;
+- in
+- typeof := instanceType;
+- instanceType
+- end
+-
+- | Literal{converter, typeof, ...} =>
+- let
+- (* Find out the overloadings on this converter and
+- construct an instance of it. The converters are
+- all functions from string to the result type. *)
+- val instanceType = overloadType(converter, true)
+- (* Apply the converter to string to get the type of the
+- literal. *)
+- val instance =
+- apply(instanceType, stringType, lex, line, foundNear pat)
+- in
+- typeof := instance; (* Remember it *)
+- instance
+- end
+-
+- | Applic {f = con, arg} =>
+- let
+- (* Apply the function to the argument and return the result. *)
+- (* Function must be a constructor. *)
+- val conType =
+- case con of
+- Ident {name, value, ...} =>
+- let (* Look up the value and return the type. *)
+- val constrVal =
+- lookupValue
+- ("Constructor",
+- {lookupVal = #lookupVal env,
+- lookupStruct = #lookupStruct env},
+- name,
+- giveError (pat, lex, line));
+- in
+- if isConstructor constrVal
+- then let
+- val U : unit = value := constrVal;
+- in
+- instanceType constrVal false (* pattern *)
+- end
+- else let (* Undeclared or a variable. *)
+- val U : unit =
+- if isUndefinedValue constrVal then ()
+- else errorNear (lex, true, pat, line,
+- name ^ " is not a constructor")
+- in
+- badType
+- end
+- end
+-
+- | _ => (* con is not an Ident *)
+- let
+- val U : unit =
+- errorNear (lex, true, pat, line,
+- "Constructor in a pattern was not an identifier");
+- in
+- badType
+- end;
+-
+- val patType = processPattern arg enterResult level notConst isRec line;
+- in
+- apply (conType, patType, lex, line, foundNear pat)
+- end (* Applic *)
+-
+- | TupleTree ptl =>
+- (* Construct the type obtained by mapping "processPattern"
+- onto each element of the tuple. *)
+- mkProductType (mapProcessPattern ptl)
+-
+- | Labelled {recList, frozen, typeof} =>
+- let (* Process each item in the list. *)
+- fun mapLabels [] = []
+- | mapLabels ((name, value)::T) =
+- (* Type is a label entry with the label name
+- and the type of the pattern. *)
+- mkLabelEntry
+- (name, processPattern value enterResult level notConst isRec line)
+- :: mapLabels T;
+- val patType =
+- mkLabelled
+- (sortLabels
+- (mapLabels recList,
+- fn msg => errorNear (lex, true, pat, line, msg)),
+- frozen);
+- in
+- typeof := patType;
+- patType
+- end
+-
+- | List ptl =>
+- let
+- (* Applies "processPattern" to every element of a list and
+- unifies the types. Returns a type variable if the list
+- is empty *)
+- fun processList tlist =
++ case pat of
++ Ident {name, value, expType, location, ...} => (* Variable or nullary constructor. *)
++ let
++ (* Look up the name. If it is a constructor then use it,
++ otherwise return `undefined'. If it is a qualified name,
++ i.e. it contains a full-stop, we assume it is a constructor
++ and give an error message if it does not exist. *)
++ (* In ML 97 recursive declarations such as val rec f = ...
++ override constructor status. If this is a recursive declaration
++ we don't check for constructor status. *)
++ val names = splitString name;
++ val nameVal =
++ if isRec
++ then undefinedValue
++ else if #first names = ""
++ then (* Not qualified - may be a variable. *)
++ getOpt (#lookupVal env name, undefinedValue)
++
++ else (* Qualified - cannot be a variable. *)
++ lookupValue
++ ("Constructor",
++ {lookupVal= #lookupVal env, lookupStruct= #lookupStruct env},
++ name,
++ giveError (pat, lex, location));
++
++
++ val instanceType =
++ (* If the result is a constructor use it. *)
++ if isConstructor nameVal (* exceptions. *)
++ then
++ (
++ if notConst
++ then errorNear (lex, true, pat, location,
++ "Identifier before `as' must not be a constructor")
++ else ();
++
++ (* set this value in the record *)
++ value := nameVal;
++
++ (* Must be a nullary constructor otherwise it should
++ have been applied to something. *)
++ let
++ val isNullary =
++ case nameVal of
++ Value{class=Constructor{nullary, ...}, ...} => nullary
++ | Value{typeOf, ...} => (* exception *) not (isSome(getFnArgType typeOf))
++ in
++ if isNullary then ()
++ else errorNear (lex, true, pat, location,
++ "Constructor must be applied to something.")
++ end;
++
++ instanceType nameVal
++ )
++
++ (* If undefined or another variable, construct a new variable. *)
++ else
++ let
++ val var =
++ mkVar (name, mkTypeVar (level, false, false), [DeclaredAt location]);
++ in
++ checkForDots (name, lex, location); (* Must not be qualified *)
++ (* Must not be "true", "false" etc. *)
++ checkForBuiltIn (name, v, lex, location, false);
++ enterResult (name, var);
++ value := var;
++ valTypeOf var (* and return its type *)
++ end;
++ in
++ expType := instanceType; (* Record the instance type.*)
++ instanceType
++ end
++
++ | Literal{converter, expType, location, ...} =>
++ let
++ (* Find out the overloadings on this converter and
++ construct an instance of it. The converters are
++ all functions from string to the result type. *)
++ val instanceType = overloadType(converter, true)
++ (* Apply the converter to string to get the type of the
++ literal. *)
++ val instance =
++ apply(instanceType, stringType, lex, location, foundNear pat, typeEnv)
++ in
++ expType := instance; (* Record the instance type.*)
++ instance
++ end
++
++ | Applic {f = con, arg, location, expType, ...} =>
++ let
++ (* Apply the function to the argument and return the result. *)
++ (* Function must be a constructor. *)
++ val conType =
++ case con of
++ Ident {name, value, location, expType, ...} =>
++ let (* Look up the value and return the type. *)
++ val constrVal =
++ lookupValue
++ ("Constructor",
++ {lookupVal = #lookupVal env, lookupStruct = #lookupStruct env},
++ name, giveError (pat, lex, location));
++ in
++ if isConstructor constrVal
++ then
++ let
++ val cType = instanceType constrVal
++ in
++ value := constrVal;
++ expType := cType; (* Record the instance type.*)
++ cType
++ end
++ else (* Undeclared or a variable. *)
++ (
++ if isUndefinedValue constrVal then ()
++ else errorNear (lex, true, pat, location, name ^ " is not a constructor");
++ badType
++ )
++ end
++
++ | _ => (* con is not an Ident *)
++ (
++ errorNear (lex, true, pat, location,
++ "Constructor in a pattern was not an identifier");
++ badType
++ )
++
++ val patType = processPattern(arg, enterResult, level, notConst, isRec);
++ (* Apply to the pattern type. *)
++ val resultType = apply (conType, patType, lex, location, foundNear pat, typeEnv)
++ in
++ expType := resultType; (* Record the instance type.*)
++ resultType
++ end (* Applic *)
++
++ | TupleTree(ptl, _) =>
++ (* Construct the type obtained by mapping "processPattern"
++ onto each element of the tuple. *)
++ mkProductType (mapProcessPattern ptl)
++
++ | Labelled {recList, frozen, expType, ...} =>
++ let (* Process each item in the list. *)
++
++ fun mapLabels [] = []
++ | mapLabels ({name, valOrPat, expType, ...}::T) =
++ (* Type is a label entry with the label name
++ and the type of the pattern. *)
++ let
++ val ty = processPattern(valOrPat, enterResult, level, notConst, isRec)
++ in
++ expType := ty;
++ mkLabelEntry(name, ty) :: mapLabels T
++ end;
++ val patType = mkLabelled (sortLabels(mapLabels recList), frozen);
++ in
++ expType := patType;
++ patType
++ end
++
++ | (aList as List{elements, location, expType}) =>
++ let
++ (* Applies "processPattern" to every element of a list and
++ unifies the types. Returns a type variable if the list
++ is empty *)
++ fun processElement elem =
++ processPattern(elem, enterResult, level, notConst, isRec)
++ val elementType =
++ assignList (processElement, ptDisplay, valTypeMessage)
++ ("Elements in a list have different types.", "Item", ",", location, aList) elements
++ val resType =
++ if isBadType elementType
++ then badType
++ else mkTypeConstruction ("list", listType, [elementType], [DeclaredAt inBasis])
++ in
++ expType := resType;
++ resType
++ end
++
++ | aConstraint as Constraint {value, given, location} =>
++ let
++ val valType = processPattern(value, enterResult, level, notConst, isRec);
++ val theType = typeFromTypeParse given
++ val () = ptAssignTypes theType pat;
++ in
++ (* These must be unifiable. *)
++ case unifyTypes(valType, theType) of
++ NONE => () (* OK. *)
++ | SOME report =>
++ typeMismatch("Type mismatch in type constraint.",
++ valTypeMessage (lex, typeEnv) ("Value:", value, valType),
++ PrettyBlock(0, false, [],
++ [
++ PrettyString "Constraint:",
++ PrettyBreak(1, 0),
++ display(theType, 10000 (* All of it *), typeEnv)
++ ]),
++ unifyErrorReport (lex, typeEnv) report,
++ lex, location, foundNear aConstraint);
++ theType
++ end
++
++ | Layered {var, pattern, location} =>
++ let
++ (* Unify the variable and the pattern - At this stage that simply
++ involves assigning the type of the pattern to the variable,
++ but it may result in more unification when the variable is
++ used *)
++
++ (* The "variable" must be either id or id: ty but we have to
++ check that the id is not a constructor. *)
++ val varType = processPattern(var, enterResult, level, true, isRec);
++ val patType = processPattern(pattern, enterResult, level, notConst, isRec)
++ val () = unify (varType, patType, lex, location, foundNear pat, typeEnv);
++ in
++ varType
++ end
++
++ | Unit _ => unitType
++
++ | WildCard _ => mkTypeVar (generalisable, false, false)
++
++ | Parenthesised(p, _) =>
++ processPattern(p, enterResult, level, notConst, isRec)
++
++ | _ => (* not a legal pattern *)
++ badType
++
++ end (* processPattern *)
++
++ (* val assValues = assignValues level line env; *)
++ and assValues near v =
++ case v of
++ Ident {name, value, expType, location} =>
++ let
++ val expValue =
++ lookupValue
++ ("Value or constructor",
++ {lookupVal = #lookupVal env, lookupStruct = #lookupStruct env},
++ name, giveError (near, lex, location));
++ (* Set the value and type found. *)
++ val instanceType = instanceType expValue;
++ in
++ (* Include this reference in the list of local references. *)
++ case expValue of
++ Value { references=SOME{localRef, ...}, ...} =>
++ localRef := location :: ! localRef
++ | _ => ();
++ expType := instanceType;
++ value := expValue;
++ instanceType (* Result is the instance type. *)
++ end
++
++ | Literal{converter, expType, location, ...} =>
++ let
++ (* Find out the overloadings on this converter and
++ construct an instance of it. The converters are
++ all functions from string to the result type. *)
++ val instanceType = overloadType(converter, true)
++ val instance =
++ apply(instanceType, stringType, lex, location, foundNear near, typeEnv)
++ in
++ expType := instance;
++ instance
++ end
++
++ | Applic {f, arg, location, expType, ...} =>
++ let
++ (* Apply the function to the argument and return the result. *)
++ val funType = assValues near f;
++ val argType = assValues near arg;
++ (* Test to see if we have a function. *)
++ val fType =
++ case eventual funType of
++ FunctionType {arg, result} => SOME(arg, result)
++ | _ => (* May be a simple type variable. *)
++ let
++ val funResType = mkTypeVar (generalisable, false, false);
++ val funArgType = mkTypeVar (generalisable, false, false);
++ val fType = mkFunctionType (funArgType, funResType);
++ in
++ case unifyTypes (fType, funType) of
++ NONE => SOME(funArgType, funResType)
++ | SOME _ =>
++ (
++ (* It's not a function. *)
++ typeMismatch("Type error in function application.",
++ valTypeMessage (lex, typeEnv) ("Function:", f, funType),
++ valTypeMessage (lex, typeEnv) ("Argument:", arg, argType),
++ PrettyString "Value being applied does not have a function type",
++ lex, location, foundNear near);
++ NONE
++ )
++ end
++
++ in
++ case fType of
++ NONE => badType (* Not a function *)
++ | SOME (fArg, fResult) =>
++ (
++ case unifyTypes (fArg, argType) of
++ NONE => ()
++ | SOME report =>
++ typeMismatch("Type error in function application.",
++ valTypeMessage (lex, typeEnv) ("Function:", f, funType),
++ valTypeMessage (lex, typeEnv) ("Argument:", arg, argType),
++ unifyErrorReport (lex, typeEnv) report, lex, location, foundNear near);
++ expType := fResult; (* Preserve for browsing. *)
++ fResult
++ )
++ end
++
++ | Cond {test, thenpt, elsept, location} =>
++ let
++ (* The test must be bool, and the then and else parts must be the
++ same. The result is either of these two once they have been
++ unified. *)
++ val testType = assValues v test;
++ val thenType = assValues v thenpt;
++ val elseType = assValues v elsept;
++ in
++ case unifyTypes(testType, boolType) of
++ NONE => ()
++ | SOME report =>
++ typeWrong("Condition in if-statement must have type bool.",
++ valTypeMessage (lex, typeEnv) ("If:", test, testType),
++ unifyErrorReport (lex, typeEnv) report, lex, location, foundNear v);
++
++ case unifyTypes(thenType, elseType) of
++ NONE => thenType (* or equally elseType *)
++ | SOME report =>
++ (
++ typeMismatch("Type mismatch between then-part and else-part.",
++ valTypeMessage (lex, typeEnv) ("Then:", thenpt, thenType),
++ valTypeMessage (lex, typeEnv) ("Else:", elsept, elseType),
++ unifyErrorReport (lex, typeEnv) report, lex, location, foundNear v);
++ badType
++ )
++ end
++
++ | TupleTree(ptl, _) =>
++ (* Construct the type obtained by mapping "assignValue" onto
++ each element of the tuple. *)
++ mkProductType (map (assValues near) ptl) (* SPF 22/10/94 *)
++
++ | Labelled {recList, frozen, expType, ...} =>
++ let
++ (* Process each item in the list. *)
++ fun labEntryToLabType {name, valOrPat, expType, ...} =
++ let
++ val ty = assValues v valOrPat
++ in
++ expType := ty;
++ {name = name, typeof = ty }
++ end
++
++ val expressionType =
++ mkLabelled
++ (sortLabels (map labEntryToLabType recList), frozen) (* should always be true *);
++ in
++ expType := expressionType;
++ expressionType
++ end
++
++ | Selector {typeof, ...} =>
++ typeof (* Already made. *)
++
++ | ValDeclaration {dec, explicit, implicit, variables, ...} =>
++ (assValDeclaration (dec, explicit, implicit, variables); badType (* Should never be used. *))
++
++ | FunDeclaration {dec, explicit, implicit, ...} =>
++ (assFunDeclaration(dec, explicit, implicit); badType (* Should never be used. *))
++
++ | OpenDec{decs=ptl, variables, location, ...} =>
++ let
++ (* Go down the list of names opening the structures. *)
++ (* We have to be careful because open A B is not the same as
++ open A; open B if A contains a structure called B. *)
++ (* We accumulate the values so that we can produce debugging
++ information if we need to. Note: we have to be careful if
++ we have the same name in multiple structures. *)
++ val valTable = HashTable.hashMake 10
++
++ (* First get the structures... *)
++ fun findStructure ({name, location, ...}: structureIdentForm) =
++ lookupStructure
++ ("Structure", {lookupStruct = #lookupStruct env}, name,
++ giveError (v, lex, location))
++
++ val strs : structVals list = map findStructure ptl;
++
++ (* Value and substructure entries in a structure will generally have
++ "Formal" access which simply gives the offset of the entry within
++ the parent structure. We need to convert these into "Select"
++ entries to capture the address of the base structure. *)
++ fun copyEntries str =
++ if isUndefinedStruct str then ()
++ else
++ let
++ val openLocs =
++ (* If we have a declaration location for the structure set this as the structure
++ location. Add in here as the "open location". *)
++ case List.find (fn DeclaredAt _ => true | _ => false) (structLocations str) of
++ SOME (DeclaredAt loc) => [StructureAt loc, OpenedAt location]
++ | _ => [OpenedAt location]
++
++ val sigTbl = structSignat str; (* Get the tables. *)
++ (* Open the structure. Formal entries are turned into Selected entries. *)
++ val _ =
++ COPIER.openSignature
++ (sigTbl,
++ {
++ enterType =
++ fn (s,v) => #enterType env (s, v),
++ enterStruct =
++ fn (name, strVal) =>
++ let
++ val selectedStruct =
++ makeSelectedStruct (strVal, str, openLocs);
++ in
++ #enterStruct env (name, selectedStruct)
++ end,
++ enterVal =
++ fn (name, value) =>
++ let
++ val selectedVar =
++ mkSelectedVar (value, str, openLocs);
++ in
++ HashTable.hashSet(valTable, name, selectedVar);
++ #enterVal env (name, selectedVar)
++ end
++ },
++ (* Add the structure we're opening here to the types of
++ the values. The name will be removed in messages if the type
++ constructor is in scope but if it has been redefined we can
++ get an identifiable name. *)
++ structName str^".");
++ in
++ ()
++ end
++
++ (* ...then put them into the name space. *)
++ val () = List.app copyEntries strs;
++ in
++ variables := HashTable.hashFold valTable (fn _ => fn v => fn t => v :: t) [];
++ badType (* Does not return a type *)
++ end
++
++ | TypeDeclaration(tlist, _) =>
++ let (* This is either a type abbreviation in the core language, in a structure
++ or in a signature or it is a type specification in a signaure. *)
++ fun messFn(name, _, new) =
++ errorNear (lex, true, v, declaredAt(tcLocations new),
++ name ^ " has already been bound in this declaration");
++
++ val newEnv = noDuplicates messFn;
++
++ (* First match all the types on the right-hand sides. *)
++ fun processTypeBody (TypeBind {decType = SOME decType, ...}) =
++ let
++ val t = typeFromTypeParse decType
++ in
++ ptAssignTypes t v;
++ t
++ end
++ | processTypeBody _ = emptyType (* Specification. *)
++
++ val resTypes = List.map processTypeBody tlist;
++
++ (* Can now declare the new types. *)
++ fun processType (TypeBind {name, typeVars, isEqtype, nameLoc, ...}, decType) =
++ let
++ (* Construct a type constructor which is an alias of the
++ right-hand side of the declaration. If we are effectively
++ giving a new name to a type constructor we use the same type
++ identifier. This is needed to check "well-formedness" in signatures. *)
++ val tcon =
++ if isEmpty decType
++ then (* Type specification *)
++ let
++ val description = { location = nameLoc, name = name, description = "" }
++ in
++ makeFrozenTypeConstrs (name, typeVars,
++ makeTypeId(isEqtype, false, description), 0, [DeclaredAt nameLoc])
++ end
++ else case typeNameRebinding(typeVars, decType) of
++ SOME typeId =>
++ makeFrozenTypeConstrs (name, typeVars,
++ typeId, 0, [DeclaredAt nameLoc])
++ | NONE =>
++ makeTypeAbbreviation (name, typeVars, decType, [DeclaredAt nameLoc]);
++ in
++ checkForDots (name, lex, nameLoc); (* Must not be qualified *)
++ #enter newEnv (name, tcon); (* Check for duplicates. *)
++ #enterType env (name, tcon) (* Put in the surrounding scope. *)
++ end
++
++ val () = ListPair.app processType (tlist, resTypes);
++ in
++ badType (* Does not return a type *)
++ end
++
++ | DatatypeDeclaration absData => assAbsData(false, absData)
++
++ | AbstypeDeclaration absData => assAbsData(true, absData)
++
++ | DatatypeReplication{oldType, newType, oldLoc, newLoc, ...} =>
++ (* Adds both the type and the constructors to the
++ current environment. *)
+ let
+- (* Construct a type variable and unite all the types to that. *)
+- val basicType = mkTypeVar (generalisable, false, false, false);
+- fun applyList [] = ()
+- | applyList (h::t) =
+- let
+- val typ = processPattern h enterResult level notConst isRec line
+- val U : unit =
+- unify (typ, basicType, lex, line, foundNear pat);
+- in
+- applyList t
+- end;
+- in
+- applyList tlist;
+- basicType (*Return the type variable - united to all the types*)
+- end (* processList *);
++ (* Look up the type constructor in the environment. *)
++ val oldTypeCons: typeConstrs =
++ lookupTyp
++ ({lookupType = #lookupType env, lookupStruct = #lookupStruct env},
++ oldType,
++ giveError (near, lex, oldLoc));
++
++ (* If the type name was qualified (e.g. S.t) we need to find the
++ value constructors from the same structure. *)
++ val {first = namePrefix, ...} = splitString oldType;
++ val baseStruct =
++ if namePrefix = ""
++ then NONE
++ else SOME(lookupStructure("Structure", {lookupStruct = #lookupStruct env},
++ namePrefix, giveError (v, lex, oldLoc)))
++
++ (* Copy the datatype, converting any Formal constructors to Selected. *)
++ val newTypeCons = mkSelectedType(oldTypeCons, newType, baseStruct, [DeclaredAt newLoc])
++
++ val newValConstrs = tcConstructors newTypeCons
++ in
++ (* Check that it has at least one constructor. *)
++ case newValConstrs of
++ [] => errorNear (lex, true, v, oldLoc, oldType ^ " is not a datatype")
++ | _ => ();
++ (* Enter the value constrs in the environment. *)
++ List.app (fn c => (#enterVal env) (valName c, c)) newValConstrs;
++ (* Add this type constructor to the environment. *)
++ (#enterType env) (newType, newTypeCons);
++ badType (* Does not return a type *)
++ end
++
++ | (aList as List{elements, location, expType, ...}) =>
++ let
++ val elementType =
++ assignList(assValues v, ptDisplay, valTypeMessage)
++ ("Elements in a list have different types.", "Item", ",", location, aList) elements
++ val resType =
++ if isBadType elementType
++ then badType
++ else mkTypeConstruction ("list", listType, [elementType], [DeclaredAt inBasis])
++ in
++ expType := resType;
++ resType
++ end
++
++ | Constraint {value, given, location} =>
++ let
++ val valType = assValues near value;
++ val theType = typeFromTypeParse given
++ val () = ptAssignTypes theType v;
+ in
+- mkTypeConstruction ("list", listType, [processList ptl])
++ (* These must be unifiable. *)
++ case unifyTypes(valType, theType) of
++ NONE => () (* OK. *)
++ | SOME report =>
++ typeMismatch("Type mismatch in type constraint.",
++ valTypeMessage (lex, typeEnv) ("Value:", value, valType),
++ PrettyBlock(0, false, [],
++ [
++ PrettyString "Constraint:",
++ PrettyBreak(1, 0),
++ display(theType, 10000 (* All of it *), typeEnv)
++ ]),
++ unifyErrorReport (lex, typeEnv) report,
++ lex, location, foundNear v);
++ theType
+ end
+
+- | Constraint {value, given} =>
++ | (aFun as Fn {matches, location, expType, ...}) => (* Must unify the types of each of the alternatives.*)
+ let
+- val valType = processPattern value enterResult level notConst isRec line;
+- val U : unit = ptAssignTypes given pat line;
++ val resType =
++ assignList(assMatchTree aFun, displayMatch, matchTypeMessage)
++ ("Clauses in fn expression have different types.", "Clause", "|", location, aFun) matches
++ in
++ expType := resType;
++ resType
++ end
++
++ | Unit _ =>
++ unitType
++
++ | Localdec {decs, body, isLocal, varsInBody, location} =>
++ let (* Local declarations or expressions. *)
++ val newValEnv = searchList();
++ val newTypeEnv = searchList();
++ val newStrEnv = searchList();
++ val newLetDepth = if isLocal then letDepth else letDepth+1;
++ (* The environment for the local declarations. *)
++ val localEnv =
++ {
++ lookupVal = lookupDefault (#lookup newValEnv) (#lookupVal env),
++ lookupType = lookupDefault (#lookup newTypeEnv) (#lookupType env),
++ lookupFix = #lookupFix env,
++ (* This environment is needed if we open a
++ structure which has sub-structures. *)
++ lookupStruct = lookupDefault (#lookup newStrEnv) (#lookupStruct env),
++ lookupSig = #lookupSig env,
++ lookupFunct = #lookupFunct env,
++ lookupTvars = #lookupTvars env,
++ enterVal = #enter newValEnv,
++ enterType = #enter newTypeEnv,
++ (* Fixity has already been dealt with in the parsing process. The only reason
++ we deal with it here is to ensure that declarations are printed in the
++ correct order. We simply need to make sure that local fixity declarations
++ are ignored. *)
++ enterFix = fn _ => (),
++ enterStruct = #enter newStrEnv,
++ enterSig = #enterSig env,
++ enterFunct = #enterFunct env
++ };
++
++ (* Process the local declarations and discard the result. *)
++ val _ : types = assignSeq localEnv newLetDepth decs;
++
++ (* This is the environment used for the body of the declaration.
++ Declarations are added both to the local environment and to
++ the surrounding scope. *)
++ val bodyEnv =
++ {
++ (* Look-ups come from the local environment *)
++ lookupVal = #lookupVal localEnv,
++ lookupType = #lookupType localEnv,
++ lookupFix = #lookupFix localEnv,
++ lookupStruct = #lookupStruct localEnv,
++ lookupSig = #lookupSig localEnv,
++ lookupFunct = #lookupFunct localEnv,
++ lookupTvars = #lookupTvars localEnv,
++ enterVal =
++ fn (pair as (_, v)) =>
++ (varsInBody := v :: ! varsInBody;
++ #enter newValEnv pair;
++ #enterVal env pair),
++ enterType =
++ fn pair =>
++ (#enter newTypeEnv pair;
++ #enterType env pair),
++ enterFix = #enterFix env,
++ enterStruct =
++ fn pair =>
++ (#enter newStrEnv pair;
++ #enterStruct env pair),
++ enterSig = #enterSig env,
++ enterFunct = #enterFunct env
++ };
++ (* Now the body, returning its result if it is an expression. *)
++ val resType = assignSeq bodyEnv newLetDepth body
++ in
++ (* If this is a let expression we have to check that there
++ are no datatypes escaping. *)
++ if isLocal then ()
++ else checkForLocalDatatypes(resType, letDepth,
++ giveError (v, lex, location));
++ resType
++ end (* LocalDec *)
++
++ | ExpSeq (ptl, _) =>
++ (* A sequence of expressions separated by semicolons.
++ Result is result of last expression. *)
++ assignSeq env letDepth ptl
++
++ | ExDeclaration(tlist, _) =>
++ let
++ fun messFn(name, _, line) =
++ errorNear (lex, true, v, line,
++ name ^ " has already been bound in this declaration");
++
++ (* Construct an environment to check for duplicate declarations.
++ Include the declaration location as the value. *)
++ val dupEnv = noDuplicates messFn;
++
++ fun processException (ExBind {name, previous, ofType, value, nameLoc, ...}) =
++ let
++ (* Fill in any types. If there was no type given the exception has type exn
++ otherwise it has type ty->exn. *)
++ val oldType =
++ case ofType of
++ NONE => exnType
++ | SOME typeof =>
++ let
++ val t = typeFromTypeParse typeof
++ in
++ ptAssignTypes t v;
++ mkFunctionType(t, exnType)
++ end
++
++ val exValue =
++ case previous of
++ EmptyTree => (* Generative binding. *)
++ mkEx (name, oldType, [DeclaredAt nameLoc])
++ | Ident {name = prevName, value = prevValue, location, expType, ...} =>
++ let
++ (* ex = ex' i.e. a non-generative binding? *)
++ (* Match up the previous exception. *)
++ val prev =
++ lookupValue
++ ("Exception",
++ {lookupVal= #lookupVal env,
++ lookupStruct= #lookupStruct env},
++ prevName,
++ giveError (v, lex, location))
++ val excType = valTypeOf prev
++ in
++ (* Check that it is an exception *)
++ case prev of
++ Value{class=Exception, ...} => ()
++ | _ => errorNear (lex, true, v, location, "(" ^ prevName ^ ") is not an exception.");
++ prevValue := prev; (* Set the value of the looked-up identifier. *)
++ expType := excType; (* And remember the type. *)
++ (* The result is an exception with the same type. *)
++ mkEx (name, excType, [DeclaredAt nameLoc])
++ end
++ | _ =>
++ raise InternalError "processException: badly-formed parse-tree"
++ in
++ (* Save this value. *)
++ value := exValue;
++
++ (* In the check environment *)
++ #enter dupEnv (name, nameLoc);
++
++ (* Must not be qualified *)
++ checkForDots (name, lex, nameLoc) : unit;
++ (* Must not be "true", "false" etc. *)
++ checkForBuiltIn (name, v, lex, nameLoc, true) : unit;
++
++ (* Put this exception into the env *)
++ #enterVal env (name, exValue)
++ end
++
++ val () = List.app processException tlist;
++ in
++ badType
++ end (* ExDeclaration *)
++
++ | Raise (pt, line) =>
++ let
++ val exType = assValues v pt
++ in
++ (* The exception value must have type exn. *)
++ case unifyTypes(exType, exnType) of
++ NONE => ()
++ | SOME report =>
++ typeWrong("Exception to be raised must have type exn.",
++ valTypeMessage (lex, typeEnv) ("Raise:", pt, exType),
++ unifyErrorReport (lex, typeEnv) report, lex, line, foundNear v);
++ (* Matches anything *)
++ mkTypeVar (generalisable, false, false)
++ end
++
++ | (aHandler as HandleTree {exp, hrules, location, ...}) =>
++ let
++ (* If the expression returns type E
++ the handler must be exn -> E *)
++ val expType = assValues aHandler exp;
++ (* Unify the handler with a function from exn -> expType *)
++ val clauses =
++ assignList(assMatchTree aHandler, displayMatch, matchTypeMessage)
++ ("Clauses in handler have different types.", "Clause", "|", location, aHandler) hrules
++ (* The result type of the handlers must match the result type of the expression being
++ handled and the arguments must all have type exn. *)
++ val () =
++ unify (clauses, mkFunctionType (exnType, expType), lex, location, foundNear v, typeEnv);
++ in
++ expType (* Result is expType. *)
++ end
+
+- (* These must be unifiable. *)
+- val U : unit = unify (valType, given, lex, line, foundNear pat);
++ | While {test, body, location} =>
++ let
++ val testType = assValues v test
++ in
++ (* Test must be bool. Result is unit *)
++ case unifyTypes(testType, boolType) of
++ NONE => ()
++ | SOME report =>
++ typeWrong("Loop condition of while-expression must have type bool.",
++ valTypeMessage (lex, typeEnv) ("While:", test, testType),
++ unifyErrorReport (lex, typeEnv) report, lex, location, foundNear v);
++ assValues v body; (* Result of body is discarded. *)
++ unitType
++ end
++
++ | aCase as Case {test, match, location, expType, ...} =>
++ let
++ val funType =
++ assignList(assMatchTree aCase, displayMatch, matchTypeMessage)
++ ("Clauses in case have different types.", "Clause", "|", location, aCase) match;
++ val argType = assValues aCase test;
++ (* The matches constitute a function from the test type to
++ the result of the case statement, so we apply the match type
++ to the test. *)
++ val resType = apply (funType, argType, lex, location, foundNear aCase, typeEnv)
++ in
++ expType := resType;
++ resType
++ end
++
++ | anAndAlso as Andalso {first, second, location} =>
++ let
++ (* Both parts must be bool and the result is bool. *)
++ val pairArgs = mkTupleTree([first, second], location)
++ val argTypes = assValues anAndAlso pairArgs;
++ val boolStarBool = mkProductType[boolType, boolType]
++ val () =
++ case unifyTypes(argTypes, boolStarBool) of
++ NONE => ()
++ | SOME report =>
++ typeWrong("Arguments of andalso must have type bool*bool.",
++ valTypeMessage (lex, typeEnv) ("Arguments:", pairArgs, argTypes),
++ unifyErrorReport (lex, typeEnv) report, lex, location, foundNear anAndAlso)
++ in
++ boolType
++ end
++
++ | anOrElse as Orelse {first, second, location} =>
++ let
++ (* Both parts must be bool and the result is bool. *)
++ val pairArgs = mkTupleTree([first, second], location)
++ val argTypes = assValues anOrElse pairArgs;
++ val boolStarBool = mkProductType[boolType, boolType]
++ val () =
++ case unifyTypes(argTypes, boolStarBool) of
++ NONE => ()
++ | SOME report =>
++ typeWrong("Arguments of orelse must have type bool*bool.",
++ valTypeMessage (lex, typeEnv) ("Arguments:", pairArgs, argTypes),
++ unifyErrorReport (lex, typeEnv) report, lex, location, foundNear anOrElse)
++ in
++ boolType
++ end
++
++ | Directive { tlist, fix, ... } =>
++ (
++ (* Infix declarations have already been processed by the parser. We include
++ them here merely so that we get all declarations in the correct order. *)
++ List.app (fn name => #enterFix env (name, fix)) tlist;
++ badType
++ )
++
++ | WildCard _ => (* Should never occur in an expression. *)
++ raise InternalError "assignTypes: wildcard found"
++
++ | Layered _ =>
++ raise InternalError "assignTypes: layered pattern found"
++
++ | EmptyTree =>
++ raise InternalError "assignTypes: emptytree found"
++
++ | Parenthesised(p, _) => assValues near p
++
++ (* end of assValues *)
++
++ and assMatchTree _ (MatchTree {vars, exp, location, resType, argType}) =
++ let
++ (* A match is a function from the pattern to the expression *)
++
++ (* Process the pattern looking for variables. *)
++
++ (* Construct a new environment for the variables. *)
++ fun messFn(name, _, Value{locations, ...}) =
++ errorNear (lex, true, v, declaredAt locations,
++ name ^ " has already been bound in this match");
++
++ val newEnv = noDuplicates messFn;
++ val newLevel = level + 1;
++ val decs = processPattern(vars, #enter newEnv, newLevel, false, false)
++
++ (* The identifiers declared in the pattern are available in the
++ body of the function. *)
++ val bodyEnv =
++ {
++ lookupVal = lookupDefault (#lookup newEnv) (#lookupVal env),
++ lookupType = #lookupType env,
++ lookupFix = #lookupFix env,
++ lookupStruct = #lookupStruct env,
++ lookupSig = #lookupSig env,
++ lookupFunct = #lookupFunct env,
++ lookupTvars = #lookupTvars env,
++ enterVal = #enterVal env,
++ enterType = #enterType env,
++ enterFix = #enterFix env,
++ enterStruct = #enterStruct env,
++ enterSig = #enterSig env,
++ enterFunct = #enterFunct env
++ };
++
++ (* Now the body. *)
++ val expType = assignValues(newLevel, letDepth, bodyEnv, v, exp);
++ in
++ resType := expType;
++ argType := decs;
++ (* Check the type of parameters to the function to make
++ sure they have not been unified with local datatypes.
++ We don't need to check the result type because the check
++ in "Localdec" will do that. *)
++ checkForLocalDatatypes(decs, letDepth, giveError (v, lex, location));
++ (* Result is a function from the type of the pattern to the type
++ of the body. This previously generalised the resulting type. Why? *)
++ mkFunctionType (decs, expType)
++ end (* MatchTree *)
++
++ and assValDeclaration (valdecs: valbind list, explicit, implicit, variables) =
++ (* assignTypes for a val-declaration. *)
++ let
++ val newLevel = level + 1;
++
++ (* Set the scope of explicit type variables. *)
++ val () = #apply explicit(fn (_, tv) => setTvarLevel (tv, newLevel));
++
++ (* For each implicit type variable associated with this value declaration,
++ link it to any type variable with the same name in an outer
++ scope. *)
++ val () =
++ #apply implicit
++ (fn (name, tv) =>
++ case #lookupTvars env name of SOME v => linkTypeVars(v, tv) | NONE => setTvarLevel (tv, newLevel));
++ (* If it isn't there set the level of the type variable. *)
++
++ (* Construct a new environment for the variables. *)
++ val newEnv =
++ noDuplicates
++ (fn(name, _, Value{locations, ...}) =>
++ errorNear (lex, true, v, declaredAt locations,
++ name ^ " has already been bound in this declaration"));
++
++ (* This environment is those identifiers declared by recursive bindings *)
++ val recEnv = searchList ();
++
++ (* If this is a recursive declaration we will have to find all
++ the variables declared by the patterns in each binding before
++ we can look at the bodies of the bindings. For simplicity we
++ process the patterns first even if this is not recursive but
++ arrange for the variables to be added to the environment
++ after rather than before processing the bodies. The result of
++ processing the patterns is a list of their types. Each item
++ in the list must be unified with the type of the
++ corresponding body. *)
++
++ (* Process the patterns. *)
++ local
++ fun mapProcess ([], _) = []
++ | mapProcess (RecValBind :: tlist, _) =
++ (* If we have val x=1 and rec ... we will have an and-list
++ as the last element of the list. (It must be the last
++ because the inner and-list will swallow all the rest).
++ All those entries will be recursive. *)
++ mapProcess(tlist, true)
++
++ | mapProcess ((ValBind {dec, ...}) :: ptl, isRec) =
++ let
++ fun enterVals pair =
++ (
++ #enter newEnv pair;
++ if isRec then #enter recEnv pair else ()
++ );
++
++ val patType = processPattern(dec, enterVals, newLevel, false, isRec);
++ in
++ patType :: mapProcess(ptl, isRec)
++ end;
++ in
++ val decs = mapProcess(valdecs, false)
++ end
++
++ (* Now the bodies. *)
++ local
++ (* Check that the types match by going down the list of value
++ bindings and the list of types produced from the patterns,
++ and matching corresponding types. *)
++ fun checkTypes (patTypes, RecValBind :: valList, _) =
++ checkTypes (patTypes, valList, true)
++
++ | checkTypes (patType :: patTypes, (ValBind {dec, exp, line,...}) :: valList, isRec) =
++ let
++ val newEnv =
++ { (* If this is recursive we find the recursive names
++ and others in the surrounding scope. *)
++ lookupVal =
++ if isRec
++ then lookupDefault (#lookup recEnv) (#lookupVal env)
++ else #lookupVal env,
++ lookupType = #lookupType env,
++ lookupFix = #lookupFix env,
++ lookupStruct = #lookupStruct env,
++ lookupSig = #lookupSig env,
++ lookupFunct = #lookupFunct env,
++ (* Extend the environment of type variables. *)
++ lookupTvars =
++ lookupDefault (#lookup explicit)
++ (lookupDefault (#lookup implicit) (#lookupTvars env)),
++ enterVal = #enterVal env,
++ enterType = #enterType env,
++ enterFix = #enterFix env,
++ enterStruct = #enterStruct env,
++ enterSig = #enterSig env,
++ enterFunct = #enterFunct env
++ }
++
++ val expType = assignValues(newLevel, letDepth, newEnv, exp, exp);
++
++ val () =
++ case unifyTypes(patType, expType) of
++ NONE => () (* OK*)
++ | SOME report =>
++ typeMismatch("Pattern and expression have incompatible types.",
++ valTypeMessage (lex, typeEnv) ("Pattern:", dec, patType),
++ valTypeMessage (lex, typeEnv) ("Expression:", exp, expType),
++ unifyErrorReport (lex, typeEnv) report, lex, line, foundNear v)
++
++ (* true if the expression is a possibly-constrained fn-expression.
++ It isn't clear whether a parenthesised expression is allowed here.
++ As often, the definition is informal. On p8 of the ML97
++ definition it says "exp must be of the form fn match". In ML90
++ it added "possibly constrained by one or more type expressions".
++ This is such a mess that I'm allowing both contraints and parentheses
++ here. *)
++ fun isConstrainedFn (Constraint {value, ...}) = isConstrainedFn value
++ | isConstrainedFn (Fn _) = true
++ | isConstrainedFn (Parenthesised(p, _)) = isConstrainedFn p
++ | isConstrainedFn _ = false;
++ in
++ (* Must check that the expression is of the form FN match. *)
++ (* N.B. the code generator assumes this is true. *)
++ if isRec andalso not (isConstrainedFn exp)
++ then errorNear (lex, true, v, line,
++ "Recursive declaration is not of the form `fn match'")
++ else ();
++
++ checkTypes(patTypes, valList, isRec)
++ end
++
++ | checkTypes _ = ()
+ in
+- given
+- end
++ val () = checkTypes(decs, valdecs, false)
++ end;
+
+- | Layered {var, pattern} =>
+- let
+- (* Unify the variable and the pattern - At this stage that simply
+- involves assigning the type of the pattern to the variable,
+- but it may result in more unification when the variable is
+- used *)
+-
+- (* The "variable" must be either id or id: ty but we have to
+- check that the id is not a constructor. *)
+- val varType = processPattern var enterResult level true isRec line;
+- val patType = processPattern pattern enterResult level notConst isRec line
+- val U : unit = unify (varType, patType, lex, line, foundNear pat);
+- in
+- varType
+- end
++ (* Variables, constructors and fn are non-expansive.
++ [] is a derived form of "nil" so must be included.
++ Integer and string constants are also constructors but
++ cannot involve imperative type variables. Constrained
++ versions are also non-expansive.
++ This has been extended and made more explicit in ML 97. *)
++ fun nonExpansive (Fn _) = true
++ | nonExpansive (Ident _) = true
++ | nonExpansive (List{elements = [], ...}) = true
++ | nonExpansive (List{elements, ...}) =
++ List.foldl (fn (v, a) => a andalso nonExpansive v) true elements
++ | nonExpansive (Constraint {value, ...}) = nonExpansive value
++ | nonExpansive (Literal _) = true
++ | nonExpansive (Unit _) = true
++ | nonExpansive (TupleTree(elems, _)) =
++ List.foldl (fn (v, a) => a andalso nonExpansive v)
++ true elems
++ | nonExpansive (Labelled{recList, ...}) =
++ List.foldl (fn ({valOrPat, ...}, a) => a andalso nonExpansive valOrPat)
++ true recList (* Every element must be non-expansive *)
++ | nonExpansive (Applic{f, arg, ...}) =
++ isNonRefConstructor f andalso nonExpansive arg
++ | nonExpansive (Selector _) = true (* derived from fn {..} => ...*)
++ | nonExpansive (Parenthesised(p, _)) = nonExpansive p
++ | nonExpansive _ = false
++
++ (* An application is non-expansive only if it is a, possibly
++ constrained, constructor which is not ref. *)
++ and isNonRefConstructor (Ident {value=ref v, name, ...}) =
++ (* Rather than looking at the name it might be better to look
++ at the operation. This is probably ok since we're not allowed
++ to rebind "ref". *)
++ isConstructor v andalso name <> "ref"
++ | isNonRefConstructor (Constraint {value, ...}) =
++ isNonRefConstructor value
++ | isNonRefConstructor (Parenthesised(p, _)) =
++ isNonRefConstructor p
++ | isNonRefConstructor _ = false
++
++ (* Now allow generalisation on the variables being declared.
++ For imperative type variables we have to know whether the
++ expression is expansive. *)
++ fun allowGen (_, []) = ()
++ | allowGen (decs, RecValBind :: tlist) = allowGen(decs, tlist)
++ | allowGen (d::dl, (ValBind {exp, line,...}) :: ptl) =
++ (
++ allowGeneralisation
++ (d, newLevel, nonExpansive exp, lex, line, foundNear v, typeEnv);
++ (* Check the type to make sure that a local datatype is
++ not escaping. Checking here is really only needed in the
++ recursive case (where a recursive call inside the body
++ sets the type of the function) because the result will be
++ checked elsewhere. *)
++ checkForLocalDatatypes(d, letDepth, giveError (v, lex, line));
++ allowGen(dl, ptl)
++ ) (* allowGen *)
++
++ | allowGen _ =
++ raise InternalError "allowGen: badly-formed parse-tree";
++
++ in
++ allowGen(decs, valdecs);
++ (* And declare the new names into the surrounding environment. *)
++ #apply newEnv (fn nv as (_, var) => (#enterVal env nv; variables := var :: !variables))
++ end (* assValDeclaration *)
+
+- | Unit =>
+- unitType
++ and assFunDeclaration (tlist: fvalbind list, explicit, implicit) =
++ (* Assigntypes for a fun-declaration. *)
++ let
++ val funLevel = level + 1; (* Level for function names. *)
++
++ (* Set the scope of explicit type variables. *)
++ val () =
++ #apply explicit(fn (_, tv) => setTvarLevel (tv, funLevel));
++
++ (* For each implicit type variable associated with this value declaration,
++ link it to any type variable with the same name in an outer
++ scope. *)
++ val () =
++ #apply implicit
++ (fn (name, tv) =>
++ case #lookupTvars env name of SOME v => linkTypeVars(v, tv) | NONE => setTvarLevel (tv, funLevel));
++ (* If it isn't there set the level of the type variable. *)
++
++ (* Construct a new environment for the variables. *)
++ fun msgFn(name, _, Value{locations, ...}) =
++ errorNear (lex, true, v, declaredAt locations,
++ name ^ " has already been bound in this declaration");
++
++ val newEnv = noDuplicates msgFn;
++
++ (* Since this is a recursive declaration we must get the function
++ names first. Because of the way they are parsed they are hidden
++ as applications of the function to one or more patterns. There
++ may be more than one clause in a function binding but each
++ should declare the same function and have the same number of
++ patterns. We need to know the number of patterns and the
++ function name in the third pass so we save them in the
++ function binding. *)
+
+- | WildCard =>
+- mkTypeVar (generalisable, false, false, false)
++ local
++ fun findNameAndPatts (FValBind {clauses = (FValClause {dec, line, ...}::_), numOfPatts, functVar, ...}) =
++ let
++ (* Just look at the first clause for the moment. *)
++ val { ident = { name, location, ... }, ... } = dec;
++ (* Declare a new identifier with this name. *)
++ val funVar =
++ mkVar (name, mkTypeVar (funLevel, false, false), [DeclaredAt location])
++
++ val arity = case dec of { args, ...} => List.length args
++ val () = numOfPatts := arity;
++ val () =
++ (* Put the results onto the function binding. *)
++ if arity = 0
++ then errorNear (lex, true, v, line,
++ "Clausal function does not have any parameters.")
++ else ()
++ in
++ (* Must not be qualified *)
++ checkForDots (name, lex, line);
++ (* Must not be "true", "false" etc. but may be "it" *)
++ checkForBuiltIn (name, v, lex, line, false);
++ functVar := funVar; (* Save the variable. *)
++ (* Enter it in the environment. *)
++ #enter newEnv (name, funVar)
++ end
++ | findNameAndPatts _ = raise InternalError "findNameAndPatts: badly-formed parse-tree";
+
+- | _ => (* not a legal pattern *)
+- badType
++ in
++ val () = List.app findNameAndPatts tlist
++ end;
+
+- end; (* processPattern *)
++ local
++ (* Can now process the clausal functions in the environment
++ of the function names and using the information about
++ function name and number of patterns we have saved. *)
++ fun processBinding
++ (fvalBind as FValBind {clauses, functVar=ref functVar, argType, resultType, location, ...}) =
++ let
++ (* Each fun binding in the declaration may consist of several
++ clauses. Each must have the same function name, the same
++ number of patterns and a unifiable type. *)
++ (* The type information is built up from the bottom so that if there are
++ errors we can report them in the most appropriate place.
++ Build a type to be used for the function. This will later be unified
++ with the type that we've already created for the function variable. *)
++ val funType = mkTypeVar(generalisable, false, false)
++
++ fun processClause (clause as FValClause {dec, exp, line}) =
++ let
++ val { ident = ident, args, constraint, ... } = dec
++ val clauseAsTree: parsetree =
++ (* This clause as a parsetree object for error messages. *)
++ mkFunDeclaration([mkClausal([clause], line)], explicit, implicit, line)
++
++ val () = (* Set the type. Only in case we look at the export tree. *)
++ #expType ident := valTypeOf functVar
+
+-
+- (* Applies "assignValues" to every element of a list and unifies the
+- types. Returns a type variable if the list is empty. *)
+- fun assignList tlist =
+- let (* Construct a type variable and unite all the types to that. *)
+- val basicType = mkTypeVar (generalisable, false, false, false);
+- fun applyList [] = ()
+- | applyList (h::t) =
+- let
+- val typ = assValues v h;
+- val U : unit = unify (typ, basicType, lex, line, foundNear v);
++ fun messFn (name, _, Value{locations, ...}) =
++ errorNear (lex, true, clauseAsTree, declaredAt locations,
++ name ^ " has already been bound in this clause.");
++ (* Construct a new environment for the variables in the patts. *)
++ val varEnv = noDuplicates messFn;
++ val varLevel = funLevel + 1; (* Level for variables. *)
++
++ (* Process the patterns. *)
++ val argTypeList =
++ List.map (fn arg => processPattern(arg, #enter varEnv, varLevel, false, false))
++ args
++ (* This list is used for the type of the helper function. *)
++ val () = argType :=
++ (case argTypeList of
++ [] => badType (* error *)
++ | [single] => single
++ | multiple => mkProductType(List.rev multiple))
++
++ (* The identifiers declared in the pattern are available in the
++ body of the function. Since it is recursive the function
++ names are also available. *)
++ val bodyEnv =
++ {
++ lookupVal =
++ lookupDefault (#lookup varEnv)
++ (lookupDefault (#lookup newEnv) (#lookupVal env)),
++ lookupType = #lookupType env,
++ lookupFix = #lookupFix env,
++ lookupStruct = #lookupStruct env,
++ lookupSig = #lookupSig env,
++ lookupFunct = #lookupFunct env,
++ (* Extend the environment of type variables. *)
++ lookupTvars =
++ lookupDefault (#lookup explicit)
++ (lookupDefault (#lookup implicit) (#lookupTvars env)),
++ enterVal = #enterVal env,
++ enterType = #enterType env,
++ enterFix = #enterFix env,
++ enterStruct = #enterStruct env,
++ enterSig = #enterSig env,
++ enterFunct = #enterFunct env
++ };
++
++ (* Now the body. *)
++ val expTyp = assignValues(varLevel, letDepth, bodyEnv, exp, exp);
++ (* Remember the result type for the debugger. Actually this
++ assigns the result type for each clause in the fun but
++ they'll all be the same. *)
++ val () = resultType := expTyp;
++ (* Check the expression type against any explicit type constraint. *)
++ val () =
++ case constraint of
++ NONE => ()
++ | SOME given =>
++ let
++ val theType = typeFromTypeParse given
++ val () = ptAssignTypes theType v
++ in
++ case unifyTypes(expTyp, theType) of
++ NONE => () (* OK. *)
++ | SOME report =>
++ typeMismatch("Body of fun binding does not match type constraint.",
++ valTypeMessage (lex, typeEnv) ("Expression:", exp, expTyp),
++ PrettyBlock(0, false, [],
++ [
++ PrettyString "Constraint:",
++ PrettyBreak(1, 0),
++ display(theType, 10000 (* All *), typeEnv)
++ ]),
++ unifyErrorReport (lex, typeEnv) report,
++ lex, line, foundNear clauseAsTree)
++ end
++ (* The type of this clause is a function type. *)
++ val clauseType = List.foldr mkFunctionType expTyp argTypeList
++ (* Unify this with the type we're using for the other clauses. *)
++ val () =
++ case unifyTypes(clauseType, funType) of
++ NONE => () (* OK. *)
++ | SOME report =>
++ typeMismatch("Type of clause does not match the type of previous clauses.",
++ valTypeMessage (lex, typeEnv) ("Clause:", clauseAsTree, clauseType),
++ PrettyBlock(0, false, [],
++ [
++ PrettyString "Other clauses:",
++ PrettyBreak(1, 0),
++ display(funType, 10000 (* All *), typeEnv)
++ ]),
++ unifyErrorReport (lex, typeEnv) report,
++ lex, line, foundNear clauseAsTree)
++ in (* body of processClause *)
++ ()
++ end
++ in (* body of processFun *)
++ List.app processClause clauses;
++ (* Finally unify the function type with the type of the function variable. If the
++ variable has not yet been used that will simply set its type but if it has been
++ used recursively it may have been given an incompatible type. *)
++ case unifyTypes(funType, valTypeOf functVar) of
++ NONE => () (* OK. *)
++ | SOME report =>
++ let
++ val fvalAsTree = mkFunDeclaration([fvalBind], explicit, implicit, location)
++ in
++ typeMismatch("Type of function does not match type of recursive application.",
++ valTypeMessage (lex, typeEnv) ("Function:", fvalAsTree, funType),
++ valTypeMessage (lex, typeEnv)
++ ("Variable:", mkIdent(valName functVar, location), valTypeOf functVar),
++ unifyErrorReport (lex, typeEnv) report,
++ lex, location, foundNear fvalAsTree)
++ end
++ end
+ in
+- applyList t
++ val () = List.app processBinding tlist
+ end;
++
+ in
+- applyList tlist;
+- basicType (* Return the type variable - united to all the types *)
+- end (* assignList *)
++ (* Now declare the new names into the surrounding environment,
++ releasing the copy flags on the type variables. All fun
++ bindings are non-expansive. *)
++ #apply newEnv
++ (fn (pair as (_, Value{typeOf, locations, ...})) =>
++ let
++ val () =
++ allowGeneralisation(typeOf, funLevel, true, lex, declaredAt locations, foundNear v, typeEnv);
++ (* Check the type to make sure that a local datatype is
++ not escaping as a result of a recursive application of
++ the function to a local datatype. *)
++ val () = checkForLocalDatatypes(typeOf, letDepth, giveError (v, lex, declaredAt locations))
++ in
++ #enterVal env pair
++ end)
++ end (* assFunDeclaration *)
+
+- (* val assValues = assignValues level line env; *)
+- and assValues near v =
+- case v of
+- Ident {name, value, typeof} =>
+- let
+- val expValue =
+- lookupValue
+- ("Value or constructor",
+- {lookupVal = #lookupVal env, lookupStruct = #lookupStruct env},
+- name,
+- giveError (near, lex, line));
+- (* Set the value and type found. *)
+- val instanceType = instanceType expValue true (* expression *);
+- in
+- value := expValue;
+- typeof := instanceType;
+- instanceType (* Result is the instance type. *)
+- end
+-
+- | Literal{converter, typeof, ...} =>
+- let
+- (* Find out the overloadings on this converter and
+- construct an instance of it. The converters are
+- all functions from string to the result type. *)
+- val instanceType = overloadType(converter, true)
+- val instance =
+- apply(instanceType, stringType, lex, line, foundNear near)
+- in
+- typeof := instance; (* Remember it *)
+- instance
+- end
+-
+- | Applic {f, arg} =>
+- let
+- (* Apply the function to the argument and return the result. *)
+- val funType = assValues near f; (* SPF 22/10/94 *)
+- val argType = assValues near arg;
+- in
+- apply (funType, argType, lex, line, foundNear near)
+- end
+-
+- | Cond {test, thenpt, elsept} =>
+- let
+- (* The test must be bool, and the then and else parts must be the
+- same. The result is either of these two once they have been
+- unified. *)
+- val testType = assValues v test;
+- val U : unit = unify (testType, boolType, lex, line, foundNear v);
+-
+- val thenType = assValues v thenpt;
+- val elseType = assValues v elsept;
+- val U : unit = unify (thenType, elseType, lex, line, foundNear v);
+- in
+- thenType (* or equally elseType *)
+- end
++ and assAbsData(isAbs, {typelist=typeList, withtypes, declist, equalityStatus, ...}) =
++ let
++ (* A type declaration causes a type to be entered in the type
++ environment, together with some constructors. *)
++ fun messFn (name, _, new) =
++ errorNear (lex, true, v, declaredAt(tcLocations new),
++ name ^ " has already been bound in this declaration");
+
+- | TupleTree ptl =>
+- (* Construct the type obtained by mapping "assignValue" onto
+- each element of the tuple. *)
+- mkProductType (map (assValues near) ptl) (* SPF 22/10/94 *)
+-
+- | Labelled {recList, frozen, typeof} =>
++ val newEnv = noDuplicates messFn;
++
++ (* datatype and abstype declarations are both recursive so we can
++ enter the type names into the environment during a first pass,
++ and then process the value constructors during a second. *)
++ fun enterType(innerType, outerType, typeName) =
++ (
++ checkForDots (typeName, lex, declaredAt(tcLocations innerType)); (* Must not be qualified *)
++ #enter newEnv (typeName, innerType); (* Check for duplicates. *)
++ #enterType env (typeName, outerType) (* and put in the enclosing scope *)
++ );
++
++ (* Make the type constructors and put them in a list. *)
++ fun enterTcon (DatatypeBind {name, tcon, typeVars, nameLoc, ...}) =
+ let
+- (* Process each item in the list. *)
++ (* Make a new ID. If this is within a let declaration we always make
++ a free ID because it is purely local and can't be exported. *)
++ val description = { location = nameLoc, name = name, description = "" }
+
+- fun msgFn msg = errorNear (lex, true, v, line, msg);
+-
+- fun labEntryToLabType (name, value) =
+- {name = name, typeof = assValues v value }
+-
+- val expType =
+- mkLabelled
+- (sortLabels (map labEntryToLabType recList, msgFn),
+- frozen) (* should always be true *);
++ val newId =
++ if letDepth = 0
++ then makeTypeId(false, true, description)
++ else makeFreeIdEqUpdate (Local{addr = ref 0, level = ref 0}, false, description)
++ val tc =
++ makeDatatypeConstr(name, typeVars, newId,
++ letDepth, [DeclaredAt nameLoc])
++ val outerType =
++ if isAbs
++ then
++ (* Outside the with..end section the type is not a datatype.
++ The type constructor we enter in the outer environment
++ uses the same typeId but with the constructors removed. *)
++ makeFrozenTypeConstrs(name, typeVars, newId,
++ letDepth, [DeclaredAt nameLoc])
++ else tc
+ in
+- typeof := expType;
+- expType
++ tcon := tc;
++ enterType(tc, outerType, name);
++ tc
+ end
++
++ val listOfTypes = map enterTcon typeList;
+
+- | Selector {typeof, ...} =>
+- typeof (* Already made. *)
++ (* First match all the types on the right-hand sides using the
++ datatypes and the existing bindings. *)
++ fun processType (TypeBind {decType = SOME decType, ...}) =
++ let
++ val t = typeFromTypeParse decType
++ in
++ ptAssignTypes t v;
++ t
++ end
++ | processType _ = emptyType
+
+- | ValDeclaration {dec, explicit, implicit, variables} =>
+- assValDeclaration dec explicit implicit variables
++ val decTypes = List.map processType withtypes;
+
+- | FunDeclaration {dec, explicit, implicit} =>
+- assFunDeclaration dec explicit implicit
++ (* Can now enter the `withtypes'. *)
++ fun enterWithType (TypeBind {name, typeVars, nameLoc, ...}, decType) =
++ let
++ (* Construct a type constructor which is an alias of the
++ right-hand side of the declaration. *)
++ val tcon =
++ makeTypeAbbreviation (name, typeVars, decType, [DeclaredAt nameLoc]);
++ in
++ enterType(tcon, tcon, name)
++ end
+
+- | OpenDec{decs=ptl, variables} =>
+- let
+- (* Go down the list of names opening the structures. *)
+- (* We have to be careful because open A B is not the same as
+- open A; open B if A contains a structure called B. *)
+- (* We accumulate the values so that we can produce debugging
+- information if we need to. Note: we have to be careful if
+- we have the same name in multiple structures. *)
+- val valTable = HashTable.hashMake 10
+-
+- (* First get the structures... *)
+- fun findStructure ({name, ...}: structureIdentForm) =
+- lookupStructure
+- ("Structure", {lookupStruct = #lookupStruct env}, name,
+- giveError (v, lex, line))
+-
+- val strs : structVals list = map findStructure ptl;
+-
+- (* Value and substructure entries in a structure will generally have
+- "Formal" access which simply gives the offset of the entry within
+- the parent structure. We need to convert these into "Select"
+- entries to capture the address of the base structure. *)
+- fun copyEntries str =
+- if isUndefinedStruct str then ()
+- else let
+- val sigTbl = structSignat str; (* Get the tables. *)
+-
+- fun copyEntry (dName, dVal, ()) =
+- if (tagIs typeConstrVar dVal)
+- then let
+- (* If this is a datatype we have to apply mkSelectedVar to the
+- value constructors. It will not do anything if the constructors
+- are global but if we are opening the argument to a functor we
+- need to do this. It's essential if we subsequently replicate
+- this datatype. Note: we don't add the value constructors to the
+- environment at this point. While a signature cannot contain
+- values which "mask" constructors we can have a structure
+- containing values which mask constructors. *)
+- val tcons = tagProject typeConstrVar dVal
+- in
+- #enterType env (dName,
+- if null(tcConstructors tcons)
+- then tcons (* Not a datatype. *)
+- else mkSelectedType(tcons, tcName tcons, SOME str))
+- end
+-
+- else if (tagIs valueVar dVal)
+- then let
+- (* If this is a datatype we could use findValueConstructor here
+- to save constructing a new object. It's probably not worth it. *)
+- val selectedVar =
+- mkSelectedVar (tagProject valueVar dVal, str);
+- in
+- HashTable.hashSet(valTable, dName, selectedVar);
+- #enterVal env (dName, selectedVar)
+- end
+-
+- else if (tagIs structVar dVal)
+- then let
+- val selectedStruct =
+- makeSelectedStruct (tagProject structVar dVal, str);
+- in
+- #enterStruct env (dName, selectedStruct)
+- end
+- else ()
+- in
+- univFold (sigTab sigTbl, copyEntry, ())
+- end
+-
+- (* ...then put them into the name space. *)
+- val () = List.app copyEntries strs;
+- in
+- variables := HashTable.hashFold valTable (fn _ => fn v => fn t => v :: t) [];
+- badType (* Does not return a type *)
+- end
+-
+- | TypeDeclaration tlist =>
+- let (* Non-generative type binding *)
+- fun messFn name =
+- errorNear (lex, true, v, line,
+- name ^ " has already been bound in this declaration");
+-
+- val newEnv = noDuplicates messFn;
+-
+- (* First match all the types on the right-hand sides. *)
+- fun processTypeBody (TypeBind {decType, ...}) =
+- ptAssignTypes decType v line
+-
+- val () = List.app processTypeBody tlist;
+-
+- (* Can now declare the new types. *)
+- fun processType (TypeBind {name, typeVars, decType, isEqtype}) =
+- let
+- (* Construct a type constructor which is an alias of the
+- right-hand side of the declaration. If the right-hand
+- side were a type constructor we could use the same unique
+- id, but it is probably not worth it. *)
+- val tcon =
+- makeTypeConstrs (strName ^ name, typeVars, decType, makeTypeId (),
+- isEqtype (* In most cases we look at the equivalent. *),
+- 0 (* This is only required for datatypes. *));
+- in
+- checkForDots (name, lex, line); (* Must not be qualified *)
+- #enter newEnv (name, tcon); (* Check for duplicates. *)
+- #enterType env (name, tcon) (* Put in the surrounding scope. *)
+- end
+-
+- val () = List.app processType tlist;
+- in
+- badType (* Does not return a type *)
+- end
+-
+- | DatatypeDeclaration
+- {typelist, withtypes, declist} =>
+- assAbsData false typelist withtypes declist
+-
+- | AbstypeDeclaration
+- {typelist, withtypes, declist} =>
+- assAbsData true typelist withtypes declist
+-
+- | DatatypeReplication{oldType, newType} =>
+- (* Adds both the type and the constructors to the
+- current environment. *)
+- let
+- (* Look up the type constructor in the environment. *)
+- val oldTypeCons: typeConstrs =
+- lookupTyp
+- ({lookupType = #lookupType env, lookupStruct = #lookupStruct env},
+- oldType,
+- giveError (near, lex, line));
+-
+- (* If the type name was qualified (e.g. S.t) we need to find the
+- value constructors from the same structure. *)
+- val {first = namePrefix, ...} = splitString oldType;
+- val baseStruct =
+- if namePrefix = ""
+- then NONE
+- else SOME(lookupStructure("Structure", {lookupStruct = #lookupStruct env},
+- namePrefix, giveError (v, lex, line)))
+-
+- (* Copy the datatype, converting any Formal constructors to Selected. *)
+- val newTypeCons = mkSelectedType(oldTypeCons, strName ^ newType, baseStruct)
+-
+- val newValConstrs = tcConstructors newTypeCons
+- in
+- (* Check that it has at least one constructor. *)
+- case newValConstrs of
+- [] => errorNear (lex, true, v, line, oldType ^ " is not a datatype")
+- | _ => ();
+- (* Enter the value constrs in the environment. *)
+- List.app (fn c => (#enterVal env) (valName c, c)) newValConstrs;
+- (* Add this type constructor to the environment. *)
+- (#enterType env) (newType, newTypeCons);
+- badType (* Does not return a type *)
+- end
+-
+- | List ptl =>
+- mkTypeConstruction ("list", listType, [assignList ptl])
+-
+- | Constraint {value, given} =>
+- let
+- val valType = assValues near value; (* SPF 22/10/94 *)
+- val U : unit = ptAssignTypes given v line;
+- (* These must be unifiable. *)
+- val U : unit = unify (valType, given, lex, line, foundNear v);
+- in
+- given
+- end
+-
+- | Fn ptl => (* Must unify the types of each of the alternatives.*)
+- assignList ptl
+-
+- | MatchTree {vars, exp, line, resType, argType} =>
+- let
+- (* A match is a function from the pattern to the expression *)
+-
+- (* Process the pattern looking for variables. *)
+-
+- (* Construct a new environment for the variables. *)
+- fun messFn name =
+- errorNear (lex, true, v, line,
+- name ^ " has already been bound in this match");
+-
+- val newEnv = noDuplicates messFn;
+- val newLevel = level + 1;
+- val decs = processPattern vars (#enter newEnv) newLevel false false line;
+-
+- (* The identifiers declared in the pattern are available in the
+- body of the function. *)
+- val bodyEnv =
+- {
+- lookupVal = lookupDefault (#lookup newEnv) (#lookupVal env),
+- lookupType = #lookupType env,
+- lookupFix = #lookupFix env,
+- lookupStruct = #lookupStruct env,
+- lookupSig = #lookupSig env,
+- lookupFunct = #lookupFunct env,
+- lookupTvars = #lookupTvars env,
+- enterVal = #enterVal env,
+- enterType = #enterType env,
+- enterFix = #enterFix env,
+- enterStruct = #enterStruct env,
+- enterSig = #enterSig env,
+- enterFunct = #enterFunct env
+- };
+-
+- (* Now the body. *)
+- val expType = assignValues newLevel letDepth line bodyEnv v exp;
+- in
+- resType := expType;
+- argType := decs;
+- (* Check the type of parameters to the function to make
+- sure they have not been unified with local datatypes.
+- We don't need to check the result type because the check
+- in "Localdec" will do that. *)
+- checkForLocalDatatypes(decs, letDepth, giveError (v, lex, line));
+- (* Result is a function from the type of the pattern to the type
+- of the body. This previously generalised the resulting type. Why? *)
+- mkFunctionType (decs, expType)
+- end (* MatchTree *)
++ val () = ListPair.app enterWithType (withtypes, decTypes);
++
++ (* For the constructors *)
++ fun messFn (name, _, Value{locations, ...}) =
++ errorNear (lex, true, v, declaredAt locations,
++ name ^ " has already been used as a constructor in this type");
++
++ val consEnv = noDuplicates messFn;
++
++ (* Now process the types and generate the constructors. *)
++ fun genValueConstrs (DatatypeBind {name, typeVars, constrs, nameLoc, ...}, typ) =
++ let
++ val numOfConstrs = length constrs;
++
++ (* The new constructor applied to the type variables (if any) *)
++ val resultType = mkTypeConstruction (name, typ, List.map TypeVar typeVars, [DeclaredAt nameLoc]);
+
+- | Unit =>
+- unitType
++ (* Sort the constructors by name. This simplifies matching with
++ datatypes in signatures. *)
++ fun leq {constrName=xname: string, ...} {constrName=yname, ...} = xname < yname;
++ val sortedConstrs = quickSort leq constrs;
+
+- | Localdec {decs, body, loc, varsInBody} =>
+- let (* Local declarations or expressions. *)
+- val newValEnv = searchList();
+- val newTypeEnv = searchList();
+- val newStrEnv = searchList();
+- val newLetDepth = if loc then letDepth else letDepth+1;
+- (* The environment for the local declarations. *)
+- val localEnv =
+- {
+- lookupVal = lookupDefault (#lookup newValEnv) (#lookupVal env),
+- lookupType = lookupDefault (#lookup newTypeEnv) (#lookupType env),
+- lookupFix = #lookupFix env,
+- (* This environment is needed if we open a
+- structure which has sub-structures. *)
+- lookupStruct = lookupDefault (#lookup newStrEnv) (#lookupStruct env),
+- lookupSig = #lookupSig env,
+- lookupFunct = #lookupFunct env,
+- lookupTvars = #lookupTvars env,
+- enterVal = #enter newValEnv,
+- enterType = #enter newTypeEnv,
+- (* Fixity has already been dealt with in the parsing process. The only reason
+- we deal with it here is to ensure that declarations are printed in the
+- correct order. We simply need to make sure that local fixity declarations
+- are ignored. *)
+- enterFix = fn _ => (),
+- enterStruct = #enter newStrEnv,
+- enterSig = #enterSig env,
+- enterFunct = #enterFunct env
+- };
+-
+- (* Process the local declarations and discard the result. *)
+- val U : types = assignSeq localEnv newLetDepth decs;
+-
+- (* This is the environment used for the body of the declaration.
+- Declarations are added both to the local environment and to
+- the surrounding scope. *)
+- val bodyEnv =
+- {
+- (* Look-ups come from the local environment *)
+- lookupVal = #lookupVal localEnv,
+- lookupType = #lookupType localEnv,
+- lookupFix = #lookupFix localEnv,
+- lookupStruct = #lookupStruct localEnv,
+- lookupSig = #lookupSig localEnv,
+- lookupFunct = #lookupFunct localEnv,
+- lookupTvars = #lookupTvars localEnv,
+- enterVal =
+- fn (pair as (name, v)) =>
+- (varsInBody := v :: ! varsInBody;
+- #enter newValEnv pair;
+- #enterVal env pair),
+- enterType =
+- fn (pair as (name, v)) =>
+- (#enter newTypeEnv pair;
+- #enterType env pair),
+- enterFix = #enterFix env,
+- enterStruct =
+- fn (pair as (name, v)) =>
+- (#enter newStrEnv pair;
+- #enterStruct env pair),
+- enterSig = #enterSig env,
+- enterFunct = #enterFunct env
+- };
+- (* Now the body, returning its result if it is an expression. *)
+- val resType = assignSeq bodyEnv newLetDepth body
+- in
+- (* If this is a let expression we have to check that there
+- are no datatypes escaping. *)
+- if loc then ()
+- else checkForLocalDatatypes(resType, letDepth,
+- giveError (v, lex, line));
+- resType
+- end (* LocalDec *)
++ fun processConstr ({constrName=name, constrArg, idLocn, ...}, repn) =
++ let
++ val cons =
++ case constrArg of
++ NONE =>
++ mkGconstr (name, resultType, repn, true, numOfConstrs, [DeclaredAt idLocn])
++ | SOME argtype =>
++ mkGconstr (name, mkFunctionType (typeFromTypeParse argtype, resultType),
++ repn, false, numOfConstrs, [DeclaredAt idLocn]);
++
++ (* Name must not be qualified *)
++ val () = checkForDots (name, lex, idLocn);
++ (* Must not be "true", "false" etc. *)
++ val () = checkForBuiltIn (name, v, lex, idLocn, true) : unit;
++
++ (* Put into the environment. *)
++ val () = #enter consEnv (name, cons);
++ in
++ cons
++ end (* processConstr *)
+
+- | ExpSeq ptl =>
+- (* A sequence of expressions separated by semicolons.
+- Result is result of last expression. *)
+- assignSeq env letDepth ptl
++ (* Declares the constructors and return a list of them. *)
++ fun decCons cs =
++ let
++ (* Match up identifiers to type constructors. *)
++ (* This side-effects "argtype" to set equivalence fields *)
++ (* Return entries for chooseConstrRepr which uses emptyType for nullary constrs. *)
++ fun checkValConstr{constrName, constrArg=NONE, ...} = (constrName, emptyType)
++ | checkValConstr{constrName, constrArg=SOME t, ...} =
++ let val ty = typeFromTypeParse t in ptAssignTypes ty v; (constrName, ty) end
+
+- | ExDeclaration tlist =>
+- let
+- fun messFn name =
+- errorNear (lex, true, v, line,
+- name ^ " has already been bound in this declaration");
+-
+- (* Construct an environment to check for duplicate declarations.
+- There is no need for a value since all this is doing is
+- checking. *)
+- val dupEnv = noDuplicates messFn;
+-
+- fun processException (ExBind {name, previous, typeof, value}) =
+- let
+- (* Fill in any types *)
+- val U : unit = ptAssignTypes typeof v line;
+- val U : unit =
+- if isEmpty typeof then ()
+- else let (* Make the type weak. *)
+- val weakTv =
+- mkTypeVar (generalisable, false, false, true);
+- in
+- unify (typeof, weakTv, lex, line, foundNear v)
+- end;
+-
+- val exValue =
+- case previous of
+- EmptyTree => (* Generative binding. *)
+- mkEx (name, typeof)
+- | Ident {name = prevName, value = prevValue, ...} =>
+- let
+- (* ex = ex' i.e. a non-generative binding? *)
+- (* Match up the previous exception. *)
+- val prev =
+- lookupValue
+- ("Exception",
+- {lookupVal= #lookupVal env,
+- lookupStruct= #lookupStruct env},
+- prevName,
+- giveError (v, lex, line))
+- in
+- (* Check that it is an exception *)
+- case prev of
+- Value{class=Exception, ...} => ()
+- | _ => errorNear (lex, true, v, line, "(" ^ prevName ^ ") is not an exception.");
+- prevValue := prev; (* Set the value of the looked-up identifier. *)
+- (* The result is an exception with the same type. *)
+- mkEx (name, valTypeOf prev)
+- end
+- | _ =>
+- raise InternalError "processException: badly-formed parse-tree"
+- in
+- (* Save this value. *)
+- value := exValue;
+-
+- (* In the check environment *)
+- #enter dupEnv (name, emptyType);
+-
+- (* Must not be qualified *)
+- checkForDots (name, lex, line) : unit;
+- (* Must not be "true", "false" etc. *)
+- checkForBuiltIn (name, v, lex, line, true) : unit;
+-
+- (* Put this exception into the env *)
+- #enterVal env (name, exValue)
+- end
+-
+- val () = List.app processException tlist;
+- in
+- badType
+- end (* ExDeclaration *)
+-
+- | Raise pt =>
+- let
+- val exType = assValues v pt;
+- (* The exception value must have type exn. *)
+- val U : unit = unify (exnType, exType, lex, line, foundNear v);
+- in
+- (* Matches anything *)
+- mkTypeVar (generalisable, false, false, false)
+- end
+-
+- | HandleTree {exp, hrules} =>
+- let
+- (* If the expression returns type E
+- the handler must be exn -> E *)
+- val expType = assValues v exp;
+- (* Unify the handler with a function from exn -> expType *)
+- val U : unit =
+- unify (assignList hrules,
+- mkFunctionType (exnType, expType),
+- lex, line, foundNear v);
+- in
+- expType (* Result is expType. *)
+- end
+-
+- | While {test, body} =>
+- let
+- val testType = assValues v test;
+-
+- (* Test must be bool. Result is unit *)
+- val U : unit = unify (testType, boolType, lex, line, foundNear v);
+-
+- (* Result of body is discarded. *)
+- val U : types = assValues v body;
+- in
+- unitType
+- end
+-
+- | Case {test, match} =>
+- let
+- val funType = assignList match;
+- val argType = assValues v test;
+- in
+- (* The matches constitute a function from the test type to
+- the result of the case statement, so we apply the match type
+- to the test. *)
+- apply (funType, argType, lex, line, foundNear v)
+- end
+-
+- | Andalso {first, second} =>
+- let
+- (* Both parts must be bool and the result is bool. *)
+- val fstType = assValues v first;
+- val U : unit = unify (fstType, boolType, lex, line, foundNear v);
+-
+- val sndType = assValues v second;
+- val U : unit = unify (sndType, boolType, lex, line, foundNear v);
+- in
+- boolType
+- end
+-
+- | Orelse {first, second} =>
+- let
+- (* Both parts must be bool and the result is bool. *)
+- val fstType = assValues v first;
+- val U : unit = unify (fstType, boolType, lex, line, foundNear v);
+-
+- val sndType = assValues v second;
+- val U : unit = unify (sndType, boolType, lex, line, foundNear v);
+- in
+- boolType
+- end
+-
+- | Directive { tlist, fix } =>
+- (
+- (* Infix declarations have already been processed by the parser. We include
+- them here merely so that we get all declarations in the correct order. *)
+- List.app (fn name => #enterFix env (name, fix)) tlist;
+- badType
+- )
++ val constrTypes = List.map checkValConstr cs
+
+- | WildCard => (* Should never occur in an expression. *)
+- raise InternalError "assignTypes: wildcard found"
++ (* Choose the representation for the constructors. *)
++ val reprs = chooseConstrRepr constrTypes
++ in
++ ListPair.map processConstr (cs,reprs)
++ end; (* decCons*)
+
+- | Layered _ =>
+- raise InternalError "assignTypes: layered pattern found"
++ in
++ tcSetConstructors (typ, decCons sortedConstrs) : unit
++ end (* genValueConstrs *)
++
++ val () = ListPair.app genValueConstrs (typeList, listOfTypes);
+
+- | EmptyTree =>
+- raise InternalError "assignTypes: emptytree found"
+- (* end of assValues *)
+
+- and assValDeclaration (valdecs: valbind list) explicit implicit variables =
+- let
+- val newLevel = level + 1;
+-
+- (* Set the scope of explicit type variables. *)
+- val U: unit =
+- #apply explicit(fn (_, tv) => setTvarLevel (tv, newLevel));
+-
+- (* For each implicit type variable associated with this value declaration,
+- link it to any type variable with the same name in an outer
+- scope. *)
+- val () =
+- #apply implicit
+- (fn (name, tv) =>
+- case #lookupTvars env name of SOME v => linkTypeVars(v, tv) | NONE => setTvarLevel (tv, newLevel));
+- (* If it isn't there set the level of the type variable. *)
+-
+- (* Construct a new environment for the variables. *)
+- val newEnv =
+- noDuplicates
+- (fn name => errorNear (lex, true, v, line,
+- name ^ " has already been bound in this declaration"));
+-
+- (* This environment is those identifiers declared by
+- recursive bindings *)
+- val recEnv = searchList ();
+-
+- (* If this is a recursive declaration we will have to find all
+- the variables declared by the patterns in each binding before
+- we can look at the bodies of the bindings. For simplicity we
+- process the patterns first even if this is not recursive but
+- arrange for the variables to be added to the environment
+- after rather than before processing the bodies. The result of
+- processing the patterns is a list of their types. Each item
+- in the list must be unified with the type of the
+- corresponding body. *)
+-
+- (* Process the patterns. *)
+- fun mapProcess [] isRec = []
+- | mapProcess (RecValBind :: tlist) isRec =
+- (* If we have val x=1 and rec ... we will have an and-list
+- as the last element of the list. (It must be the last
+- because the inner and-list will swallow all the rest).
+- All those entries will be recursive. *)
+- mapProcess tlist true
+-
+- | mapProcess ((ValBind {dec,line,...}) :: ptl) isRec =
+- let
+- (* To check that every binding actually declares
+- something i.e. to catch val _ = 99, we enter the
+- names through the following environment. *)
+- val nothingEntered = ref true;
+- fun enterVals (pair as (name, v)) =
+- (nothingEntered := false;
+- #enter newEnv pair;
+- if isRec then #enter recEnv pair else ());
+-
+- val patType = processPattern dec enterVals newLevel false isRec line;
+-
+- (* Give a warning if no variables are declared, except at
+- top level. This check was removed in ML97. *)
+- in
+- if !nothingEntered andalso level <> 1 andalso getParameter ml90Tag (debugParams lex)
+- then errorNear (lex, false, dec, line,
+- "Pattern does not declare any variables.")
+- else ();
+- patType :: mapProcess ptl isRec
+- end;
+-
+- val decs = mapProcess valdecs false;
+-
+- (* Now the bodies. *)
+-
+- (* Check that the types match by going down the list of value
+- bindings and the list of types produced from the patterns,
+- and matching corresponding types. *)
+- fun checkTypes [] [] isRec = ()
+- | checkTypes dl (RecValBind :: tlist) isRec =
+- checkTypes dl tlist true
+-
+- | checkTypes (d::dl) ((ValBind {dec, exp, line,...}) :: ptl) isRec =
+- let
+- val newEnv =
+- { (* If this is recursive we find the recursive names
+- and others in the surrounding scope. *)
+- lookupVal =
+- if isRec
+- then lookupDefault (#lookup recEnv) (#lookupVal env)
+- else #lookupVal env,
+- lookupType = #lookupType env,
+- lookupFix = #lookupFix env,
+- lookupStruct = #lookupStruct env,
+- lookupSig = #lookupSig env,
+- lookupFunct = #lookupFunct env,
+- (* Extend the environment of type variables. *)
+- lookupTvars =
+- lookupDefault (#lookup explicit)
+- (lookupDefault (#lookup implicit) (#lookupTvars env)),
+- enterVal = #enterVal env,
+- enterType = #enterType env,
+- enterFix = #enterFix env,
+- enterStruct = #enterStruct env,
+- enterSig = #enterSig env,
+- enterFunct = #enterFunct env
+- }
+-
+- val typ = assignValues newLevel letDepth line newEnv exp exp;
+-
+- val U : unit = unify (d, typ, lex, line, foundNear v);
+-
+- (* true if the expression is a possibly-constrained fn-expression *)
+- fun isConstrainedFn (exp : parsetree) : bool =
+- case exp of
+- Constraint {value, ...} => isConstrainedFn value
+- | Fn _ => true
+- | _ => false;
+- in
+- (* Must check that the expression is of the form FN match. *)
+- (* N.B. the code generator assumes this is true. *)
+- if isRec andalso not (isConstrainedFn exp)
+- then errorNear (lex, true, v, line,
+- "Recursive declaration is not of the form `fn match'")
+- else ();
+-
+- checkTypes dl ptl isRec
+- end
+-
+- | checkTypes decs _ isRec =
+- raise InternalError "checkTypes: badly-formed parse-tree";
+-
+-
+- (* Variables, constructors and fn are non-expansive.
+- [] is a derived form of "nil" so must be included.
+- Integer and string constants are also constructors but
+- cannot involve imperative type variables. Constrained
+- versions are also non-expansive.
+- This has been extended and made more explicit in ML 97. *)
+- fun nonExpansive (Fn _) = true
+- | nonExpansive (Ident _) = true
+- | nonExpansive (List []) = true
+- | nonExpansive (List elems) = not (getParameter ml90Tag (debugParams lex)) andalso
+- List.foldl (fn (v, a) => a andalso nonExpansive v)
+- true elems
+- | nonExpansive (Constraint {value, ...}) = nonExpansive value
+- | nonExpansive (Literal _) = true
+- | nonExpansive Unit = true
+- | nonExpansive (TupleTree elems) =
+- not (getParameter ml90Tag (debugParams lex))
+- andalso List.foldl (fn (v, a) => a andalso nonExpansive v)
+- true elems
+- | nonExpansive (Labelled{recList, ...}) =
+- not (getParameter ml90Tag (debugParams lex))
+- andalso List.foldl (fn ((n, v), a) => a andalso nonExpansive v)
+- true recList (* Every element must be non-expansive *)
+- | nonExpansive (Applic{f, arg}) =
+- not (getParameter ml90Tag (debugParams lex)) andalso isNonRefConstructor f andalso nonExpansive arg
+- | nonExpansive (Selector _) = not (getParameter ml90Tag (debugParams lex)) (* derived from fn {..} => ...*)
+- | nonExpansive _ = false
+-
+- (* An application is non-expansive only if it is a, possibly
+- constrained, constructor which is not ref. *)
+- and isNonRefConstructor (Ident {value=ref v, name, ...}) =
+- (* Rather than looking at the name it might be better to look
+- at the operation. This is probably ok since we're not allowed
+- to rebind "ref". *)
+- isConstructor v andalso name <> "ref"
+- | isNonRefConstructor (Constraint {value, ...}) =
+- isNonRefConstructor value
+- | isNonRefConstructor _ = false
+-
+- (* Now allow generalisation on the variables being declared.
+- For imperative type variables we have to know whether the
+- expression is expansive. *)
+- fun allowGen decs [] = ()
+- | allowGen decs (RecValBind :: tlist) = allowGen decs tlist
+-
+- | allowGen (d::dl) ((ValBind {exp, line,...}) :: ptl) =
+- let
+- val U : unit =
+- allowGeneralisation
+- (d, newLevel, nonExpansive exp, lex, line, foundNear v);
+- (* Check the type to make sure that a local datatype is
+- not escaping. Checking here is really only needed in the
+- recursive case (where a recursive call inside the body
+- sets the type of the function) because the result will be
+- checked elsewhere. *)
+- val U: unit =
+- checkForLocalDatatypes(d, letDepth, giveError (v, lex, line))
+- in
+- allowGen dl ptl
+- end (* allowGen *)
+-
+- | allowGen _ _ =
+- raise InternalError "allowGen: badly-formed parse-tree";
+-
+- val U : unit = checkTypes decs valdecs false;
+- val U : unit = allowGen decs valdecs;
+- (* And declare the new names into the surrounding environment. *)
+- val U : unit = #apply newEnv
+- (fn nv as (_, var) => (#enterVal env nv; variables := var :: !variables));
+- in
+- badType (* Type should not be used *)
+- end (* assValDeclaration *)
+-
+- and assFunDeclaration (tlist: fvalbind list) explicit implicit =
+- let
+- val funLevel = level + 1; (* Level for function names. *)
+-
+- (* Set the scope of explicit type variables. *)
+- val U: unit =
+- #apply explicit(fn (name, tv) => setTvarLevel (tv, funLevel));
+-
+- (* For each implicit type variable associated with this value declaration,
+- link it to any type variable with the same name in an outer
+- scope. *)
+- val () =
+- #apply implicit
+- (fn (name, tv) =>
+- case #lookupTvars env name of SOME v => linkTypeVars(v, tv) | NONE => setTvarLevel (tv, funLevel));
+- (* If it isn't there set the level of the type variable. *)
+-
+- (* Construct a new environment for the variables. *)
+- fun msgFn name =
+- errorNear (lex, true, v, line,
+- name ^ " has already been bound in this declaration");
+-
+- val newEnv = noDuplicates msgFn;
+-
+- fun getName pat =
+- case pat of
+- Constraint {value, ...} => getName value
+- | Applic {f, arg} => getName f
+- | Ident {name, ...} => name
+- | _ => ""; (* error - report it later. *)
+-
+- fun getArity pat =
+- case pat of
+- Constraint {value, ...} => getArity value
+- | Applic {f, arg} => getArity f + 1
+- | Ident {name, ...} => 0
+- | _ => 0; (* error - report it later. *)
+-
+- (* Since this is a recursive declaration we must get the function
+- names first. Because of the way they are parsed they are hidden
+- as applications of the function to one or more patterns. There
+- may be more than one clause in a function binding but each
+- should declare the same function and have the same number of
+- patterns. We need to know the number of patterns and the
+- function name in the third pass so we save them in the
+- function binding. *)
+-
+- (* findNameAndPatts. Find the name and number of patterns in the
+- first of the clauses. The other clauses should be the same.
+- We check that later. *)
+- fun findNameAndPatts (FValBind {clauses = (FValClause {dec, exp, line}::_), numOfPatts, functVar, ...}) =
+- let
+- (* Just look at the first clause for the moment. *)
+- val name = getName dec;
+- val arity = getArity dec;
+-
+- (* Declare a new identifier with this name. *)
+- val funVar =
+- mkVar (name, mkTypeVar (funLevel, false, false, false));
+-
+- val U : unit = numOfPatts := arity;
+-
+- val U : unit =
+- (* Put the results onto the function binding. *)
+- if arity = 0
+- then errorNear (lex, true, v, line,
+- "Clausal function does not have any parameters.")
+- else ();
+- in
+- if name <> ""
+- then let
+- (* Must not be qualified *)
+- val U : unit = checkForDots (name, lex, line);
+- (* Must not be "true", "false" etc. but may be "it" *)
+- val U : unit = checkForBuiltIn (name, v, lex, line, false) : unit;
+-
+- (* Look up the name to check it isn't a constructor. *)
+- (* This check no longer applies in ML97. *)
+- val value = getOpt(#lookupVal env name, undefinedValue);
+- val U :unit =
+- if getParameter ml90Tag (debugParams lex) andalso isConstructor value
+- then errorNear (lex, true, v, line,
+- "Variable " ^ String.toString name ^
+- " already declared as a constructor")
+- else ()
+-
+- val U : unit = functVar := funVar;
+- in
+- (* Enter it in the environment. *)
+- #enter newEnv (name, funVar)
+- end
+- else ()
+- end
+- | findNameAndPatts _ =
+- raise InternalError "findNameAndPatts: badly-formed parse-tree";
+-
+- val () = List.app findNameAndPatts tlist;
+-
+- (* Can now process the clausal functions in the environment
+- of the function names and using the information about
+- function name and number of patterns we have saved. *)
+- fun processFun (FValBind {clauses, numOfPatts, functVar, argType, resultType})=
+- let
+- val functVar = !functVar;
+-
+- (* Each fun binding in the declaration may consist of several
+- clauses. Each must have the same function name, the same
+- number of patterns and a unifiable type. *)
+- fun processClause (FValClause {dec, exp, line}) =
+- let
+- (* Each clause is a val binding with the function
+- and patterns as the `pattern' and the function body
+- as the `expression' *)
+-
+- (* Construct a new environment for the variables
+- in the patts. *)
+- fun messFn name =
+- errorNear (lex, true, dec, line,
+- name ^ " has already been bound in this clause.");
+-
+- val varEnv = noDuplicates messFn;
+-
+- val varLevel = funLevel + 1; (* Level for variables. *)
+-
+- (* Processes a single alternative. Similar to processPattern.
+- A variable for the function being declared is passed as a
+- parameter so that its type can be used for the result. *)
+- fun doPatterns pat numOfPats : types * types list =
+- case pat of
+- Constraint {value, given} =>
+- let (* Check the constraint against the returned type. *)
+- val (patType, argTypes) = doPatterns value numOfPats;
+- val U : unit = ptAssignTypes given pat line;
+-
+- (* These must be unifiable. *)
+- val U : unit =
+- unify (patType, given, lex, line, foundNear dec);
+- in
+- (patType, argTypes)
+- end
+-
+- | Applic {f, arg} =>
+- let
+- (* Apply the function to this pattern. Return the result
+- type. This will have the effect of making the
+- function we are declaring into a function from the
+- type of the pattern to some other type yet to be
+- determined. This type will be found when we unify
+- with the body of the function. *)
+- val (funType, argTypes) = doPatterns f (numOfPats - 1);
+- val argType =
+- processPattern arg (#enter varEnv) varLevel false false line;
+- in
+- (apply (funType, argType, lex, line, foundNear dec), argType :: argTypes)
+- end
+-
+- | Ident {name, value, ...} =>
+- let
+- (* We have presumably reached the function name. *)
+- val functName = valName functVar;
+- in
+- (* Must check this is the same name. *)
+- if name = functName then ()
+- else errorNear (lex, true, dec, line,
+- "In clausal function one clause defines "^
+- name ^ " and another defines " ^ functName);
+-
+- (* And it has the same number of patterns. *)
+- if numOfPats = 0 then ()
+- else errorNear
+- (lex, true, dec, line,
+- "Clausal function contains clauses with " ^
+- "different numbers of patterns");
+-
+- value := functVar;
+- (valTypeOf functVar, []) (* Return function type. *)
+- end
+-
+- | EmptyTree =>
+- (badType, [])
+-
+- | _ =>
+- let (* error *)
+- val U : unit =
+- errorNear (lex, true, pat, line,
+- "Start of clausal function is not a variable")
+- in
+- (badType, [])
+- end
+- (* end doPatterns *);
+-
+- val (pattType, argTypeList) = doPatterns dec (!numOfPatts);
+- val () = argType :=
+- (case argTypeList of
+- [] => badType (* error *)
+- | [single] => single
+- | multiple => mkProductType(List.rev multiple))
+-
+- (* The identifiers declared in the pattern are available in the
+- body of the function. Since it is recursive the function
+- names are also available. *)
+- val bodyEnv =
+- {
+- lookupVal =
+- lookupDefault (#lookup varEnv)
+- (lookupDefault (#lookup newEnv) (#lookupVal env)),
+- lookupType = #lookupType env,
+- lookupFix = #lookupFix env,
+- lookupStruct = #lookupStruct env,
+- lookupSig = #lookupSig env,
+- lookupFunct = #lookupFunct env,
+- (* Extend the environment of type variables. *)
+- lookupTvars =
+- lookupDefault (#lookup explicit)
+- (lookupDefault (#lookup implicit) (#lookupTvars env)),
+- enterVal = #enterVal env,
+- enterType = #enterType env,
+- enterFix = #enterFix env,
+- enterStruct = #enterStruct env,
+- enterSig = #enterSig env,
+- enterFunct = #enterFunct env
+- };
+-
+- (* Now the body. *)
+- (* The type from `doPatterns' is the effect of applying
+- the function to the patterns. This must be unified with
+- the type of the expression which will set the result type
+- of the function. *)
+- val expTyp =
+- assignValues varLevel letDepth line bodyEnv exp exp;
+-
+- in (* body of processClause *)
+- (* Remember the result type for the debugger. Actually this
+- assigns the result type for each clause in the fun but
+- they will all be the same type because we've used the same
+- variable for the function in each pattern. *)
+- resultType := expTyp;
+- (* Unify the pattern and the clause body. *)
+- unify (pattType, expTyp, lex, line, foundNear dec)
+- end
+- in (* body of processFun *)
+- List.app processClause clauses
+- end
+-
+- val () = List.app processFun tlist;
+-
+- (* Now declare the new names into the surrounding environment,
+- releasing the copy flags on the type variables. All fun
+- bindings are non-expansive. *)
+- val U : unit =
+- #apply newEnv
+- (fn (pair as (name, var)) =>
+- let
+- val ty: types = valTypeOf var
+- val U : unit =
+- allowGeneralisation(ty, funLevel, true, lex, line, foundNear v);
+- (* Check the type to make sure that a local datatype is
+- not escaping as a result of a recursive application of
+- the function to a local datatype. *)
+- val U: unit =
+- checkForLocalDatatypes(ty, letDepth, giveError (v, lex, line))
+- in
+- #enterVal env pair
+- end);
+- in
+- badType (* Type should not be used *)
+- end (* FunDeclaration *)
+-
+- and assAbsData isAbs (typeList : datatypebind list) withtypes declist =
+- let
+- (* A type declaration causes a type to be entered in the type
+- environment, together with some constructors. *)
+- fun messFn name =
+- errorNear (lex, true, v, line,
+- name ^ " has already been bound in this declaration");
+-
+- val newEnv = noDuplicates messFn;
+-
+- (* datatype and abstype declarations are both recursive so we can
+- enter the type names into the environment during a first pass,
+- and then process the value constructors during a second. *)
+- fun enterType tcon typeName =
+- (
+- checkForDots (typeName, lex, line) : unit; (* Must not be qualified *)
+- #enter newEnv (typeName, tcon); (* Check for duplicates. *)
+- #enterType env (typeName, tcon) (* and put in the enclosing scope *)
+- );
+-
+- (* Make the type constructors and put them in a list. *)
+- fun enterTcon (DatatypeBind {name, tcon, typeVars, ...}) =
+- let
+- val tc =
+- makeTypeConstrs (strName ^ name, typeVars, emptyType,
+- makeTypeId (), false, letDepth)
+- in
+- tcon := tc;
+- enterType tc name;
+- tc
+- end
+-
+- val listOfTypes = map enterTcon typeList;
+-
+- (* First match all the types on the right-hand sides using the
+- datatypes and the existing bindings. *)
+- fun processType (TypeBind {decType, ...}) = ptAssignTypes decType v line
+- val () = List.app processType withtypes;
+-
+- (* Can now enter the `withtypes'. *)
+- fun enterWithType (TypeBind {name, typeVars, decType, ...}) =
+- let
+- (* Construct a type constructor which is an alias of the
+- right-hand side of the declaration. *)
+- val tcon =
+- makeTypeConstrs (strName ^ name, typeVars, decType, makeTypeId (),
+- false, 0);
+- in
+- enterType tcon name
+- end
+- val () = List.app enterWithType withtypes;
+-
+- (* For the constructors *)
+- fun messFn name =
+- errorNear (lex, true, v, line,
+- name ^ " has already been used as a constructor in this type");
+-
+- val consEnv = noDuplicates messFn;
+-
+- (* Now process the types and generate the constructors. *)
+- fun genValueConstrs (DatatypeBind {name, typeVars, constrs, ...}, typ) =
+- let
+- val numOfConstrs = length constrs;
+-
+- (* The new constructor applied to the type variables (if any) *)
+- val resultType = mkTypeConstruction (name, typ, typeVars);
+-
+- (* Sort the constructors by name. This simplifies matching with
+- datatypes in signatures. *)
+- fun leq (xname: string, _) (yname, _) = xname < yname;
+- val sortedConstrs = quickSort leq constrs;
+-
+- fun processConstr ((name, argtype), repn) =
+- let
+- val cons =
+- if isEmpty argtype
+- then mkGconstr (name, resultType, repn, true)
+- else mkGconstr (name, mkFunctionType (argtype, resultType), repn, false);
+-
+- (* Name must not be qualified *)
+- val U : unit = checkForDots (name, lex, line);
+- (* Must not be "true", "false" etc. *)
+- val U : unit = checkForBuiltIn (name, v, lex, line, true) : unit;
+-
+- (* Put into the environment. *)
+- val U : unit = #enter consEnv (name, cons);
+- in
+- cons
+- end (* processConstr *)
+-
+- (* Declares the constructors and return a list of them. *)
+- fun decCons cs =
+- let
+- (* Match up identifiers to type constructors. *)
+- (* This side-effects "argtype" to set equivalence fields *)
+- val () = List.app(fn (_, t) => ptAssignTypes t v line) cs
+-
+- (* Choose the representation for the constructors. *)
+- val reprs = chooseConstrRepr cs;
+- in
+- ListPair.map processConstr (cs,reprs)
+- end; (* decCons*)
+-
+- in
+- tcSetConstructors (typ, decCons sortedConstrs) : unit
+- end (* genValueConstrs *)
+-
+- val U : unit = ListPair.app genValueConstrs (typeList, listOfTypes);
+-
+-
+- (* Third pass - Check to see if equality testing is allowed for
+- these types. No error messages should be produced. In ML90
+- we did not do this here for datatypes in signatures. Instead
+- all the datatypes in a signature were analysed as a whole. *)
+- val U : unit =
+- genEqualityFunctions(listOfTypes, fn s => raise InternalError s, false) ;
+-
+- (* If this is a datatype declaration the value constructors should be
+- entered in the surrounding scope, otherwise (abstract type
+- declaration) we evaluate the declarations in an environment
+- containing the value constructors, but the value constructors
+- themselves do not appear in the surrounding scope. *)
+- val U : unit =
+- if not isAbs
+- then #apply consEnv (#enterVal env)
+- else let (* Abstract type *)
+- (* The declarations have to be evaluated in an environment in
+- which the constructors have been declared. When an identifier
+- is looked up it may:
+- (a) be one of these new declarations, or else
+- (b) be a constructor from the type declarations, or else
+- (c) be outside the abstract type declaration.
+- New declarations are entered in the local environment so that
+- they can be found under (a) and in the surrounding environment
+- where they will be available after this declaration. *)
+- val decEnv =
+- let
+- val localEnv = searchList ();
+- fun enterValFn (pair as (name, v)) =
+- (#enter localEnv pair;
+- #enterVal env pair);
+- val lookupValFn =
+- lookupDefault (#lookup localEnv)
+- (lookupDefault (#lookup consEnv) (#lookupVal env))
+- in
+- {
+- lookupVal = lookupValFn,
+- lookupType = #lookupType env,
+- lookupFix = #lookupFix env,
+- lookupStruct = #lookupStruct env,
+- lookupSig = #lookupSig env,
+- lookupFunct = #lookupFunct env,
+- lookupTvars = #lookupTvars env,
+- enterVal = enterValFn,
+- enterType = #enterType env,
+- enterFix = #enterFix env,
+- enterStruct = #enterStruct env,
+- enterSig = #enterSig env,
+- enterFunct = #enterFunct env
+- }
+- end;
+-
+- (* Process the declarations, discarding the result. *)
+- val U : types = assignSeq decEnv letDepth declist;
+-
+- fun setConstructors (DatatypeBind {tcon=ref tc, valueConstrs, ...}) =
+- (
+- tcSetEquality (tc, false);
+- valueConstrs := tcConstructors tc;
+- tcSetConstructors (tc, [])
+- )
+- in
+- (* Now clobber the equality operations and the constructor list
+- - equality and printing are not allowed outside the abstract
+- type declaration, and the type should not match a datatype
+- in a signature. The problem is that we need the constructor
+- list for exhaustiveness checking of patterns inside the abstype
+- declaration but we do exhaustiveness checking during the code
+- generation phase. *)
+- List.app setConstructors typeList
+- end;
++ (* Third pass - Check to see if equality testing is allowed for
++ these types. *)
++ val () = computeDatatypeEqualities listOfTypes;
++
++ (* If this is a datatype declaration the value constructors should be
++ entered in the surrounding scope, otherwise (abstract type
++ declaration) we evaluate the declarations in an environment
++ containing the value constructors, but the value constructors
++ themselves do not appear in the surrounding scope. *)
++ val () =
++ if not isAbs
++ then #apply consEnv (#enterVal env)
++ else
++ let (* Abstract type *)
++ (* The declarations have to be evaluated in an environment in
++ which the constructors have been declared. When an identifier
++ is looked up it may:
++ (a) be one of these new declarations, or else
++ (b) be a constructor from the type declarations, or else
++ (c) be outside the abstract type declaration.
++ New declarations are entered in the local environment so that
++ they can be found under (a) and in the surrounding environment
++ where they will be available after this declaration. *)
++ val decEnv =
++ let
++ val localEnv = searchList ();
++ fun enterValFn pair = ( #enter localEnv pair; #enterVal env pair);
++ val lookupValFn =
++ lookupDefault (#lookup localEnv)
++ (lookupDefault (#lookup consEnv) (#lookupVal env))
++ in
++ {
++ lookupVal = lookupValFn,
++ lookupType = #lookupType env,
++ lookupFix = #lookupFix env,
++ lookupStruct = #lookupStruct env,
++ lookupSig = #lookupSig env,
++ lookupFunct = #lookupFunct env,
++ lookupTvars = #lookupTvars env,
++ enterVal = enterValFn,
++ enterType = #enterType env,
++ enterFix = #enterFix env,
++ enterStruct = #enterStruct env,
++ enterSig = #enterSig env,
++ enterFunct = #enterFunct env
++ }
++ end;
++
++ in
++ (* Process the declarations, discarding the result. *)
++ assignSeq decEnv letDepth declist;
++ (* Turn off equality outside the with..end block. This is required by the
++ "Abs" function defined in section 4.9 of the ML Definition.
++ We need to record the equality status, though, because we need
++ to reinstate this for code-generation. *)
++ equalityStatus := List.map tcEquality listOfTypes;
++ List.app(fn tc => tcSetEquality (tc, false)) listOfTypes;
++ ()
++ end;
+ in
+- badType (* Does not return a type *)
+- end (* assAbsData *)
+- in
++ badType (* Does not return a type *)
++ end (* assAbsData *)
++ in
+ assValues near v
+- end (* assignValues *);
++ end (* assignValues *);
+
+ val Env gEnv = env
+
+@@ -3353,7 +3661,7 @@
+ lookupStruct = #lookupStruct gEnv,
+ lookupSig = #lookupSig gEnv,
+ lookupFunct = #lookupFunct gEnv,
+- lookupTvars = fn name => NONE,
++ lookupTvars = fn _ => NONE,
+ enterVal = #enterVal gEnv,
+ enterType = #enterType gEnv,
+ enterFix = #enterFix gEnv,
+@@ -3362,7 +3670,7 @@
+ enterFunct = #enterFunct gEnv
+ };
+ in
+- assignValues 1 0 line env v v
++ assignValues(1, 0, env, v, v)
+ end (* pass2 *);
+
+
+@@ -3412,66 +3720,67 @@
+ end;
+
+ (* tupleWidth returns the width of a tuple or record or 1 if it
+- isn't one. It is used to detect both argument tuples and results.
+- When used for arguments the idea is that frequently a tuple is
+- used as a way of passing multiple arguments and these can be
+- passed on the stack. When used for results the idea is to
+- create the result tuple on the stack and avoid garbage collector
+- and allocator time. If we could tell that the caller was simply going
+- to explode it we would gain but if the caller needed a
+- tuple on the heap we wouldn't. We wouldn't actually lose
+- if we were going to create a tuple and return it but we
+- would lose if we exploded a tuple here and then created
+- a new one in the caller.
+- This version of the code assumes that if we create a tuple
+- on one branch we're going to create one on others which may
+- not be correct. *)
+- fun tupleWidth(TupleTree l) = List.length l
++ isn't one. It is used to detect both argument tuples and results.
++ When used for arguments the idea is that frequently a tuple is
++ used as a way of passing multiple arguments and these can be
++ passed on the stack. When used for results the idea is to
++ create the result tuple on the stack and avoid garbage collector
++ and allocator time. If we could tell that the caller was simply going
++ to explode it we would gain but if the caller needed a
++ tuple on the heap we wouldn't. We wouldn't actually lose
++ if we were going to create a tuple and return it but we
++ would lose if we exploded a tuple here and then created
++ a new one in the caller.
++ This version of the code assumes that if we create a tuple
++ on one branch we're going to create one on others which may
++ not be correct. *)
++ fun tupleWidth(TupleTree(l, _)) = List.length l
+
+- | tupleWidth(Labelled{typeof, ...}) =
+- if recordNotFrozen (! typeof) (* An error, but reported elsewhere. *)
++ | tupleWidth(Labelled{expType=ref expType, ...}) =
++ if recordNotFrozen expType (* An error, but reported elsewhere. *)
+ then 1 (* Safe enough *)
+- else recordWidth (! typeof)
++ else recordWidth expType
++
++ | tupleWidth(Cond{thenpt, elsept, ...}) =
++ let
++ val w = tupleWidth thenpt
++ in
++ if w = 1
++ then tupleWidth elsept
++ else w
++ end
++
++ | tupleWidth(Constraint{value, ...}) =
++ tupleWidth value
++
++ | tupleWidth(HandleTree{exp, ...}) =
++ (* Look only at the expression and ignore
++ the handlers on the, possibly erroneous,
++ assumption that they won't normally be
++ executed. *)
++ tupleWidth exp
++
++ | tupleWidth(Localdec{body=[], ...}) =
++ raise InternalError "tupleWidth: empty localdec"
++ | tupleWidth(Localdec{body, ...}) =
++ (* We are only interested in the last expression. *)
++ tupleWidth(List.last body)
++
++ | tupleWidth(Case{match, ...}) =
++ let
++ fun getWidth(MatchTree{exp, ...}) = tupleWidth exp
++ in
++ List.foldl(fn(v, 1) => getWidth v | (_, s) => s)
++ 1 match
++ end
+
+- | tupleWidth(Cond{thenpt, elsept, ...}) =
+- let
+- val w = tupleWidth thenpt
+- in
+- if w = 1
+- then tupleWidth elsept
+- else w
+- end
+-
+- | tupleWidth(Constraint{value, ...}) =
+- tupleWidth value
+-
+- | tupleWidth(HandleTree{exp, ...}) =
+- (* Look only at the expression and ignore
+- the handlers on the, possibly erroneous,
+- assumption that they won't normally be
+- executed. *)
+- tupleWidth exp
+-
+- | tupleWidth(Localdec{body=[], ...}) =
+- raise InternalError "tupleWidth: empty localdec"
+- | tupleWidth(Localdec{body, ...}) =
+- (* We are only interested in the last expression. *)
+- tupleWidth(#1(List.last body))
+-
+- | tupleWidth(Case{match, ...}) =
+- let
+- fun getWidth(MatchTree{exp, ...}) = tupleWidth exp
+- | getWidth _ = raise InternalError "getWidth"
+- in
+- List.foldl(fn(v, 1) => getWidth v | (_, s) => s)
+- 1 match
+- end
++ | tupleWidth(Parenthesised(p, _)) = tupleWidth p
+
+- | tupleWidth _ = 1
++ | tupleWidth _ = 1
+ in
+ (* Start of the code-generator itself. *)
+- type debugenv = environEntry list * (int->codetree)
+-
++ type debugenv = environEntry list * (int->codetree)
++
+ (* Code generates the parse tree. `pt' is the tree of declarations,
+ `valDeclarations' and `exDeclarations' are the lists of the value
+ and exception variables which have been declared at the top level.
+@@ -3481,7 +3790,7 @@
+ to `gencode' to handle structure declarations containing applications
+ of functors. *)
+ fun gencode (pt : parsetree, lex: lexan, debugEnv: debugenv, level,
+- addresses, structName: string, line) : codetree list * debugenv =
++ addresses, structName: string) : codetree list * debugenv =
+ let
+ fun mkAddr () =
+ let
+@@ -3492,9 +3801,26 @@
+ end;
+
+ val level = ref level; (* Incremented by one for each nested proc. *)
+- val lastLine = ref 0 (* The last line for which we produced debug info. *)
+- val fileName = getParameter fileNameTag (debugParams lex)
++ val lastLine = ref 0 (* The last line for which we produced debug info. *)
++
++ (* Report unreferenced identifiers. *)
++ val reportUnref = getParameter reportUnreferencedIdsTag (debugParams lex)
++
++ fun reportUnreferencedValue
++ (Value{name, references=SOME{exportedRef=ref false, localRef=ref nil}, locations, ...}) =
++ let
++ fun getDeclLoc (DeclaredAt loc :: _) = loc
++ | getDeclLoc (_ :: locs) = getDeclLoc locs
++ | getDeclLoc [] = nullLocation (* Shouldn't happen. *)
++ in
++ if reportUnref
++ then warningMessage(lex, getDeclLoc locations,
++ "Value identifier ("^name^") has not been referenced.")
++ else ()
++ end
++ | reportUnreferencedValue _ = ()
+
++
+ (* Debugging control and debug function. *)
+ val debugging = getParameter debugTag (debugParams lex)
+
+@@ -3503,135 +3829,143 @@
+ SOME f => Universal.tagProject DEBUGGER.debuggerFunTag f
+ | NONE => DEBUGGER.nullDebug
+
+- (* Add a call to the debugger. *)
+- fun addDebugCall (decName: string, (ctEnv, rtEnv), line: int) : codetree =
+- let
++ (* Add a call to the debugger. *)
++ fun addDebugCall (decName: string, (ctEnv, rtEnv), location) : codetree =
++ let
+ open DEBUGGER
+- val debugger =
+- debugFunction(debuggerFun, DebugStep, fileName, decName, line) ctEnv
+- in
+- lastLine := line;
+- mkEval(mkConst(toMachineWord debugger), [rtEnv(!level)], false)
+- end
+-
+- (* Add a debug call if line has changed. This is used between
+- declarations and expression sequences to avoid more than one
+- call on a line. *)
+- fun changeLine (decName, env, line) =
+- if not debugging orelse line = !lastLine then []
+- else [addDebugCall(decName, env, line)]
+-
+- fun createDebugEntry (v: values, (ctEnv, rtEnv), loadVal) =
+- if not debugging
+- then { dec = [], rtEnv = rtEnv, ctEnv = ctEnv }
+- else let
+- val newEnv =
+- (* Create a new entry in the environment. *)
+- mkTuple [ loadVal (* Value. *), rtEnv(!level) ]
+- val { dec, load } = multipleUses (newEnv, mkAddr, !level)
+- val ctEntry =
+- case v of
+- Value{class=Exception, name, typeOf, ...} =>
+- EnvException(name, typeOf)
+- | Value{class=Constructor{nullary}, name, typeOf, ...} =>
+- EnvVConstr(name, typeOf, nullary)
+- | Value{name, typeOf, ...} =>
+- EnvValue(name, typeOf)
+- in
+- { dec = dec, rtEnv = load, ctEnv = ctEntry :: ctEnv}
+- end
+-
+- (* Start a new static level. This is currently used only to
+- distinguish function arguments from the surrounding static
+- environment. *)
+- fun newDebugLevel (ctEnv, rtEnv) = (EnvStaticLevel :: ctEnv, rtEnv)
+-
+- fun makeDebugEntries (vars: values list, debugEnv: debugenv) =
+- if debugging
+- then
+- let
+- fun loadVar (var, (decs, env)) =
+- let
+- val loadVal =
+- codeVal (var, !level, valTypeOf var, lex, line)
+- val {dec, rtEnv, ctEnv} =
+- createDebugEntry(var, env, loadVal)
+- in
+- (decs @ dec, (ctEnv, rtEnv))
+- end
+- in
+- List.foldl loadVar ([], debugEnv) vars
+- end
+- else ([], debugEnv)
+-
+- (* In order to build a call stack in the debugger we need to know about
+- function entry and exit. It would be simpler to wrap the whole function
+- in a debug function (i.e. loop the call through the debugger) but that
+- would prevent us from using certain call optimisations. *)
+- fun wrapFunctionInDebug(body: codetree, name: string, argCode: codetree,
+- argType: types, restype: types, (ctEnv, rtEnv)): codetree =
+- if not debugging then body (* Return it unchanged. *)
+- else
+- let
++ val currLine = #startLine location
++ val debugger =
++ debugFunction(debuggerFun, DebugStep, decName, location) ctEnv
++ in
++ lastLine := currLine;
++ mkEval(mkConst(toMachineWord debugger), [rtEnv(!level)], false)
++ end
++
++ (* Add a debug call if line has changed. This is used between
++ declarations and expression sequences to avoid more than one
++ call on a line. *)
++ fun changeLine (decName, env, loc) =
++ if not debugging orelse #startLine loc = !lastLine then []
++ else [addDebugCall(decName, env, loc)]
++
++ fun createDebugEntry (v: values, (ctEnv, rtEnv), loadVal) =
++ if not debugging
++ then { dec = [], rtEnv = rtEnv, ctEnv = ctEnv }
++ else let
++ val newEnv =
++ (* Create a new entry in the environment. *)
++ mkTuple [ loadVal (* Value. *), rtEnv(!level) ]
++ val { dec, load } = multipleUses (newEnv, mkAddr, !level)
++ val ctEntry =
++ case v of
++ Value{class=Exception, name, typeOf, locations, ...} =>
++ EnvException(name, typeOf, locations)
++ | Value{class=Constructor{nullary, ofConstrs, ...}, name, typeOf, locations, ...} =>
++ EnvVConstr(name, typeOf, nullary, ofConstrs, locations)
++ | Value{name, typeOf, locations, ...} =>
++ EnvValue(name, typeOf, locations)
++ in
++ { dec = dec, rtEnv = load, ctEnv = ctEntry :: ctEnv}
++ end
++
++ (* Start a new static level. This is currently used only to
++ distinguish function arguments from the surrounding static
++ environment. *)
++ fun newDebugLevel (ctEnv, rtEnv) = (EnvStaticLevel :: ctEnv, rtEnv)
++
++ fun makeDebugEntries (vars: values list, debugEnv: debugenv) =
++ if debugging
++ then
++ let
++ fun loadVar (var, (decs, env)) =
++ let
++ val loadVal =
++ codeVal (var, !level, valTypeOf var, lex, nullLocation)
++ val {dec, rtEnv, ctEnv} =
++ createDebugEntry(var, env, loadVal)
++ in
++ (decs @ dec, (ctEnv, rtEnv))
++ end
++ in
++ List.foldl loadVar ([], debugEnv) vars
++ end
++ else ([], debugEnv)
++
++ (* In order to build a call stack in the debugger we need to know about
++ function entry and exit. It would be simpler to wrap the whole function
++ in a debug function (i.e. loop the call through the debugger) but that
++ would prevent us from using certain call optimisations. *)
++ fun wrapFunctionInDebug(body: codetree, name: string, argCode: codetree,
++ argType: types, restype: types, location, (ctEnv, rtEnv)): codetree =
++ if not debugging then body (* Return it unchanged. *)
++ else
++ let
+ open DEBUGGER
+ (* At the moment we can't deal with function arguments. *)
+ fun enterFunction (rtEnv, args) =
+- debugFunction(debuggerFun, DebugEnter(args, argType), fileName, name, line) ctEnv rtEnv
++ debugFunction(debuggerFun, DebugEnter(args, argType), name, location) ctEnv rtEnv
+ and leaveFunction (rtEnv, result) =
+- (debugFunction(debuggerFun, DebugLeave(result, restype), fileName, name, line) ctEnv rtEnv; result)
++ (debugFunction(debuggerFun, DebugLeave(result, restype), name, location) ctEnv rtEnv; result)
+ and exceptionFunction (rtEnv, exn) =
+- (debugFunction(debuggerFun, DebugException exn, fileName, name, line) ctEnv rtEnv; raise exn)
++ (debugFunction(debuggerFun, DebugException exn, name, location) ctEnv rtEnv; raise exn)
++
++ val entryCode = toMachineWord enterFunction
++ and exitCode = toMachineWord leaveFunction
++ and exceptionCode = toMachineWord exceptionFunction
++ val ldexAddr = mkAddr ()
++ in
++ mkEnv [
++ (* Call the enter code. *)
++ mkEval(mkConst entryCode, [mkTuple[rtEnv(!level), argCode]], false),
++ (* Call the exit code with the function result. The
++ function is wrapped in a handler that catches all
++ exceptions and calls the exception code. *)
++ mkEval(mkConst exitCode,
++ [mkTuple[rtEnv(!level), mkHandle (body, [CodeZero (* all exceptions *)],
++ mkEnv
++ [
++ (* Must save the exception packet first. *)
++ mkDec(ldexAddr, Ldexc),
++ mkEval(mkConst exceptionCode,
++ [mkTuple[rtEnv(!level), mkLoad(ldexAddr, 0)]], false)])
++ ]
++ ], false)
++ ]
++ end
++
++ (* datatype 'a option = SOME of 'a | NONE *)
+
+- val entryCode = toMachineWord enterFunction
+- and exitCode = toMachineWord leaveFunction
+- and exceptionCode = toMachineWord exceptionFunction
+- in
+- mkEnv [
+- (* Call the enter code. *)
+- mkEval(mkConst entryCode, [mkTuple[rtEnv(!level), argCode]], false),
+- (* Call the exit code with the function result. The
+- function is wrapped in a handler that catches all
+- exceptions and calls the exception code. *)
+- mkEval(mkConst exitCode,
+- [mkTuple[rtEnv(!level), mkHandle (body, [CodeZero (* all exceptions *)],
+- mkEval(mkConst exceptionCode, [mkTuple[rtEnv(!level), Ldexc]], false))]
+- ], false)
+- ]
+- end
+-
+- (* datatype 'a option = SOME of 'a | NONE *)
+-
+- (* Convert a literal constant. We can only do this once any overloading
+- has been resolved. *)
+- fun getLiteralValue(converter, literal, instance, line, near): machineWord option =
+- let
+- val (conv, name) =
+- getOverloadInstance(valName converter, instance, true, lex, line)
+- in
+- SOME(RunCall.unsafeCast(evalue conv) literal)
+- handle Match => NONE (* Overload error *)
+- | Conversion s =>
+- (
+- errorNear (lex, true, near, line,
+- "Conversion exception ("^s^") raised while converting " ^
+- literal ^ " to " ^ name);
+- NONE
+- )
+- | Overflow =>
+- (
+- errorNear (lex, true, near, line,
+- "Overflow exception raised while converting " ^
+- literal ^ " to " ^ name);
+- NONE
+- )
+- | _ =>
+- (
+- errorNear (lex, true, near, line,
+- "Exception raised while converting " ^
+- literal ^ " to " ^ name);
+- NONE
+- )
+- end
++ (* Convert a literal constant. We can only do this once any overloading
++ has been resolved. *)
++ fun getLiteralValue(converter, literal, instance, line, near): machineWord option =
++ let
++ val (conv, name) =
++ getOverloadInstance(valName converter, instance, true)
++ in
++ SOME(RunCall.unsafeCast(evalue conv) literal)
++ handle Match => NONE (* Overload error *)
++ | Conversion s =>
++ (
++ errorNear (lex, true, near, line,
++ "Conversion exception ("^s^") raised while converting " ^
++ literal ^ " to " ^ name);
++ NONE
++ )
++ | Overflow =>
++ (
++ errorNear (lex, true, near, line,
++ "Overflow exception raised while converting " ^
++ literal ^ " to " ^ name);
++ NONE
++ )
++ | _ =>
++ (
++ errorNear (lex, true, near, line,
++ "Exception raised while converting " ^
++ literal ^ " to " ^ name);
++ NONE
++ )
++ end
+
+ (* Devised by Mike Fourman, Nick Rothwell and me (DCJM). First coded
+ up by Nick Rothwell for the Kit Compiler. First phase of the match
+@@ -3667,11 +4001,6 @@
+
+ (* Set from i to j inclusive. *)
+ fun from i j = if i > j then empty else i ::: from (i + 1) j;
+-
+- fun stringOfSet p =
+- "[" ^
+- List.foldl (fn (i, s) => s ^ " " ^ Int.toString i) "" (list p) ^
+- "]";
+
+ infix 3 plus;
+ infix 4 inside;
+@@ -3725,8 +4054,6 @@
+ else if isEmpty b
+ then false
+ else first a = first b andalso next a eq next b;
+-
+- fun a neq b = not (a eq b);
+
+ end (* patSet *);
+
+@@ -3756,9 +4083,9 @@
+
+ and sconsrec =
+ {
+- eqFun: codetree, (* Equality functions for this type*)
+- specVal: machineWord option, (* The constant value. NONE here means we had
+- a conversion error. *)
++ eqFun: codetree, (* Equality functions for this type*)
++ specVal: machineWord option, (* The constant value. NONE here means we had
++ a conversion error. *)
+ patts: patSet (* Patterns containing this value. *)
+ };
+
+@@ -3781,13 +4108,13 @@
+ fun makeSconsrec eqFun specVal patts : sconsrec =
+ {
+ eqFun = eqFun,
+- specVal = specVal,
++ specVal = specVal,
+ patts = patts
+ };
+
+
+ fun aVars (Aot {vars,...}) = vars;
+-
++
+ (* An empty wild card - can be expanded as required. *)
+ val aotEmpty = makeAot Wild empty 0 [];
+
+@@ -3825,26 +4152,18 @@
+
+ (* Add a constructor to the tree. It can only be added to a
+ cons node or a wild card. *)
+- fun addConstr cons doArg (tree as Aot {patts, defaults, width, vars}) patNo =
++ fun addConstr(cons, noOfConstrs, doArg, tree as Aot {patts, defaults, width, vars}, patNo) =
+ let
+ val consName = valName cons;
+ in
+ case patts of
+ Wild =>
+- let (* Expand out the wildCard into a constructor node. *)
+- (* Get the constructor list from the type information
+- of the constructor and put the length of this list
+- into the "width". *)
+- val noOfConstrs = length (getConstrList (valTypeOf cons));
+-
+- val cr =
+- makeConsrec
+- cons
+- (singleton patNo) (* Expand the argument *)
+- (doArg (wild tree));
+- in
+- makeAot (Cons [cr]) defaults noOfConstrs vars
+- end
++ let (* Expand out the wildCard into a constructor node. *)
++ val cr =
++ makeConsrec cons (singleton patNo) (* Expand the argument *) (doArg (wild tree));
++ in
++ makeAot (Cons [cr]) defaults noOfConstrs vars
++ end
+
+ | Cons pl =>
+ let
+@@ -3871,7 +4190,7 @@
+ end (* addConstr *);
+
+ (* Add a special constructor to the tree. Very similar to preceding. *)
+- fun addSconstr eqFun cval (Aot {patts, defaults, width, vars}) patNo =
++ fun addSconstr eqFun cval (Aot {patts, defaults, vars, ...}) patNo =
+ case patts of
+ Wild => (* Expand out the wildCard into a constructor node. *)
+ makeAot
+@@ -3897,16 +4216,15 @@
+ in
+ makeAot (Scons (addClist pl)) defaults 0 vars
+ end
+-
++
+ | _ =>
+ raise InternalError "addSconstr: badly-formed and-or tree"
+ (* end addSconstr *);
+
+ (* Add an exception constructor to the tree. Similar to the above
+ except that exception constructors must be kept in order. *)
+- fun addExconstr cons arg (Aot {patts, defaults, width, vars}) patNo =
++ fun addExconstr cons arg (Aot {patts, defaults, vars, ...}) patNo =
+ let
+- val consName = valName cons;
+ in
+ case patts of
+ Wild => (* Expand out the wildCard into a constructor node. *)
+@@ -3923,15 +4241,15 @@
+
+ | Excons (cl as (h::t)) =>
+ let
+- (* The exception constructor list is maintained in reverse order.
+- We have to be careful about merging exception constructors.
+- Two exceptions may have different names but actually have the
+- same exception value, or have the same (short) name but come
+- from different structures. We only add to the last entry in
+- the list if we can tell that it is the same exception. We could
+- be more sophisticated and allow merging with other entries if
+- we could show that the entries we were skipping over were
+- definitely different, but it's probably not worth it. *)
++ (* The exception constructor list is maintained in reverse order.
++ We have to be careful about merging exception constructors.
++ Two exceptions may have different names but actually have the
++ same exception value, or have the same (short) name but come
++ from different structures. We only add to the last entry in
++ the list if we can tell that it is the same exception. We could
++ be more sophisticated and allow merging with other entries if
++ we could show that the entries we were skipping over were
++ definitely different, but it's probably not worth it. *)
+ val newList =
+ if isTheSameException (#constructor h, cons)
+ then
+@@ -3951,29 +4269,30 @@
+ in (* body of buildAot *)
+ case vars of
+ Ident {value=ref ident, ... } =>
+- (
+- case ident of
+- Value{class=Constructor _, ...} =>
+- (* Only nullary constructors. Constructors with arguments
+- will be dealt with by ``isApplic'. *)
+- addConstr ident (fn a => buildAot wildCard a patNo line) tree patNo
+- | Value{class=Exception, ...} =>
+- addExconstr ident wildCard tree patNo
+- | _ => (* variable - matches everything. Defaults here and pushes a var. *)
+- addVar (addDefault tree patNo) ident
+- )
++ (
++ case ident of
++ Value{class=Constructor {ofConstrs, ...}, ...} =>
++ (* Only nullary constructors. Constructors with arguments
++ will be dealt with by ``isApplic'. *)
++ addConstr(ident, ofConstrs,
++ fn a => buildAot (wildCard nullLocation) a patNo line, tree, patNo)
++ | Value{class=Exception, ...} =>
++ addExconstr ident (wildCard nullLocation) tree patNo
++ | _ => (* variable - matches everything. Defaults here and pushes a var. *)
++ addVar (addDefault tree patNo) ident
++ )
+
+- | TupleTree ptl => (* Tree must be a wild card or a tuple. *)
++ | TupleTree(ptl, location) => (* Tree must be a wild card or a tuple. *)
+ (case treePatts of
+ Wild =>
+ let
+- val tlist =
+- map (fn el => buildAot el (wild tree) patNo line) ptl;
+- in
+- makeAot (TupleField tlist) treeDefaults 0 treeVars
+- end
++ val tlist =
++ map (fn el => buildAot el (wild tree) patNo location) ptl;
++ in
++ makeAot (TupleField tlist) treeDefaults 0 treeVars
++ end
+
+- | TupleField pl =>
++ | TupleField pl =>
+ let (* Must be tuple already. *)
+ (* Merge each field of the tuple in with the corresponding
+ field of the existing tree. *)
+@@ -3984,150 +4303,151 @@
+ in
+ makeAot (TupleField tlist) treeDefaults 0 treeVars
+ end
+- | _ =>
+- raise InternalError "pattern is not a tuple in a-o-t")
++ | _ =>
++ raise InternalError "pattern is not a tuple in a-o-t")
+
+- | Labelled {recList, frozen, typeof} =>
++ | Labelled {recList, expType=ref expType, location, ...} =>
+ let
+- (* Treat as a tuple, but in the order of the record entries.
+- Missing entries are replaced by wild-cards. The order of
+- the patterns given may bear no relation to the order in
+- the record which will be matched.
+- e.g. case X of (a = 1, ...) => ___ | (b = 2, a = 3) => ___ *)
+-
+- (* Check that the type is frozen. *)
+- (* This check is probably redundant since we now check at the
+- point when we generalise the type (except for top-level
+- expressions - those could be detected in
+- checkForFreeTypeVariables). Retain it for the moment.
+- DCJM 15/8/2000. *)
+- val U =
+- if recordNotFrozen (! typeof)
+- then errorNear (lex, true, vars, line,
+- "Can't find a fixed record type.")
+- else ();
+-
+- (* Make a list of wild cards. *)
+- fun buildl 0 = []
+- | buildl n = wildCard :: buildl (n-1);
+-
+- (* Get the maximum number of patterns. *)
+- val wilds = buildl (recordWidth (! typeof));
+-
+- (* Now REPLACE entries from the actual pattern, leaving
+- the defaulting ones behind. *)
+- (* Take a pattern and add it into the list. *)
+- fun mergen (h :: t) 0 pat = pat :: t
+- | mergen (h :: t) n pat = h :: mergen t (n - 1) pat
+- | mergen [] _ _ = raise InternalError "mergen";
+-
+- fun enterLabel ((name, value), l) =
+- (* Put this label in the appropriate place in the tree. *)
+- mergen l (entryNumber (name, ! typeof)) value
+-
+- val tupleList = List.foldl enterLabel wilds recList;
+- in
+- (* And process it as a tuple. *)
+- buildAot (TupleTree tupleList) tree patNo line
+- end
+-
+- | Applic{f = Ident{value = ref applVal, ...}, arg} =>
+- (
+- case applVal of
+- Value{class=Constructor _, ...} =>
+- addConstr applVal (fn atree => buildAot arg atree patNo line) tree patNo
+-
+- | Value{class=Exception, ...} => addExconstr applVal arg tree patNo
++ (* Treat as a tuple, but in the order of the record entries.
++ Missing entries are replaced by wild-cards. The order of
++ the patterns given may bear no relation to the order in
++ the record which will be matched.
++ e.g. case X of (a = 1, ...) => ___ | (b = 2, a = 3) => ___ *)
++
++ (* Check that the type is frozen. *)
++ (* This check is probably redundant since we now check at the
++ point when we generalise the type (except for top-level
++ expressions - those could be detected in
++ checkForFreeTypeVariables). Retain it for the moment.
++ DCJM 15/8/2000. *)
++ val () =
++ if recordNotFrozen expType
++ then errorNear (lex, true, vars, location,
++ "Can't find a fixed record type.")
++ else ();
++
++ (* Make a list of wild cards. *)
++ fun buildl 0 = []
++ | buildl n = wildCard nullLocation :: buildl (n-1);
++
++ (* Get the maximum number of patterns. *)
++ val wilds = buildl (recordWidth expType);
++
++ (* Now REPLACE entries from the actual pattern, leaving
++ the defaulting ones behind. *)
++ (* Take a pattern and add it into the list. *)
++ fun mergen (_ :: t) 0 pat = pat :: t
++ | mergen (h :: t) n pat = h :: mergen t (n - 1) pat
++ | mergen [] _ _ = raise InternalError "mergen";
++
++ fun enterLabel ({name, valOrPat, ...}, l) =
++ (* Put this label in the appropriate place in the tree. *)
++ mergen l (entryNumber (name, expType)) valOrPat
++
++ val tupleList = List.foldl enterLabel wilds recList;
++ in
++ (* And process it as a tuple. *)
++ buildAot (TupleTree(tupleList, location)) tree patNo location
++ end
++
++ | Applic{f = Ident{value = ref applVal, ...}, arg, location, ...} =>
++ (
++ case applVal of
++ Value{class=Constructor{ofConstrs, ...}, ...} =>
++ addConstr(applVal, ofConstrs,
++ fn atree => buildAot arg atree patNo location, tree, patNo)
++
++ | Value{class=Exception, ...} => addExconstr applVal arg tree patNo
+
+- | _ => tree (* Only if error *)
+- )
++ | _ => tree (* Only if error *)
++ )
+
+ | Applic _ => tree (* Only if error *)
+
+- | Unit =>
++ | Unit _ =>
+ (* There is only one value so it matches everything. *)
+ addDefault tree patNo
+
+- | WildCard =>
++ | WildCard _ =>
+ addDefault tree patNo (* matches everything *)
+
+- | List ptl =>
+- let (* Generate suitable combinations of cons and nil.
++ | List{elements, location, ...} =>
++ let (* Generate suitable combinations of cons and nil.
+ e.g [1,2,3] becomes ::(1, ::(2, ::(3, nil))). *)
+
+- fun processList [] tree =
+- (* At the end put in a nil constructor. *)
+- addConstr nilConstructor (fn a => buildAot wildCard a patNo line) tree patNo
+- | processList (h :: t) tree = (* Cons node. *)
+- let
+- fun mkConsPat (Aot {patts = TupleField [hPat, tPat],
+- defaults, width, vars}) =
+- let (* The argument is a pair consisting of the
+- list element and the rest of the list. *)
+- val tlist = [buildAot h hPat patNo line, processList t tPat];
+- in
+- makeAot (TupleField tlist) defaults 0 vars
+- end
+- | mkConsPat (tree as Aot {patts = Wild, defaults,
+- width, vars}) =
+- let
+- val hPat = wild tree;
+- val tPat = wild tree;
+- val tlist = [buildAot h hPat patNo line, processList t tPat];
+- in
+- makeAot (TupleField tlist) defaults 0 vars
+- end
+- | mkConsPat _ =
+- raise InternalError "mkConsPat: badly-formed parse-tree"
+- in
+- addConstr consConstructor mkConsPat tree patNo
+- end
+- (* end processList *);
+- in
+- processList ptl tree
+- end
+-
+- | Literal{converter, literal, typeof=ref instance} =>
+- let
+- (* At the same time we have to get the equality function
+- for this type to plug into the code. This will find
+- a type-specific equality function if there is one
+- otherwise default to structure equality. *)
+- val (equality, _) =
+- getOverloadInstance("=", instance, false, lex, line)
+- val litValue: machineWord option =
+- getLiteralValue(converter, literal, instance, line, vars)
+- in
+- addSconstr equality litValue tree patNo
+- end
++ fun processList [] tree =
++ (* At the end put in a nil constructor. *)
++ addConstr(nilConstructor, 2,
++ fn a => buildAot (wildCard nullLocation) a patNo location, tree, patNo)
++ | processList (h :: t) tree = (* Cons node. *)
++ let
++ fun mkConsPat (Aot {patts = TupleField [hPat, tPat], defaults, vars, ...}) =
++ let (* The argument is a pair consisting of the
++ list element and the rest of the list. *)
++ val tlist = [buildAot h hPat patNo location, processList t tPat];
++ in
++ makeAot (TupleField tlist) defaults 0 vars
++ end
++ | mkConsPat (tree as Aot {patts = Wild, defaults, vars, ...}) =
++ let
++ val hPat = wild tree;
++ val tPat = wild tree;
++ val tlist = [buildAot h hPat patNo location, processList t tPat];
++ in
++ makeAot (TupleField tlist) defaults 0 vars
++ end
++ | mkConsPat _ =
++ raise InternalError "mkConsPat: badly-formed parse-tree"
++ in
++ addConstr(consConstructor, 2, mkConsPat, tree, patNo)
++ end
++ (* end processList *);
++ in
++ processList elements tree
++ end
++
++ | Literal{converter, literal, expType=ref expType, location} =>
++ let
++ (* At the same time we have to get the equality function
++ for this type to plug into the code. Literals are overloaded
++ so this may require first resolving the overload to the
++ preferred type. *)
++ val constr = typeConstrFromOverload(expType, true)
++ val equality =
++ equalityForType(mkTypeConstruction(tcName constr, constr, [], []), !level)
++ val litValue: machineWord option =
++ getLiteralValue(converter, literal, expType, location, vars)
++ in
++ addSconstr equality litValue tree patNo
++ end
+
+- | Constraint {value, given} => (* process the pattern *)
+- buildAot value tree patNo line
++ | Constraint {value, location, ...} => (* process the pattern *)
++ buildAot value tree patNo location
+
+- | Layered {var, pattern} => (* process the pattern *)
++ | Layered {var, pattern, location} => (* process the pattern *)
+ let
+ (* A layered pattern may involve a constraint which
+ has to be removed. *)
+- fun getVar pat =
+- case pat of
+- Ident {value, ...} => !value
++ fun getVar pat =
++ case pat of
++ Ident {value, ...} => !value
+ | Constraint {value, ...} => getVar value
+- | _ => undefinedValue (* error *);
+- in
+- addVar (buildAot pattern tree patNo line) (getVar var)
+- end
++ | _ => undefinedValue (* error *);
++ in
++ addVar (buildAot pattern tree patNo location) (getVar var)
++ end
++
++ | Parenthesised(p, location) => buildAot p tree patNo location
+
+ | _ =>
+ tree (* error cases *)
+ end; (* buildAot *)
+
+- fun buildTree (patts: parsetree list) =
++ fun buildTree (patts: matchtree list) =
+ let (* Merge together all the patterns into a single tree. *)
+- fun maket [] patNo tree = tree
+- | maket ((MatchTree{vars, line, ...})::t) patNo tree =
+- maket t (patNo + 1) (buildAot vars tree patNo line)
+- | maket _ _ _ =
+- raise InternalError "maket - badly formed parsetree"
++ fun maket [] _ tree = tree
++ | maket ((MatchTree{vars, location, ...})::t) patNo tree =
++ maket t (patNo + 1) (buildAot vars tree patNo location)
+ in
+ maket patts 1 aotEmpty
+ end;
+@@ -4144,34 +4464,36 @@
+ else ident :: varl
+ end
+
+- | TupleTree ptl =>
++ | TupleTree(ptl, _) =>
+ List.foldl (fn (v1, v2) => findVars v1 v2) varl ptl
+
+ | Labelled {recList, ...} =>
+- List.foldl (fn ((_, value), v) => findVars value v) varl recList
++ List.foldl (fn ({valOrPat, ...}, v) => findVars valOrPat v) varl recList
+
+ (* Application of a constructor: only the argument
+ can contain vars. *)
+- | Applic {f, arg} =>
++ | Applic {arg, ...} =>
+ findVars arg varl
+
+- | List ptl =>
+- List.foldl (fn (v1, v2) => findVars v1 v2) varl ptl
++ | List{elements, ...} =>
++ List.foldl (fn (v1, v2) => findVars v1 v2) varl elements
+
+ | Constraint {value, ...} =>
+ findVars value varl
+
+- | Layered {var, pattern} =>
++ | Layered {var, pattern, ...} =>
+ (* There may be a constraint on the variable
+ so it is easiest to recurse. *)
+ findVars pattern (findVars var varl)
++
++ | Parenthesised(p, _) =>
++ findVars p varl
+
+ | _ =>
+ varl (* constants and error cases. *);
+
+ val findAllVars =
+- map (fn (MatchTree{vars, ...}) => findVars vars []
+- | _ => raise InternalError "findAllVars - badly formed parsetree");
++ map (fn (MatchTree{vars, ...}) => findVars vars []);
+
+ (* Put the arg into a local declaration and set the address of any
+ variables to it. We declare all the variables that can be
+@@ -4181,22 +4503,22 @@
+ : {load: codetree, decs: codetree list, env: debugenv} =
+ let
+ val addressOfVar = mkAddr ();
+- val dec = mkDec (addressOfVar, arg)
+- and load = mkLoad (addressOfVar, 0)
++ val dec = mkDec (addressOfVar, arg)
++ and load = mkLoad (addressOfVar, 0)
+
+ fun setAddr (v as Value{access=Local{addr=lvAddr, level=lvLevel}, ...}, (oldDec, oldEnv) ) =
+ let (* Set the address of the variable to this and create
+- debug environment entries if required. *)
+- val {dec=nextDec, ctEnv, rtEnv} = createDebugEntry(v, oldEnv, load)
++ debug environment entries if required. *)
++ val {dec=nextDec, ctEnv, rtEnv} = createDebugEntry(v, oldEnv, load)
+ in
+ lvAddr := addressOfVar;
+ lvLevel := !level;
+- (oldDec @ nextDec, (ctEnv, rtEnv))
++ (oldDec @ nextDec, (ctEnv, rtEnv))
+ end
+
+ | setAddr _ = raise InternalError "setAddr"
+
+- val (envDec, newEnv) = List.foldl setAddr ([], env) (aVars tree)
++ val (envDec, newEnv) = List.foldl setAddr ([], env) (aVars tree)
+
+ in
+ {decs = dec :: envDec, load = load, env = newEnv}
+@@ -4211,8 +4533,24 @@
+
+ fun makePatcode code pat : patcode = { code = code, pat = pat };
+ val matchFailCode : patcode = makePatcode [MatchFail] 0;
+- val raiseMatchCode : patcode = makePatcode [raiseMatch] 0;
+- val raiseBindCode : patcode = makePatcode [raiseBind] 0;
++
++ local
++ (* Raises an exception. *)
++ (* TODO: Set the location of the exception rather than using
++ the null location. *)
++ fun raiseException(exName, exIden, line) =
++ makeRaise (mkTuple [exIden, mkStr exName, CodeZero, codeLocation line]);
++ (* Create exception values - Small integer values are used for
++ run-time system exceptions. *)
++ val bindExceptionVal = mkConst (toMachineWord EXC_Bind);
++ val matchExceptionVal = mkConst (toMachineWord EXC_Match);
++ in
++ (* Raise match and bind exceptions. *)
++ fun raiseMatchCode line : patcode =
++ makePatcode [raiseException("Match", matchExceptionVal, line)] 0
++ and raiseBindCode line : patcode =
++ makePatcode [raiseException("Bind", bindExceptionVal, line)] 0;
++ end
+
+ (* Code generate a set of patterns. tree is the aot we are working
+ on, arg is the code representing the argument to take apart.
+@@ -4235,24 +4573,24 @@
+ the fact that the constructor matches X does not imply that it
+ cannot also match Y. *)
+ fun codePatt
+- (tree as Aot {patts, defaults, width, vars})
++ (tree as Aot {patts, defaults, width, ...})
+ (arg : codetree)
+ (active : patSet)
+ (othermatches : (patSet * (unit->patcode) * debugenv) -> patcode)
+ (default : unit -> patcode)
+ (isBind : bool)
+- (debugEnv: debugenv)
++ (debugEnv: debugenv)
+ : patcode =
+ let
+ val decl : {load: codetree, decs: codetree list, env: debugenv} =
+- declareVars (tree, arg, debugEnv);
++ declareVars (tree, arg, debugEnv);
+ val load : codetree = #load decl;
+- (* In several cases below we used "arg". "arg" is the code used to
+- create the value to be taken apart and may well involve several
+- indirections. I've changed them to use "load" since that avoids
+- duplication of code. It probably doesn't matter too much since the
+- low level code-generator will probably optimise these anyway.
+- DCJM 27/3/01. *)
++ (* In several cases below we used "arg". "arg" is the code used to
++ create the value to be taken apart and may well involve several
++ indirections. I've changed them to use "load" since that avoids
++ duplication of code. It probably doesn't matter too much since the
++ low level code-generator will probably optimise these anyway.
++ DCJM 27/3/01. *)
+
+ (* Get the set of defaults which are active. *)
+ val activeDefaults : patSet = defaults intersect active;
+@@ -4260,7 +4598,7 @@
+ (* Code-generate a list of constructors. "constrsLeft" is the
+ number of constructors left to deal with. If this gets to 1
+ we have dealt with all the rest. *)
+- fun genConstrs ([]:consrec list) constrsLeft =
++ fun genConstrs ([]:consrec list) _ =
+ (* Come to the end without exhausting the datatype. *)
+ othermatches(activeDefaults, default, #env decl)
+
+@@ -4319,7 +4657,7 @@
+ then elseCode (* This didn't actually do any discrimination,
+ probably because a default was above a constructor. *)
+ else makePatcode [mkIf (testCode, mkblock (#code thenCode),
+- mkblock (#code elseCode))] ~1
++ mkblock (#code elseCode))] ~1
+ end
+ end (* genConstrs *);
+
+@@ -4337,31 +4675,31 @@
+ if newActive eq empty
+ then genExnConstrs ps
+ else let (* Code generate the choice. *)
+- (* Called if this exception constructor matches, but
+- none of the active patterns match, either because
+- the values in the datatype do not match (e.g. value
+- is A 2, but pattern is A 1), or because of other
+- fields in the tuple (e.g. value is (A, 2) but
+- pattern is (A, 1)). If this were an ordinary
+- constructor we would go straight to the default,
+- because if it matches this constructor it could not
+- match any of the others, but with exceptions it can
+- match other exceptions, so we have to test them.
+-
+- We do this by generating MatchFail, which jumps
+- to the "handler" of the enclosing AltMatch construct.
+- *)
++ (* Called if this exception constructor matches, but
++ none of the active patterns match, either because
++ the values in the datatype do not match (e.g. value
++ is A 2, but pattern is A 1), or because of other
++ fields in the tuple (e.g. value is (A, 2) but
++ pattern is (A, 1)). If this were an ordinary
++ constructor we would go straight to the default,
++ because if it matches this constructor it could not
++ match any of the others, but with exceptions it can
++ match other exceptions, so we have to test them.
++
++ We do this by generating MatchFail, which jumps
++ to the "handler" of the enclosing AltMatch construct.
++ *)
+ (* This doesn't work properly for bindings since the values we bind have to
+- be retained after this match. However, this isn't really a problem.
+- The reason for using AltMatch is to avoid the code blow-up that used
+- to occur with complex matches. That doesn't happen with bindings
+- because the elseCode simply raises a Bind exception. DCJM 27/3/01. *)
++ be retained after this match. However, this isn't really a problem.
++ The reason for using AltMatch is to avoid the code blow-up that used
++ to occur with complex matches. That doesn't happen with bindings
++ because the elseCode simply raises a Bind exception. DCJM 27/3/01. *)
+
+ (* If the match fails we look at the next constructor in the list. *)
+ val elseCode : patcode = genExnConstrs ps;
+
+ fun codeDefault () =
+- if isBind then elseCode else matchFailCode;
++ if isBind then elseCode else matchFailCode;
+
+ val testCode = makeGuard (#constructor p, load, !level);
+
+@@ -4380,31 +4718,31 @@
+ done first, and the then-part is done after the test.
+ e.g. val (a::b) = e generates code similar to if not
+ (e is ::) then raise Bind; val a = e.0; val b = e.1 *)
+- (* There was a bug here because the code used an AltMatch which
+- doesn't work properly if the elseCode makes bindings which
+- have to be retained after the AltMatch. Since a binding can
+- only have a single pattern we don't need to use an AltMatch
+- here. DCJM 27/3/01. *)
++ (* There was a bug here because the code used an AltMatch which
++ doesn't work properly if the elseCode makes bindings which
++ have to be retained after the AltMatch. Since a binding can
++ only have a single pattern we don't need to use an AltMatch
++ here. DCJM 27/3/01. *)
+ if isBind
+ then
+ makePatcode
+ (mkIf (mkNot testCode, mkblock (#code elseCode), CodeNil):: #code thenCode)
+- ~1
+-
+- (* Needed? *)
++ ~1
++
++ (* Needed? *)
+ else if #pat thenCode = #pat elseCode andalso #pat thenCode >= 0
+ then elseCode
+
+ else
+ makePatcode
+ [
+- mkAltMatch
+- (
+- mkIf (testCode, mkblock (#code thenCode), MatchFail),
+- mkblock (#code elseCode)
+- )
+- ]
+- ~1
++ mkAltMatch
++ (
++ mkIf (testCode, mkblock (#code thenCode), MatchFail),
++ mkblock (#code elseCode)
++ )
++ ]
++ ~1
+ end
+ end (* genExnConstrs *);
+
+@@ -4416,77 +4754,77 @@
+ then othermatches(active, default, #env decl)
+ else case patts of
+ TupleField [patt] =>
+- codePatt patt load (* optimise unary tuples - no indirection! *)
+- active othermatches default isBind (#env decl)
++ codePatt patt load (* optimise unary tuples - no indirection! *)
++ active othermatches default isBind (#env decl)
+
+ | TupleField asTuples =>
+ let
+- (* A simple-minded scheme would despatch the first column
+- and then do the others. The scheme used here tries to do
+- better by choosing the column that has any wild card
+- furthest down the column. *)
+- val noOfCols = length asTuples;
+-
+- fun despatch colsToDo (active, def, env) =
+- let
+- (* Find the "depth" of pattern i.e. the position of
+- any defaults. If one of the fields is itself a
+- tuple find the maximum depth of its fields, since
+- if we decide to discriminate on this field we will
+- come back and choose the deepest in that tuple. *)
+- fun pattDepth (Aot {patts, defaults,...}) =
+- case patts of
+- TupleField pl =>
+- List.foldl (fn (t, d) => Int.max(pattDepth t, d)) 0 pl
+-
+- | _ =>
+- let (* Wild cards, constructors etc. *)
+- val activeDefaults = defaults intersect active;
+- in
+- if activeDefaults eq empty
+- then
+- (* No default - the depth is the number of
+- patterns that will be discriminated. Apart
+- from Cons which could be a complete match,
+- all the other cases will only occur
+- if the match is not exhaustive. *)
+- case patts of
+- Cons cl => length cl + 1
+- | Excons cl => length cl + 1
+- | Scons sl => length sl + 1
+- | _ => 0 (* Error? *)
+- else first activeDefaults
+- end;
+-
+- fun findDeepest column bestcol depth =
+- if column = noOfCols (* Finished. *)
+- then bestcol
+- else if column inside colsToDo
+- then let
+- val thisDepth = pattDepth (List.nth(asTuples, column));
+- in
+- if thisDepth > depth
+- then findDeepest (column + 1) column thisDepth
+- else findDeepest (column + 1) bestcol depth
+- end
+- else findDeepest (column + 1) bestcol depth;
+- in
+- (* If we have done all the columns we can stop. (Or if
+- the active set is empty). *)
+- if colsToDo eq empty orelse
+- active eq empty
+- then othermatches(active, def, env)
+- else let
+- val bestcol = findDeepest 0 0 0;
+- in
+- codePatt (List.nth(asTuples, bestcol)) (mkInd (bestcol, load)) active
+- (despatch (colsToDo diff (singleton bestcol)))
+- def isBind env
+- end
+- end (* despatch *);
+- in
+- despatch (from 0 (noOfCols-1)) (active, default, #env decl)
+- end (* TupleField. *)
++ (* A simple-minded scheme would despatch the first column
++ and then do the others. The scheme used here tries to do
++ better by choosing the column that has any wild card
++ furthest down the column. *)
++ val noOfCols = length asTuples;
++
++ fun despatch colsToDo (active, def, env) =
++ let
++ (* Find the "depth" of pattern i.e. the position of
++ any defaults. If one of the fields is itself a
++ tuple find the maximum depth of its fields, since
++ if we decide to discriminate on this field we will
++ come back and choose the deepest in that tuple. *)
++ fun pattDepth (Aot {patts, defaults,...}) =
++ case patts of
++ TupleField pl =>
++ List.foldl (fn (t, d) => Int.max(pattDepth t, d)) 0 pl
++
++ | _ =>
++ let (* Wild cards, constructors etc. *)
++ val activeDefaults = defaults intersect active;
++ in
++ if activeDefaults eq empty
++ then
++ (* No default - the depth is the number of
++ patterns that will be discriminated. Apart
++ from Cons which could be a complete match,
++ all the other cases will only occur
++ if the match is not exhaustive. *)
++ case patts of
++ Cons cl => length cl + 1
++ | Excons cl => length cl + 1
++ | Scons sl => length sl + 1
++ | _ => 0 (* Error? *)
++ else first activeDefaults
++ end;
++
++ fun findDeepest column bestcol depth =
++ if column = noOfCols (* Finished. *)
++ then bestcol
++ else if column inside colsToDo
++ then let
++ val thisDepth = pattDepth (List.nth(asTuples, column));
++ in
++ if thisDepth > depth
++ then findDeepest (column + 1) column thisDepth
++ else findDeepest (column + 1) bestcol depth
++ end
++ else findDeepest (column + 1) bestcol depth;
++ in
++ (* If we have done all the columns we can stop. (Or if
++ the active set is empty). *)
++ if colsToDo eq empty orelse
++ active eq empty
++ then othermatches(active, def, env)
++ else let
++ val bestcol = findDeepest 0 0 0;
++ in
++ codePatt (List.nth(asTuples, bestcol)) (mkInd (bestcol, load)) active
++ (despatch (colsToDo diff (singleton bestcol)))
++ def isBind env
++ end
++ end (* despatch *);
++ in
++ despatch (from 0 (noOfCols-1)) (active, default, #env decl)
++ end (* TupleField. *)
+
+ | Cons cl =>
+ genConstrs cl width
+@@ -4500,95 +4838,95 @@
+ | Scons sl =>
+ let (* Int, real, string *)
+
+- (* Generate if..then..else for each of the choices. *)
+- fun foldConstrs ([]: sconsrec list) =
+- othermatches(activeDefaults, default, #env decl)
+- | foldConstrs (v :: vs) =
+- let
+- (* If this pattern is in the active set
+- we discriminate on it. *)
+- val newActive = (#patts v) intersect active;
+-
+- in
+- if newActive eq empty
+- then (* No point *) foldConstrs vs
+- else let
+- val constVal =
+- case #specVal v of NONE => CodeZero | SOME w => mkConst w
+- val testCode =
+- mkEval(#eqFun v,
+- [mkTuple[constVal, load]], true)
+-
+- (* If it is a binding we turn the test round - see
+- comment in genConstrs. *)
+- val rest =
+- othermatches(newActive plus activeDefaults, default, #env decl);
+-
+- (* If we have a handler of the form
+- handle e as Io "abc" => <E1> we will
+- generate a handler which catches all Io exceptions
+- and checks the argument. If it fails to match it
+- generates the other cases as explicit checks. The
+- other cases will generate a new address for "e"
+- (even though "e" is not used in them "declareVars"
+- does all). We have to make sure that we
+- code-generate <E1> BEFORE we go on to the next
+- case. (i.e. we must call "othermatches" before
+- "foldConstrs"). *)
+- val elsept = foldConstrs vs;
+- in
+- if isBind
+- then makePatcode (mkIf (mkNot testCode, mkblock (#code elsept),
+- CodeNil) :: #code rest) ~1
+- (* Match or handler. *)
+- else if (#pat rest) = (#pat elsept) andalso (#pat rest) >= 0
+- then elsept
+- else makePatcode [mkIf (testCode, mkblock (#code rest),
+- mkblock (#code elsept))] ~1
+- end
+- end (* foldConstrs *);
+- in
+- foldConstrs sl
+- end
++ (* Generate if..then..else for each of the choices. *)
++ fun foldConstrs ([]: sconsrec list) =
++ othermatches(activeDefaults, default, #env decl)
++ | foldConstrs (v :: vs) =
++ let
++ (* If this pattern is in the active set
++ we discriminate on it. *)
++ val newActive = (#patts v) intersect active;
++
++ in
++ if newActive eq empty
++ then (* No point *) foldConstrs vs
++ else let
++ val constVal =
++ case #specVal v of NONE => CodeZero | SOME w => mkConst w
++ val testCode =
++ mkEval(#eqFun v,
++ [mkTuple[constVal, load]], true)
++
++ (* If it is a binding we turn the test round - see
++ comment in genConstrs. *)
++ val rest =
++ othermatches(newActive plus activeDefaults, default, #env decl);
++
++ (* If we have a handler of the form
++ handle e as Io "abc" => <E1> we will
++ generate a handler which catches all Io exceptions
++ and checks the argument. If it fails to match it
++ generates the other cases as explicit checks. The
++ other cases will generate a new address for "e"
++ (even though "e" is not used in them "declareVars"
++ does all). We have to make sure that we
++ code-generate <E1> BEFORE we go on to the next
++ case. (i.e. we must call "othermatches" before
++ "foldConstrs"). *)
++ val elsept = foldConstrs vs;
++ in
++ if isBind
++ then makePatcode (mkIf (mkNot testCode, mkblock (#code elsept),
++ CodeNil) :: #code rest) ~1
++ (* Match or handler. *)
++ else if (#pat rest) = (#pat elsept) andalso (#pat rest) >= 0
++ then elsept
++ else makePatcode [mkIf (testCode, mkblock (#code rest),
++ mkblock (#code elsept))] ~1
++ end
++ end (* foldConstrs *);
++ in
++ foldConstrs sl
++ end
+ | _ => (* wild - no choices to make here. *)
+- othermatches(activeDefaults, default, #env decl)
++ othermatches(activeDefaults, default, #env decl)
+ in
+ makePatcode (#decs decl @ #code pattCode) (#pat pattCode)
+ end; (* codePatt *)
+
+ (* Make an argument list from the variables bound in the pattern. *)
+- fun makeArglist [] argno = []
++ fun makeArglist [] _ = []
+ | makeArglist (Value{access=Local{addr=ref lvAddr, ...}, ...} :: vs) argno =
+- mkLoad (lvAddr, 0) :: makeArglist vs (argno - 1)
+- | makeArglist _ argno = raise InternalError "makeArgList"
++ mkLoad (lvAddr, 0) :: makeArglist vs (argno - 1)
++ | makeArglist _ _ = raise InternalError "makeArgList"
+
+
+ (* Generate variable-bindings (declarations) for each of the
+ expressions as functions. *)
+- fun cgExps [] varl base patNo uses decName debugEnv cgExpression lex near = []
+- | cgExps (MatchTree {exp, line, ...} ::al) (vl::vll)
+- base patNo uses decName debugEnv cgExpression lex near =
++ fun cgExps [] _ _ _ _ _ _ _ _ _ = []
++ | cgExps (MatchTree {exp, location, ...} ::al) (vl::vll)
++ base patNo uses decName debugEnv cgExpression lex near =
+ let
+ val noOfArgs = length vl;
+ val patNoIndex = patNo - 1;
+ open Array
+ val pattUses = uses sub patNoIndex;
+
+- val U : unit =
++ val () =
+ if pattUses = 0
+- then errorNear (lex, false, near, line,
++ then errorNear (lex, false, near, location,
+ "Pattern " ^ Int.toString patNo ^ " is redundant.")
+ else ();
+
+- val U = level := !level + 1; (* For the function. *)
++ val () = level := !level + 1; (* For the function. *)
+
+ (* Set the addresses to be suitable for arguments. At the
+- same time create a debugging environment if required. *)
++ same time create a debugging environment if required. *)
+ fun setAddr (v as Value{access=Local{addr=lvAddr, level=lvLevel}, ...},
+- (argno, oldDec, oldEnv)) =
++ (argno, oldDec, oldEnv)) =
+ let
+- val load = mkLoad (~argno, 0)
+- val {dec=nextDec, ctEnv, rtEnv} = createDebugEntry(v, oldEnv, load)
++ val load = mkLoad (~argno, 0)
++ val {dec=nextDec, ctEnv, rtEnv} = createDebugEntry(v, oldEnv, load)
+ in
+ lvAddr := ~argno;
+ lvLevel := !level;
+@@ -4596,12 +4934,12 @@
+ end
+ | setAddr _ = raise InternalError "setAddr"
+
+- val (_, envDec, newEnv) = List.foldl setAddr (noOfArgs, [], debugEnv) vl
++ val (_, envDec, newEnv) = List.foldl setAddr (noOfArgs, [], debugEnv) vl
+
+ val functionBody =
+- mkEnv(envDec @ [cgExpression (exp, newEnv, decName, line)]);
++ mkEnv(envDec @ [cgExpression (exp, newEnv, decName)]);
+
+- val U = level := !level - 1; (* Back to the surroundings. *)
++ val () = level := !level - 1; (* Back to the surroundings. *)
+
+ (* Make it an inline function if it only used once. *)
+ val theCode =
+@@ -4611,27 +4949,30 @@
+ mkDec (base + patNoIndex, theCode) ::
+ cgExps al vll base (patNo + 1) uses decName debugEnv cgExpression lex near
+ end
+- | cgExps _ _ base patNo uses decName debugEnv cgExpression lex near =
++ | cgExps _ _ _ _ _ _ _ _ _ _ =
+ raise InternalError "cgExps";
+
+ fun codeMatch
+ (near : parsetree,
+- alt : parsetree list,
++ alt : matchtree list,
+ arg : codetree,
+ lex : lexan,
+ decName : string,
+- debugEnv : debugenv,
+- cgExpression : parsetree * debugenv * string * int -> codetree,
++ debugEnv : debugenv,
++ cgExpression : parsetree * debugenv * string -> codetree,
+ isHandlerMatch : bool)
+ : codetree =
+ let
+ val noOfPats = length alt;
+ val andortree = buildTree alt;
+ val allVars = findAllVars alt;
+- val lineNo =
+- case alt of
+- MatchTree {line, ... } :: _ => line
+- | _ => raise Match
++ (* Check for unreferenced variables. *)
++ val () = List.app (fn l => List.app reportUnreferencedValue l) allVars
++
++ val lineNo =
++ case alt of
++ MatchTree {location, ... } :: _ => location
++ | _ => raise Match
+
+ (* Save the argument in a variable. *)
+ val decCode = multipleUses (arg, mkAddr, !level);
+@@ -4641,7 +4982,7 @@
+
+ (* Generate a range of addresses for the expressions. *)
+ val baseAddr = !addresses;
+- val U = addresses := baseAddr + noOfPats;
++ val () = addresses := baseAddr + noOfPats;
+
+ (* Make an array to count the number of references to a pattern.
+ This is used to decide whether to use a function for certain
+@@ -4655,7 +4996,7 @@
+ val codeDefault : unit -> patcode =
+ if isHandlerMatch
+ then (fn () => makePatcode [makeRaise loadExpCode] 0)
+- else (fn () => (exhaustive := false; raiseMatchCode));
++ else (fn () => (exhaustive := false; raiseMatchCode lineNo));
+
+ (* Generate the code and also check for redundancy
+ and exhaustiveness. *)
+@@ -4676,21 +5017,20 @@
+ (* If we have a single pattern it cannot be duplicated
+ so we can put the code in immediately, other cases
+ are made into inline functions and inserted later. *)
+- (* The idea is to avoid the code size blowing up if we
+- have a large expression which occurs multiple times in
+- the resulting code
+- e.g. case x of [1,2,3,4] => exp1 | _ => exp2
+- Here exp2 will be called at several points in the
+- code. DCJM 13/2/01. *)
++ (* The idea is to avoid the code size blowing up if we
++ have a large expression which occurs multiple times in
++ the resulting code
++ e.g. case x of [1,2,3,4] => exp1 | _ => exp2
++ Here exp2 will be called at several points in the
++ code. DCJM 13/2/01. *)
+ if noOfPats = 1
+ then
+- (
+- case alt of
+- MatchTree {exp, line, ... } :: _ =>
+- makePatcode [cgExpression (exp, env, decName, line)]
+- pattChosen
+- | _ => raise InternalError "codeMatch - badly formed parsetree"
+- )
++ (
++ case alt of
++ MatchTree {exp, ... } :: _ =>
++ makePatcode [cgExpression (exp, env, decName)] pattChosen
++ | _ => raise InternalError "codeMatch - badly formed parsetree"
++ )
+ else let
+ val thisVars = List.nth(allVars, pattChosenIndex);
+ val noOfArgs = length thisVars;
+@@ -4707,9 +5047,9 @@
+ )
+ codeDefault
+ false
+- debugEnv;
++ debugEnv;
+ (* Report inexhaustiveness if necessary. *)
+- val U : unit =
++ val () =
+ if not (!exhaustive)
+ then errorNear (lex, false, near, lineNo,
+ "Matches are not exhaustive.")
+@@ -4724,7 +5064,7 @@
+ (* Now generate the expressions as functions, inline
+ if only used once. Also checks for redundancy. *)
+ val expressionFuns =
+- cgExps alt allVars baseAddr 1 uses decName debugEnv cgExpression lex near;
++ cgExps alt allVars baseAddr 1 uses decName debugEnv cgExpression lex near;
+ in
+ (* Return the code in a block. *)
+ mkblock (#dec decCode @ (expressionFuns @ #code code))
+@@ -4737,6 +5077,9 @@
+ let
+ (* Build a single pattern tree. *)
+ val andortree = buildAot decl aotEmpty 1 line;
++
++ (* Check for unreferenced variables. *)
++ val () = List.app reportUnreferencedValue(findVars decl [])
+
+ (* Save the argument in a variable. *)
+ val decCode = multipleUses (exp, mkAddr, !level);
+@@ -4748,20 +5091,20 @@
+ (* Set to false if we find it is not exhaustive. *)
+
+ (* Make some code to insert at defaults. *)
+- fun codeDefault () = (exhaustive := false; raiseBindCode);
++ fun codeDefault () = (exhaustive := false; raiseBindCode line);
+
+ (* Generate the code and also check for redundancy and exhaustiveness. *)
+ val code : patcode =
+ codePatt andortree loadExpCode (singleton 1)
+ (fn (pattsLeft, default, _) =>
+ if pattsLeft eq empty then (default ())
+- else makePatcode [] ~1
++ else makePatcode [] ~1
+ )
+ codeDefault
+ true
+- debugEnv;
++ debugEnv;
+ (* Report inexhaustiveness if necessary. *)
+- val U : unit =
++ val () =
+ if not (!exhaustive) andalso (!level) > 0
+ then errorNear (lex, false, near, line, "Pattern is not exhaustive.")
+ else ();
+@@ -4778,157 +5121,156 @@
+ declarations and the body if the test for "x" being a cons-cell
+ is true. *)
+
+- fun codeSequence (dlist: (parsetree * int) list, debugEnv: debugenv, decName: string)
++ fun codeSequence (dlist: parsetree list, debugEnv: debugenv, decName: string)
+ : codetree list * debugenv =
+ let
+ (* Makes a block from a series of alternatives in a match.
+ Used only for functions. *)
+ fun codeAlt
+ (near: parsetree,
+- alt : parsetree list,
++ alt : matchtree list,
+ arg : codetree,
+ decName : string,
+- debugEnv : debugenv)
++ debugEnv : debugenv)
+ : codetree =
+- let
+- (* Insert a call to the debugger in each arm of the match after
+- the variables have been bound but before the body. *)
+- fun cgExp (c: parsetree, debugEnv: debugenv, decName: string, line: int) =
+- if debugging
+- then mkEnv[addDebugCall(decName, debugEnv, line),
+- codegen(c, debugEnv, decName, line)]
+- else codegen(c, debugEnv, decName, line)
+- in
+- codeMatch (near, alt, arg, lex, decName, debugEnv, cgExp, false)
+- end
++ let
++ (* Insert a call to the debugger in each arm of the match after
++ the variables have been bound but before the body. *)
++ fun cgExp (c: parsetree, debugEnv: debugenv, decName: string) =
++ let
++ val code = codegen(c, debugEnv, decName)
++ in
++ if not debugging
++ then code
++ else mkEnv[addDebugCall(decName, debugEnv, getLocation c), code]
++ end
++ in
++ codeMatch (near, alt, arg, lex, decName, debugEnv, cgExp, false)
++ end
+
+ (* Code-generates a piece of tree. *)
+- and codegen (c: parsetree, debugEnv: debugenv, decName: string, line: int) : codetree =
+- let
+- fun codeList debugEnv [] = []
+- | codeList debugEnv ((x, line)::tl) =
+- (* Generate any line change code first, then this entry, then the rest. *)
+- changeLine(decName, debugEnv, line) @ (codegen (x, debugEnv, decName, line)
+- :: codeList debugEnv tl)
+- in
++ and codegen (c: parsetree, debugEnv: debugenv, decName: string) : codetree =
++ let
++ fun codeList _ [] = []
++ | codeList debugEnv (x::tl) =
++ (* Generate any line change code first, then this entry, then the rest. *)
++ let
++ val lineChange = changeLine(decName, debugEnv, getLocation x)
++ val code = codegen (x, debugEnv, decName)
++ in
++ lineChange @ code :: codeList debugEnv tl
++ end
++ in
+ case c of
+- Ident {value, typeof, ...} =>
+- let
+- val v : values = !value;
+- (* The instance type is not necessarily the same as the type
+- of the value of the identifier. e.g. in the expression
+- 1 :: nil, "::" has an instance type of
+- int * list int -> list int but the type of "::" is
+- 'a * 'a list -> 'a list. *)
+- in
+- case v of
+- Value{class=Exception, ...} =>
+- codeExFunction (v, !level, !typeof, lex, line)
+- | Value{class=Constructor _, ...} =>
+- let
+- (* When using the constructor as a value we just want
+- then second word. *)
+- val constrTuple = codeVal (v, !level, !typeof, lex, line)
+- in
+- mkInd(1, constrTuple)
+- end
+- | _ => codeVal (v, !level, !typeof, lex, line)
+- end
+-
+- | Literal{converter, literal, typeof=ref instance} =>
+- (
+- case getLiteralValue(converter, literal, instance, line, c) of
+- SOME w => mkConst w
+- | NONE => CodeNil
+- )
+-
+- | Applic {f, arg} =>
+- let
+- (* The overloaded functions of more than one argument are
+- applied to their arguments rather than to a tuple. *)
+- (* The only other optimisation we make is to remove applications
+- of constructors such as ``::'' which are no-ops. *)
+- val argument : codetree = codegen (arg, debugEnv, decName, line);
+- in
+- (* If the function is an identifier then see if it is a global
+- constructor. If it is not then we must code-generate the
+- whole identifier, not the value it is bound to. *)
+- case f of
+- Ident {value, typeof, ...} =>
+- let
+- val function : values = !value;
+- val instanceType = !typeof;
+- in
+- applyFunction (function, argument,
+- !level, instanceType, lex, line) : codetree
+- end
+- | _ =>
+- mkEval (codegen (f, debugEnv, decName, line), [argument],
+- false) (* not early *) : codetree
+- end
+-
+- | Cond {test, thenpt, elsept} =>
+- mkIf (codegen (test, debugEnv, decName, line),
+- codegen (thenpt, debugEnv, decName, line),
+- codegen (elsept, debugEnv, decName, line)) : codetree
+-
+- | TupleTree [pt] => (* can this occur? *)
+- codegen (pt, debugEnv, decName, line) (* optimise unary tuples *)
+-
+- | TupleTree ptl =>
+- let (* Construct a vector of objects. *)
+- val args = map (fn x => codegen (x, debugEnv, decName, line)) ptl;
+- in
+- mkTuple args : codetree
+- end
+-
+- | Labelled {recList = [(_, value)], ...} =>
+- codegen (value, debugEnv, decName, line) (* optimise unary tuples *)
+-
+- | Labelled {recList, typeof, ...} =>
+- let
+- (* We must evaluate the expressions in the order they are
+- written. This is not necessarily the order they appear
+- in the record. *)
+- val recordSize = length recList; (* The size of the record. *)
+-
+- (* First declare the values as local variables. *)
+- (* We work down the list evaluating the expressions and putting
+- the results away in temporaries. When we reach the end we
+- construct the tuple by asking for each entry in turn. *)
+- fun declist [] look =
+- let
+- val args = List.tabulate (recordSize, look);
+- in
+- [mkTuple args]
+- end
+-
+- | declist ((name, value) :: t) look =
+- let
+- val thisDec =
+- multipleUses (codegen (value, debugEnv, decName, line), mkAddr, !level);
+-
+- val myPosition = entryNumber (name, !typeof);
+-
+- fun lookFn i =
+- if i = myPosition
+- then #load thisDec (!level)
+- else look i
+- in
+- #dec thisDec @ declist t lookFn
+- end (* declist *)
+- in
+- (* Create the record and package it up as a block. *)
+- mkEnv (declist recList (fn i => raise InternalError "missing in record")) : codetree
+- end
++ Ident {value, expType=ref expType, location, ...} =>
++ let
++ val v : values = !value;
++ (* The instance type is not necessarily the same as the type
++ of the value of the identifier. e.g. in the expression
++ 1 :: nil, "::" has an instance type of
++ int * list int -> list int but the type of "::" is
++ 'a * 'a list -> 'a list. *)
++ in
++ case v of
++ Value{class=Exception, ...} =>
++ codeExFunction (v, !level, expType, lex, location)
++ | Value{class=Constructor _, ...} =>
++ let
++ (* When using the constructor as a value we just want
++ then second word. *)
++ val constrTuple = codeVal (v, !level, expType, lex, location)
++ in
++ mkInd(1, constrTuple)
++ end
++ | _ => codeVal (v, !level, expType, lex, location)
++ end
++
++ | Literal{converter, literal, expType=ref expType, location} =>
++ (
++ case getLiteralValue(converter, literal, expType, location, c) of
++ SOME w => mkConst w
++ | NONE => CodeNil
++ )
++
++ | Applic {f, arg, location, ...} =>
++ let
++ (* The overloaded functions of more than one argument are
++ applied to their arguments rather than to a tuple. *)
++ (* The only other optimisation we make is to remove applications
++ of constructors such as ``::'' which are no-ops. *)
++ val argument : codetree = codegen (arg, debugEnv, decName);
++ in
++ (* If the function is an identifier then see if it is a global
++ constructor. If it is not then we must code-generate the
++ whole identifier, not the value it is bound to. *)
++ case f of
++ Ident {value = ref function, expType=ref expType, ...} =>
++ applyFunction (function, argument, !level, expType, lex, location)
++ | _ =>
++ mkEval (codegen (f, debugEnv, decName), [argument], false) (* not early *)
++ end
++
++ | Cond {test, thenpt, elsept, ...} =>
++ mkIf (codegen (test, debugEnv, decName),
++ codegen (thenpt, debugEnv, decName),
++ codegen (elsept, debugEnv, decName))
++
++ | TupleTree([pt], _) => (* can this occur? *)
++ codegen (pt, debugEnv, decName) (* optimise unary tuples *)
++
++ | TupleTree(ptl, _) =>
++ let (* Construct a vector of objects. *)
++ val args = map (fn x => codegen (x, debugEnv, decName)) ptl;
++ in
++ mkTuple args : codetree
++ end
++
++ | Labelled {recList = [{valOrPat, ...}], ...} =>
++ codegen (valOrPat, debugEnv, decName) (* optimise unary tuples *)
++
++ | Labelled {recList, expType=ref expType, ...} =>
++ let
++ (* We must evaluate the expressions in the order they are
++ written. This is not necessarily the order they appear
++ in the record. *)
++ val recordSize = length recList; (* The size of the record. *)
++
++ (* First declare the values as local variables. *)
++ (* We work down the list evaluating the expressions and putting
++ the results away in temporaries. When we reach the end we
++ construct the tuple by asking for each entry in turn. *)
++ fun declist [] look =
++ let
++ val args = List.tabulate (recordSize, look);
++ in
++ [mkTuple args]
++ end
++
++ | declist ({name, valOrPat, ...} :: t) look =
++ let
++ val thisDec =
++ multipleUses (codegen (valOrPat, debugEnv, decName), mkAddr, !level);
++
++ val myPosition = entryNumber (name, expType);
++
++ fun lookFn i =
++ if i = myPosition
++ then #load thisDec (!level)
++ else look i
++ in
++ #dec thisDec @ declist t lookFn
++ end (* declist *)
++ in
++ (* Create the record and package it up as a block. *)
++ mkEnv (declist recList (fn _ => raise InternalError "missing in record")) : codetree
++ end
+
+- | Selector {name, labType, ...} =>
++ | Selector {name, labType, location, ...} =>
+ let
+ (* Check that the type is frozen. *)
+- val U =
++ val () =
+ if recordNotFrozen labType
+- then errorNear (lex, true, c, line,
+- "Can't find a fixed record type.")
++ then errorNear (lex, true, c, location, "Can't find a fixed record type.")
+ else ();
+
+ val selectorBody : codetree =
+@@ -4939,35 +5281,35 @@
+ in
+ mkInd (offset, singleArg)
+ end
+- in (* Make an inline function. *)
+- mkInlproc (selectorBody, !level + 1, 1, decName ^ "#" ^ name) : codetree
+- end
++ in (* Make an inline function. *)
++ mkInlproc (selectorBody, !level + 1, 1, decName ^ "#" ^ name) : codetree
++ end
+
+- | Unit => (* Use zero. It is possible to have () = (). *)
++ | Unit _ => (* Use zero. It is possible to have () = (). *)
+ CodeZero : codetree
+
+- | List ptl =>
++ | List{elements, ...} =>
+ let (* Construct a list. *)
+ (* At the end of the list put a "nil" *)
+ fun consList [] = CodeZero
+ | consList (h :: t) =
+ let
+- val H = codegen (h, debugEnv, decName, line);
++ val H = codegen (h, debugEnv, decName);
+ val T = consList t;
+ in
+ mkTuple [H,T]
+ end (* consList*);
+ in
+- consList ptl : codetree
++ consList elements : codetree
+ end
+
+ | Constraint {value, ...} =>
+ (* code gen. the value *)
+- codegen (value, debugEnv, decName, line) : codetree
++ codegen (value, debugEnv, decName) : codetree
+
+- | Fn _ =>
++ | Fn { location, ... } =>
+ (* Function *)
+- mkblock (codeProc c decName false (ref 0)) : codetree
++ mkblock (codeProc(c, decName, false, ref 0, location)) : codetree
+
+ | Localdec {decs, body, ...} =>
+ (* Local expressions only. Local declarations will be handled
+@@ -4979,7 +5321,7 @@
+ mkblock (decs @ exps) : codetree
+ end
+
+- | ExpSeq ptl =>
++ | ExpSeq(ptl, _) =>
+ (* Sequence of expressions. Discard results of all except the
+ last. It isn't clear whether this will work properly since
+ the code-generator does not expect expressions to return
+@@ -4987,13 +5329,22 @@
+ all except the last into declarations. *)
+ mkblock (codeList debugEnv ptl) : codetree
+
+- | Raise pt =>
+- makeRaise (codegen (pt, debugEnv, decName, line)) : codetree
++ | Raise (pt, location) =>
++ let
++ val {dec, load} =
++ multipleUses (codegen (pt, debugEnv, decName), mkAddr, !level);
++ val load = load(!level)
++ in
++ (* Copy the identifier, name and argument from the packet and add this location. *)
++ makeRaise (
++ mkEnv(dec @
++ [mkTuple[mkInd(0, load), mkInd(1, load), mkInd(2, load), codeLocation location]]))
++ end
+
+- | HandleTree {exp, hrules} =>
++ | HandleTree {exp, hrules, location, ...} =>
+ (* Execute an expression in the scope of a handler *)
+ let
+- val handleExp : codetree = codegen (exp, debugEnv, decName, line);
++ val handleExp : codetree = codegen (exp, debugEnv, decName);
+
+ (*
+ We only bother with matchTags because they allow
+@@ -5016,8 +5367,7 @@
+ Aot { patts = Excons exList, defaults, ...} =>
+ if defaults eq empty
+ then map (fn cons : consrec =>
+- codeVal (#constructor cons, !level, emptyType, lex,
+- line))
++ codeVal (#constructor cons, !level, emptyType, lex, location))
+ exList
+ else [CodeZero]
+ | _ => [CodeZero]
+@@ -5025,34 +5375,35 @@
+ val handlerCode : codetree =
+ codeMatch (c, hrules, Ldexc, lex, decName, debugEnv, codegen, true)
+ in
+- mkHandle (handleExp, matchTagList, handlerCode) : codetree
++ mkHandle (handleExp, matchTagList, handlerCode)
+ end
+
+- | While {test, body} =>
++ | While {test, body, ...} =>
+ makeWhile
+- (codegen (test, debugEnv, decName, line),
+- codegen (body, debugEnv, decName, line)) : codetree
++ (codegen (test, debugEnv, decName),
++ codegen (body, debugEnv, decName)) : codetree
+
+- | Case {test, match} =>
+- (* The matches are made into a series of tests and
+- applied to the test expression. *)
++ | Case {test, match, ...} =>
++ (* The matches are made into a series of tests and
++ applied to the test expression. *)
+ let
+- val testCode : codetree =
+- codegen (test, debugEnv, decName, line)
++ val testCode = codegen (test, debugEnv, decName)
+ in
+- codeMatch (c, match, testCode, lex, decName, debugEnv, codegen, false) : codetree
+- end
++ codeMatch (c, match, testCode, lex, decName, debugEnv, codegen, false) : codetree
++ end
+
+- | Andalso {first, second} =>
++ | Andalso {first, second, ...} =>
+ (* Equivalent to if first then second else false *)
+- mkCand (codegen (first, debugEnv, decName, line),
+- codegen (second, debugEnv, decName, line)) : codetree
++ mkCand (codegen (first, debugEnv, decName),
++ codegen (second, debugEnv, decName)) : codetree
+
+- | Orelse {first, second} =>
++ | Orelse {first, second, ...} =>
+ (* Equivalent to if first then true else second *)
+- mkCor (codegen (first, debugEnv, decName, line),
+- codegen (second, debugEnv, decName, line)) : codetree
+-
++ mkCor (codegen (first, debugEnv, decName),
++ codegen (second, debugEnv, decName)) : codetree
++
++ | Parenthesised(p, _) => codegen (p, debugEnv, decName)
++
+ | _ => (* empty and any others *)
+ CodeNil : codetree
+
+@@ -5060,27 +5411,26 @@
+
+ (* Generate a function either as a free standing lambda expression
+ or as a declaration. *)
+- and codeProc c decName isRecursive varAddr =
++ and codeProc(c, decName, isRecursive, varAddr, location) =
+ let
+- fun getFnBody (exp : parsetree) : parsetree list =
+- case exp of
+- Constraint {value, ...} => getFnBody value
+- | Fn e => e
+- | _ => raise InternalError "getFnBody: not a constrained fn-expression";
++ fun getFnBody (Constraint {value, ...}) = getFnBody value
++ | getFnBody (Fn{matches, ...}) = matches
++ | getFnBody (Parenthesised(p, _)) = getFnBody p
++ | getFnBody _ = raise InternalError "getFnBody: not a constrained fn-expression";
+
+ val f = getFnBody c;
+- val U = level := !level + 1; (* This function comprises a new declaration level*)
++ val () = level := !level + 1; (* This function comprises a new declaration level*)
+ val oldAddr = !addresses;
+- val U = addresses := 1;
++ val () = addresses := 1;
+ val (firstPat, resType, argType) =
+ case f of
+ MatchTree {vars, resType = ref rtype, argType = ref atype, ...} :: _ => (vars, rtype, atype)
+ | _ => raise InternalError "codeProc: body of fn is not a clause list";
+
+- val tupleSize = tupleWidth firstPat
++ val tupleSize = tupleWidth firstPat
+ in
+- if tupleSize <> 1
+- then
++ if tupleSize <> 1
++ then
+ let
+ (* If the first pattern is a tuple we make a tuple from the
+ arguments and pass that in. Could possibly treat labelled
+@@ -5088,19 +5438,19 @@
+ finding the size of the record. *)
+
+ val newDecName : string = decName ^ "(" ^ Int.toString tupleSize ^ ")";
+- val newDebugEnv = newDebugLevel debugEnv
++ val newDebugEnv = newDebugLevel debugEnv
+
+ val argumentCode = mkArgTuple tupleSize 1
+ val mainProc =
+ mkProc
+- (wrapFunctionInDebug
+- (codeAlt (c, f, argumentCode, newDecName, newDebugEnv),
+- newDecName, argumentCode, argType, resType, newDebugEnv),
+- !level, tupleSize, newDecName);
++ (wrapFunctionInDebug
++ (codeAlt (c, f, argumentCode, newDecName, newDebugEnv),
++ newDecName, argumentCode, argType, resType, location, newDebugEnv),
++ !level, tupleSize, newDecName);
+
+ (* Reset level and addresses *)
+- val U = level := !level - 1;
+- val U = addresses := oldAddr;
++ val () = level := !level - 1;
++ val () = addresses := oldAddr;
+
+ (* Now make a block containing the procedure which expects
+ multiple arguments and an inline procedure which expects
+@@ -5125,16 +5475,16 @@
+ end
+
+ else
+- let (* Ordinary function. *)
++ let (* Ordinary function. *)
+ (* Must set the address to zero to get recursive references right. *)
+ val addr = !varAddr;
+- val U = varAddr := 0;
++ val () = varAddr := 0;
+ val newDecName : string = decName ^ "(1)";
+- val newDebug = newDebugLevel debugEnv
++ val newDebug = newDebugLevel debugEnv
+ val alt = codeAlt (c, f, mkLoad (~1, 0), newDecName, newDebug);
+ (* If we're debugging add the debug info before resetting the level. *)
+ val wrapped =
+- wrapFunctionInDebug(alt, newDecName, mkLoad (~1, 0), argType, resType, newDebug)
++ wrapFunctionInDebug(alt, newDecName, mkLoad (~1, 0), argType, resType, location, newDebug)
+ in
+ varAddr := addr; (* Reset the address *)
+ level := !level - 1; (* Reset level and addresses *)
+@@ -5146,14 +5496,12 @@
+ end
+ end
+ end (* codeProc *);
+-
++
+ in (* codeSequence *)
+ if null dlist then ([], debugEnv)
+ else let
+- val lineChangeCode = changeLine(decName, debugEnv, #2 (hd dlist))
++ val c : parsetree = hd dlist (* First in the list. *)
+
+- val c : parsetree = #1 (hd dlist); (* First in the list. *)
+-
+ val (firstDec, firstEnv) =
+ case c of
+ FunDeclaration {dec = tlist, ...} =>
+@@ -5174,15 +5522,15 @@
+ address of each variable first. *)
+ local
+ fun setAddr (FValBind{
+- functVar = ref (Value{access=Local{addr=lvAddr, level=lvLevel}, ...}), ...}) =
++ functVar = ref (Value{access=Local{addr=lvAddr, level=lvLevel}, ...}), ...}) =
+ let (* Set the addresses of the variables. *)
+ val addr = mkAddr ();
+- val addr1 = mkAddr ();
++ val _ = mkAddr (); (* We need this second address. *)
+ in
+ lvAddr := addr;
+ lvLevel := !level
+ end
+- | setAddr _ = raise InternalError "setAddr"
++ | setAddr _ = raise InternalError "setAddr"
+
+ in
+ val () = List.app setAddr tlist;
+@@ -5191,26 +5539,17 @@
+ (* Now we can process the function bindings. *)
+ fun loadFunDecs [] = []
+ | loadFunDecs ((FValBind{numOfPatts = ref numOfPats,
+- functVar = ref var, clauses, argType = ref aType,
+- resultType = ref resType})::otherDecs) =
++ functVar = ref var, clauses, argType = ref aType,
++ resultType = ref resType, location, ...})::otherDecs) =
+ let
+ (* Make up the function, and if there are several mutually
+ recursive functions, put it in the vector. *)
+ val address =
+- case var of
+- Value{access=Local{addr, ...}, ...} => addr
+- | _ => raise InternalError "lvAddr"
++ case var of
++ Value{access=Local{addr, ...}, ...} => addr
++ | _ => raise InternalError "lvAddr"
+ val addr = !address;
+ val procName = decName ^ valName var;
+-
+- (* Make a list of the patterns in the clause such that the lowest
+- pattern in the structure is the first on the list. *)
+- fun getPatts (Constraint {value, ...}) f acc =
+- getPatts value f acc
+- | getPatts (Applic{f=applF, arg=applA, ...}) f acc =
+- getPatts applF f (f applA :: acc)
+- | getPatts vars f acc = acc
+-
+ (* Produce a list of the size of any tuples or labelled records
+ in the first clause. Tuples in the first clause are passed as
+ separate arguments. We could look at the other clauses and only
+@@ -5226,20 +5565,20 @@
+ SPF 19/12/96
+ *)
+ val tupleSeq : int list =
+- case clauses of
+- (FValClause{dec, ...} :: _) => getPatts dec tupleWidth []
+- | _ => raise InternalError "badly formed parse tree";
+-
+- fun getResultTuple(FValClause{exp, ...}) = tupleWidth exp
+-
+- val resultTuples =
+- List.foldl(fn(t, 1) => getResultTuple t | (_, s) => s) 1 clauses
+-
+- (* If we're debugging we want the result of the
+- function so we don't do this optimisation. *)
+- val resultTuple = if debugging then 1 else resultTuples
++ case clauses of
++ (FValClause{dec= { args, ...}, ...} :: _) => List.map tupleWidth args
++ | _ => raise InternalError "badly formed parse tree";
++
++ fun getResultTuple(FValClause{exp, ...}) = tupleWidth exp
++
++ val resultTuples =
++ List.foldl(fn(t, 1) => getResultTuple t | (_, s) => s) 1 clauses
++
++ (* If we're debugging we want the result of the
++ function so we don't do this optimisation. *)
++ val resultTuple = if debugging then 1 else resultTuples
+
+- val extraArg = if resultTuple = 1 then 0 else 1
++ val extraArg = if resultTuple = 1 then 0 else 1
+
+ (* Count the total number of arguments needed. *)
+ val totalArgs = List.foldl (op +) extraArg tupleSeq
+@@ -5250,28 +5589,22 @@
+ mechanism to optimise this (unusual) case too.
+ SPF 19/12/96
+ *)
+- val noInlineFunction = numOfPats = 1 andalso totalArgs = 1
++ val noInlineFunction = numOfPats = 1 andalso totalArgs = 1
+
+ (* If there is only one pattern and it is not a tuple we
+ generate only one function so we recurse directly. *)
+- val U : unit = if noInlineFunction then address := 0 else (); (* Marks a recursive call. *)
++ val () = if noInlineFunction then address := 0 else (); (* Marks a recursive call. *)
+
+ (* This function comprises a new declaration level *)
+- val U : unit = level := !level + 1;
++ val () = level := !level + 1;
+ val oldAddr = !addresses;
+- val U : unit = addresses := 1;
++ val () = addresses := 1;
+
+ (* Turn the list of clauses into a match. *)
+ val matches =
+- map (fn FValClause {dec=vbDec, exp=vbExp, line, ...} =>
+- let
+- val patList = getPatts vbDec (fn x => x) [];
+- in
+- mkMatchTree
+- (if numOfPats = 1 then hd patList else TupleTree patList,
+- vbExp,
+- line)
+- end)
++ map (fn FValClause {dec={ args, ...}, exp, line, ...} =>
++ mkMatchTree(if numOfPats = 1 then hd args else TupleTree(args, line), exp, line)
++ )
+ clauses;
+
+ (* We arrange for the inner function to be called with
+@@ -5320,29 +5653,30 @@
+ val codeMatches : codetree =
+ codeAlt (c, matches, argList, innerProcName, newDebugLevel debugEnv);
+
+- (* If the result is a tuple we try to avoid creating it by adding
+- an extra argument to the inline function and setting this to
+- the result. *)
+- val bodyCode =
+- if resultTuple = 1
+- then codeMatches
+- else
+- (* The function sets the extra argument to the result
+- of the body of the function. We use the last
+- argument (addr = ~1) for the container so that
+- other arguments will be passed in registers in
+- preference. Since the container is used for the
+- result this argument is more likely to have to be
+- pushed onto the stack within the function than an
+- argument which may have its last use early on. *)
+- mkSetContainer(mkLoad(~1, 0), codeMatches, resultTuple)
++ (* If the result is a tuple we try to avoid creating it by adding
++ an extra argument to the inline function and setting this to
++ the result. *)
++ val bodyCode =
++ if resultTuple = 1
++ then codeMatches
++ else
++ (* The function sets the extra argument to the result
++ of the body of the function. We use the last
++ argument (addr = ~1) for the container so that
++ other arguments will be passed in registers in
++ preference. Since the container is used for the
++ result this argument is more likely to have to be
++ pushed onto the stack within the function than an
++ argument which may have its last use early on. *)
++ mkSetContainer(mkLoad(~1, 0), codeMatches, resultTuple)
+
+ (* If we're debugging add the debug info before resetting the level. *)
+ val wrapped =
+- wrapFunctionInDebug(bodyCode, procName, argList, aType, resType, newDebugLevel debugEnv)
++ wrapFunctionInDebug(bodyCode, procName, argList,
++ aType, resType, location, newDebugLevel debugEnv)
+ (* Reset level and addresses *)
+- val U = level := !level - 1;
+- val U = addresses := oldAddr;
++ val () = level := !level - 1;
++ val () = addresses := oldAddr;
+
+ val innerFun : codetree = mkProc (wrapped, !level + 1, totalArgs, innerProcName);
+
+@@ -5354,30 +5688,30 @@
+ optimised away. *)
+
+ (* Make into curried functions *)
+- fun makeFuns depth decName parms [] argCount =
++ fun makeFuns _ _ parms [] _ =
+ (* Got to the bottom. - put in a call to the procedure. *)
+- if resultTuple = 1
+- then mkEval (mkLoad (addr + 1, numOfPats), parms, false)
+- else (* Create a container for the result, side-effect
+- it in the function, then create a tuple from it.
+- Most of the time this will be optimised away. *)
+- let
+- val {load, dec} =
+- multipleUses(mkContainer resultTuple, mkAddr, !level)
+- val ld = load(!level)
+- in
+- mkEnv(dec @
+- [mkEval (mkLoad (addr + 1, numOfPats),
+- parms @ [ld], false),
+- mkTupleFromContainer(ld, resultTuple)])
+- end
++ if resultTuple = 1
++ then mkEval (mkLoad (addr + 1, numOfPats), parms, false)
++ else (* Create a container for the result, side-effect
++ it in the function, then create a tuple from it.
++ Most of the time this will be optimised away. *)
++ let
++ val {load, dec} =
++ multipleUses(mkContainer resultTuple, mkAddr, !level)
++ val ld = load(!level)
++ in
++ mkEnv(dec @
++ [mkEval (mkLoad (addr + 1, numOfPats),
++ parms @ [ld], false),
++ mkTupleFromContainer(ld, resultTuple)])
++ end
+
+ | makeFuns depth decName parms (t::ts) argCount =
+ let (* Make a function. *)
+ (* This function comprises a new declaration level *)
+- val U = level := !level + 1;
++ val () = level := !level + 1;
+ val oldAddr = !addresses;
+- val U = addresses := 1;
++ val () = addresses := 1;
+
+ val newDecName : string = decName ^ "(1)";
+
+@@ -5397,7 +5731,7 @@
+ end (* end makeFuns *);
+
+ (* Reset the address of the variable. *)
+- val U : unit = address := addr;
++ val () = address := addr;
+ in
+ if noInlineFunction
+ then mkDec (addr, innerFun) :: loadFunDecs otherDecs
+@@ -5412,16 +5746,18 @@
+ end (* loadFunDecs *);
+ val loaded = loadFunDecs tlist;
+
+- (* Construct the debugging environment by loading all variables.
+- This won't be available recursively in the
+- functions but it will be in the rest of the scope. *)
+- val vars = map (fn(FValBind{functVar, ...}) => !functVar) tlist
+- val (decEnv, newDebugEnv) = makeDebugEntries(vars, debugEnv)
++ (* Construct the debugging environment by loading all variables.
++ This won't be available recursively in the
++ functions but it will be in the rest of the scope. *)
++ val vars = map (fn(FValBind{functVar, ...}) => !functVar) tlist
++ val (decEnv, newDebugEnv) = makeDebugEntries(vars, debugEnv)
++ (* Check whether any of the functions were unreferenced. *)
++ val _ = List.app reportUnreferencedValue vars
+ in
+- case loaded of
+- [singleton] => (singleton :: decEnv, newDebugEnv)
++ case loaded of
++ [singleton] => (singleton :: decEnv, newDebugEnv)
+ | _ => (* Put the declarations into a package of mutual decs. *)
+- (mkMutualDecs loaded :: decEnv, newDebugEnv)
++ (mkMutualDecs loaded :: decEnv, newDebugEnv)
+ end (* FunDeclaration *)
+
+ | ValDeclaration {dec = valDec, variables = ref vars, ...} =>
+@@ -5430,17 +5766,18 @@
+ fun codeRecursive [] = []
+ | codeRecursive (RecValBind :: ds) =
+ (* e.g. val rec a = ... and rec b = ... *)
+- codeRecursive ds
+- | codeRecursive ((ValBind{dec=vbDec, exp=vbExp, ...})::ds) =
++ codeRecursive ds
++ | codeRecursive ((ValBind{dec=vbDec, exp=vbExp, line, ...})::ds) =
+ let
+ local
+ (* The pattern being declared may be a variable or a
+ constraint or (perversely)
+ a layered pattern or a wild-card. *)
+ fun getVars (Constraint{value, ...}) = getVars value
+- | getVars (Layered{var, pattern, ...}) =
++ | getVars (Layered{var, pattern, ...}) =
+ getVars var @ getVars pattern
+- | getVars (pat as (Ident _)) = [pat]
++ | getVars (pat as (Ident _)) = [pat]
++ | getVars (Parenthesised(p, _)) = getVars p
+ | getVars _ = (* wild-card *) [];
+ in
+ val vars = getVars vbDec;
+@@ -5454,15 +5791,18 @@
+ address, since they all refer to the same function.
+ There will normally be precisely one variable. *)
+ fun setAddress (
+- Ident{value = ref(Value{access=Local{addr=lvAddr, level=lvLevel}, ...}),...}) =
+- (
+- lvAddr := addr;
+- lvLevel := !level
+- )
+- | setAddress _ =
+- raise InternalError "setAddress - badly formed parsetree"
++ Ident{value = ref(var as Value{access=Local{addr=lvAddr, level=lvLevel}, ...}),...}) =
++ (
++ lvAddr := addr;
++ lvLevel := !level;
++ (* Non-recursive declarations are checked as part of the pattern
++ checking. *)
++ reportUnreferencedValue var
++ )
++ | setAddress _ =
++ raise InternalError "setAddress - badly formed parsetree"
+ in
+- val () = List.app setAddress vars;
++ val () = List.app setAddress vars
+ end;
+
+ val rest = codeRecursive ds
+@@ -5470,25 +5810,25 @@
+ (* Recursive declarations must be of the form var = fn ...
+ so the declaration part of the binding must be an
+ identifier pointing to a variable. *)
+- case vars of
+- [] => rest (* ignore it *)
+- (* Perverse but legal: val rec _ = fn ... *)
+- | (Ident{name = idname, value=ref idval, ...} :: _) =>
+- let
+- (* Normally precisely one identifier, but may be more
+- if layered. Just create one - all the others have
++ case vars of
++ [] => rest (* ignore it *)
++ (* Perverse but legal: val rec _ = fn ... *)
++ | (Ident{name = idname, value=ref idval, ...} :: _) =>
++ let
++ (* Normally precisely one identifier, but may be more
++ if layered. Just create one - all the others have
+ the same address. *)
+- val lvAddr =
+- case idval of
+- Value{access=Local{addr, ...}, ...} => addr
+- | _ => raise InternalError "lvAddr";
+- in
+- (* Must be a function. This returns either a single
+- declaration or possibly a pair of mutually recursive
+- functions. *)
+- (codeProc vbExp idname true lvAddr) @ rest
+- end
+- | _ => raise InternalError "ValDeclaration - not a variable"
++ val lvAddr =
++ case idval of
++ Value{access=Local{addr, ...}, ...} => addr
++ | _ => raise InternalError "lvAddr";
++ in
++ (* Must be a function. This returns either a single
++ declaration or possibly a pair of mutually recursive
++ functions. *)
++ (codeProc(vbExp, idname, true, lvAddr, line)) @ rest
++ end
++ | _ => raise InternalError "ValDeclaration - not a variable"
+ end
+
+ (* Non-recursive val bindings. Always called initially but will
+@@ -5507,7 +5847,7 @@
+ [mkMutualDecs loaded]
+ end
+
+- | codeDecs ((ValBind{dec=vbDec, exp=vbExp, ...})::otherDecs) =
++ | codeDecs ((ValBind{dec=vbDec, exp=vbExp, line, ...})::otherDecs) =
+ let (* A binding. *)
+ (* Codegen and push the declarations. For non-recursive
+ declarations, where a declaration may involve a pattern
+@@ -5518,13 +5858,14 @@
+
+ (* added to improve name generation SPF 18/10/94 *)
+ fun getName (Ident {name, ...}) = name
+- | getName (Constraint {value, ...}) = getName value
+- | getName (Layered {var=vbl, pattern, ...}) =
++ | getName (Constraint {value, ...}) = getName value
++ | getName (Parenthesised(p, _)) = getName p
++ | getName (Layered {var=vbl, pattern, ...}) =
+ (
+- case vbl of
+- Ident {name, ...} =>
+- name (* could (perversely) be "_" *)
+- | _ => getName pattern
++ case vbl of
++ Ident {name, ...} =>
++ name (* could (perversely) be "_" *)
++ | _ => getName pattern
+ )
+ | getName _ = "<pattern>" (* give up *)
+
+@@ -5532,137 +5873,205 @@
+ (* Get the name of this declaration. *)
+ decName ^ getName vbDec ^ "-";
+
+- val decCode =
+- codeBind c vbDec (codegen (vbExp, debugEnv, name, line)) lex line debugEnv
++ val decCode =
++ codeBind c vbDec (codegen (vbExp, debugEnv, name)) lex line debugEnv
+ in
+ decCode @ codeDecs otherDecs
+ end
+- val decCode = codeDecs valDec
++ val decCode = codeDecs valDec
+
+- (* Construct the debugging environment by loading all variables. *)
+- val (decEnv, env) = makeDebugEntries (vars, debugEnv)
++ (* Construct the debugging environment by loading all variables. *)
++ val (decEnv, env) = makeDebugEntries (vars, debugEnv)
+ in
+ (decCode @ decEnv, env)
+ end (* ValDeclaration *)
+
+ | Localdec {decs, body, varsInBody=ref vars, ...} => (* Local declarations only *)
+- let
++ let
+ (* Simply process the declarations in sequence. *)
+- val (decCode, decEnv) = codeSequence (decs, debugEnv, decName)
+- val (bodyCode, bodyEnv) = codeSequence (body, decEnv, decName)
+- (* We can't simply pass through the environment because it
+- would include the declarations in the local part. Instead
+- we create a new environment here containing only the variables
+- in the in...dec part. *)
+- val (decEnv, resEnv) = makeDebugEntries (vars, debugEnv)
+- in
++ val (decCode, decEnv) = codeSequence (decs, debugEnv, decName)
++ val (bodyCode, _) = codeSequence (body, decEnv, decName)
++ (* We can't simply pass through the environment because it
++ would include the declarations in the local part. Instead
++ we create a new environment here containing only the variables
++ in the in...dec part. *)
++ val (decEnv, resEnv) = makeDebugEntries (vars, debugEnv)
++ in
+ (decCode @ bodyCode @ decEnv, resEnv)
+- end
++ end
+
+- | ExDeclaration tlist =>
++ | ExDeclaration(tlist, _) =>
+ let
+- fun codeEx (ExBind{value=ref exval, previous, ... }) =
+- let
+- val ex = exval;
+- (* This exception is treated in the same way as a local
+- variable except that the value it contains is created
+- by generating a word on the heap. The address of this word
+- constitutes a unique identifier. Non-generative exception
+- bindings i.e. exception ex=ex' merely copy the word from
+- the previous exception. *)
+- val (lvAddr, lvLevel) =
+- case ex of
+- Value{access=Local{addr, level}, ...} => (addr, level)
+- | _ => raise InternalError "lvAddr"
+- in
+- lvAddr := mkAddr ();
+- lvLevel := !level;
+-
+- mkDec
+- (! lvAddr,
+- case previous of
+- EmptyTree =>
+- (* Generate a new exception. This is a single
+- mutable word which acts as a token. It is a
+- mutable to ensure that there is precisely one
+- copy of it. *)
+- mkExIden ()
+- | Ident{value=ref prevVal, ...} =>
+- (* Copy the previous value. N.B. We want the exception
+- identifier here so we can't call codegen. *)
+- codeVal (prevVal, !level, emptyType, lex, line)
+- | _ => raise InternalError "codeEx"
+- )
+- end (* codeEx *);
+-
+- val exdecs = map codeEx tlist
+-
+- fun getValue(ExBind{value=ref exval, ...}) = exval
+- val (debugDecs, newDebugEnv) =
+- makeDebugEntries(map getValue tlist, debugEnv)
+- in
+- (exdecs @ debugDecs, newDebugEnv)
+- end (* ExDeclaration *)
++ fun codeEx (ExBind{value=ref exval, previous, ... }) =
++ let
++ val ex = exval;
++ (* This exception is treated in the same way as a local
++ variable except that the value it contains is created
++ by generating a word on the heap. The address of this word
++ constitutes a unique identifier. Non-generative exception
++ bindings i.e. exception ex=ex' merely copy the word from
++ the previous exception. *)
++ val (lvAddr, lvLevel, exType) =
++ case ex of
++ Value{access=Local{addr, level}, typeOf, ...} => (addr, level, typeOf)
++ | _ => raise InternalError "lvAddr"
++ in
++ lvAddr := mkAddr ();
++ lvLevel := !level;
++
++ mkDec
++ (! lvAddr,
++ case previous of
++ EmptyTree =>
++ (* Generate a new exception. This is a single
++ mutable word which acts as a token. It is a
++ mutable to ensure that there is precisely one
++ copy of it. It contains a function to print values
++ of the type so when we raise the exception we can print
++ the exception packet without knowing the type. *)
++ mkExIden (exType, !level)
++ | Ident{value=ref prevVal, location, ...} =>
++ (* Copy the previous value. N.B. We want the exception
++ identifier here so we can't call codegen. *)
++ codeVal (prevVal, !level, emptyType, lex, location)
++ | _ => raise InternalError "codeEx"
++ )
++ end (* codeEx *);
++
++ val exdecs = map codeEx tlist
++
++ fun getValue(ExBind{value=ref exval, ...}) = exval
++ val (debugDecs, newDebugEnv) =
++ makeDebugEntries(map getValue tlist, debugEnv)
++ in
++ (exdecs @ debugDecs, newDebugEnv)
++ end (* ExDeclaration *)
+
+- | AbstypeDeclaration {typelist=typeList, declist, ...} =>
+- let (* Code-generate the declarations. *)
+-
+- (* We have to put the constructors back onto the abstype
+- temporarily so that we can do exhaustiveness checking. *)
+- val () =
+- List.app
+- (fn (DatatypeBind{tcon=ref tc, valueConstrs = ref vconstrs, ...}) =>
+- tcSetConstructors (tc, vconstrs)
+- )
+- typeList;
+- (* The debugging environment for the declarations should include
+- the constructors but the result shouldn't. For the moment
+- ignore the constructors. *)
+- val (code, newDebug) = codeSequence (declist, debugEnv, decName);
+-
+- (* Now we can take the constructors off again. *)
+- val () =
+- List.app
+- (fn (DatatypeBind{tcon=ref tc, ...}) => tcSetConstructors (tc, []))
+- typeList;
+- in
+- (code, newDebug)
+- end (* AbstypeDeclaration *)
+-
+- | DatatypeDeclaration {typelist, ...} =>
+- (* We just need the value constructors for the debug env.
+- Later we will include the types as well. *)
+- let
+- fun getConstrs(DatatypeBind {tcon = ref tc, ...}, (decs, debugEnv)) =
+- let
+- val (newDecs, newDebug) = makeDebugEntries(tcConstructors tc, debugEnv)
+- in
+- (decs @ newDecs, newDebug)
+- end
+-
+- val (decs: codetree list, newDebugenv: debugenv) =
+- List.foldl getConstrs ([], debugEnv) typelist
+- in
+- (decs, newDebugenv)
+- end
++ | AbstypeDeclaration {typelist, declist, equalityStatus = ref eqStatus, ...} =>
++ let (* Code-generate the eq and print functions for the abstype first
++ then the declarations, which may use these. *)
++ (* The debugging environment for the declarations should include
++ the constructors but the result shouldn't. For the moment
++ ignore the constructors. *)
++ (* Add the type ids to the debug environment. *)
++ val typeCons =
++ List.map(fn (DatatypeBind {tcon = ref tc, ...}) => tc) typelist
++ val typeFunctions = createDatatypeFunctions(typeCons, eqStatus, mkAddr, !level)
++ val (typeDebugDecs, typeDebugEnv) =
++ if not debugging then ([], debugEnv)
++ else
++ let
++ fun foldIds(tc::tcs, (ctEnv, rtEnv)) =
++ let
++ (* This code will build a cons cell containing the run-time value
++ associated with the type Id as the hd and the rest of the run-time
++ environment as the tl. *)
++ val id = tcIdentifier tc
++ val loadTypeId = codeId(id, !level)
++ val newEnv = mkTuple [ loadTypeId, rtEnv(!level) ]
++ val { dec, load } = multipleUses (newEnv, mkAddr, !level)
++ val (decs, newEnv) = foldIds(tcs, (DEBUGGER.envTypeId id :: ctEnv, load))
++ in
++ (dec @ decs, newEnv)
++ end
++ | foldIds([], debugEnv) = ([], debugEnv)
++ in
++ foldIds(typeCons, debugEnv)
++ end
++ val (code, newDebug) = codeSequence (declist, typeDebugEnv, decName);
++ in
++ (typeFunctions @ typeDebugDecs @ code, newDebug)
++ end
++
++ | DatatypeDeclaration {typelist, ...} =>
++ (* We just need the value constructors for the debug env.
++ Types aren't currently included although the type-ids are. *)
++ let
++ val typeCons =
++ List.map(fn (DatatypeBind {tcon = ref tc, ...}) => tc) typelist
++ (* Datatypes don't lose equality unlike abstypes so we can evaluate
++ this here. *)
++ val areEqTypes = List.map tcEquality typeCons
++ val codeIds = createDatatypeFunctions(typeCons, areEqTypes, mkAddr, !level)
++ val (typeDebugDecs, typeDebugEnv) =
++ if not debugging then ([], debugEnv)
++ else
++ let
++ fun foldIds(tc::tcs, (ctEnv, rtEnv)) =
++ let
++ (* This code will build a cons cell containing the run-time value
++ associated with the type Id as the hd and the rest of the run-time
++ environment as the tl. *)
++ val id = tcIdentifier tc
++ val loadTypeId = codeId(id, !level)
++ val newEnv = mkTuple [ loadTypeId, rtEnv(!level) ]
++ val { dec, load } = multipleUses (newEnv, mkAddr, !level)
++ val (decs, newEnv) = foldIds(tcs, (DEBUGGER.envTypeId id :: ctEnv, load))
++ in
++ (dec @ decs, newEnv)
++ end
++ | foldIds([], debugEnv) = ([], debugEnv)
++ in
++ foldIds(typeCons, debugEnv)
++ end
++
++ fun getConstrs(DatatypeBind {tcon = ref tc, ...}, (decs, debugEnv)) =
++ let
++ val (newDecs, newDebug) = makeDebugEntries(tcConstructors tc, debugEnv)
++ in
++ (decs @ newDecs, newDebug)
++ end
++
++ val (decs: codetree list, newDebugenv: debugenv) =
++ List.foldl getConstrs ([], typeDebugEnv) typelist
++ in
++ (codeIds @ typeDebugDecs @ decs, newDebugenv)
++ end
+
+- | OpenDec {variables=ref vars, ...} =>
+- (* All we need to do here is make debugging entries. *)
++ | OpenDec {variables=ref vars, ...} =>
++ (* All we need to do here is make debugging entries. *)
+ makeDebugEntries(vars, debugEnv)
+
+ | _ => (* c is Directive or TypeDeclaration*)
+ ([], debugEnv);
+
+- val (decRest, finalEnv) = codeSequence (tl dlist, firstEnv, decName)
++ val (decRest, finalEnv) = codeSequence (tl dlist, firstEnv, decName)
+ in (* Append the remaining declarations. *)
+- (lineChangeCode @ firstDec @ decRest, finalEnv)
++ (firstDec @ decRest, finalEnv)
+ end
+ end (* codeSequence *);
+ in
+- codeSequence ([(pt, line)], debugEnv, structName)
++ codeSequence ([pt], debugEnv, structName)
+ end (* gencode *)
+ end (* type *)
+-
+- end; (* parsetree abstype *)
++
++ (* Types that can be shared. *)
++ structure Sharing =
++ struct
++ type lexan = lexan
++ and pretty = pretty
++ and environEntry = environEntry
++ and codetree = codetree
++ and types = types
++ and values = values
++ and typeId = typeId
++ and structVals = structVals
++ and typeConstrs= typeConstrs
++ and typeVarForm=typeVarForm
++ and env = env
++ and fixStatus = fixStatus
++ and structureIdentForm = structureIdentForm
++ and typeParsetree = typeParsetree
++ and parsetree = parsetree
++ and valbind = valbind
++ and fvalbind = fvalbind
++ and fvalclause = fvalclause
++ and typebind = typebind
++ and datatypebind=datatypebind
++ and exbind = exbind
++ and labelRecEntry=labelRecEntry
++ and ptProperties = ptProperties
++ and matchtree = matchtree
++ end
+
+ end (* PARSETREE *);
+diff -u -r mlsource/MLCompiler/PARSE_TYPE.ML mlsource/MLCompiler/PARSE_TYPE.ML
+--- mlsource/MLCompiler/PARSE_TYPE.ML 2005-09-17 18:39:57.000000000 +0200
++++ mlsource/MLCompiler/PARSE_TYPE.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -71,17 +71,7 @@
+ (*****************************************************************************)
+ (* LEX *)
+ (*****************************************************************************)
+-structure LEX :
+-sig
+- type lexan;
+- type sys;
+-
+- val insymbol: lexan -> unit;
+- val sy: lexan -> sys;
+- val id: lexan -> string;
+- val lineno: lexan -> int;
+- val errorMessage: lexan * int * string -> unit;
+-end;
++structure LEX : LEXSIG
+
+ (*****************************************************************************)
+ (* SKIPS *)
+@@ -91,45 +81,30 @@
+ type sys;
+ type lexan;
+ type symset;
++ type location =
++ { file: string, startLine: int, startPosition: int, endLine: int, endPosition: int }
+
+ val badsyms: sys * lexan -> unit;
+ val testfor: sys * symset * lexan -> bool;
+ val getsym: sys * lexan -> unit;
+ val skipon: symset * symset * string * lexan -> unit;
+- val getid: symset * symset * lexan -> string;
+- val getLabel: symset * lexan -> string;
+- val getList: sys * symset * lexan * (unit -> 'a) -> 'a list
+-end;
+-
+-(*****************************************************************************)
+-(* STRUCTVALS *)
+-(*****************************************************************************)
+-structure STRUCTVALS :
+-sig
+- type types;
+- type typeConstrs;
+-
+- val badType: types;
+- val undefType: typeConstrs;
++ val getid: symset * symset * lexan -> string * location;
++ val getLabel: symset * lexan -> string * location;
++ val getList: sys * symset * lexan * (unit -> 'a * location) -> 'a list * location;
+ end;
+
+ (*****************************************************************************)
+-(* TYPETREE *)
++(* UTILITIES *)
+ (*****************************************************************************)
+-structure TYPETREE :
++structure UTILITIES :
+ sig
+- type types;
+- type typeConstrs;
+-
+- val mkTypeConstruction: string * typeConstrs * types list -> types;
+- val mkProductType: types list -> types;
+- val mkFunctionType: types * types -> types;
+- val mkLabelled: {name: string, typeof: types } list * bool -> types;
+- val mkLabelEntry: string * types -> {name: string, typeof: types };
+- val sortLabels: {name: string, typeof: types } list * (string -> unit) ->
+- {name: string, typeof: types } list;
+- val unitType: types
+-end;
++ val noDuplicates: (string * 'a * 'a -> unit) ->
++ { apply: (string * 'a -> unit) -> unit,
++ enter: string * 'a -> unit,
++ lookup: string -> 'a option };
++end
++
++structure TYPETREE : TYPETREESIG
+
+ (*****************************************************************************)
+ (* PARSETYPE sharing constraints *)
+@@ -148,14 +123,6 @@
+ sharing type
+ LEX.lexan
+ = SKIPS.lexan
+-
+-sharing type
+- STRUCTVALS.types
+-= TYPETREE.types
+-
+-sharing type
+- STRUCTVALS.typeConstrs
+-= TYPETREE.typeConstrs
+
+ ) :
+
+@@ -163,11 +130,15 @@
+ (* PARSETYPE export signature *)
+ (*****************************************************************************)
+ sig
+- type symset;
+- type lexan;
+- type types;
++ type symset;
++ type lexan;
++ type types;
++ type typeParsetree;
++ type typeVarForm
++ type location =
++ { file: string, startLine: int, startPosition: int, endLine: int, endPosition: int }
+
+- val parseType: symset * lexan * {lookupTvar:string -> types} -> types;
++ val parseType: symset * lexan * {lookupTvar:string -> typeVarForm} -> typeParsetree * location;
+ end =
+
+
+@@ -175,153 +146,184 @@
+ (* PARSETYPE functor body *)
+ (*****************************************************************************)
+ struct
+-
+- open LEX;
+- open SYMSET;
+- open SKIPS;
+- open TYPETREE;
+- open SYMBOLS;
+- open STRUCTVALS;
+-
++ open TYPETREE;
++ open LEX;
++ open SYMSET;
++ open SKIPS;
++ open SYMBOLS;
++ open UTILITIES;
+
+ infix 7 eq;
+ infix 8 ++;
+ infix 8 inside;
+
+- (* defined here to save re-evaluation (SPF 24/9/94) *)
+- val tyseqSyntax = SYMSET.comma ++ SYMSET.rightParen;
+- val lrSyntax = SYMSET.comma ++ SYMSET.rightCurly;
++ (* defined here to save re-evaluation (SPF 24/9/94) *)
++ val tyseqSyntax = SYMSET.comma ++ SYMSET.rightParen;
++ val lrSyntax = SYMSET.comma ++ SYMSET.rightCurly;
+
+- fun parseType (fsys, lex, env as {lookupTvar}) =
++ fun parseType (fsys, lex, env) =
+ let
+- fun tupleType fsys =
+- let
+- fun basicType fsys =
+- let (* First part may be a type sequence. *)
+- val tySeq =
+- if sy lex eq leftParen
+- then (* sequence of types *)
+- let
+- fun processList () =
+- let
+- val thisType =
+- if sy lex inside startTypeSys
+- then parseType (fsys ++ tyseqSyntax, lex, env)
+- else
+- (
+- badsyms (typeIdent, lex);
+- badType (* not there *)
+- );
+- in (* Check for any more *)
+- if testfor (SYMBOLS.comma, startTypeSys, lex)
+- then thisType :: processList() (* get some more *)
+- else [thisType] (* that's it *)
+- end (* processList *);
+-
+- (* code bugfixed SPF 19/2/94 *)
+- val UUU = insymbol lex; (* Remove opening bracket *)
+- val sequence = processList(); (* read list of items *)
+- in
+- getsym (SYMBOLS.rightParen, lex);
+- sequence
+- end
+-
+- else if sy lex eq leftCurly
+- then
+- (
+- insymbol lex; (* Remove opening bracket *)
++ fun tupleType fsys =
++ let
++ fun basicType fsys =
++ let (* First part may be a type sequence. *)
++ val sym = sy lex and startLocn = location lex
++ val (tySeq, seqLocn) =
++ if sym eq leftParen
++ then (* sequence of types *)
++ let
++ fun processList () =
++ let
++ val thisType =
++ if sy lex inside startTypeSys
++ then #1 (parseType (fsys ++ tyseqSyntax, lex, env))
++ else
++ (
++ badsyms (typeIdent, lex);
++ ParseTypeBad (* not there *)
++ );
++ in (* Check for any more *)
++ if testfor (SYMBOLS.comma, startTypeSys, lex)
++ then thisType :: processList() (* get some more *)
++ else [thisType] (* that's it *)
++ end (* processList *);
++
++ val () = insymbol lex; (* Remove opening bracket *)
++ val sequence = processList(); (* read list of items *)
++ val endLocn = location lex (* Should be the loc. of the close paren. *)
++ in
++ getsym (SYMBOLS.rightParen, lex);
++ (sequence, locSpan(startLocn, endLocn))
++ end
++
++ else if sym eq leftCurly
++ then
++ let
++ val () = insymbol lex; (* Remove opening bracket *)
++ val posEnd = location lex
++ in
+
+- if testfor (SYMBOLS.rightCurly, empty, lex)
+- then [unitType]
++ if testfor (SYMBOLS.rightCurly, empty, lex)
++ then
++ let
++ val locs = locSpan(startLocn, posEnd)
++ in
++ ([unitTree locs], locs)
++ end
+
+- else let (* All the labels should be the same sort. *)
+- val l =
+- getList (SYMBOLS.comma, empty, lex,
+- fn () =>
+- let
+- val name = getLabel (fsys ++ SYMSET.colon, lex);
+- in
+- getsym (SYMBOLS.colon, lex);
+- mkLabelEntry (name, parseType (fsys ++ lrSyntax, lex, env))
+- end);
+- in
+- getsym (SYMBOLS.rightCurly, lex);
+- [mkLabelled
+- (sortLabels (l, fn msg => errorMessage (lex, lineno lex, msg)),
+- true) (* frozen *)]
+- end
+- )
++ else
++ let
++ (* The same label name should not be used more than once. *)
++ fun reportDup (name, newLoc, _) =
++ errorMessage (lex, newLoc, "Label (" ^ name ^ ") appears more than once.")
++ val dupCheck = noDuplicates reportDup
++ (* All the labels should be the same sort. *)
++ val (l, _) =
++ getList (SYMBOLS.comma, empty, lex,
++ fn () =>
++ let
++ val nameAndLoc as (_, nameLoc) =
++ getLabel (fsys ++ SYMSET.colon, lex);
++ val () = #enter dupCheck nameAndLoc;
++ val () = getsym (SYMBOLS.colon, lex);
++ val (types, typeLoc) = parseType (fsys ++ lrSyntax, lex, env)
++ val fullLoc = locSpan(nameLoc, typeLoc)
++ in
++ ((nameAndLoc, types, fullLoc), fullLoc)
++ end);
++ val locs = locSpan(startLocn, location lex) (* Include '}' *)
++ in
++ getsym (SYMBOLS.rightCurly, lex);
++ ([makeParseTypeLabelled(l, true, locs) (* frozen *)], locs)
++ end
++ end
+
+- else if sy lex eq typeIdent
+- then let (* type variable *)
+- val ty =
+- [#lookupTvar env (id lex)];
+- in
+- getsym (typeIdent, lex);
+- ty
+- end
++ else if sym eq typeIdent
++ then
++ let (* type variable *)
++ val ty = #lookupTvar env (id lex);
++ in
++ getsym (typeIdent, lex);
++ ([makeParseTypeId(ty, startLocn)], startLocn)
++ end
+
+- else if sy lex eq SYMBOLS.ident
+- (* Constructor such as `int' *)
+- then [mkTypeConstruction (getid (SYMSET.ident, fsys, lex), undefType, [])]
+- else
+- (
+- badsyms (SYMBOLS.ident, lex);
+- []
+- );
+- in
+- (* Type sequence read. Can now have some type constructors. *)
+- if sy lex eq SYMBOLS.ident
+- then
+- let (* Returns the type made from the constructors. *)
+- fun constructors args =
+- let
+- val constructed = mkTypeConstruction (id lex, undefType, args);
+- in
+- insymbol lex;
+- if sy lex eq SYMBOLS.ident
+- then constructors [constructed]
+- else constructed
+- end;
+- in
+- constructors tySeq
+- end
+-
+- (* no constructor - get the first part of the sequence
+- and check that that's all. *)
+- else
+- case tySeq of
+- [] => badType
+- | [t] => t
+- | (t::_) => (badsyms (SYMBOLS.ident, lex); t)
+- end (* basicType *);
+-
+- (* ty * .. * ty *)
+- val fsys' = fsys ++ SYMSET.asterisk;
+- val firstPart = basicType fsys';
+- in
+- if testfor (SYMBOLS.asterisk, empty, lex)
+- then let
+- fun parseRest () =
+- basicType fsys' ::
+- (if testfor (SYMBOLS.asterisk, empty, lex)
+- then parseRest ()
+- else []
+- );
+- in
+- mkProductType (firstPart :: parseRest ())
+- end
+- else firstPart
+- end; (* tupleType *)(* ty -> ty *)
++ else if sym eq SYMBOLS.ident
++ (* Constructor such as `int' *)
++ then
++ let
++ val idLocn as (_, locn) = getid (SYMSET.ident, fsys, lex)
++ in
++ ([makeParseTypeConstruction (idLocn, ([], locn), locn)], locn)
++ end
++ else
++ (
++ badsyms (SYMBOLS.ident, lex);
++ ([], startLocn)
++ );
++ in
++ (* Type sequence read. Can now have some type constructors. *)
++ if sy lex eq SYMBOLS.ident
++ then
++ let (* Returns the type made from the constructors. *)
++ fun constructors(args, argLoc) =
++ let
++ val idAndLoc as (_, idLoc) = (id lex, location lex)
++ val loc = locSpan(argLoc, idLoc)
++ val constructed = makeParseTypeConstruction(idAndLoc, (args, argLoc), loc);
++ in
++ insymbol lex;
++ if sy lex eq SYMBOLS.ident
++ then constructors([constructed], loc)
++ else (constructed, loc)
++ end;
++ in
++ constructors(tySeq, seqLocn)
++ end
++
++ (* no constructor - get the first part of the sequence
++ and check that that's all. *)
++ else
++ case tySeq of
++ [] => (ParseTypeBad, seqLocn)
++ | [t] => (t, seqLocn)
++ | (t::_) => (badsyms (SYMBOLS.ident, lex); (t, seqLocn))
++ end (* basicType *);
++
++ (* ty * .. * ty *)
++ fun getProduct () =
++ let
++ val fsys' = fsys ++ SYMSET.asterisk;
++ val (firstPart, firstLocn) = basicType fsys'
++ in
++ if testfor (SYMBOLS.asterisk, empty, lex)
++ then
++ let
++ val (rest, restLocn) = getProduct ()
++ in
++ (firstPart :: rest, locSpan(firstLocn, restLocn))
++ end
++ else ([firstPart], firstLocn)
++ end
++ in
++ case getProduct () of
++ ([notProduct], locn) => (notProduct, locn)
++ | (product, locn) => (makeParseTypeProduct(product, locn), locn)
++ end; (* tupleType *)(* ty -> ty *)
+
+- val firstType = tupleType (fsys ++ SYMSET.arrow);
+- in
+- if testfor (SYMBOLS.arrow, empty, lex)
+- then mkFunctionType (firstType, parseType (fsys, lex, env))
+- else
+- (
+- skipon (fsys, empty, "End of type", lex);
+- firstType
+- )
++ val (firstType, firstLoc) = tupleType (fsys ++ SYMSET.arrow);
++ in
++ if testfor (SYMBOLS.arrow, empty, lex)
++ then
++ let
++ val (resType, resLocn) = parseType (fsys, lex, env)
++ val locs = locSpan(firstLoc, resLocn)
++ in
++ (makeParseTypeFunction (firstType, resType, locs), locs)
++ end
++ else
++ (
++ skipon (fsys, empty, "End of type", lex);
++ (firstType, firstLoc)
++ )
+ end;
+ end;
+Only in mlsource/MLCompiler: PRETTYSIG.sml
+diff -u -r mlsource/MLCompiler/PRINT_TABLE.ML mlsource/MLCompiler/PRINT_TABLE.ML
+--- mlsource/MLCompiler/PRINT_TABLE.ML 2008-03-25 12:14:19.000000000 +0100
++++ mlsource/MLCompiler/PRINT_TABLE.ML 2009-09-15 08:56:47.000000000 +0200
+@@ -59,12 +59,11 @@
+ end;
+
+ (*****************************************************************************)
+-(* PRETTYPRINTER *)
++(* PRETTY *)
+ (*****************************************************************************)
+-structure PRETTYPRINTER :
+-sig
+- type prettyPrinter;
+-end):
++structure PRETTY : PRETTYSIG
++
++):
+
+ (*****************************************************************************)
+ (* PRINTTABLE export signature *)
+@@ -72,14 +71,10 @@
+ sig
+ type machineWord
+ type typeId;
+- type prettyPrinter;
+ type typeConstrs
+ type codetree
++ type pretty
+
+- val addPp: typeId *
+- (prettyPrinter -> int -> machineWord -> machineWord -> unit) -> unit;
+- val getPrint: typeId ->
+- (prettyPrinter -> int -> machineWord -> machineWord -> unit);
+ val addOverload: string * typeConstrs * codetree -> unit
+ val getOverloads: string -> (typeConstrs * codetree) list
+ val getOverload: string * typeConstrs * (unit->codetree) -> codetree
+@@ -90,7 +85,7 @@
+ (*****************************************************************************)
+ struct
+ open STRUCTVALS;
+- open PRETTYPRINTER;
++ type pretty = PRETTY.pretty
+ open CODETREE
+ type overloadEntry = string * typeConstrs * codetree;
+
+@@ -134,37 +129,6 @@
+ in
+ searchList (! overloadTable)
+ end;
+-
+- (* TODO: Treat the pretty print functions as just another form of
+- overloading except that we only want the most recent occurrence. *)
+- type printEntry = typeId *
+- (prettyPrinter -> int -> machineWord -> machineWord -> unit);
+-
+- (* Create a ref to hold the list. *)
+- val printTable : printEntry list ref = ref [];
+-
+- fun addPp (consid, pproc) =
+- let
+- (* Remove any existing occurrences of the type. The only reason
+- is to allow any existing function to be garbage-collected. *)
+- fun filter [] = []
+- | filter ((this as (i, _)) :: rest) =
+- if sameTypeId (i, consid)
+- then filter rest
+- else this :: filter rest
+- in
+- printTable := (consid,pproc) :: filter (!printTable)
+- end
+-
+- (* However, we should search ALL the refs when we lookup a constructor *)
+- fun getPrint id =
+- let
+- fun searchList [] = raise Subscript
+- | searchList ((i,p)::t) =
+- if sameTypeId (i, id) then p else searchList t;
+- in
+- searchList (! printTable)
+- end;
+
+ end;
+
+diff -u -r mlsource/MLCompiler/ParseDec.ML mlsource/MLCompiler/ParseDec.ML
+--- mlsource/MLCompiler/ParseDec.ML 2005-09-17 18:39:57.000000000 +0200
++++ mlsource/MLCompiler/ParseDec.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -32,5 +32,5 @@
+ structure STRUCTURES = Structures
+ structure PARSETYPE = ParseType
+ structure UTILITIES = Utilities
+- structure DEBUG = Debug
++ structure SIGNATURES = SignaturesStruct
+ );
+diff -u -r mlsource/MLCompiler/ParseTree.ML mlsource/MLCompiler/ParseTree.ML
+--- mlsource/MLCompiler/ParseTree.ML 2008-03-25 12:14:19.000000000 +0100
++++ mlsource/MLCompiler/ParseTree.ML 2009-09-15 08:56:47.000000000 +0200
+@@ -1,5 +1,5 @@
+ (*
+- Copyright (c) 2000
++ Copyright (c) 2000,2009
+ Cambridge University Technical Services Limited
+
+ This library is free software; you can redistribute it and/or
+@@ -25,12 +25,14 @@
+ structure TYPETREE = TypeTree
+ structure VALUEOPS = ValueOps
+ structure UTILITIES = Utilities
+- structure UNIVERSAL = Universal
+ structure UNIVERSALTABLE = UniversalTable
+ structure MISC = Misc
+- structure PRETTYPRINTER = PrettyPrinter
++ structure PRETTY = Pretty
+ structure DEBUG = Debug
+ structure ADDRESS = Address
+ structure RUNCALL = RunCall
+- structure DEBUGGER = Debugger
++ structure DEBUGGER = Debugger
++ structure EXPORTTREE = ExportTreeStruct
++ structure COPIER = CopierStruct
++ structure TYPEIDCODE = TypeIDCodeStruct
+ ) ;
+diff -u -r mlsource/MLCompiler/ParseType.ML mlsource/MLCompiler/ParseType.ML
+--- mlsource/MLCompiler/ParseType.ML 2005-09-17 18:39:57.000000000 +0200
++++ mlsource/MLCompiler/ParseType.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -25,5 +25,5 @@
+ structure SKIPS = Skips
+ structure TYPETREE = TypeTree
+ structure SYMBOLS = Symbols
+- structure STRUCTVALS = StructVals
++ structure UTILITIES = Utilities
+ ) ;
+Only in mlsource/MLCompiler: Pretty.sml
+diff -u -r mlsource/MLCompiler/PrintTable.ML mlsource/MLCompiler/PrintTable.ML
+--- mlsource/MLCompiler/PrintTable.ML 2008-03-25 12:14:19.000000000 +0100
++++ mlsource/MLCompiler/PrintTable.ML 2009-09-15 08:56:47.000000000 +0200
+@@ -23,6 +23,6 @@
+ (
+ structure CODETREE = CodeTree
+ structure STRUCTVALS = StructVals
+- structure PRETTYPRINTER = PrettyPrinter
++ structure PRETTY = Pretty
+ );
+
+Only in mlsource/MLCompiler: SIGNATURES.sml
+Only in mlsource/MLCompiler: SIGNATURESSIG.sml
+diff -u -r mlsource/MLCompiler/SKIPS_.ML mlsource/MLCompiler/SKIPS_.ML
+--- mlsource/MLCompiler/SKIPS_.ML 2005-09-17 18:39:57.000000000 +0200
++++ mlsource/MLCompiler/SKIPS_.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -43,14 +43,18 @@
+ (*****************************************************************************)
+ structure LEX :
+ sig
+- type lexan;
+- type sys;
+-
+- val sy: lexan -> sys;
+- val id: lexan -> string;
+- val insymbol: lexan -> unit;
+- val lineno: lexan -> int;
+- val errorMessage: lexan * int * string -> unit;
++ type lexan;
++ type sys;
++ type location =
++ { file: string, startLine: int, startPosition: int, endLine: int, endPosition: int }
++
++ val sy: lexan -> sys;
++ val id: lexan -> string;
++ val insymbol: lexan -> unit;
++ val location: lexan -> location;
++ val errorMessage: lexan * location * string -> unit;
++ val nullLocation: location
++ val locSpan: location * location -> location
+ end;
+
+
+@@ -89,15 +93,17 @@
+ type sys;
+ type lexan;
+ type symset;
++ type location =
++ { file: string, startLine: int, startPosition: int, endLine: int, endPosition: int }
+
+ val notfound: string * lexan -> unit;
+ val badsyms: sys * lexan -> unit;
+ val getsym: sys * lexan -> unit;
+ val skipon: symset * symset * string * lexan -> unit;
+ val testfor: sys * symset * lexan -> bool;
+- val getid: symset * symset * lexan -> string;
+- val getLabel: symset * lexan -> string;
+- val getList: sys * symset * lexan * (unit -> 'a) -> 'a list;
++ val getid: symset * symset * lexan -> string * location;
++ val getLabel: symset * lexan -> string * location;
++ val getList: sys * symset * lexan * (unit -> 'a * location) -> 'a list * location;
+ end =
+
+ (*****************************************************************************)
+@@ -124,7 +130,7 @@
+ then id lex
+ else repr (sy lex)
+ in
+- errorMessage (lex, lineno lex,
++ errorMessage (lex, location lex,
+ expected ^ " expected but " ^ found ^ " was found")
+ end;
+ end;
+@@ -151,32 +157,37 @@
+ else ();
+
+ (* returns an identifier *)
+- fun getid (syms, fsys, lex) =
++ fun getid (syms, fsys, lex) =
+ if (sy lex) inside syms
+- then let
+- val iden = id lex
++ then
++ let
++ val iden = id lex
++ val loc = location lex
+ in
+- insymbol lex;
+- iden end
++ insymbol lex;
++ (iden, loc)
++ end
+ else
+ (
+ notfound ("Identifier", lex);
+ while sy lex notin fsys do insymbol lex;
+- ""
++ ("", nullLocation)
+ );
+
+ (* Read a label and check that it is valid if numeric. *)
+- fun getLabel (fsys, lex) =
++ fun getLabel (fsys, lex) =
+ if (sy lex) eq SYMBOLS.integerConst
+- then let
+- val iden = id lex;
+- val firstCh = String.str(String.sub(iden, 0));
++ then
++ let
++ val iden = id lex;
++ val loc = location lex
++ val firstCh = String.str(String.sub(iden, 0));
+ in
+- insymbol lex;
+- if firstCh = "~" orelse firstCh = "0"
+- then errorMessage (lex, lineno lex, "Labels must be 1,2,3,....")
+- else ();
+- iden
++ insymbol lex;
++ if firstCh = "~" orelse firstCh = "0"
++ then errorMessage (lex, location lex, "Labels must be 1,2,3,....")
++ else ();
++ (iden, loc)
+ end
+ else getid (declarableVarSys, fsys, lex);
+
+@@ -190,12 +201,19 @@
+ then (badsyms (sym, lex); true)
+ else false;
+
+- fun getList (separator, startsys, lex, each) =
+- let
+- fun forList () =
+- each () ::
+- (if testfor (separator, startsys, lex) then forList () else []);
+- in
+- forList ()
+- end;
++ fun getList (separator, startsys, lex, each) =
++ let
++ fun forList(list, startLoc) =
++ let
++ val (item, itemLoc) = each()
++ in
++ (* Add each item to the list. The final span is from
++ the start to the final location. *)
++ if testfor (separator, startsys, lex)
++ then forList(list @ [item], startLoc)
++ else (list @ [item], locSpan(startLoc, itemLoc))
++ end
++ in
++ forList ([], location lex)
++ end;
+ end (* SKIPS *);
+Only in mlsource/MLCompiler: STRUCTURESSIG.sml
+diff -u -r mlsource/MLCompiler/STRUCTURES_.ML mlsource/MLCompiler/STRUCTURES_.ML
+--- mlsource/MLCompiler/STRUCTURES_.ML 2008-04-21 13:36:11.000000000 +0200
++++ mlsource/MLCompiler/STRUCTURES_.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -1,6 +1,8 @@
+ (*
+- Copyright (c) 2000-7
++ Copyright (c) 2000
+ Cambridge University Technical Services Limited
++
++ Modified D.C.J. Matthews 2001-2009
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+@@ -25,370 +27,22 @@
+
+ functor STRUCTURES_ (
+
+-(*****************************************************************************)
+-(* LEX *)
+-(*****************************************************************************)
+-structure LEX :
+-sig
+- type lexan;
+- type prettyPrinter;
+-
+- val errorProc: lexan * int * (prettyPrinter -> unit) -> unit;
+- val errorMessage: lexan * int * string -> unit;
+- val warningProc: lexan * int * (prettyPrinter -> unit) -> unit;
+- val lineno: lexan -> int;
+- val nullLex: lexan; (* Used when no errors are expected - streams raise exceptions. *)
+-
+- val debugParams: lexan -> Universal.universal list
+-end;
+-
+-(*****************************************************************************)
+-(* CODETREE *)
+-(*****************************************************************************)
+-structure CODETREE :
+-sig
+- type machineWord;
+- type codetree;
+-
+- val CodeNil: codetree;
+- val CodeZero: codetree;
+- val mkLoad: int * int -> codetree;
+- val mkConst: machineWord -> codetree;
+- val mkDec: int * codetree -> codetree;
+- val mkInd: int * codetree -> codetree;
+- val mkProc: codetree * int * int * string -> codetree;
+- val mkMacroProc: codetree * int * int * string -> codetree;
+- val mkStr: string -> codetree;
+- val mkRaise: codetree -> codetree;
+- val mkEval: codetree * codetree list * bool -> codetree;
+- val mkTuple: codetree list -> codetree;
+- val mkEnv: codetree list -> codetree;
+- val multipleUses: codetree * (unit -> int) * int -> {load: int -> codetree, dec: codetree list};
+-end (* CODETREE *);
+-
+-
+-(*****************************************************************************)
+-(* STRUCTVALS *)
+-(*****************************************************************************)
+-structure STRUCTVALS :
+-sig
+- type signatures;
+- type typeDependent;
+- type codetree;
+- type typeId;
+- type types
+-
+- type 'a tag;
+-
+- datatype structVals =
+- NoStruct
+- | Struct of
+- {
+- name: string,
+- signat: signatures,
+- access: valAccess
+- }
+-
+- and values =
+- Value of {
+- name: string,
+- typeOf: types,
+- access: valAccess,
+- class: valueClass }
+-
+- (* Classes of values. *)
+- and valueClass =
+- SimpleValue
+- | Exception
+- | Constructor of { nullary: bool }
+-
+- and valAccess =
+- Global of codetree
+- | Local of { addr: int ref, level: int ref }
+- | Selected of { addr: int, base: structVals }
+- | Formal of int
+- | Overloaded of typeDependent (* Values only. *)
+-
+- (* Structures *)
+-
+- val undefinedStruct: structVals;
+- val isUndefinedStruct: structVals -> bool;
+- val structSignat: structVals -> signatures;
+- val structName: structVals -> string;
+- val structAccess: structVals -> valAccess;
+-
+- val structVar: structVals tag;
+-
+- val makeSelectedStruct: structVals * structVals -> structVals;
+- val makeLocalStruct: string * signatures -> structVals;
+- val makeGlobalStruct: string * signatures * codetree -> structVals;
+- val makeFormalStruct: string * signatures * int -> structVals;
+-
+- (* Functors *)
+-
+- type functors;
+-
+- val undefinedFunctor: functors;
+- val isUndefinedFunctor: functors -> bool;
+- val functorName: functors -> string;
+- val functorArg: functors -> structVals;
+- val functorResult: functors -> signatures;
+- val functorAccess: functors -> valAccess;
+-
+- val makeFunctor: string * structVals * signatures * valAccess -> functors;
+-
+-
+- (* Signatures *)
+- type univTable;
+- val sigName: signatures -> string;
+- val sigTab: signatures -> univTable;
+- val sigMinTypes: signatures -> int;
+- val sigMaxTypes: signatures -> int;
+-
+- val makeSignatures: string -> signatures;
+- val makeCopy: string * signatures * int * int -> signatures;
+-
+- (* type or structure identifiers *)
+- val makeFreeId: unit -> typeId;
+- val makeVariableId: unit -> typeId;
+- val makeBoundId: int -> typeId;
+-
+- val unsetId: typeId;
+- val isUnsetId: typeId -> bool;
+- val isFreeId: typeId -> bool;
+- val isBoundId: typeId -> bool;
+- val isVariableId: typeId -> bool;
+- val offsetId: typeId -> int;
+- val sameTypeId: typeId * typeId -> bool;
+- val unifyTypeIds: typeId * typeId -> bool;
+-
+- (* Types *)
+-
+- (* Standard type constructors. *)
+- type typeConstrs;
+-
+- val undefType: typeConstrs;
+-
+- val tcName: typeConstrs -> string;
+- val tcArity: typeConstrs -> int;
+- val tcTypeVars: typeConstrs -> types list;
+- val tcEquality: typeConstrs -> bool;
+- val tcEquivalent: typeConstrs -> types;
+- val tcConstructors: typeConstrs -> values list;
+- val tcSetConstructors: typeConstrs * values list -> unit;
+- val tcIdentifier: typeConstrs -> typeId;
+-
+- val typeConstrVar: typeConstrs tag;
+-
+- val makeTypeConstrs:
+- string * types list * types * typeId * bool * int -> typeConstrs;
+-
+- val badType: types;
+- val emptyType: types;
+- val isEmpty: types -> bool;
+-
+- val makeValueConstr: string * types * bool * valAccess -> values;
+- val isConstructor: values -> bool;
+-
+- (* Access to values, structures etc. *)
+-
+- val makeGlobal: codetree -> valAccess;
+- val makeLocal: unit -> valAccess;
+- val makeFormal: int -> valAccess;
+-
+- val isGlobal: valAccess -> bool;
+- val isLocal: valAccess -> bool;
+- val isFormal: valAccess -> bool;
+- val isSelected: valAccess -> bool;
+-
+- val vaGlobal: valAccess -> codetree;
+- val vaFormal: valAccess -> int;
+- val vaLocal: valAccess -> { addr: int ref, level: int ref };
+- val vaSelected: valAccess -> { addr: int, base: structVals };
+-
+-
+- (* Values. *)
+-
+- val valName: values -> string;
+- val valTypeOf: values -> types;
+-
+- val valueVar: values tag;
+-
+- (* Infix status *)
+- type fixStatus;
+-
+- val fixVar: fixStatus tag;
+-
+- datatype env =
+- Env of
+- {
+- lookupVal: string -> values option,
+- lookupType: string -> typeConstrs option,
+- lookupFix: string -> fixStatus option,
+- lookupStruct: string -> structVals option,
+- lookupSig: string -> signatures option,
+- lookupFunct: string -> functors option,
+- enterVal: string * values -> unit,
+- enterType: string * typeConstrs -> unit,
+- enterFix: string * fixStatus -> unit,
+- enterStruct: string * structVals -> unit,
+- enterSig: string * signatures -> unit,
+- enterFunct: string * functors -> unit
+- };
+-
+- val makeEnv: signatures -> env;
+-end (* STRUCTVALS *);
+-
+-(*****************************************************************************)
+-(* VALUEOPS *)
+-(*****************************************************************************)
+-structure VALUEOPS :
+-sig
+- type types;
+- type codetree;
+- type values;
+- type structVals;
+- type valAccess;
+- type lexan;
+- type typeConstrs;
+- type fixStatus
+-
+- val mkGvar: string * types * codetree -> values;
+- val mkGex: string * types * codetree -> values;
+- val mkSelectedVar: values * structVals -> values;
+-
+- val codeStruct: structVals * int -> codetree;
+- val codeAccess: valAccess * int -> codetree
+- val codeVal: values * int * types * lexan * int -> codetree
+- val codeExFunction: values * int * types * lexan * int -> codetree
+-
+- val lookupAny: string * (string -> 'a option) * (string -> structVals option) *
+- (structVals -> string -> 'a option) * string * 'a * (string -> unit) -> 'a
+-
+- val lookupStructure: string * {lookupStruct: string -> structVals option} *
+- string * (string -> unit) -> structVals
+-
+- val lookupStructureDirectly: string * {lookupStruct: string -> structVals option} *
+- string * (string -> unit) -> structVals
+-
+-
+- val lookupTyp: {lookupType: string -> typeConstrs option,
+- lookupStruct: string -> structVals option} *
+- string * (string -> unit) -> typeConstrs
+-end (* VALUEOPS *);
+-
+-
+-(*****************************************************************************)
+-(* TYPETREE *)
+-(*****************************************************************************)
+-structure TYPETREE :
+-sig
+- type typeConstrs;
+- type types;
+- type lexan;
+- type prettyPrinter;
+- type typeId;
+- type values;
+-
+- val mkTypeConstruction: string * typeConstrs * types list -> types;
+- val mkFunctionType: types * types -> types;
+-
+- (* Fill in the values of type variables and make checks. *)
+- val assignTypes: types * (string -> typeConstrs) * lexan * int -> unit;
+-
+- val exnType: types;
+-
+- (* Match a candidate to a target type. *)
+- val matchTypes: types * types * (typeId -> typeConstrs option) *
+- lexan * int * (prettyPrinter -> unit) -> unit;
+-
+-
+- (* Used to establish sharing constraints between type constructors. *)
+- val linkTypeConstructors: typeConstrs * typeConstrs * (string -> unit) -> unit;
+-
+- (* Used to link a type constructor to a type as the result of a "where type"
+- construction. *)
+- val setWhereType: typeConstrs * typeConstrs * (string -> unit) -> unit;
+-
+- (* Check that a type constructor permits equality. *)
+- val permitsEquality: typeConstrs -> bool;
+-
+- val copyType: types * (types -> types) *
+- (typeConstrs -> typeConstrs) -> types;
+-
+- val setTypeConstr: typeConstrs * (typeConstrs -> typeId) -> unit;
+-
+- val enterTypeConstrs: typeConstrs * typeConstrs *
+- { enter: typeId * typeConstrs -> unit,
+- lookup: typeId -> typeConstrs option} -> unit;
+-
+- val identical: types * types -> bool;
+- val identicalConstr: typeConstrs * typeConstrs -> bool;
+- val makeEquivalent: typeConstrs * types list -> types;
+- val genEqualityFunctions: typeConstrs list * (string -> unit) * bool -> unit;
+- val checkWellFormed: types * (string -> unit) -> unit;
+-
+- val findValueConstructor: values -> values;
+-
+- val copyTypeConstr: typeConstrs * (typeId -> bool) *
+- (unit -> typeId) *
+- {enter: typeId * typeConstrs -> unit,
+- lookup: typeId -> typeConstrs option} *
+- (types -> types) * string -> typeConstrs;
+-
+- val display: types * int * prettyPrinter * bool -> unit;
+- val displayTypeConstrs: typeConstrs * int * prettyPrinter * bool -> unit;
+- (* A list of type variables. *)
+- val displayTypeVariables: types list * int * prettyPrinter * bool -> unit;
+-
+- (* added SPF 16/4/95 *)
+- val sameTypeVar : types * types -> bool;
+-
+- (* Check for free type variables. Added for ML97. *)
+- val checkForFreeTypeVariables: string * types * lexan -> unit;
+-
+-end (* TYPETREE *);
+-
+-(*****************************************************************************)
+-(* PARSETREE *)
+-(*****************************************************************************)
+-structure PARSETREE :
+-sig
+- type parsetree;
+- type types;
+- type lexan;
+- type prettyPrinter;
+- type typeId;
+- type env;
+- type codetree;
+- type environEntry
+- type fixStatus
+- type values
+-
+- val ptDisplay: parsetree * int * prettyPrinter -> unit;
+-
+- val pass2: parsetree * (unit -> typeId) * env * lexan * int * string -> types;
+-
+- type debugenv = environEntry list * (int->codetree)
+-
+- val gencode: parsetree * lexan * debugenv * int * int ref * string * int -> codetree list * debugenv
+-end;
+-
+-(*****************************************************************************)
+-(* MISC *)
+-(*****************************************************************************)
+-structure MISC :
+-sig
+- exception InternalError of string; (* compiler error *)
+- val lookupDefault : ('a -> 'b option) -> ('a -> 'b option) -> 'a -> 'b option
+-end;
++structure LEX : LEXSIG
++structure CODETREE : CODETREESIG
++structure STRUCTVALS : STRUCTVALSIG;
++structure VALUEOPS : VALUEOPSSIG;
++structure EXPORTTREE: EXPORTTREESIG
++structure TYPETREE : TYPETREESIG
++structure PARSETREE : PARSETREESIG
++structure PRETTY : PRETTYSIG
++structure COPIER: COPIERSIG
++structure TYPEIDCODE: TYPEIDCODESIG
++structure SIGNATURES: SIGNATURESSIG
++structure DEBUGGER : DEBUGGERSIG
+
+-(*****************************************************************************)
+-(* UTILITIES *)
+-(*****************************************************************************)
+ structure UTILITIES :
+ sig
+- val noDuplicates: (string -> unit) ->
++ val noDuplicates: (string * 'a * 'a -> unit) ->
+ { apply: (string * 'a -> unit) -> unit,
+ enter: string * 'a -> unit,
+ lookup: string -> 'a option };
+@@ -399,213 +53,40 @@
+ val splitString: string -> { first:string,second:string }
+ end;
+
+-(*****************************************************************************)
+-(* UNIVERSAL *)
+-(*****************************************************************************)
+-structure UNIVERSAL :
+-
+-sig
+- type universal
+- type 'a tag
+-
+- val tagIs : 'a tag -> universal -> bool
+- val tagProject : 'a tag -> universal -> 'a
+-end;
+-
+-(*****************************************************************************)
+-(* UNIVERSALTABLE *)
+-(*****************************************************************************)
+ structure UNIVERSALTABLE:
+ sig
+- type universal
++ type universal = Universal.universal
+ type univTable
+- type 'a tag
++ type 'a tag = 'a Universal.tag
+
+ val univEnter: univTable * 'a tag * string * 'a -> unit;
+ val univLookup: univTable * 'a tag * string -> 'a option;
+ val univFold: univTable * (string * universal * 'a -> 'a) * 'a -> 'a;
+ end;
+
+-(*****************************************************************************)
+-(* DEBUG *)
+-(*****************************************************************************)
+ structure DEBUG :
+ sig
+- val ml90Tag: bool Universal.tag
+ val inlineFunctorsTag: bool Universal.tag
+ val errorDepthTag : int Universal.tag
++ val debugTag: bool Universal.tag
+ val getParameter :
+ 'a Universal.tag -> Universal.universal list -> 'a
+ end;
+
+-(*****************************************************************************)
+-(* PRETTYPRINTER *)
+-(*****************************************************************************)
+-structure PRETTYPRINTER :
+-sig
+- type prettyPrinter
+-
+- val ppAddString : prettyPrinter -> string -> unit
+- val ppBeginBlock : prettyPrinter -> int * bool -> unit
+- val ppEndBlock : prettyPrinter -> unit -> unit
+- val ppBreak : prettyPrinter -> int * int -> unit
+-end;
+-
+-(*****************************************************************************)
+-(* STRETCHARRAY *)
+-(*****************************************************************************)
+-structure STRETCHARRAY :
+-sig
+- type 'a stretchArray
+-
+- val stretchArray : int * '_a -> '_a stretchArray
+- val update : '_a stretchArray * int * '_a -> unit
+- val sub : 'a stretchArray * int -> 'a
+-end;
+-
+-(*****************************************************************************)
+-(* STRUCTURES sharing constraints *)
+-(*****************************************************************************)
+-
+-sharing type
+- LEX.lexan
+-= VALUEOPS.lexan
+-= TYPETREE.lexan
+-= PARSETREE.lexan
+-
+-sharing type
+- LEX.prettyPrinter
+-= PARSETREE.prettyPrinter
+-= TYPETREE.prettyPrinter
+-= PRETTYPRINTER.prettyPrinter
+-
+-sharing type
+- CODETREE.codetree
+-= VALUEOPS.codetree
+-= PARSETREE.codetree
+-= STRUCTVALS.codetree
+-
+-sharing type
+- STRUCTVALS.types
+-= VALUEOPS.types
+-= TYPETREE.types
+-= PARSETREE.types
+-
+-sharing type
+- STRUCTVALS.values
+-= VALUEOPS.values
+-= PARSETREE.values
+-= TYPETREE.values
+-
+-sharing type
+- STRUCTVALS.typeId
+-= TYPETREE.typeId
+-= PARSETREE.typeId
+-
+-sharing type
+- STRUCTVALS.structVals
+-= VALUEOPS.structVals
+-
+-sharing type
+- STRUCTVALS.valAccess
+-= VALUEOPS.valAccess
+-
+-sharing type
+- STRUCTVALS.typeConstrs
+-= VALUEOPS.typeConstrs
+-= TYPETREE.typeConstrs
+-
+-sharing type
+- STRUCTVALS.tag
+-= UNIVERSALTABLE.tag
+-= UNIVERSAL.tag
+-
+-sharing type
+- STRUCTVALS.env
+-= PARSETREE.env
+-
+-sharing type
+- UNIVERSALTABLE.univTable
+-= STRUCTVALS.univTable
+-
+-sharing type
+- UNIVERSALTABLE.universal
+-= UNIVERSAL.universal;
+-
+-sharing type
+- STRUCTVALS.fixStatus
+-= PARSETREE.fixStatus
+-= VALUEOPS.fixStatus
+-) :
+-
+-(*****************************************************************************)
+-(* STRUCTURES export signature *)
+-(*****************************************************************************)
+-sig
+- (* Structures form the global name spaces. *)
+- type structs;
+- type structVals;
+- type types;
+- type parsetree;
+- type lexan;
+- type prettyPrinter;
+- type values;
+- type typeConstrs;
+- type codetree;
+- type signatures;
+- type functors;
+- type env;
+- type sigBind and functorBind and structBind
+- type machineWord
+- type fixStatus
+-
+- val isEmptyStruct: structs -> bool;
+- val emptyStruct: structs (* added 8/2/94 SPF *)
+- val mkStructureDec: structBind list -> structs;
+- val mkStruct: structs list -> structs;
+- val mkSignatureDec: sigBind list -> structs;
+- val mkSig: structs list -> structs;
+- val mkFunctorDec: functorBind list -> structs;
+- val mkInclude: structs list -> structs;
+- val mkLocaldec: structs list * structs list * bool * int -> structs;
+- val mkTopLevel: parsetree * int -> structs;
+- val mkStructureBinding: string * structs * bool * structs * int -> structBind;
+- val mkStructIdent: string -> structs;
+- val mkSigIdent: string -> structs;
+- val mkSignatureBinding: string * structs * int -> sigBind;
+- val mkValSig: string * types * int -> structs;
+- val mkExSig: string * types * int -> structs;
+- val mkFunctorAppl: string * structs -> structs;
+- val mkFormalArg: string * structs -> structs;
+- val mkFunctorBinding: string * structs * bool * structs * structs * int -> functorBind;
+- val mkSharing: bool * string list * int -> structs;
+- val mkWhereType: structs * types list * string * types * int -> structs
+- val mkSigConstraint: structs * structs * bool -> structs
+-
+- val pass2Structs: structs list * lexan * env -> unit;
+-
+- val checkForFreeTypeVars:
+- ((string*values->unit)->unit) * ((string*structVals->unit)->unit) *
+- ((string*functors->unit)->unit) * lexan -> unit
+-
+- val pass4Structs:
+- codetree * structs list ->
+- { fixes: (string * fixStatus) list, values: (string * values) list,
+- structures: (string * structVals) list, signatures: (string * signatures) list,
+- functors: (string * functors) list, types: (string* typeConstrs) list };
+-
+- val gencodeStructs: structs list * lexan -> codetree;
++sharing LEX.Sharing = VALUEOPS.Sharing = TYPETREE.Sharing = PARSETREE.Sharing
++ = PRETTY.Sharing = EXPORTTREE.Sharing = STRUCTVALS.Sharing = COPIER.Sharing
++ = CODETREE = UNIVERSALTABLE = TYPEIDCODE.Sharing = SIGNATURES.Sharing = DEBUGGER.Sharing
+
+- val displayStructs: structs list * int * prettyPrinter -> unit;
+-end (* STRUCTURES export signature *) =
++) : STRUCTURESSIG =
+
+ (*****************************************************************************)
+ (* STRUCTURES functor body *)
+ (*****************************************************************************)
+ struct
+- open MISC;
+- open PRETTYPRINTER;
+-
++ open Misc;
++ open PRETTY;
++
++ open COPIER;
+ open LEX;
+ open CODETREE;
+ open STRUCTVALS;
+@@ -615,9 +96,11 @@
+ open UTILITIES;
+ open DEBUG;
+ open UNIVERSALTABLE;
+- open UNIVERSAL; (* for tag record selectors *)
+-
+- val displayType = TYPETREE.display;
++ open Universal; (* for tag record selectors *)
++ open EXPORTTREE;
++ open TYPEIDCODE
++ open SIGNATURES
++ open DEBUGGER
+
+ (* Union of the various kinds of core language declaration. Structures are included
+ because they can be declared by opening a structure with substructures. *)
+@@ -629,81 +112,57 @@
+
+ (* "structs" is the abstract syntax for the module language. *)
+ datatype structs =
+- StructureDec of structBind list (* List of structure decs *)
++ StructureDec of structBind list * location (* List of structure decs *)
++
+ | StructureIdent of structureIdentForm (* A structure name *)
+- | StructDec of structDecForm (* struct ... end *)
+- | SignatureDec of sigBind list (* List of signature decs *)
+- | SignatureIdent of string (* A signature name *)
+- | SigDec of structs list (* sig ... end *)
+- | ValSig of valExSig
+- | ExSig of valExSig
+- | FunctorDec of functorBind list (* List of functor decs. *)
++
++ | StructDec of (* struct ... end *)
++ {
++ alist: structs list, (* List of items in it. *)
++ location: location,
++ value: univTable (* Value *),
++ resultSig: signatures ref
++ }
++
+ | FunctorAppl of functorApplForm (* Appln of a functor *)
+- | Singleton of singletonForm (* Any other decln. *)
+- | FormalArg of formalArgStruct (* Functor arg. *)
+- | Sharing of shareConstraint (* Sharing constraints. *)
+- | WhereType of whereTypeStruct (* type realisation. *)
++
++ | CoreLang of (* Any other decln. *)
++ {
++ dec: parsetree, (* The value *)
++ vars: coreDeclaration list ref, (* The declarations *)
++ location: location
++ }
++
+ | Localdec of localdecStruct (* Local/Let. *)
+- | IncludeSig of structs list (* Include. *)
++
+ | SigConstraint of (* Constraint of str to match sig. *)
+ {
+ str: structs, (* Structure to constain *)
+- csig: structs, (* Constraining signature *)
+- opaque: bool (* True if opaque, false if transparent. *)
++ csig: sigs, (* Constraining signature *)
++ opaque: bool, (* True if opaque, false if transparent. *)
++ sigLoc: location,
++ opaqueIds: { source : typeId, dest: typeId } list ref,
++ resultSig: signatures ref
+ }
+ | EmptyStruct (* Error cases. *)
+
+- (* List of structures. *)
+ withtype structBind =
+ {
+ name: string, (* The name of the structure *)
+- sigStruct: structs, (* Its signature *)
+- opaque: bool, (* true if it was :> rather than : *)
++ nameLoc: location,
++ haveSig: bool, (* Whether we moved an explicit signature to the value. *)
+ value: structs, (* And its value *)
+ valRef: structVals ref, (* The structure variable declared. *)
+- line: int
++ line: location
+ }
+- (* The constraint could be removed from here and instead the parser could
+- desugar the structure binding. i.e. structure S: SIG = STREXP becomes
+- structure S = STREXP: SIG. structBind is also used for structures
+- within signatures where this wouldn't work so a separate data structure
+- for structure specifications would be needed. *)
+-
+- and sigBind =
+- {
+- name: string, (* The name of the signature *)
+- sigStruct: structs,(* Its value *)
+- sigRef: signatures ref, (* The "value" of the signature. *)
+- line: int
+- }
++
+
+ (* A reference to a name *)
+ and structureIdentForm =
+ {
+- name: string, (* The name *)
+- valRef: structVals ref (* The variable found. *)
+- }
+-
+- (* struct ... end *)
+- and structDecForm =
+- {
+- alist: structs list, (* The list of items in it. *)
+- value: signatures (* The value *)
+- }
+-
+- and singletonForm =
+- {
+- dec: parsetree, (* The value *)
+- vars: coreDeclaration list ref, (* The declarations *)
+- line: int
+- }
+-
+- (* Signature of a value or exception. *)
+- and valExSig =
+- {
+- name: string,
+- typeof: types,
+- line: int
++ name: string, (* The name *)
++ valRef: structVals ref, (* The variable found. *)
++ location: location
+ }
+
+ (* Application of a functor. *)
+@@ -711,176 +170,75 @@
+ {
+ name: string,
+ arg: structs,
+- valRef: functors ref (* The functor looked up. *)
+- }
+-
+- (* Functor binding. *)
+- and functorBind =
+- {
+- name: string,
+- sigStruct: structs,
+- opaque: bool, (* true if it was :> rather than : *)
+- body: structs,
+- arg: structs,
+- valRef: functors ref, (* The functor variable declared. *)
+- line: int
+- }
+-
+- and formalArgStruct =
+- {
+- name: string,
+- sigStruct: structs,
+- valRef: structVals ref
+- } (* The structure variable. *)
+-
+- and shareConstraint =
+- {
+- isType: bool,
+- shares: string list,
+- line: int
+- }
+-
+- and whereTypeStruct =
+- {
+- sigExp: structs,
+- typeVars: types list,
+- typeName: string,
+- realisation: types,
+- line: int
++ valRef: functors ref, (* The functor looked up. *)
++ nameLoc: location, (* The location of the name itself. *)
++ fullLoc: location, (* The location of the full application. *)
++ argIds: { source: typeId, dest: typeId } list ref, (* The IDs that are required in the arguments. *)
++ resIds: { source: typeId, dest: typeId } list ref, (* Generative IDs in the result. *)
++ resultSig: signatures ref
+ }
+
+-
+ (* Used for local strdec in strdec and let strdec in strexp. *)
+ and localdecStruct =
+ {
+ decs: structs list,
+ body: structs list,
+ localDec: bool,
+- line: int
++ line: location
+ }
+-
+- (* with *)
+- fun isSignatureIdent (SignatureIdent x) = true | isSignatureIdent _ = false;
++
+ fun isEmptyStruct EmptyStruct = true | isEmptyStruct _ = false;
+-
+- (* Make a signature for initialisating variables and for
+- undeclared signature variables. *)
+- val undefinedSignature = makeCopy("UNDEFINED", makeSignatures "UNDEFINED", 0, 0);
+
+ (* Construction functions called by the parser. *)
+ val emptyStruct = EmptyStruct; (* added SPF 8/2/94 *)
+-
+- val mkStructureDec = StructureDec;
+-
+- fun mkStructureBinding (name, signat, opaque, value, line) =
+- {
+- name = name,
+- sigStruct = signat,
+- opaque = opaque,
+- value = value,
+- valRef = ref undefinedStruct,
+- line = line
+- };
+
+- fun mkStructIdent name =
++ fun mkStructIdent (name, location) =
+ StructureIdent
+ {
+ name = name,
+- valRef = ref undefinedStruct
++ valRef = ref undefinedStruct,
++ location = location
+ };
+
+
+ (* For struct...end, make a signature to accept the values. *)
+- fun mkStruct alist =
++ fun mkStruct(alist, location) =
+ StructDec
+ {
+ alist = alist,
+- value = makeSignatures ""
+- };
+-
+- val mkSignatureDec = SignatureDec;
+-
+- fun mkSignatureBinding (name, sg, ln) =
+- {
+- name = name,
+- sigStruct = sg,
+- line = ln,
+- sigRef = ref undefinedSignature
+- };
+-
+- val mkSigIdent = SignatureIdent;
+-
+- val mkSig = SigDec;
+-
+- fun mkTopLevel (dec, line) =
+- Singleton
+- {
+- dec = dec,
+- vars = ref [],
+- line = line
++ location = location,
++ value = makeSignatureTable (),
++ resultSig = ref undefinedSignature
+ };
+
+- val mkFunctorDec = FunctorDec;
+
+- fun mkFunctorBinding (name, signat, opaque, body, arg, line) =
++ fun mkCoreLang (dec, location) =
++ CoreLang
+ {
+- name = name,
+- sigStruct = signat,
+- opaque = opaque,
+- body = body,
+- arg = arg,
+- valRef = ref undefinedFunctor,
+- line = line
++ dec = dec,
++ vars = ref [],
++ location = location
+ };
+-
+- fun mkFunctorAppl (name, arg) =
++
++ fun mkFunctorAppl (name, arg, nameLoc, fullLoc) =
+ FunctorAppl
+ {
+ name = name,
+ arg = arg,
+- valRef = ref undefinedFunctor
+- };
+-
+- fun mkValSig (name, typeof, line) =
+- ValSig
+- {
+- name = name,
+- typeof = typeof,
+- line = line
+- };
+-
+- fun mkExSig (name, typeof, line) =
+- ExSig
+- {
+- name = name,
+- typeof = typeof,
+- line = line
++ valRef = ref undefinedFunctor,
++ nameLoc = nameLoc,
++ fullLoc = fullLoc,
++ argIds = ref nil,
++ resIds = ref nil,
++ resultSig = ref undefinedSignature
+ };
+
+ fun mkFormalArg (name, signat) =
+- FormalArg
+ {
+ name = name,
+ sigStruct = signat,
+ valRef = ref undefinedStruct
+ };
+-
+- fun mkSharing (isType, shares, line) =
+- Sharing {
+- isType = isType,
+- shares = shares,
+- line = line
+- };
+-
+- fun mkWhereType (sigexp, typeVars, name, types, line) =
+- WhereType {
+- sigExp = sigexp,
+- typeVars = typeVars,
+- typeName = name,
+- realisation = types,
+- line = line
+- };
+-
+
+ fun mkLocaldec (decs, body, localDec, line) =
+ Localdec
+@@ -891,1884 +249,1168 @@
+ line = line
+ };
+
+- val mkInclude = IncludeSig;
++ fun mkSigConstraint(str, csig, opaque, sigLoc) =
++ SigConstraint
++ {
++ str=str, csig=csig, opaque=opaque, sigLoc=sigLoc,
++ opaqueIds=ref nil, resultSig = ref undefinedSignature
++ }
+
+- fun mkSigConstraint(str, csig, opaque) =
+- SigConstraint{str=str, csig=csig, opaque=opaque}
+-
+- (* end; structs abstype *)
++ val mkStructureDec = StructureDec
++
++ fun mkStructureBinding ((name, nameLoc), signat, value, fullLoc): structBind =
++ let
++ (* If there's an explicit signature move that to a constraint. *)
++ val value =
++ case signat of
++ NONE => value
++ | SOME (csig, opaque, sigLoc) =>
++ mkSigConstraint(value, csig, opaque, sigLoc)
++ in
++ {
++ name = name,
++ nameLoc = nameLoc,
++ haveSig = isSome signat,
++ value = value,
++ valRef = ref undefinedStruct,
++ line = fullLoc
++ }
++ end;
+
+- (* Pretty printing *)
++ type formalArgStruct =
++ {
++ name: string,
++ sigStruct: sigs,
++ valRef: structVals ref
++ } (* The structure variable. *)
+
+- fun displayStructs
+- (strs : structs list,
+- depth : int,
+- pprint: prettyPrinter
+- ) : unit =
+- let (* Prints a list of items. *)
+- fun displayList ([], separator, depth) dodisplay = ()
+-
+- | displayList ([v], separator, depth) dodisplay =
+- if depth <= 0
+- then ppAddString pprint "..."
+- else dodisplay (v, depth)
+-
+- | displayList (v::vs, separator, depth) dodisplay =
+- if depth <= 0
+- then ppAddString pprint "..."
+- else let
+- val brk = if separator = "," orelse separator = ";" then 0 else 1
+- in
+- ppBeginBlock pprint (0, false);
+- dodisplay (v, depth);
+- ppBreak pprint (brk, 0);
+- ppAddString pprint separator;
+- ppEndBlock pprint ();
+- ppBreak pprint (1, 0);
+- displayList (vs, separator, depth - 1) dodisplay
+- end (* displayList *)
+-
+- fun display (str, depth) =
+- ( if depth <= 0 (* elide further text. *)
+- then ppAddString pprint "..."
++ (* Top level declarations and program. *)
++ datatype topdec =
++ StrDec of structs * typeId list ref (* Structure decs and core lang. *)
++ | FunctorDec of functorBind list * location (* List of functor decs. *)
++ | SignatureDec of sigBind list * location (* List of signature decs *)
+
+- else case str of
+- StructureDec (structList : structBind list) =>
+- let
+- fun displayStructBind (
+- {name, sigStruct, value, opaque, ...}: structBind, depth) =
+- (
+- ppBeginBlock pprint (3, false);
+- ppAddString pprint name;
+- if isEmptyStruct sigStruct then ()
+- else (* Signature is optional *)
+- (
+- ppAddString pprint (if opaque then " :>" else " :");
+- ppBreak pprint (1, 0);
+- display (sigStruct, depth - 1)
+- );
+- if isEmptyStruct value then ()
+- else (* May be a structure signature *)
+- (
+- ppAddString pprint " =";
+- ppBreak pprint (1, 0);
+- display (value, depth - 1)
+- );
+- ppEndBlock pprint ()
+- )
+- in
+- ppBeginBlock pprint (3, false);
+- ppAddString pprint "structure";
+- ppBreak pprint (1, 0);
+- displayList (structList, "and", depth) displayStructBind;
+- ppEndBlock pprint ()
+- end
++ withtype (* Functor binding. *)
++ functorBind =
++ {
++ name: string,
++ nameLoc: location,
++ haveSig: bool, (* Whether we moved an explicit signature to the value. *)
++ body: structs,
++ arg: formalArgStruct,
++ valRef: functors ref, (* The functor variable declared. *)
++ resIds: { source: typeId, dest: typeId } list ref,
++ line: location
++ }
+
+- | StructureIdent {name, ...} =>
+- ppAddString pprint name
++ and sigBind =
++ {
++ name: string, (* The name of the signature *)
++ nameLoc: location,
++ sigStruct: sigs,(* Its value *)
++ sigRef: signatures ref, (* The "value" of the signature. *)
++ line: location
++ }
+
+- | StructDec {alist, ...} =>
+- (
+- ppBeginBlock pprint (1, true);
+- ppAddString pprint "struct";
+- ppBreak pprint (1, 0);
+- displayList (alist, "", depth) display;
+- ppBreak pprint (1, 0);
+- ppAddString pprint "end";
+- ppEndBlock pprint ()
+- )
++ fun mkTopDec t = StrDec(t, ref nil)
++ and mkFunctorDec s = FunctorDec s
++ and mkSignatureDec s = SignatureDec s;
++
++ fun mkFunctorBinding (name, nameLoc, signat, body, arg, line) =
++ let
++ (* If there's an explicit signature move that to a constraint. *)
++ val body =
++ case signat of
++ NONE => body
++ | SOME (csig, opaque, sigLoc) =>
++ mkSigConstraint(body, csig, opaque, sigLoc)
++ in
++ {
++ name = name,
++ nameLoc = nameLoc,
++ haveSig = isSome signat,
++ body = body,
++ arg = arg,
++ valRef = ref undefinedFunctor,
++ resIds = ref nil,
++ line = line
++ }
++ end
+
+- | SignatureDec (structList : sigBind list) =>
+- let
+- fun displaySigBind ({name, sigStruct, ...}: sigBind, depth) =
+- (
+- ppBeginBlock pprint (3, false);
+- ppAddString pprint (name ^ " =");
+- ppBreak pprint (1, 0);
+- display (sigStruct, depth - 1);
+- ppEndBlock pprint ()
+- )
+- in
+- ppBeginBlock pprint (3, false);
+- ppAddString pprint "signature";
+- ppBreak pprint (1, 0);
+- displayList (structList, "and", depth) displaySigBind;
+- ppEndBlock pprint ()
+- end
++ and mkSignatureBinding ((name, nameLoc), sg, ln) =
++ {
++ name = name,
++ nameLoc = nameLoc,
++ sigStruct = sg,
++ line = ln,
++ sigRef = ref undefinedSignature
++ }
+
+- | SignatureIdent (name : string) =>
+- ppAddString pprint name
++ type program = topdec list * location
++ fun mkProgram tl = tl
+
+- | SigDec (structList : structs list) =>
+- (
+- ppBeginBlock pprint (1, true);
+- ppAddString pprint "sig";
+- ppBreak pprint (1, 0);
+- displayList (structList, "", depth) display;
+- ppBreak pprint (1, 0);
+- ppAddString pprint "end";
+- ppEndBlock pprint ()
+- )
++ (* Pretty printing *)
+
+- | ValSig {name, typeof, ...} =>
+- let
+- in
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint "val";
+- ppBreak pprint (1, 1);
+- ppAddString pprint (name ^ " :");
+- ppBreak pprint (1, 0);
+- displayType (typeof, depth - 1, pprint, true);
+- ppEndBlock pprint ()
+- end
++ fun displayList ([], _, _) _ = []
++
++ | displayList ([v], _, depth) dodisplay =
++ if depth <= 0
++ then [PrettyString "..."]
++ else [dodisplay (v, depth)]
++
++ | displayList (v::vs, separator, depth) dodisplay =
++ if depth <= 0
++ then [PrettyString "..."]
++ else
++ let
++ val brk = if separator = "," orelse separator = ";" then 0 else 1
++ in
++ PrettyBlock (0, false, [],
++ [
++ dodisplay (v, depth),
++ PrettyBreak (brk, 0),
++ PrettyString separator
++ ]
++ ) ::
++ PrettyBreak (1, 0) ::
++ displayList (vs, separator, depth - 1) dodisplay
++ end (* displayList *)
++
++ fun displayStruct (str, depth) =
++ if depth <= 0 (* elide further text. *)
++ then PrettyString "..."
+
+- | ExSig {name, typeof, ...} =>
+- let
+- in
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint "exception";
+- ppBreak pprint (1, 1);
+- ppAddString pprint (name ^ " :");
+- ppBreak pprint (1, 0);
+- displayType (typeof, depth - 1, pprint, true);
+- ppEndBlock pprint ()
+- end
++ else
++ case str of
++ StructureDec (structList : structBind list, _) =>
++ let
++ fun displayStructBind (
++ {name, haveSig, value, ...}: structBind, depth) =
++ let
++ (* If we desugared this before, return it to its original form. *)
++ val (sigStruct, value) =
++ case (haveSig, value) of
++ (true, SigConstraint{str, csig, opaque, sigLoc, ...}) =>
++ (SOME(csig, opaque, sigLoc), str)
++ | _ => (NONE, value)
++ in
++ PrettyBlock (3, false, [],
++ PrettyString name ::
++ (
++ case sigStruct of (* Signature is optional *)
++ NONE => []
++ | SOME (sigStruct, opaque, _) =>
++ [
++ PrettyString (if opaque then " :>" else " :"),
++ PrettyBreak (1, 0),
++ displaySigs (sigStruct, depth - 1)
++ ]
++ ) @
++ [
++ PrettyString " =",
++ PrettyBreak (1, 0),
++ displayStruct (value, depth - 1)
++ ]
++ )
++ end
++ in
++ PrettyBlock (3, false, [],
++ PrettyString "structure" ::
++ PrettyBreak (1, 0) ::
++ displayList (structList, "and", depth) displayStructBind
++ )
++ end
+
+- | FunctorDec (structList : functorBind list) =>
+- let
+- fun displayFunctBind (
+- {name, arg, sigStruct, body, opaque, ...}: functorBind, depth) =
+- (
+- ppBeginBlock pprint (3, false);
+- ppAddString pprint (name ^ "(");
+- ppBreak pprint (1, 0);
+- ppBeginBlock pprint (3, true);
+- display (arg, depth - 1);
+- ppEndBlock pprint ();
+- ppAddString pprint ")";
+- if not (isEmptyStruct sigStruct)
+- then (* Signature is optional *)
+- (
+- ppAddString pprint(if opaque then " :>" else " :");
+- ppBreak pprint (1, 0);
+- display (sigStruct, depth - 1)
+- )
+- else ();
+- ppBreak pprint (1, 0);
+- ppAddString pprint "=";
+- ppBreak pprint (1, 0);
+- display (body, depth - 1);
+- ppEndBlock pprint ()
+- )
+- in
+- ppBeginBlock pprint (3, false);
+- ppAddString pprint "functor";
+- ppBreak pprint (1, 0);
+- displayList (structList, "and", depth) displayFunctBind;
+- ppEndBlock pprint ()
+- end
++ | StructureIdent {name, ...} =>
++ PrettyString name
++
++ | StructDec {alist, ...} =>
++ PrettyBlock (1, true, [],
++ PrettyString "struct" ::
++ PrettyBreak (1, 0) ::
++ displayList (alist, "", depth) displayStruct @
++ [ PrettyBreak (1, 0), PrettyString "end"]
++ )
+
+ | FunctorAppl {name, arg, ...} =>
+- let
+- in
+- ppBeginBlock pprint (1, false);
+- ppAddString pprint (name ^ "(");
+- ppBreak pprint (0, 0);
+- display (arg, depth);
+- ppBreak pprint (0, 0);
+- ppAddString pprint ")";
+- ppEndBlock pprint ()
+- end
++ PrettyBlock (1, false, [],
++ [
++ PrettyString (name ^ "("),
++ PrettyBreak (0, 0),
++ displayStruct (arg, depth),
++ PrettyBreak (0, 0),
++ PrettyString ")"
++ ]
++ )
+
+- | FormalArg {name, sigStruct, ...} =>
+- let
+- in
+- ppBeginBlock pprint (1, false);
+- if name = "" then ()
+- else
+- (
+- ppAddString pprint (name ^ " :");
+- ppBreak pprint (1, 2)
+- );
+- display (sigStruct, depth - 1);
+- ppEndBlock pprint ()
+- end
++ | Localdec {decs, body, localDec, ...} =>
++ PrettyBlock (3, false, [],
++ PrettyString (if localDec then "local" else "let") ::
++ PrettyBreak (1, 0) ::
++ displayList (decs, ";", depth - 1) displayStruct @
++ [ PrettyBreak (1, 0), PrettyString "in", PrettyBreak (1, 0)] @
++ displayList (body, ";", depth - 1) displayStruct @
++ [ PrettyBreak (1, 0), PrettyString "end" ]
++ )
++
++ | CoreLang {dec, ...} =>
++ ptDisplay (dec, depth - 1)
++
++ | SigConstraint{str, csig, opaque, ...} =>
++ PrettyBlock (0, false, [],
++ [
++ displayStruct (str, depth - 1),
++ PrettyString (if opaque then " :>" else " :"),
++ PrettyBreak (1, 0),
++ displaySigs (csig, depth - 1)
++ ]
++ )
+
+- | Sharing { isType, shares, ... } =>
+- (
+- ppBeginBlock pprint (3, false);
+- ppAddString pprint "sharing";
+- ppBreak pprint (1, 0);
+- if not isType then ()
+- else
+- (
+- ppAddString pprint "type";
+- ppBreak pprint (1, 0)
+- );
+- displayList (shares, "=", depth)
+- (fn (name, depth) => ppAddString pprint name);
+- ppEndBlock pprint ()
+- )
++ | EmptyStruct =>
++ PrettyString "<bad>"
++ (* End displayStruct *)
++
++ fun displayTopDec(top, depth) =
++ if depth <= 0 (* elide further text. *)
++ then PrettyString "..."
++
++ else
++ case top of
++ StrDec(s, _) => displayStruct(s, depth)
+
+- | WhereType { sigExp, typeVars, typeName, realisation, ... } =>
+- (
+- ppBeginBlock pprint (3, false);
+- display (sigExp, depth);
+- ppBreak pprint (1, 0);
+- ppAddString pprint "where";
+- ppBreak pprint (1, 0);
+- ppAddString pprint "type";
+- ppBreak pprint (1, 0);
+- displayTypeVariables (typeVars, depth, pprint, true);
+- ppAddString pprint typeName;
+- ppBreak pprint (1, 0);
+- ppAddString pprint "=";
+- ppBreak pprint (1, 0);
+- displayType (realisation, depth - 1, pprint, true);
+- ppEndBlock pprint ()
+- )
++ | SignatureDec (structList : sigBind list, _) =>
++ let
++ fun displaySigBind ({name, sigStruct, ...}: sigBind, depth) =
++ PrettyBlock (3, false, [],
++ [
++ PrettyString (name ^ " ="),
++ PrettyBreak (1, 0),
++ displaySigs (sigStruct, depth - 1)
++ ]
++ )
++ in
++ PrettyBlock (3, false, [],
++ PrettyString "signature" ::
++ PrettyBreak (1, 0) ::
++ displayList (structList, "and", depth) displaySigBind
++ )
++ end
+
+- | Localdec {decs, body, localDec, ...} =>
+- (
+- ppBeginBlock pprint (3, false);
+- ppAddString pprint (if localDec then "local" else "let");
+- ppBreak pprint (1, 0);
+- displayList (decs, ";", depth - 1) display;
+- ppBreak pprint (1, 0);
+- ppAddString pprint "in";
+- ppBreak pprint (1, 0);
+- displayList (body, ";", depth - 1) display;
+- ppBreak pprint (1, 0);
+- ppAddString pprint "end";
+- ppEndBlock pprint ()
++ | FunctorDec (structList : functorBind list, _) =>
++ let
++ fun displayFunctBind (
++ {name, arg={name=argName, sigStruct=argStruct, ...}, haveSig, body, ...}, depth) =
++ let
++ val (sigStruct, body) =
++ case (haveSig, body) of
++ (true, SigConstraint{str, csig, opaque, sigLoc, ...}) =>
++ (SOME(csig, opaque, sigLoc), str)
++ | _ => (NONE, body)
++ in
++ PrettyBlock (3, false, [],
++ PrettyString (name ^ "(") ::
++ PrettyBreak (1, 0) ::
++ PrettyBlock (1, false, [],
++ (
++ if argName = "" then []
++ else [ PrettyString (argName ^ " :"), PrettyBreak (1, 2)]
++ ) @
++ [displaySigs (argStruct, depth - 1)]
++ ) ::
++ PrettyString ")" ::
++ (
++ case sigStruct of
++ NONE => [] (* Signature is optional *)
++ | SOME (sigStruct, opaque, _) =>
++ [
++ PrettyString(if opaque then " :>" else " :"),
++ PrettyBreak (1, 0),
++ displaySigs (sigStruct, depth - 1)
++ ]
++ ) @
++ [
++ PrettyBreak (1, 0),
++ PrettyString "=",
++ PrettyBreak (1, 0),
++ displayStruct (body, depth - 1)
++ ]
++ )
++ end
++ in
++ PrettyBlock (3, false, [],
++ PrettyString "functor" ::
++ PrettyBreak (1, 0) ::
++ displayList (structList, "and", depth) displayFunctBind
++ )
++ end
++ (* End displayTopDec *)
++
++ fun displayProgram ((sl, _), d) =
++ PrettyBlock(0, true, [],
++ displayList (sl, "", d) displayTopDec
+ )
+
+- | IncludeSig (structList : structs list) =>
+- (
+- ppBeginBlock pprint (3, true);
+- ppAddString pprint "include";
+- ppBreak pprint (1, 0);
+- displayList (structList, "", depth - 1) display;
+- ppEndBlock pprint ()
+- )
++ fun structExportTree(navigation, s: structs) =
++ let
++ (* Common properties for navigation and printing. *)
++ val commonProps =
++ PTprint(fn d => displayStruct(s, d)) ::
++ exportNavigationProps navigation
+
+- | Singleton {dec, ...} =>
+- ptDisplay (dec, depth - 1, pprint)
++ fun asParent () = structExportTree(navigation, s)
++ in
++ case s of
++ StructureDec(sbl, location) =>
++ let
++ fun exportSB(navigation, sb as {name, nameLoc, haveSig, value, line, ...}) =
++ let
++ (* If we desugared this before, return it to its original form. *)
++ val (sigStruct, value) =
++ case (haveSig, value) of
++ (true, SigConstraint{str, csig, opaque, sigLoc, ...}) =>
++ (SOME(csig, opaque, sigLoc), str)
++ | _ => (NONE, value)
++ fun exportThis () = exportSB(navigation, sb)
++ (* Three groups: name, signature and structures.
++ It's all complicated because the signature
++ may not be present. *)
++ fun getName () =
++ let
++ val next =
++ case sigStruct of
++ SOME _ => getSigStruct
++ | NONE => getValue
++ in
++ getStringAsTree({parent=SOME exportThis, previous=NONE, next=SOME next}, name, nameLoc, [])
++ end
++
++ and getSigStruct () =
++ let
++ val next = SOME getValue
++ val (theSig, _, _) = valOf sigStruct
++ in
++ sigExportTree({parent=SOME exportThis, previous=SOME getName, next=next}, theSig)
++ end
++
++ and getValue () =
++ let
++ val previous =
++ case sigStruct of
++ NONE => getName
++ | SOME _ => getSigStruct
++ in
++ structExportTree({parent=SOME exportThis, previous=SOME previous, next=NONE}, value)
++ end
++ in
++ (line, PTfirstChild getName :: exportNavigationProps navigation)
++ end
+
+- | SigConstraint{str, csig, opaque} =>
+- (
+- display (str, depth - 1);
+- ppAddString pprint (if opaque then " :>" else " :");
+- ppBreak pprint (1, 0);
+- display (csig, depth - 1)
+- )
++ val expChild = exportList(exportSB, SOME asParent) sbl
++ in
++ (location, expChild @ commonProps)
++ end
+
+- | EmptyStruct =>
+- ppAddString pprint ("<bad>")
+- );
+- in
+- displayList (strs, "", depth) display
+- end (* displayStructs *);
++ | StructureIdent { valRef = ref var, location, ... } =>
++ (* Get the location properties for the identifier. *)
++ (location, mapLocationProps (structLocations var) @ commonProps)
+
++ | StructDec{ location, alist, ...} =>
++ (location, exportList(structExportTree, SOME asParent) alist @ commonProps)
+
+- (* Puts out an error message and then prints the piece of tree. *)
+- fun errorNear (lex, hard, near, lno, message) : unit =
+- let
+- val printProc = if hard then errorProc else warningProc;
+- in
+- printProc
+- (lex,
+- lno,
+- fn (pprint: prettyPrinter) =>
+- let
+- val parameters = debugParams lex
+- val errorDepth = getParameter errorDepthTag parameters
+- in
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint message;
+- ppBreak pprint (3, 0);
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint "Found near";
+- ppBreak pprint (1, 0);
+- displayStructs ([near], errorDepth, pprint);
+- ppEndBlock pprint ();
+- ppEndBlock pprint ()
+- end)
+- end;
+-
+- (* Returns a function which can be passed to typetree.match to
+- print a bit of context information. *)
+- fun foundNear (sVal : structs, name : string, lex) : prettyPrinter -> unit =
+- fn (pprint: prettyPrinter) =>
+- let
+- val parameters = debugParams lex
+- val errorDepth = getParameter errorDepthTag parameters
+- in
+- ppAddString pprint ("While checking (" ^ name ^ ") near");
+- ppBreak pprint (1, 2);
+- displayStructs ([sVal], errorDepth, pprint)
+- end;
+-
+- (* Error message routine for lookupType and lookupStructure. *)
+- fun giveError (sVal : structs, lno : int, lex : lexan) : string -> unit =
+- fn (message : string) => errorNear (lex, true, sVal, lno, message);
++ | FunctorAppl { valRef = ref fnctr, name, nameLoc, fullLoc, arg, ... } =>
++ let
++ (* Navigate between the functor name and the argument. *)
++ (* The first position is the expression, the second the type *)
++ fun getFunctorName () =
++ getStringAsTree({parent=SOME asParent, previous=NONE, next=SOME getFunctorArg},
++ name, nameLoc, [PTdeclaredAt(functorDeclaredAt fnctr)])
++ and getFunctorArg () =
++ structExportTree({parent=SOME asParent, previous=SOME getFunctorName, next=NONE}, arg)
++ in
++ (fullLoc, PTfirstChild getFunctorName :: commonProps)
++ end
+
+- (* Structures and values in signatures. *)
+-
+- (* Formal paramater to a functor - either value or exception. *)
+- fun mkFormal (name : string, class, typ, addr) =
+- Value{class=class, name=name, typeOf=typ, access=Formal addr}
+-
+- (* A null map from a structure identifier to anything. *)
+- fun nullMap (id : 'a) : 'b option = NONE;
+-
+- (* Check that a matching has succeeded, and check the value
+- constructors if they are datatypes. Used for both signature
+- matching and also for sharing constraints where there is no
+- obvious direction of matching. However the rule for signature
+- matching requires the types of the constructors to match
+- whereas the rule for sharing only requires that they have the
+- same names (type checking in that case could require second-order
+- unification). *)
+- fun checkTypeConstrs
+- (candid,
+- target,
+- targTypeMap,
+- checkTypes,
+- lex : lexan,
+- near,
+- lno : int
+- ) : unit=
+- let
+- val candidName : string = tcName candid;
+- val targetName : string = tcName target;
+-
+- fun checkConstrs ([], []) = ()
++ | CoreLang {dec, ...} => (* A value parse-tree entry. *)
++ getExportTree(navigation, dec)
++
++ | Localdec {decs, body, line, ...} =>
++ (line, exportList(structExportTree, SOME asParent) (decs @ body) @ commonProps)
++
++ | SigConstraint { str, csig, sigLoc, ... } =>
++ let
++ (* Navigate between the functor name and the argument. *)
++ (* The first position is the expression, the second the type *)
++ fun getStructure () =
++ structExportTree({parent=SOME asParent, previous=NONE, next=SOME getSignature}, str)
++ and getSignature () =
++ sigExportTree({parent=SOME asParent, previous=SOME getStructure, next=NONE}, csig)
++ in
++ (sigLoc, PTfirstChild getStructure :: commonProps)
++ end
++
++ | EmptyStruct => (nullLocation, commonProps)
++
++ end
+
+- | checkConstrs (cList, []) =
+- errorNear (lex, true, near, lno,
+- "Too many constructors to match type (" ^ candidName ^ ")")
+-
+- | checkConstrs ([], tList) =
+- errorNear
+- (lex, true, near, lno,
+- "Not enough constructors to match type (" ^ candidName ^ ")")
+-
+- | checkConstrs (cVal :: cList, tVal :: tList) =
+- let
+- val cName : string = valName cVal;
+- val tName : string = valName tVal;
++ fun topDecExportTree(navigation, top: topdec) =
++ let
++ (* Common properties for navigation and printing. *)
++ val commonProps =
++ PTprint(fn d => displayTopDec(top, d)) ::
++ exportNavigationProps navigation
++
++ fun asParent () = topDecExportTree(navigation, top)
++ in
++ case top of
++ StrDec(s, _) => structExportTree(navigation, s)
++
++ | SignatureDec(sigs, location) =>
++ let
++ fun exportSB(navigation, sb as {name, nameLoc, sigStruct, line, ...}) =
++ let
++ fun exportThis () = exportSB(navigation, sb)
++ fun getName () =
++ getStringAsTree({parent=SOME exportThis, previous=NONE, next=SOME getSig}, name, nameLoc, [])
++ and getSig () =
++ sigExportTree({parent=SOME exportThis, previous=SOME getName, next=NONE}, sigStruct)
++ in
++ (line, PTfirstChild getName :: exportNavigationProps navigation)
++ end
++ in
++ (location, exportList(exportSB, SOME asParent) sigs @ commonProps)
++ end
++
++ | FunctorDec(fbl, location) =>
++ let
++ fun exportFB(navigation,
++ fb as {name, nameLoc, haveSig, arg={sigStruct=argStruct, ...}, body, line, ...}) =
++ let
++ val (sigStruct, body) =
++ case (haveSig, body) of
++ (true, SigConstraint{str, csig, opaque, sigLoc, ...}) =>
++ (SOME(csig, opaque, sigLoc), str)
++ | _ => (NONE, body)
++ val fbProps = exportNavigationProps navigation
++ fun exportThis () = exportFB(navigation, fb)
++ (* Because the signature is optional navigation on the arg and body depends on
++ whether there's a signature. *)
++ fun getName() =
++ getStringAsTree({parent=SOME exportThis, previous=NONE, next=SOME getArg},
++ name, nameLoc, [])
++
++ and getArg() =
++ let
++ val next =
++ if isSome sigStruct then getSig else getBody
++ in
++ sigExportTree({parent=SOME exportThis, previous=SOME getName, next=SOME next},
++ argStruct)
++ end
++
++ and getSig() =
++ sigExportTree({parent=SOME exportThis, previous=SOME getArg, next=SOME getBody},
++ #1(valOf sigStruct))
++
++ and getBody() =
++ let
++ val previous = if isSome sigStruct then getSig else getArg
++ in
++ structExportTree({parent=SOME exportThis, previous=SOME previous, next=NONE}, body)
++ end
++ in
++ (line, PTfirstChild getName :: fbProps)
++ end
++
++ val expChild = exportList(exportFB, SOME asParent) fbl
++ in
++ (location, expChild @ commonProps)
++ end
++ end
++
++ (* Convert a "program" into a navigable tree. *)
++ fun structsExportTree (parentTree, trees: program) =
++ let
++ val parentTreeNav = exportNavigationProps parentTree
++ (* The top level is actually a list. *)
++ fun exportTree(([], location)) = (location, parentTreeNav)
++ | exportTree(topdec as (sl, location)) =
++ let
++ fun getEntry(this as (s :: sl), getPrevious) (): exportTree =
++ topDecExportTree(
++ {
++ parent = SOME(fn () => exportTree topdec), (* Parent is this. *)
++ previous = getPrevious,
++ (* If we have a successor then that is the entry and
++ its predecessor returns here. *)
++ next =
++ case sl of
++ [] => NONE
++ | t => SOME(getEntry(t, SOME(getEntry(this, getPrevious))))
++ },
++ s
++ )
++ | getEntry _ () = raise Empty
+ in
+- (* Check they have the same name. *)
+- if cName <> tName
+- then errorNear
+- (lex, true, near, lno,
+- "Looking for constructor " ^ tName ^
+- " but found " ^ cName)
+- (* Check their types match. *)
+- else let
+- (* This works correctly for polytypes
+- (e.g. datatype 'a t = ...) because the type variables
+- in the signature will be non-unifiable. checkTypes does
+- nothing if we are generating a sharing constraint and then
+- the rest of the list. *)
+- val cType : types = valTypeOf cVal;
+- val tType : types = valTypeOf tVal;
+- val U : unit = checkTypes (cType, tType, cName);
+- in
+- checkConstrs (cList, tList)
+- end
+- end;
+- in
+- if tcArity candid <> tcArity target
+- then () (* Have already given the error message. *)
+- else let
+- (* Check the type constructors themselves first. This checks
+- that the sharing constraints have been satisfied. *)
+- val tvars : types list = tcTypeVars target; (* either will do *)
+- val U : unit =
+- matchTypes
+- (mkTypeConstruction (candidName, candid, tvars),
+- mkTypeConstruction (targetName, target, tvars),
+- targTypeMap,
+- lex,
+- lno,
+- foundNear (near, targetName, lex));
+-
+- val candidConstrs : values list = tcConstructors candid;
+- val targetConstrs : values list = tcConstructors target;
+- in
+- (* We have already checked for matching a type in the structure
+- to a datatype in the signature. *)
+- if null targetConstrs orelse null candidConstrs
+- then ()
+- else checkConstrs (candidConstrs, targetConstrs)
++ (location, parentTreeNav @ [PTfirstChild(getEntry(sl, NONE))])
++ end
++ in
++ exportTree trees
+ end
+- end (* checkTypeConstrs *);
+
+- (* Check that a candidate signature (actually the environment part of
+- a structure) matches a target signature. The direction is important
+- because a candidate is allowed to have more components and more
+- polymorphism than the target. Along with the candidate and target
+- signatures we also pass maps which are applied to the structure and
+- type "names" (unique ids) before the matching process. *)
++ (* Puts out an error message and then prints the piece of tree. *)
++ fun errorMsgNear (lex, hard, near, lno, message) : unit =
++ let
++ val parameters = debugParams lex
++ val errorDepth = getParameter errorDepthTag parameters
++ in
++ reportError lex
++ {
++ hard = hard, location = lno, message = message,
++ context = SOME(near errorDepth)
++ }
++ end;
++
++ (* TODO: If the item being errored is in a substructure it currently doesn't report
++ the name of the substructure. *)
++ (* Report an error about signature-structure matching. *)
++ fun sigStructMatchMsg (lex, near, lno, structName) (doDisplay: 'a -> pretty)
++ (structValue: 'a, sigValue: 'a, reason) =
++ let
++ val message =
++ PrettyBlock(3, true, [],
++ [
++ PrettyString
++ ("Structure does not match signature" ^
++ (if structName = "" then "." else " in sub-structure " ^ structName)),
++ PrettyBreak(1, 0),
++ PrettyBlock(3, false, [],
++ [
++ PrettyString "Signature:",
++ PrettyBreak(1, 0),
++ doDisplay sigValue
++ ]),
++ PrettyBreak(1, 0),
++ PrettyBlock(3, false, [],
++ [
++ PrettyString "Structure:",
++ PrettyBreak(1, 0),
++ doDisplay structValue
++ ]),
++ PrettyBreak(1, 0),
++ PrettyBlock(3, false, [],
++ [
++ PrettyString "Reason:",
++ PrettyBreak(1, 0),
++ reason
++ ])
++ ])
++ in
++ errorMsgNear(lex, true, near, lno, message)
++ end
++
++ fun sigStructMissingMsg (lex, near, lno, structName) (doDisplay: 'a -> pretty) (sigValue: 'a) =
++ let
++ val message =
++ PrettyBlock(3, true, [],
++ [
++ PrettyString
++ ("Structure does not match signature" ^
++ (if structName = "" then "." else " in sub-structure " ^ structName)),
++ PrettyBreak(1, 0),
++ PrettyBlock(3, false, [],
++ [
++ PrettyString "Signature:",
++ PrettyBreak(1, 0),
++ doDisplay sigValue
++ ]),
++ PrettyBreak(1, 0),
++ PrettyBlock(3, false, [],
++ [
++ PrettyString "Structure:",
++ PrettyBreak(1, 0),
++ PrettyString "Not present"
++ ])
++ ])
++ in
++ errorMsgNear(lex, true, near, lno, message)
++ end
++
++ (* Older version: prints just a string message. *)
++ fun errorNear(lex, hard, near, lno, message: string) =
++ errorMsgNear (lex, hard, near, lno,
++ PrettyBlock (0, false, [], [PrettyString message]))
+
+- type 'a map =
+- {
+- lookup: typeId -> 'a option,
+- enter: typeId * 'a -> unit
+- };
+-
+- fun matchSigs
+- (candidate : signatures,
+- target : signatures,
+- tArgTypeMap : typeConstrs map,
+- near,
+- lno : int,
+- lex : lexan
+- ) : unit =
+- let
+- val lookupType = #lookup tArgTypeMap;
+-
+- (* Match names (unique ids) for types. This is slightly more
+- complicated than simply assigning the stamps. *)
+- fun matchNames (candidate, target) : unit=
+- univFold
+- (sigTab target,
+- (fn (dName, dVal, ()) =>
++ fun errorDepth lex =
++ let
++ open DEBUG
++ val parameters = LEX.debugParams lex
++ in
++ getParameter errorDepthTag parameters
++ end
++
++ (* Error message routine for lookupType and lookupStructure. *)
++ fun giveError (sVal : structs, lno : LEX.location, lex : lexan) : string -> unit =
++ fn (message : string) => errorNear (lex, true, fn n => displayStruct(sVal, n), lno, message);
++
++ (* Turn a result from matchTypes into a pretty structure so that it
++ can be included in a message. *)
++ (* TODO: When reporting type messages from inside the structure we should use
++ the environment from within the structure and for type within the signature the signature env. *)
++ fun matchErrorReport(lex, structTypeEnv, sigTypeEnv) =
++ unifyTypesErrorReport(lex, structTypeEnv, sigTypeEnv, "match")
++
++ (* Check that two types match. *)
++ fun matchTypes (candidate, target, targMap: int -> typeId option) =
++ let
++ fun copyId(Bound{ offset, ...}) = targMap offset
++ | copyId _ = NONE
++ fun copyATypeConstr tcon = copyTypeConstr(tcon, copyId, fn x => x, fn s => s)
++ fun copyTarget t = (* Don't bother with type variables. *)
++ copyType (t, fn x => x, copyATypeConstr);
++ val copiedTarget = copyTarget target
++ (* Do the match to a version of the candidate with copies of the
++ type variables so that we can instantiate them. We could do
++ this by passing in a mapping function but the problem is that
++ if we have a type variable that gets unified to another variable
++ we will not map it properly if it occurs again (we call "eventual"
++ and get the second tv before calling the map function so we get a
++ second copy and not the first copy). *)
++ val copiedCandidate : types = generalise candidate;
++ in
++ unifyTypes (copiedCandidate, copiedTarget)
++ end;
++
++ (* Check that a matching has succeeded, and check the value
++ constructors if they are datatypes. *)
++ fun checkTypeConstrs (candid, target, targTypeMap: int -> typeId option, lex, near, lno, typeEnv, structPath) =
++ let
++ val candidName : string = tcName candid;
++ val targetName : string = tcName target;
++ val tvars = List.map TypeVar (tcTypeVars target); (* either will do *)
++ (* If we get an error in the datatype itself print the full datatype. *)
++ val printTypeEnv = { lookupType = fn _ => NONE, lookupStruct = fn _ => NONE }
++ val errorInDatatype =
++ sigStructMatchMsg(lex, near, lno, structPath)(fn t => displayTypeConstrs(t, errorDepth lex, printTypeEnv))
++ in
++ if tcArity candid <> tcArity target
++ then () (* Have already given the error message. *)
++ else (* Check the type constructors themselves first. This checks
++ that the sharing constraints have been satisfied. *)
++ case matchTypes (mkTypeConstruction (candidName, candid, tvars, []),
++ mkTypeConstruction (targetName, target, tvars, []),
++ targTypeMap) of
++ SOME error => errorInDatatype(candid, target, matchErrorReport(lex, typeEnv, typeEnv) error) (* Report the error. *)
++ | NONE => () (* We have already checked for matching a type in the structure to a datatype in the signature.
++ In ML97 we can't rebind an identifier in a signature so each constructor for this datatype
++ must be present in the signature i.e. it can't be hidden by a constructor for another datatype.
++ So we can check the constructors when we check the values. *)
++ end (* checkTypeConstrs *);
++
++ (* Check that a candidate signature (actually the environment part of
++ a structure) matches a target signature. The direction is important
++ because a candidate is allowed to have more components and more
++ polymorphism than the target. As part of the matching process we
++ build up a map of typeIDs in the target to type IDs in the candidate
++ and that is returned as the result.
++ N.B. the map function takes an argument between minTarget and maxTarget. *)
++ fun matchSigs(originalCandidate, originalTarget, near, lno, lex, typeIdEnv, typeEnv): int -> typeId =
++ let
++ val candidate = (* The structure. *)
++ let
++ val Signatures { typeIdMap, minTypes, boundIds, ... } = originalCandidate
++ val _ =
++ case boundIds of
++ [] => ()
++ | _ => raise InternalError "Candidate structure with non-empty bound ID list"
++ in
++ replaceMap(originalCandidate, typeIdMap, minTypes, [], typeIdEnv)
++ end
++
++ val target = (* The signature. *)
++ let
++ val Signatures { typeIdMap, minTypes, boundIds, ... } = originalTarget
++ fun newMap n =
++ if n < minTypes then typeIdEnv n
++ else List.nth(boundIds, n-minTypes)
++ in
++ replaceMap(originalTarget, typeIdMap, minTypes, boundIds, newMap)
++ end
++
++ local
++ val minTarget = sigMinTypes target
++ and maxTarget = sigMaxTypes target
++ (* All the Bound type IDs in the target are in this range. We create an array
++ to contain the matched IDs from the candidate. *)
++ val matchArray = Array.array(maxTarget-minTarget, NONE)
++ in
++ (* These two functions are used during the match process. *)
++ (* When looking up a Bound ID we return NONE if it is out of the range.
++ Bound IDs below the minimum are treated as global at this level and so
++ only match if they are the same in the target and candidate. *)
++ fun lookupType n =
++ if n < minTarget then NONE else Array.sub(matchArray, n-minTarget)
++ and enterType (n, id) =
++ if n < minTarget then () else Array.update(matchArray, n-minTarget, SOME id)
++
++ (* This is the result function. If everything is right every entry in the
++ array will be SOME but if we have had an error there may be entries that
++ are still NONE. To prevent an exception we return the undefined type in
++ that case. *)
++ fun resultType n = getOpt(Array.sub(matchArray, n-minTarget), tcIdentifier undefType)
++ end
++
++ (* Match typeIDs for types. This is slightly more
++ complicated than simply assigning the stamps. *)
++ fun matchNames (candidate, target, structPath) : unit =
++ univFold (sigTab target,
++ fn (dName, dVal, ()) =>
+ if tagIs typeConstrVar dVal
+- then let (* See if there is one with the same name. *)
+- val target = tagProject typeConstrVar dVal;
++ then
++ let (* See if there is one with the same name. *)
++ val target = tagProject typeConstrVar dVal;
++ val printTypeEnv = { lookupType = fn _ => NONE, lookupStruct = fn _ => NONE }
++ fun displayType t = displayTypeConstrs(t, errorDepth lex, printTypeEnv)
++ val typeError = sigStructMatchMsg(lex, near, lno, structPath) displayType
+ in (* Match up the types. This does certain checks but
+ does not check sharing. Equality is checked for. *)
+- case univLookup (sigTab candidate, typeConstrVar, dName) of
+- SOME candid =>
+- if not (isUnsetId (tcIdentifier target)) (* just in case *)
+- then
+- (
+- (* Check for arity and equality - value constructors
+- are checked later. If the target is a bound identifier
+- in the range it can be matched by a candidate. *)
+- enterTypeConstrs (target, candid, tArgTypeMap);
++ case univLookup (sigTab candidate, typeConstrVar, dName) of
++ SOME candid =>
++ if not (isUndefinedTypeConstr target) (* just in case *)
++ then
++ (
++ (* Check for arity and equality - value constructors
++ are checked later. If the target is a bound identifier
++ in the range it can be matched by a candidate. *)
++ case tcIdentifier target of
++ Bound { offset, ...} => enterType (offset, tcIdentifier candid)
++ | _ => ();
+
+- if tcArity target <> tcArity candid
+- then errorNear (lex, true, near, lno,
+- "Types (" ^ tcName target ^ ") have different arities.")
++ if tcArity target <> tcArity candid
++ then typeError(candid, target,
++ PrettyString "Types take different numbers of type arguments.")
++
++ (* Check that it's a datatype before checking for eqtype. *)
++ else if not (null (tcConstructors target)) andalso
++ null (tcConstructors candid)
++ then typeError(candid, target,
++ PrettyString "Type in structure is not a datatype")
++
++ else if not(tcIsAbbreviation target) andalso tcEquality target
++ andalso not (permitsEquality candid)
++ then typeError(candid, target,
++ PrettyString "Type in structure is not an equality type")
+
+- else if tcEquality target andalso
+- not (permitsEquality candid)
+- then errorNear (lex, true, near, lno,
+- "(" ^ tcName candid ^ ") is not an eqtype")
+-
+- else if not (null (tcConstructors target)) andalso
+- null (tcConstructors candid)
+- then errorNear (lex, true, near, lno,
+- "(" ^ tcName candid ^ ") is not a datatype")
+-
+- else ()
+- )
+- else ()
+- | NONE =>
+- errorNear (lex, true, near, lno,
+- "Type (" ^ dName ^ ") missing in structure.")
+- end
++ else ()
++ )
++ else ()
++ | NONE => sigStructMissingMsg(lex, near, lno, structPath) displayType target
++ end
+
+ else if tagIs structVar dVal
+- then let (* and sub-structures. *)
++ then
++ let (* and sub-structures. *)
+ val target = (tagProject structVar) dVal;
+ (* For each target structure: find a candidate with the
+ same name and recursively check them. *)
+- in
++ in
+ case univLookup (sigTab candidate, structVar, dName) of
+- SOME candid => matchNames (structSignat candid, structSignat target)
+- | NONE => errorNear (lex, true, near, lno,
+- "Structure (" ^ dName ^ ") missing in structure.")
+- end
+- else () (* not a type or structure *)
+- ), (* end of fn *)
++ SOME candid =>
++ matchNames (structSignat candid, structSignat target, structPath ^ dName ^ ".")
++ | NONE =>
++ let
++ fun displayStructure s =
++ PrettyBlock(0, false, [],
++ [PrettyString "structure" , PrettyBreak(1, 3), PrettyString(structName s)])
++ in
++ sigStructMissingMsg(lex, near, lno, structPath) displayStructure target
++ end
++ end
++ else (), (* not a type or structure *)
+ () (* default value for fold *)
+ ) (* matchNames *);
+
+- val U : unit = matchNames (candidate, target);
++ val () = matchNames (candidate, target, "");
+
+- (* Match the values and exceptions in the signatures.
+- This actually does the checking of types. *)
+- fun matchVals (candidate, target) : unit =
+- (* Map the identifiers first, returning the originals if they are
+- not in the map. *)
+- let
+- val checkTypesAndStructures : unit =
+- univFold
+- (sigTab target,
+- (fn (dName, dVal, ()) =>
+- if tagIs typeConstrVar dVal
+- then let (* For each type in the target ... *)
+- val target = tagProject typeConstrVar dVal;
++ (* Match the values and exceptions in the signatures.
++ This actually does the checking of types. *)
++ fun matchVals (candidate, target, structPath) : unit =
++ (* Map the identifiers first, returning the originals if they are
++ not in the map. *)
++ let
++ val () : unit =
++ univFold
++ (sigTab target,
++ (fn (dName, dVal, ()) =>
++ if tagIs typeConstrVar dVal
++ then let (* For each type in the target ... *)
++ val target = tagProject typeConstrVar dVal;
+
+- (* Find a candidate with the same name. *)
+- in
+- case univLookup (sigTab candidate, typeConstrVar, dName) of
+- SOME candid =>
+- (* Now check that the types match. *)
+- checkTypeConstrs
+- (candid,
+- target,
+- lookupType,
+- fn (c, t, n) =>
+- matchTypes (c, t, lookupType, lex, lno, foundNear (near, n, lex)),
+- lex,
+- near,
+- lno)
+- | NONE => () (* If the lookup failed ignore
+- the error - we've already reported it in matchNames *)
+- end
++ (* Find a candidate with the same name. *)
++ in
++ case univLookup (sigTab candidate, typeConstrVar, dName) of
++ SOME candid =>
++ (* Now check that the types match. *)
++ checkTypeConstrs(candid, target, lookupType, lex, near, lno, typeEnv, structPath)
++ | NONE => () (* If the lookup failed ignore
++ the error - we've already reported it in matchNames *)
++ end
+
+- else if tagIs structVar dVal
+- then let (* and each sub-structure *)
+- val target = tagProject structVar dVal;
+- in
+- (* For each target structure: find a candidate with the same
+- name and recursively check them. *)
+- case univLookup (sigTab candidate, structVar, dName) of
+- SOME candid => matchVals (structSignat candid, structSignat target)
+- | NONE => () (* Ignore the error - we've already reported it in matchNames *)
+- end
+-
+- else ()
+- ), (* fn *)
+- ()
+- );
+-
+- val checkValuesAndExceptions : unit =
+- (* Finally the values and exceptions. *)
+- univFold
+- (sigTab target,
+- (fn (dName, dVal, ()) =>
+- if tagIs valueVar dVal
+- then let
+- val v = tagProject valueVar dVal;
+- in
+- (* The constructors in the target are ignored since
+- they have already been checked. *)
+- case v of
+- Value{class=Constructor _, ...} => ()
+- | _ =>
+- case univLookup (sigTab candidate, valueVar, dName)
+- (* Look up a corresponding value and check the type. *)
+- of SOME candid =>
+- let
+- val vIsEx = case v of Value{class=Exception, ...} => true | _ => false
+- and cIsEx = case candid of Value{class=Exception, ...} => true | _ => false
++ else if tagIs structVar dVal
++ then let (* and each sub-structure *)
++ val target = tagProject structVar dVal;
+ in
+- (* Check that exceptions have matched with exceptions
+- and values with values, and have not mixed. *)
+- if not cIsEx andalso vIsEx
+- then errorNear (lex, true, near, lno,
+- "Value (" ^ dName ^
+- ") must be an exception to match the signature.")
+-
+- (* An exception will match a value provided the types are right. *)
+- else if cIsEx andalso not vIsEx
+- then let
+- val exType = valTypeOf candid;
+- val candidType =
+- if isEmpty exType
+- then exnType
+- else mkFunctionType (exType, exnType)
+- in
+- matchTypes
+- (candidType, valTypeOf v, lookupType,
+- lex, lno, foundNear (near, dName, lex))
+- end
+-
+- else
+- matchTypes
+- (valTypeOf candid, valTypeOf v, lookupType,
+- lex, lno, foundNear (near, dName, lex))
++ (* For each target structure: find a candidate with the same
++ name and recursively check them. *)
++ case univLookup (sigTab candidate, structVar, dName) of
++ SOME candid =>
++ matchVals (structSignat candid, structSignat target, structPath ^ dName ^ ".")
++ | NONE => () (* Ignore the error - we've already reported it in matchNames *)
+ end
+- | NONE =>
+- errorNear (lex, true, near, lno,
+- "Value (" ^ dName ^ ") missing in structure.")
++
++ else ()
++ ), (* fn *)
++ ()
++ );
++
++ fun displayValue value =
++ let
++ fun dispVal(kind, typeof) =
++ PrettyBlock(0, false, [],
++ [
++ PrettyString kind,
++ PrettyBreak(1, 3),
++ PrettyString(valName value ^ ":"),
++ PrettyBreak(1, 0),
++ display (typeof, errorDepth lex, typeEnv)
++ ])
++ in
++ case value of
++ Value{class=Constructor _, ...} =>
++ (* When displaying the constructor show the function type. We may have rebound
++ the constructor in the candidate structure so that it creates a different datatype. *)
++ dispVal("constructor", valTypeOf value)
++ | Value{class=Exception, ...} =>
++ PrettyBlock(0, false, [],
++ PrettyString "exception" ::
++ PrettyBreak(1, 3) ::
++ PrettyString(valName value) ::
++ (
++ case getFnArgType (valTypeOf value) of
++ NONE => []
++ | SOME excType =>
++ [
++ PrettyBreak (1, 1), PrettyString "of",
++ PrettyBreak (1, 3), display (excType, errorDepth lex, typeEnv) ]
++ ))
++ | _ => dispVal("val", valTypeOf value)
+ end
+- else ()
+- ),
+- ()
+- )
+- in
+- ()
+- end (* matchVals *);
+- in
+- matchVals (candidate, target)
+- end (* matchSigs *);
+
+- fun typeMatchTab (minOffset : int, size : int) : typeConstrs map =
+- let
+- (* Make a vector with an entry for each bound name. *)
+- val v = Array.array (Int.max(0, size), undefType) ;
+- in
+- (* Return the entry corresponding to the name, unless it is empty
+- when an exception is raised. *)
+- {
+- lookup =
+- (fn id =>
+- ( if not (isBoundId id) orelse
+- offsetId id < minOffset orelse
+- offsetId id >= size
+- (* It is possible for the offset to be >= size if the type
+- is being shared inside the result signature of a functor. It
+- will only happen for types inside structures which are shared. *)
+- then NONE (* Not present if it isn't bound. *)
+- else
+- let
+- (* Must be a bound stamp. *)
+- val entry = Array.sub (v, offsetId id);
+- (* SPF 7/6/94 fixed off-by-one *)
+- in
+- if isUnsetId (tcIdentifier entry) (* undefType *)
+- then NONE
+- else SOME entry
+- end
+- )
+- ),
+-
+- enter =
+- (fn (id, value) =>
+- if isBoundId id andalso
+- offsetId id >= minOffset andalso
+- offsetId id < size
+- then Array.update (v, offsetId id, value)
+- else ()
+- )
+- }
+- end;
++ val () : unit =
++ (* Finally the values and exceptions. *)
++ univFold
++ (sigTab target,
++ (fn (dName, dVal, ()) =>
++ if tagIs valueVar dVal
++ then
++ let
++ val v = tagProject valueVar dVal
++ in
++ case univLookup (sigTab candidate, valueVar, dName) of
++ NONE => sigStructMissingMsg(lex, near, lno, structPath) displayValue v
++ | SOME candid =>
++ let
++ (* If the target is a constructor or exception the candidate must be
++ similar. *)
++ val matchKind =
++ case (v, candid) of
++ (Value{class = Constructor _, ...}, Value {class = Constructor _, ...}) => NONE
++ | (Value{class = Constructor _, ...}, _) => SOME(PrettyString "Value is not a constructor")
++ | (Value{class = Exception, ...}, Value {class = Exception, ...}) => NONE
++ | (Value{class = Exception, ...}, _) => SOME(PrettyString "Value is not an exception")
++ | _ => NONE
++ in
++ case matchKind of
++ SOME error =>
++ sigStructMatchMsg(lex, near, lno, structPath)
++ displayValue (candid, v, error)
++ | NONE =>
++ case matchTypes (valTypeOf candid, valTypeOf v, lookupType) of
++ NONE => ()
++ | SOME error =>
++ sigStructMatchMsg(lex, near, lno, structPath)
++ displayValue (candid, v,
++ matchErrorReport(lex, typeEnv, typeEnv) error);
++ (* If it matches an entry in the signature it counts being exported. *)
++ case candid of
++ Value { references=SOME{exportedRef, ...}, ...} =>
++ exportedRef := true
++ | _ => ()
++ end
++ end
++ else ()
++ ),
++ ()
++ )
++ in
++ ()
++ end (* matchVals *);
++ in
++ matchVals (candidate, target, ""); (* Do the match. *)
++ resultType (* Return the function to look up the results. *)
++ end (* matchSigs *);
+
+- type tsvEnv = { enterType: string * typeConstrs -> unit,
+- enterStruct: string * structVals -> unit,
+- enterVal : string * values -> unit };
+-
+- fun tsvEnv (Env E) = {enterType = #enterType E,
+- enterStruct = #enterStruct E,
+- enterVal = #enterVal E};
+-
+- (* Copy the signature so that types in different signatures are distinct. *)
+- fun copySig
+- (source : signatures,
+- mustCopyType : typeId -> bool,
+- makeTypeId : unit -> typeId,
+- typeMap : typeConstrs map,
+- strName : string)
+- : signatures =
+- let
+- (* Make a new signature. *)
+- val newSig = makeSignatures (sigName source);
+- (* Copy everything into the new signature. *)
+- val tab = sigTab newSig
+- val lastAddr =
+- fullCopySig
+- (0, source,
+- {
+- enterType = fn (s,v) => univEnter (tab, typeConstrVar, s, v),
+- enterStruct = fn (s,v) => univEnter (tab, structVar, s, v),
+- enterVal = fn (s,v) => univEnter (tab, valueVar, s, v)
+- },
+- mustCopyType, makeTypeId, typeMap, strName);
+- in
+- makeCopy(sigName source, newSig, sigMinTypes newSig, sigMaxTypes newSig)
+- end (* copySig *)
++ val makeEnv = fn x => let val Env e = makeEnv x in e end;
+
+- (* Generate new entries for all the elements of the signature. *)
+- and fullCopySig
+- (offset : int,
+- source : signatures,
+- resEnv : tsvEnv,
+- mustCopyType : typeId -> bool,
+- makeTypeId : unit -> typeId,
+- typeMap : typeConstrs map,
+- strName : string)
+- : int =
+- let
+- fun copyTypeCons (tcon : typeConstrs) : typeConstrs =
+- copyTypeConstr (tcon, mustCopyType, makeTypeId, typeMap,
+- fn x => x, strName);
+-
+- fun copyTyp (t : types) : types =
+- copyType (t, fn x => x, (* Don't bother with type variables. *) copyTypeCons);
+-
+- (* First copy the type constructors in this signature and any substructures.
+- It's inefficient but harmless to do this again for substructures.
+- TODO: Tidy this up. *)
+- val u: unit =
+- copyTypeConstructors(source, mustCopyType, makeTypeId, typeMap, strName)
+- in
+- univFold
+- (sigTab source,
+- (fn (dName: string, dVal: universal, num) =>
+- (if tagIs structVar dVal
+- then let
+- val oldStruct = tagProject structVar dVal;
+- val oldSig = structSignat oldStruct;
+-
+- (* Make a new sub-structure. *)
+- val newSig =
+- copySig (oldSig, mustCopyType, makeTypeId, typeMap,
+- strName ^ dName ^ ".");
+-
+- val addr =
+- if isFormal (structAccess oldStruct)
+- then vaFormal (structAccess oldStruct) + offset
+- else num (* From sig ... open Global; ... end *);
+-
+- val newStruct =
+- makeFormalStruct (structName oldStruct, newSig, addr);
+- in
+- #enterStruct resEnv (dName, newStruct);
+- Int.max(num, addr+1)
+- end (* structures *)
+-
+- else if tagIs typeConstrVar dVal
+- then let (* Types *)
+- val address = ref num
+- (* Make a new constructor. *)
+- val oldConstr = tagProject typeConstrVar dVal;
+-
+- (*
+- The new type constructor will use the NEW polymorphic
+- type variables. This is because copyTypeCons uses the
+- table built by matchSigs which maps OLD constructors to
+- NEW ones, and the NEW constructors contain NEW type variables.
+- *)
+- val newConstr = copyTypeCons oldConstr;
+-
+- (* We must copy the datatype if any of the value
+- constructors have to be copied. The datatype may
+- be rigid but some of the value constructors may
+- refer to flexible type names. *)
+- val mustCopy = ref (not (identicalConstr (newConstr, oldConstr)));
+-
+- local
+- val oldTypeVars : types list = tcTypeVars oldConstr;
+- val newTypeVars : types list = tcTypeVars newConstr;
+-(*
+- We CAN legitimately get different numbers of type variables here,
+- it we're trying to recover from a user error that we've already
+- diagnosed. We'll just ignore the extra variables. SPF 26/6/96
+-*)
+- fun zipTypeVars (x::xs) (y::ys) = (x, y) :: zipTypeVars xs ys
+- | zipTypeVars _ _ = []
+-
+- val typeVarTable : (types * types) list =
+- zipTypeVars oldTypeVars newTypeVars;
+-
+- fun copyTypeVar (t : types) : types =
+- let
+- fun search [] = t
+- | search ((oldTypeVar, newTypeVar) :: rest) =
+- if sameTypeVar (t, oldTypeVar) then newTypeVar else search rest
+- in
+- search typeVarTable
+- end;
+- in
+- (*
+- Dave was wrong - we DO need to copy the polymorphic type variables -
+- at least, we do here! This version hides the old version of
+- copyTyp, which is in the enclosing environment. The entire
+- type/signature matching code needs a thorough overhaul.
+- SPF 16/4/96
+- *)
+- (* TODO: If SPF is right we also need to redefine
+- copyTypeCons. DCJM 17/2/00. *)
+- fun copyTyp (t : types) : types =
+- copyType (t, copyTypeVar, copyTypeCons);
+- end;
+-
+- (*
+- Now copy the value constructors. The equality status
+- and any equivalence (i.e. type t = ...) will have been
+- processed when the constructor was copied.
+-
+- What's going on here? Copying the type constructor will
+- use the NEW polymorphic variables, but copying the rest of
+- the type will use the OLD ones, since copyTyp doesn't copy
+- individual type variables - what a MESS! I think this means
+- that we end up with OLD variables throughout.
+- SPF 15/4/96
+- *)
+- val copiedConstrs =
+- map
+- (fn (v as Value{name, typeOf, class, access}) =>
+- let
+- (* Copy its type and make a new constructor if the type
+- has changed. *)
+- val newType = copyTyp typeOf;
+- val typeChanged = not (identical (newType, typeOf));
+- val (newAccess, addressChanged) =
+- case access of
+- Formal addr =>
+- let
+- val newAddr = addr+offset
+- in
+- address := Int.max(newAddr+1, !address);
+- (Formal newAddr, offset <> 0)
+- end
+- | access => (access, false)
+- (* If this datatype shares with another one we will already have
+- constructors available. This can happen, in particular, if
+- we have a signature constraining the result of a structure.
+- There will be sharing between the datatype in the implementing
+- structure and the result signature. *)
+- val copy =
+- if typeChanged orelse addressChanged
+- then let
+- val v' = Value{name=name, typeOf=newType, class=class, access=newAccess}
+- (* See if the constructor already exists. *)
+- in
+- let
+- val original = findValueConstructor v'
+- in
+- (* We try to use the original if it is global since that
+- allows us to print values of the datatype. If it is
+- not global we MUSTN'T use the copy. It may be local
+- and so may not exist later on. *)
+- case original of
+- Value{access=Global _, ...} => original
+- | _ => v'
+- end
+- end
+- else v;
+- in
+- if typeChanged orelse addressChanged then mustCopy := true else ();
+- copy (* Return the copy. *)
+- end)
+- (tcConstructors oldConstr);
+- in
+- if !mustCopy
+- then let
+- (* If the copied datatype already has constructors on it
+- we must have two datatypes which share. They need not
+- necessarily have the same constructors e.g. datatype
+- t = X of int t can share with datatype t = X of int * int
+- or even with datatype t = X of bool . We have to make a new
+- type constructor in that case. We don't need to put this
+- in the typeMap table because we can always return the
+- type that is already in there. This will also work correctly
+- if we have a type constructor which does not itself need to
+- be copied (e.g. it is rigid) but at least one of whose
+- value constructors involves a flexible type. Another
+- case could be where we have a structure containing a datatype.
+- The type in the signature may be either a datatype or a type. *)
+-
+- val newType =
+- if not (null (tcConstructors newConstr))
+- then (* Matched to a datatype. Use the NEW types throughout *)
+- makeTypeConstrs (* Necessary? *)
+- (tcName newConstr, tcTypeVars newConstr,
+- emptyType,
+- tcIdentifier newConstr, tcEquality newConstr, 0)
+-(* old (16/4/96) ...
+- makeTypeConstrs
+- (tcName oldConstr, tcTypeVars oldConstr,
+- makeEquivalent (newConstr, tcTypeVars oldConstr),
+- tcIdentifier newConstr, tcEquality newConstr)
+-... *)
+- else newConstr;
+- in
+- (* Put the new constructors on the result type *)
+- tcSetConstructors (newType, copiedConstrs);
+- (* and put it into the table. *)
+- #enterType resEnv (dName, newType)
+- end
+- else #enterType resEnv (dName, newConstr);
+-
+- Int.max(num, !address)
+- end
+-
+- (* Finally the values and exceptions. *)
+- else if tagIs valueVar dVal
+- then let
+- val v = tagProject valueVar dVal;
+- in
+- case v of
+- Value {typeOf=oldType, class, name, access=Formal addr, ...} =>
+- let
+- val newType = copyTyp oldType;
+- val newAddr = addr + offset;
+-
+- (* Make a new entry if the address or type have changed. *)
+- val res =
+- if addr <> newAddr orelse not (identical (newType, oldType))
+- then mkFormal (name, class, newType, newAddr)
+- else v;
+- in
+- #enterVal resEnv (name, res);
+- Int.max(num, newAddr+1)
+- end
+-
+- | Value {typeOf, class, name, access, ...} =>
+- (* Values in the result signature of a structure may be globals
+- as a result of a call to extractValsToSig. This applies
+- if we have a functor which returns a global structure
+- e.g. structure S = ...; functor F() = S.
+- We still have to consider the possibility that the types might
+- be different due to an opaque signature e.g. structure S1 :> SIG = S2. *)
+- let
+- val newType = copyTyp typeOf;
+- (* Can save creating a new object if the address and type
+- are the same as they were. *)
+- val res =
+- if not (identical (newType, typeOf))
+- then Value {typeOf=newType, class=class, name=name, access=access}
+- else v
+- in
+- #enterVal resEnv (name, res);
+- num
+- end
+- end
+- else num
+- )
+- ),
+- offset
+- )
+- end (* fullCopySig *)
+-
+- (* Make entries for all the type constructors. The only reason for
+- doing this separately from fullCopySig is to try to ensure that the
+- names we give the types are appropriate. If we do this as part of
+- fullCopySig we could get the wrong name in cases such as
+- sig structure S: sig type t end structure T : sig val x: S.t end end.
+- If fullCopySig happens to process "x" before "S" it will copy "t"
+- and give it the name "T.t" rather than "S.t". *)
+- and copyTypeConstructors(
+- source: signatures,
+- mustCopyType : typeId -> bool,
+- makeTypeId : unit -> typeId,
+- typeMap : typeConstrs map,
+- strName : string): unit =
+- let
+- fun copyTypeCons (tcon : typeConstrs) : typeConstrs =
+- copyTypeConstr (tcon, mustCopyType, makeTypeId, typeMap,
+- fn x => x, strName);
+- in
+- univFold
+- (sigTab source,
+- (fn (dName: string, dVal: universal, ()) =>
+- (if tagIs structVar dVal
+- then let
+- val oldStruct = tagProject structVar dVal;
+- val oldSig = structSignat oldStruct;
+- in
+- copyTypeConstructors(oldSig, mustCopyType, makeTypeId, typeMap,
+- strName ^ dName ^ ".")
+- end (* structures *)
+-
+- else if tagIs typeConstrVar dVal
+- then let (* Types *)
+- (* Make a new constructor. It will be entered in the match table
+- and picked up when we copy the signature. *)
+- val oldConstr = tagProject typeConstrVar dVal;
+- val newConstr = copyTypeCons oldConstr
+- in
+- ()
+- end
+-
+- else ()
+- )
+- ),
+- ()
+- )
+- end;
+-
+- (* This used to be checkExplicitness which, as well as replacing variable
+- stamps with bound stamps also checked for type explicitness. That is
+- no longer required since ML97 does not allow types to be redefined. *)
+- fun renameVariableAsBound (signat, initTypeId, errorMessage) =
+- let
+- (* First set every different variable stamp in types to be
+- new bound stamps. We may not start at zero
+- if this is the result signature of a functor because there
+- may be sharing between the argument and the result. *)
+- val typeCounter = ref initTypeId;
+-
+- fun makeTypeId () =
++ (* Any values in the signature are counted as exported. *)
++ fun markValsAsExported resSig =
+ let
+- val n = !typeCounter;
++ fun refVals(_, dVal, ()) =
++ if tagIs valueVar dVal
++ then
++ (
++ case tagProject valueVar dVal of
++ Value {references=SOME{exportedRef, ...}, ...} =>
++ exportedRef := true
++ | _ => ()
++ )
++ else ()
+ in
+- typeCounter := n + 1;
+- makeBoundId n
++ univFold(sigTab resSig, refVals, ())
+ end
+-
+- fun setStamps source =
+- (* Don't make the signature bound yet, we may have
+- several shared structures and if we make any of
+- them bound we will make them all bound. Process
+- all the types. *)
+- univFold
+- (sigTab source,
+- (fn (dName, dVal, ()) =>
+- if tagIs structVar dVal
+- then setStamps (structSignat (tagProject structVar dVal))
+-
+- else if tagIs typeConstrVar dVal
+- then setTypeConstr (tagProject typeConstrVar dVal,
+- fn tc => makeTypeId ())
+- else ()
+- ),
+- ()
+- );
+-
+- in
+- setStamps signat;
+- (* Set the size of the type table for the signature we return. *)
+- makeCopy (sigName signat, signat, initTypeId, !typeCounter)
+- end (* renameVariableAsBound *);
+-
+- val makeEnv = fn x => let val Env e = makeEnv x in e end;
+
+ (* Second pass - identify names with values and type-check *)
+- fun pass2Structs (strs : structs list, lex : lexan, Env env : env) : unit =
+- let
+- fun pass2Struct
+- (strs : structs list,
+- typeNo : int ref,
+- Env env : env,
+- lno : int,
+- strName : string
+- ) : unit =
++
++ (* Process structure-returning expressions i.e. structure names,
++ struct..end values and functor applications. *)
++ fun structValue(str, newTypeId: (bool*bool*bool*typeIdDescription)->typeId, currentTypeCount,
++ newTypeIdEnv: unit -> int->typeId, Env env, lex, lno, structPath) =
+ let
+- (* Get the value from a signature-returning expression
+- (either the name of a signature or sig ... end.
+- The names (type and structure ids) in the signature
+- are bound names. *)
+- fun sigVal
+- (str : structs,
+- initTypeId : int,
+- Env globalEnv : env,
+- lno : int,
+- strName : string
+- ) : signatures =
+- let
+- (* Process a sharing constraint. *)
+- fun applySharingConstraint
+- ({shares = tlist, isType, line}: shareConstraint,
+- Env tEnv : env,
+- near : structs)
+- : unit =
+- let
+- fun shareTypes
+- (aType : typeConstrs,
+- bType : typeConstrs,
+- lno : int
+- ) : unit =
+- (* In ML90 we had to check that two datatypes which shared were
+- "consistent" i.e. had the same constructor names (but not
+- necessarily the same types since that would have required
+- second order unification). That requirement has been removed
+- in ML97. *)
+- linkTypeConstructors (aType, bType, giveError (near, lno, lex));
+-
+-
+-(********************* Start of SPF's rewrite (incomplete!) **********************)
+-
+- (* The purpose of the following code was to fix some bugs in my
+- original structure sharing code for ML90 and also to simplify it. In
+- particular it detected cyclic sharing constraints more accurately.
+- These were cases of "sharing A = A.B" which were illegal in ML90
+- but are legal in ML97 (it's a short-hand for sharing type A.t = A.B.t).
+- Much of it is no longer relevant since we are only interested in
+- sharing types in ML97. I've simplified it somewhat but it
+- might be worth simplifying it further. DCJM 27/7/00. *)
+-
+- (* useful stuff *)
+- (* sets as unordered lists *)
+- fun member (eq : 'a * 'a -> bool) x [] = false
+- | member (eq : 'a * 'a -> bool) x (h :: t) =
+- eq (x, h) orelse member eq x t;
+-
+- fun addToSet (eq : 'a * 'a -> bool) x l =
+- if member eq x l then l else x :: l;
+-
+- fun union (eq : 'a * 'a -> bool) [] l = l
+- | union (eq : 'a * 'a -> bool) (h :: t) l =
+- if member eq h l then union eq t l else h :: union eq t l;
+-
+- fun unionMap (eq : 'b * 'b -> bool) (f : 'a -> 'b list) ([] : 'a list) : 'b list = []
+- | unionMap (eq : 'b * 'b -> bool) (f : 'a -> 'b list) (h :: t) =
+- union eq (f h) (unionMap eq f t)
+-
+- type virtStruct = signatures list;
+-
+- (* Find all the substructure names occurring in a single structure *)
+- fun subStructureNames (sigVal : signatures) : string list =
+- univFold
+- (sigTab sigVal,
+- fn (structName, dVal, names) =>
+- if tagIs structVar dVal then structName :: names else names,
+- []);
+-
+- (* Find all the type constructor names occurring in a single structure *)
+- fun typeConstrNames (sigVal : signatures) : string list =
+- univFold
+- (sigTab sigVal,
+- fn (typeName, dVal, names) =>
+- if tagIs typeConstrVar dVal then typeName :: names else names,
+- []);
+-
+- (* Find all the substructure names occurring in a virtual structure. *)
+- fun virtSubStructureNames sigs : string list =
+- unionMap (op =) subStructureNames sigs;
+-
+- (* Find all the type constructor names occurring in a virtual structure. *)
+- fun virtTypeConstrNames sigs : string list =
+- unionMap (op =) typeConstrNames sigs;
+-
+- (* Find the named virtual substructure of a virtual structure. *)
+- fun getVirtSubStructure sigs (strName : string) : virtStruct =
+- let
+- (*
+- Look up the name of the substructure. It may not
+- be there because not every substructure occurs
+- in every structure of the virtual structure.
+- *)
+- val substrList : signatures list =
+- List.foldr
+- (fn (sigVal : signatures, res : signatures list) =>
+- case univLookup (sigTab sigVal, structVar, strName) of
+- SOME str => structSignat str :: res
+- | NONE => res)
+- []
+- sigs;
+- in
+- substrList
+- end;
+-
+- (* Find the named typed constructors of a virtual structure. *)
+- fun getVirtTypeConstrs sigs (typeName : string) : typeConstrs list =
+- let
+- fun funForFold (sigVal : signatures, res : typeConstrs list) : typeConstrs list =
+- case univLookup (sigTab sigVal, typeConstrVar, typeName) of
+- SOME r => r :: res
+- | NONE => res
+- in
+- List.foldr funForFold [] sigs
+- end;
+-
+- (* Find all the substructure names occurring in a list of virtual structures *)
+- fun listVirtSubStructureNames (virts : virtStruct list) : string list =
+- unionMap (op =) virtSubStructureNames virts;
+-
+- (* Find all the type constructor names occurring in a list of virtual structures *)
+- fun listVirtTypeConstrNames (virts : virtStruct list) : string list =
+- unionMap (op =) virtTypeConstrNames virts;
+-
+- (* Find all the named virtual substructures occurring in a list of virtual structures *)
+- fun listVirtSubStructures (virts : virtStruct list) (strName : string) : virtStruct list =
+- let
+- fun funForFold (vs : virtStruct, res : virtStruct list) : virtStruct list =
+- getVirtSubStructure vs strName :: res
+- in
+- List.foldr funForFold [] virts
+- end;
+-
+- (* Find all the named virtual type constructors occurring in a list of virtual structures *)
+- fun listVirtTypeConstrs (virts : virtStruct list) (strName : string) : typeConstrs list =
+- let
+- fun funForFold (vs : virtStruct, res : typeConstrs list) : typeConstrs list =
+- (getVirtTypeConstrs vs strName) @ res
+- in
+- List.foldr funForFold [] virts
+- end;
+-
+- fun shareVirtStructs ([], _) = raise InternalError "Empty sharing list"
+- | shareVirtStructs (virts, _) =
+- let
+- (* Share the types *)
+- val typeConstrNames : string list = listVirtTypeConstrNames virts;
+-
+- fun shareVirtTypeConstr (typeName : string) : unit =
+- let
+- (* Find all the type constructors with this name *)
+- val tcs : typeConstrs list = listVirtTypeConstrs virts typeName;
+-
+- fun shareWith (tc : typeConstrs) ([] : typeConstrs list) = ()
+- | shareWith tc (h :: t) =
+- let
+- val U : unit = shareTypes (tc, h, lno);
+- in
+- shareWith tc t
+- end;
+-
+- fun shareAll ([] : typeConstrs list) = ()
+- | shareAll (h :: t) =
+- let
+- val U : unit = shareWith h t
+- in
+- shareAll t
+- end;
+- in
+- (* Share them all pair-wise (inefficient!) *)
+- shareAll tcs
+- end;
+-
+- val U : unit list = map shareVirtTypeConstr typeConstrNames;
+-
+- (* Share the substructures *)
+- val subStrNames : string list = listVirtSubStructureNames virts;
+-
+- fun shareVirtSubstruct (strName : string) : unit =
+- shareVirtStructs (listVirtSubStructures virts strName, lno);
+-
+- in
+- map shareVirtSubstruct subStrNames;
+- ()
+- end;
+-
+-
+- fun shareStructures (shareList : signatures list, lno : int) : unit =
+- shareVirtStructs (map (fn strVal => [strVal]) shareList, lno);
+-
+- (* When looking up the structure and type names we look only
+- in the signature in ML97. We add this to make it clear that
+- we are only looking up in the signature otherwise we get
+- confusing messages such as "type (int) has not been declared". *)
+- fun lookupFailure msg =
+- giveError (str, line, lex) (msg ^ " in signature.")
+-
+- in
+- if isType
+- then let (* Type sharing. *)
+- fun lookupSharing (name: string) =
+- lookupTyp
+- ({
+- lookupType = #lookupType tEnv,
+- lookupStruct = #lookupStruct tEnv
+- },
+- name,
+- lookupFailure)
+-
+- val first = lookupSharing (hd tlist);
+- in
+- if not (isUnsetId (tcIdentifier first))
+- then
+- List.app
+- (fn typ => shareTypes (lookupSharing typ, first, line))
+- (tl tlist)
+- else ()
+- end
+-
+- else let (* structure sharing. *)
+- fun getStructSignat (name: string) : signatures =
+- let
+- val subStr : structVals =
+- lookupStructureDirectly
+- ("Structure" ,
+- {lookupStruct = #lookupStruct tEnv},
+- name,
+- lookupFailure);
+- in
+- structSignat subStr
+- end
+- in (* Now share all these signatures. *)
+- shareStructures (map getStructSignat tlist, line)
+- end
+- end (* applySharingConstraint *);
+-
+-(**************************** End of SPF's rewrite *************************)
+-
+- (* Look up a signature. Strictly a signature cannot be contained
+- in a structure but this allows a structure to be used as a
+- general name space. *)
+- fun lookSig (name : string, lno : int) : signatures =
+- let
+- val errorFn = giveError (str, lno, lex);
+- fun lookupFn s = #lookupSig (makeEnv (structSignat s));
+- in
+- lookupAny
+- (name,
+- #lookupSig globalEnv,
+- #lookupStruct globalEnv,
+- lookupFn,
+- "Signature",
+- undefinedSignature,
+- errorFn)
+- end
+-
+- (* Construct a signature. *)
+- fun sigValue (str : structs, Env env : env, lno : int, strName: string) =
+- let
+- (* Make a new signature. *)
+- val sigName =
+- case str of
+- SignatureIdent name => name
+- | _ => ""
+- val newSig = makeSignatures sigName;
+- (* Copy everything into the new signature. *)
+- val structEnv = makeEnv newSig;
+-
+- (* ML 97 does not allow multiple declarations in a signature. *)
+- fun checkAndEnter enter lookup kind (s: string, v) =
+- if getParameter ml90Tag (debugParams lex) then enter(s, v)
+- else case lookup s of
+- SOME _ => (* Already there. *)
+- errorNear (lex, true, str, lno,
+- kind ^ " (" ^ s ^ ") is already present in this signature.")
+- | NONE => enter(s, v)
+-
+- val checkedStructEnv =
+- {
+- lookupVal = #lookupVal structEnv,
+- lookupType = #lookupType structEnv,
+- lookupFix = #lookupFix structEnv,
+- lookupStruct = #lookupStruct structEnv,
+- lookupSig = #lookupSig structEnv,
+- lookupFunct = #lookupFunct structEnv,
+- enterVal =
+- checkAndEnter (#enterVal structEnv) (#lookupVal structEnv) "Value",
+- enterType =
+- checkAndEnter (#enterType structEnv) (#lookupType structEnv) "Type",
+- enterStruct =
+- checkAndEnter (#enterStruct structEnv) (#lookupStruct structEnv) "Structure",
+- (* These next three can't occur. *)
+- enterFix =
+- checkAndEnter (#enterFix structEnv) (#lookupFix structEnv) "Fixity",
+- enterSig =
+- checkAndEnter (#enterSig structEnv) (#lookupSig structEnv) "Signature",
+- enterFunct =
+- checkAndEnter (#enterFunct structEnv) (#lookupFunct structEnv) "Functor"
+- }
+- in
+- makeSigInto(str, Env checkedStructEnv, Env env, lno, strName, 0);
+- (* Make a copy to freeze it as immutable.*)
+- makeCopy(sigName, newSig, sigMinTypes newSig, sigMaxTypes newSig)
+- end
+-
+- (* Constructs a signature and inserts it into an environment at a given offset.
+- Generally offset will be zero except if we are including a signature. *)
+- and makeSigInto(str: structs,
+- Env structEnv, (* The immediately enclosing sig. *)
+- Env globalEnv, (* The surrounding environment excluding this sig. *)
+- lno: int, strName: string,
+- offset: int): int =
+- (* Either a named signature or sig ... end or one of
+- these with possibly multiple where type realisations. *)
+- case str of
+- SignatureIdent name =>
+- let
+- (* Look up the signature and copy it to get new instances
+- of variables. *)
+- val sourceSig = lookSig (name, lno);
+-
+- val typeMap : typeConstrs map =
+- typeMatchTab (sigMinTypes sourceSig, sigMaxTypes sourceSig);
++ val typeEnv =
++ {
++ lookupType =
++ fn s => case #lookupType env s of NONE => NONE | SOME t => SOME(t, SOME(newTypeIdEnv())),
++ lookupStruct =
++ fn s => case #lookupStruct env s of NONE => NONE | SOME t => SOME(t, SOME(newTypeIdEnv()))
++ }
++ in
++ case str of
++ StructureIdent {name, valRef, location} =>
++ let (* Look up the name and save the value. *)
++ val result =
++ lookupStructure ("Structure", {lookupStruct = #lookupStruct env},
++ name, giveError (str, location, lex));
+ in
+- (* Copy the signature into the result. *)
+- fullCopySig(offset, sourceSig, tsvEnv (Env structEnv),
+- isBoundId, makeVariableId, typeMap, strName)
++ if isUndefinedStruct result
++ then undefinedSignature
++ else (valRef := result; structSignat result )
+ end
+-
+- | SigDec (sigsList : structs list) => (* sig .... end *)
+- let
+- (* Process the entries in the signature and allocate an address
+- to each. *)
+- fun processSig (signat, offset : int, lno : int) : int =
+- case signat of
+- StructureDec (structList : structBind list) =>
+- let
+- (* Each element in the list should be a structure binding. *)
+- fun pStruct [] offset = offset
+- | pStruct (({name, sigStruct, line, ...}: structBind) :: t) offset =
+- let
+- (* Create a new surrounding environment to include the surrounding
+- structure. This is the scope for any structures or types.
+- Specifically, if we look up a type defined by a "where type"
+- we use this environment and not the signature we're creating. *)
+- val newEnv =
+- {
+- lookupVal = #lookupVal structEnv,
+- lookupType =
+- lookupDefault (#lookupType structEnv) (#lookupType globalEnv),
+- lookupFix = #lookupFix structEnv,
+- lookupStruct =
+- lookupDefault (#lookupStruct structEnv) (#lookupStruct globalEnv),
+- lookupSig = #lookupSig structEnv,
+- lookupFunct = #lookupFunct structEnv,
+- enterVal = #enterVal structEnv,
+- enterType = #enterType structEnv,
+- enterStruct = #enterStruct structEnv,
+- enterFix = #enterFix structEnv,
+- enterSig = #enterSig structEnv,
+- enterFunct = #enterFunct structEnv
+- };
+- val resSig =
+- sigValue (sigStruct, Env newEnv, line, strName ^ name ^ ".");
+- (* Process the rest of the list before declaring
+- the structure. *)
+- val result = pStruct t (offset + 1);
+- (* Make a structure. *)
+- val resStruct = makeFormalStruct (name, resSig, offset);
+- val U : unit = #enterStruct structEnv (name, resStruct);
+- in
+- result (* One slot for each structure. *)
+- end
+- in
+- pStruct structList offset
+- end
+-
+- | ValSig {name, typeof, line} =>
+- let
+- val errorFn = giveError (signat, line, lex);
+-
+- fun lookup s =
+- lookupTyp
+- ({
+- lookupType =
+- lookupDefault (#lookupType structEnv) (#lookupType globalEnv),
+- lookupStruct =
+- lookupDefault (#lookupStruct structEnv) (#lookupStruct globalEnv)
+- },
+- s,
+- errorFn);
+- in (* If the type is not found give an error. *)
+- (* Check for rebinding of built-ins. "it" is allowed here. *)
+- if getParameter ml90Tag (debugParams lex) then ()
+- else if name = "true" orelse name = "false" orelse name = "nil"
+- orelse name = "::" orelse name = "ref"
+- then errorFn("Specifying \"" ^ name ^ "\" is illegal.")
+- else ();
+- assignTypes (typeof, lookup, lex, line);
+- (* The type is copied before being entered in the environment.
+- This isn't logically necessary but has the effect of removing
+- ref we put in for type constructions. *)
+- #enterVal structEnv (name, mkFormal (name, SimpleValue,
+- copyType (typeof, fn x => x, fn x => x), offset));
+- (offset + 1)
+- end
+-
+- | ExSig {name, typeof, line} =>
+- let
+- val errorFn = giveError (signat, line, lex);
+-
+- fun lookup s =
+- lookupTyp
+- ({
+- lookupType =
+- lookupDefault (#lookupType structEnv) (#lookupType globalEnv),
+- lookupStruct =
+- lookupDefault (#lookupStruct structEnv) (#lookupStruct globalEnv)
+- },
+- s,
+- errorFn);
+- in (* If the type is not found give an error. *)
+- (* Check for rebinding of built-ins. "it" is not allowed. *)
+- if getParameter ml90Tag (debugParams lex) then ()
+- else if name = "true" orelse name = "false" orelse name = "nil"
+- orelse name = "::" orelse name = "ref" orelse name = "it"
+- then errorFn("Specifying \"" ^ name ^ "\" is illegal.")
+- else ();
+- assignTypes (typeof, lookup, lex, line);
+- #enterVal structEnv (name, mkFormal (name, Exception, typeof, offset));
+- (offset + 1)
+- end
+-
+- | IncludeSig (structList : structs list) =>
+- let
+- (* include sigid ... sigid or include sigexp. For
+- simplicity we handle the slightly more general case
+- of a list of signature expressions.
+- The contents of the signature are added to the environment. *)
+- fun includeSigExp (str: structs, offset) =
+- makeSigInto(str, Env structEnv, Env globalEnv, lno, strName, offset)
+- in
+- List.foldl includeSigExp offset structList
+- end
+-
+- | Sharing (share : shareConstraint) =>
+- (* Sharing constraint. *)
+- let
+- (* In ML90 it was possible to share with any identifier
+- in scope. In ML97 sharing is restricted to identifiers
+- in the "spec". *)
+- val envForSharing =
+- if getParameter ml90Tag (debugParams lex)
+- then Env
+- {
+- lookupVal = #lookupVal structEnv,
+- lookupType =
+- lookupDefault (#lookupType structEnv) (#lookupType globalEnv),
+- lookupFix = #lookupFix structEnv,
+- lookupStruct =
+- lookupDefault (#lookupStruct structEnv) (#lookupStruct globalEnv),
+- lookupSig = #lookupSig structEnv,
+- lookupFunct = #lookupFunct structEnv,
+- enterVal = #enterVal structEnv,
+- enterType = #enterType structEnv,
+- enterStruct = #enterStruct structEnv,
+- enterFix = #enterFix structEnv,
+- enterSig = #enterSig structEnv,
+- enterFunct = #enterFunct structEnv
+- }
+- else Env structEnv
+- in
+- applySharingConstraint (share, envForSharing, str);
+- offset (* No entry *)
+- end
+-
+- | Singleton {dec, line, ...} =>
+- let (* datatype or type binding(s) *)
+- (* This pass puts the data constructors into the environment. *)
+- val addrs = ref offset
+- (* Pass2 creates value constructors of datatypes as global values.
+- Rather than complicate pass2 by trying to make formal values
+- in this case it's easier to trap the value constructors at
+- this point. N.B. We may get constructors from a datatype
+- declaration or from datatype replication. *)
+- fun enterVal(name, Value{class=class, typeOf, ...}) =
+- let
+- val addr = !addrs
+- val _ = addrs := addr+1
+- in
+- (#enterVal structEnv)(name,
+- Value{class=class, typeOf=typeOf, access=Formal addr, name=name})
+- end
+-
+- (* Record all the datatypes we declare. *)
+- val datatypeList = ref []
+- fun enterType(name, tyCons) =
+- (
+- if isEmpty (tcEquivalent tyCons)
+- then datatypeList := tyCons :: !datatypeList else ();
+- #enterType structEnv (name, tyCons)
+- )
+-
+- val newEnv =
+- {
+- lookupVal = #lookupVal structEnv,
+- lookupType =
+- lookupDefault (#lookupType structEnv) (#lookupType globalEnv),
+- lookupFix = #lookupFix structEnv,
+- lookupStruct =
+- lookupDefault (#lookupStruct structEnv) (#lookupStruct globalEnv),
+- lookupSig = #lookupSig structEnv,
+- lookupFunct = #lookupFunct structEnv,
+- enterVal = enterVal,
+- enterType = enterType,
+- enterStruct = #enterStruct structEnv,
+- enterFix = #enterFix structEnv,
+- enterSig = #enterSig structEnv,
+- enterFunct = #enterFunct structEnv
+- };
+-
+- val t : types =
+- pass2 (dec, makeVariableId, Env newEnv, lex, line, strName);
+- (* Replace the constructor list for the datatype with the modified
+- constructors. All the constructors should be in the set. Is
+- it possible that one might not be because of an error? *)
+- fun findConstr(v: values): values =
+- getOpt((#lookupVal structEnv)(valName v), v)
+- fun updateConstrList tyCons =
+- tcSetConstructors(tyCons, List.map findConstr (tcConstructors tyCons))
+- val _ = List.app updateConstrList (!datatypeList)
+- in
+- ! addrs
+- end
+-
+- | _ =>
+- raise InternalError "processSig: not a signature"
+- (* end processSig *);
+- in
+- List.foldl
+- (fn (signat, offset) =>
+- processSig (signat, offset, lno))
+- offset sigsList
+- end
+-
+- | WhereType { sigExp, typeVars, typeName, realisation, line } =>
+- let
+- (* We construct the signature into the result signature. When we apply the
+- "where" we need to look up the types (and structures) only within the
+- signature constrained by the "where" and not in the surrounding signature.
+- e.g. If we have sig type t include S where type t = ... end
+- we need to generate an error if S does not include t. Of course
+- if it does that's also an error since t would be rebound!
+- Equally, we must look up the right hand side of a where type
+- in the surrounding scope, which will consist of the global environment
+- and the signature excluding the entries we're adding here. *)
+- val findTypes = searchList() and findStructs = searchList()
+- val newEnv =
+- {
+- lookupVal = #lookupVal structEnv,
+- lookupType =
+- lookupDefault (#lookup findTypes)
+- (lookupDefault (#lookupType structEnv) (#lookupType globalEnv)),
+- lookupFix = #lookupFix structEnv,
+- lookupStruct =
+- lookupDefault (#lookup findStructs)
+- (lookupDefault (#lookupStruct structEnv) (#lookupStruct globalEnv)),
+- lookupSig = #lookupSig structEnv,
+- lookupFunct = #lookupFunct structEnv,
+- enterVal = #enterVal structEnv,
+- enterType = #enter findTypes,
+- enterFix = #enterFix structEnv,
+- enterStruct = #enter findStructs,
+- enterSig = #enterSig structEnv,
+- enterFunct = #enterFunct structEnv
+- }
+-
+- val resAddr = makeSigInto(sigExp, Env newEnv, Env globalEnv, lno, strName, offset)
+-
+- fun lookupFailure msg =
+- giveError (str, line, lex) (msg ^ " in signature.")
+-
+- (* Look up the type constructor in the signature. *)
+- val typeConstr =
+- lookupTyp
+- ({
+- lookupType = #lookup findTypes,
+- lookupStruct = #lookup findStructs
+- },
+- typeName,
+- lookupFailure);
+- (* The type, though, is looked up in the surrounding environment. *)
+- fun lookupGlobal s =
+- lookupTyp
+- ({
+- lookupType =
+- lookupDefault (#lookupType structEnv) (#lookupType globalEnv),
+- lookupStruct =
+- lookupDefault (#lookupStruct structEnv) (#lookupStruct globalEnv)
+- },
+- s,
+- giveError (str, line, lex))
+-
+- (* Process the type, looking up any type constructors. *)
+- val U: unit = assignTypes (realisation, lookupGlobal, lex, line);
+- (* Now build a dummy type constructor whose equivalent is
+- the type on the right hand side. *)
+- val dummyTypeCons =
+- makeTypeConstrs (typeName, typeVars, realisation,
+- makeVariableId(), false, 0);
+- in
+- (* Now match these up. This is very similar to an ML90
+- sharing constraint where one of the types was rigid. *)
+- setWhereType(typeConstr, dummyTypeCons, giveError (str, line, lex));
+- (* Finally we can safely add the new declarations to the surrounding scope. *)
+- #apply findTypes (#enterType structEnv);
+- #apply findStructs (#enterStruct structEnv);
+- resAddr
+- end
+-
+- | _ =>
+- raise InternalError "makeSigInto: not a SigIdent nor a SigDec"; (* end makeSigInto *)
+- in
+- case str of
+- SignatureIdent (name : string) =>
+- (* We can speed things up because the stamps are already bound.
+- N.B. When processing the result signature of a functor we
+- explicitly check for this case. *)
+- lookSig (name, lno)
+-
+- | _ =>
+- let (* Anything else has to be copied. *)
+- val result = sigValue (str, Env globalEnv, lno, strName);
+-
+- (* We used to have code in here to generate equality types for
+- all the datatypes in the signature and also to check that the
+- signature was well formed (that meant that if we had shared
+- a structure in the signature with a global structure then every
+- type and substructure in the shared structure had a counterpart
+- in the global structure). That has all changed in ML97. *)
+- in
+- (* Now enumerate the bound names. *)
+- renameVariableAsBound(result, initTypeId, giveError (str, lno, lex))
+- end (* not (isSignatureIdent str) *)
+- end (* sigVal *);
+-
+- (* Process structure-returning expressions i.e. structure names,
+- struct..end values and functor applications. typeNo is the
+- number of the next bound identifier. If < 0 make a free identifier. *)
+- fun structValue str typeNo (Env env) lno strName =
+- let (* Look up a structure name. *)
+- fun lookStr name kind =
+- lookupStructure (kind,{lookupStruct = #lookupStruct env},
+- name, giveError (str, lno, lex));
+
+- (* these were anonymous fn; moved here for convenience SPF 11/8/94 *)
+- fun newTypeId () =
+- let
+- val n = !typeNo;
+- in
+- if n < 0 then makeFreeId () else (typeNo := n + 1; makeBoundId n)
+- end;
+-
+- in
+- case str of
+- StructureIdent {name, valRef} =>
+- let (* Look up the name and save the value. *)
+- val result = lookStr name "Structure";
+- in
+- if isUndefinedStruct result
+- then undefinedSignature
+- else (valRef := result; structSignat result )
+- end
+-
+- | FunctorAppl {name, arg, valRef} =>
++ | FunctorAppl {name, arg, valRef, nameLoc, fullLoc, argIds, resIds, resultSig, ... } =>
+ (* The result structure must be copied to generate a new
+ environment. This will make new types so that different
+ applications of the functor yield different types. There may be
+ dependencies between the parameters and result signatures so
+ copying may have to take that into account. *)
+- let
+- (* Look up the name, and copy the structure. Strictly functors
+- cannot be contained in structures but this allows structures
+- to be used as general name spaces. *)
+- val functr: functors =
+- lookupAny
+- (name,
+- #lookupFunct env,
+- #lookupStruct env,
+- (fn s => #lookupFunct (makeEnv (structSignat s))),
+- "Functor",
+- undefinedFunctor,
+- giveError (str, lno, lex));
+- in
+- if isUndefinedFunctor functr
+- then undefinedSignature
+- else let
+- val U : unit = valRef := functr; (* save it till later. *)
+-
+- val resultSig : signatures = functorResult functr;
+- val argStruct : structVals = functorArg functr;
+-
+- (* We must ensure that types are correctly shared
+- between the arguments and the result. This table keeps track
+- of which actual parameters have been matched to the formals
+- and are then used in the generation of new stamps for types
+- declared in the functor. *)
+- val typeMap : typeConstrs map =
+- typeMatchTab (sigMinTypes resultSig, sigMaxTypes resultSig);
+-
+- (* Get the actual parameter value. *)
+- val argSig = structValue arg typeNo (Env env) lno "";
++ let
++ (* Look up the functor name. ML doesn't allow functors to be in structures. *)
++ val functr: functors =
++ case #lookupFunct env name of
++ SOME f => f
++ | NONE =>
++ (
++ giveError (str, nameLoc, lex) ("Functor (" ^ name ^ ") has not been declared");
++ undefinedFunctor
++ )
++ in
++ if isUndefinedFunctor functr
++ then undefinedSignature
++ else
++ let
++ val () = valRef := functr; (* save it till later. *)
++ (* Apply a functor to an argument. The result structure contains a mixture of IDs
++ from the argument structure and generative IDs from the result structure.
++ There are two parts to this process.
++ 1. We have to match the actual argument structure to the formal argument to
++ ensure that IDs are in the right place for the functor.
++ 2. We have to take the actual argument structure and the functor result structure
++ and produce a combination of this as a structure. *)
++ (* IDs:
++ argIDs: A list of pairs of IDs as Selected/Local/Global values and Formal values.
++ This contains the IDs that must be passed into the functor.
++ resIDs: A list of pairs of IDs as Local values and Formal values. The Local value
++ is the location where a new generative ID is stored and the Formal offset is the
++ offset within the run-time vector returned by the signature where the source ID
++ for the generative ID is to be found. *)
++ val functorResSig : signatures = functorResult functr;
++ val argStruct : structVals = functorArg functr;
++ val formalArgSig = structSignat argStruct
++
++ (* This provides information about the arguments. *)
++ (* Get the actual parameter value. *)
++ val actualArgSig =
++ structValue(arg, newTypeId, currentTypeCount, newTypeIdEnv, Env env, lex, fullLoc, structPath);
++
++ (* Check that the actual arguments match formal arguments,
++ and instantiate the variables. *)
++ val matchResults =
++ matchSigs (actualArgSig, formalArgSig,
++ fn n => displayStruct(str, n), fullLoc, lex, newTypeIdEnv(), typeEnv);
++ (* Create a list of the type IDs that the argument must supply. *)
++ local
++ val maxT = sigMaxTypes formalArgSig and minT = sigMinTypes formalArgSig
++ val results = List.tabulate(maxT-minT, fn n => matchResults(n+minT))
++ val args = ListPair.mapEq(fn(s, d) => { source = s, dest = d })(results, sigBoundIds formalArgSig)
++ in
++ val () = argIds := args; (* Save for code-generation. *)
++ end
+
+- (* Check that the actual arguments match formal arguments,
+- and instantiate the variables. *)
+- val U : unit =
+- matchSigs (argSig, structSignat argStruct,
+- typeMap, str, lno, lex);
+- in
+- (* Finally copy the result signature, incorporating the actual
+- args, and creating new stamps for any generative stamps
+- (i.e. stamps that were not put in the table before. *)
+- copySig (resultSig, isBoundId, newTypeId,
+- typeMap, strName)
++ (* Now create the generative typeIDs. These are IDs that are in the bound ID range of
++ the result signature. Any type IDs inherited from the argument will have type ID
++ values less than sigMinTypes functorResSig. *)
++ local
++ fun makeNewTypeId(
++ oldId as Bound{description = { name=oldName, ...}, isDatatype, ...}) =
++ let
++ val description =
++ { location = fullLoc, name = oldName, description = "Created from applying functor " ^ name }
++ val newId = newTypeId(false, isEquality oldId, isDatatype, description)
++ in
++ { source = oldId, dest = newId }
++ end
++ | makeNewTypeId _ = raise InternalError "Not Bound"
++ (* The resIds list tells the code-generator where to find the source of each
++ ID in the result structure and where to save the generative ID. *)
++ val sdList = List.map makeNewTypeId (sigBoundIds functorResSig)
++ val _ = resIds := sdList (* Save for code-generation. *)
++ in
++ (* This vector contains the resulting type IDs. They all have Local access. *)
++ val resVector = Vector.fromList(List.map(fn { dest, ...} => dest) sdList)
++ end
++
++ (* Construct a result signature using copySigAndRenumber. This will contain all the
++ IDs created here i.e. IDs in the argument and generative IDs at the start and then
++ all the values and structures returned from the functor.
++ When we come to code-generate we need to
++ 1. Use loadOpaqueIds over the resIDs to create the opaque IDs.
++ 2. Basically, do the same as StructDec to match to the result signature.
++ We don't need to do anything about type IDs from the argument. Processing
++ the argument will ensure that type IDs created in the argument are declared
++ as Locals and if we pass localIDs to matchStructure we will load IDs from
++ both the argument and generative IDs created by loadOpaqueIds. *)
++ val minCopy = Int.min(sigMinTypes formalArgSig, sigMinTypes functorResSig)
++ val idEnv = newTypeIdEnv()
++ fun getCombinedTypeId n =
++ if n < minCopy then idEnv n
++ else if n >= sigMinTypes functorResSig
++ then Vector.sub(resVector, n - sigMinTypes functorResSig)
++ else if n >= sigMinTypes formalArgSig
++ then matchResults n
++ else sigTypeIdMap formalArgSig n
++
++ val resSig =
++ let
++ val Signatures { name, tab, declaredAt, ... } = functorResSig
++ in
++ makeSignature(name, tab, currentTypeCount(), currentTypeCount(), declaredAt,
++ composeMaps(sigTypeIdMap functorResSig, getCombinedTypeId), [])
++ end
++ in
++ resultSig := resSig;
++ resSig
++ end
+ end
+- end
+
+- | StructDec {alist, value = signat} =>
++ | StructDec {alist, value = structTable, location, resultSig, ...} =>
+ let
+ (* Collection of declarations packaged into a structure
+ or a collection of signatures. *)
+ (* Some of the environment, the types and the value constructors,
+ is generated during the first pass. Get the environment from
+ the structure. *)
+- val structEnv = makeEnv signat;
+-
+- (* Make a result signature. This will have the value and structure
+- entries as formals. *)
+- val resultSig = makeSignatures (sigName signat);
+- val resultEnv = makeEnv resultSig;
+- val addrs = ref 0;
++ val structEnv = makeEnv structTable
++
++ val makeLocalTypeId = newTypeId
++ val makeLocalTypeIdEnv = newTypeIdEnv
++
++ val newEnv =
++ {
++ enterType = #enterType structEnv,
++ enterVal = #enterVal structEnv,
++ enterStruct = #enterStruct structEnv,
++ enterSig = fn _ => raise InternalError "Signature in Struct End",
++ enterFunct = fn _ => raise InternalError "Functor in Struct End",
++ lookupVal = lookupDefault (#lookupVal structEnv) (#lookupVal env),
++ lookupType = lookupDefault (#lookupType structEnv) (#lookupType env),
++ lookupStruct = lookupDefault (#lookupStruct structEnv) (#lookupStruct env),
++ lookupSig = #lookupSig env, (* Global *)
++ lookupFunct = #lookupFunct env, (* Global *)
++ lookupFix = #lookupFix env,
++ (* Fixity declarations are dealt with in the parsing process. They
++ are only processed again in this pass in order to get declarations
++ in the right order. *)
++ enterFix = fn _ => ()
++ }
++
++ (* process body of structure *)
++ val () =
++ pass2Struct (alist, makeLocalTypeId, currentTypeCount, makeLocalTypeIdEnv, Env newEnv, lex, lno, structPath);
++
++ (* We need to make a signature for the result in the form that can be used if there is no
++ explicit signature, for example if this is used as the result of a functor. That means
++ creating Formal values for all the values and structures. These Formal entries define
++ the position in the run-time vector where each of the values and sub-structures are
++ located. We don't include typeIDs in this. Any typeIDs that need to be included in
++ the run-time vector are added by the functor declaration code. *)
++ val finalTable = makeSignatureTable();
++ val finalEnv = makeEnv finalTable
+
+- (* This environment receives the declarations from calling pass2. *)
+- val newEnv =
+- {
+- enterType =
+- fn (pair as (name,v)) =>
+- (
+- #enterType structEnv pair;
+- #enterType resultEnv pair
+- ),
+-
+- (* Should never occur. *)
+- enterSig =
+- fn (pair as (name,v)) =>
+- (
+- #enterSig structEnv pair;
+- #enterSig resultEnv pair
+- ),
+-
+- (* Never occurs in normal ML, might happen if we opened a
+- structure that was actually a name space. *)
+- enterFunct =
+- fn (pair as (name,v)) =>
+- (
+- #enterFunct structEnv pair;
+- #enterFunct resultEnv pair
+- ),
+-
+- (* Enter the value in the environment of the struct..end,
+- but turn local declarations or selections from other
+- structures into entries for the result vector. *)
+- enterVal =
+- fn (pair as (name,v)) =>
+- (
+- #enterVal structEnv pair;
+-
+- case v of
+- Value{access=Overloaded _, ...} =>
+- #enterVal resultEnv pair (* Just copy. *)
+- | Value{class, typeOf, ...} =>
+- let (* Local or selected. *)
+- val isVal = not (isConstructor v);
+-
+- val a = !addrs;
+- in
+- #enterVal resultEnv (name, mkFormal (name, class, typeOf, a));
+- addrs := a + 1
+- end
+- ),
+-
+- (* Make entries in the result vector. *)
+- enterStruct =
+- fn (pair as (name, str)) =>
++ fun enterItem(dName, dVal, addrs) =
++ if tagIs typeConstrVar dVal
++ then (#enterType finalEnv (dName, tagProject typeConstrVar dVal); addrs)
++ else if tagIs structVar dVal
++ then
+ let
+- val U = #enterStruct structEnv pair;
+- val resSig = structSignat str;
+- val a = !addrs;
++ val strVal = tagProject structVar dVal
++ val locations = structLocations strVal
+ in
+- #enterStruct resultEnv (name, makeFormalStruct (name, resSig, a));
+- addrs := a + 1
+- end,
+-
+- lookupVal =
+- lookupDefault (#lookupVal structEnv) (#lookupVal env),
+-
+- lookupType =
+- lookupDefault (#lookupType structEnv) (#lookupType env),
+-
+- lookupStruct =
+- lookupDefault (#lookupStruct structEnv) (#lookupStruct env),
+-
+- lookupSig = #lookupSig env, (* Global *)
+-
+- lookupFunct = #lookupFunct env, (* Global *)
+-
+- lookupFix = #lookupFix env,
+-
+- (* Fixity declarations are dealt with in the parsing process. They
+- are only processed again in this pass in order to get declarations
+- in the right order. *)
+- enterFix = fn _ => ()
+- };
++ #enterStruct finalEnv (dName, makeFormalStruct (dName, structSignat strVal, addrs, locations));
++ addrs + 1
++ end
++ else if tagIs valueVar dVal
++ then
++ let
++ val valVal = tagProject valueVar dVal
++ in
++ (* If this is a type-dependent function such as PolyML.print we must put in the
++ original type-dependent version not the version which will have frozen
++ its type as 'a. *)
++ case valVal of
++ value as Value{access = Overloaded _, ...} =>
++ (
++ #enterVal finalEnv (dName, value);
++ addrs
++ )
++ | Value{class, typeOf, locations, references, ...} =>
++ (
++ #enterVal finalEnv (dName,
++ Value{class=class, name=dName, typeOf=typeOf, access=Formal addrs,
++ locations=locations, references=references});
++ addrs + 1
++ )
++ end
++ else addrs
+
+- (* process body of structure *)
+- val U : unit =
+- pass2Struct (alist, typeNo, Env newEnv, lno, strName);
++ val _ = univFold(structTable, enterItem, 0)
++ val resSig =
++ makeSignature("", finalTable, currentTypeCount(), currentTypeCount(), location, newTypeIdEnv(), [])
+ in
+- resultSig
++ resultSig := resSig;
++ resSig
+ end
+
+ | Localdec {decs, body = [localStr], line, ...} =>
+ let (* let strdec in strexp end *)
+- val newEnv = makeEnv (makeSignatures "");
++ val newEnv = makeEnv (makeSignatureTable());
+
+ (* The environment for the local declarations. *)
+ val localEnv =
+@@ -2794,363 +1436,139 @@
+ };
+
+ (* Process the local declarations. *)
+- val U : unit =
+- pass2Struct (decs, typeNo, Env localEnv, line, strName);
++ val () =
++ pass2Struct (decs, newTypeId, currentTypeCount, newTypeIdEnv, Env localEnv, lex, line, structPath);
+
+ in
+ (* There should just be one entry in the "body" list. *)
+- structValue localStr typeNo (Env localEnv) line strName
++ structValue(localStr, newTypeId, currentTypeCount, newTypeIdEnv, Env localEnv, lex, line, structPath)
+ end
+
+- | SigConstraint { str, csig, opaque } =>
+- let (* struct: sig or struct :> sig *)
+- val resSig = structValue str typeNo (Env env) lno strName;
+- val explicitSig : signatures =
+- sigVal(csig, Int.max(!typeNo, 0), Env env, lno, strName);
+-
+- (* Make tables to contain the matched ids. *)
+- val typeMap : typeConstrs map =
+- typeMatchTab (sigMinTypes explicitSig, sigMaxTypes explicitSig);
+-
+- fun mustCopyType (s : typeId) : bool =
+- isBoundId s andalso offsetId s >= sigMinTypes explicitSig;
+-
+- (* These maps are used to construct the resultant signature.
+- If we are using transparent matching we use the map constructed
+- from matching the signature to the structure but if we are
+- using opaque matching we need to make new instances of
+- every type. *)
+- val resTypeMap =
+- if opaque
+- then typeMatchTab (sigMinTypes explicitSig, sigMaxTypes explicitSig)
+- else typeMap;
+- in
+- matchSigs (resSig, explicitSig, typeMap, str, lno, lex);
+- (* Copy the signature to ensure that any "names" from the structure
+- value are copied into the result signature. *)
+- copySig (explicitSig, mustCopyType, newTypeId, resTypeMap, strName)
+- end
++ | SigConstraint { str, csig, opaque, sigLoc, opaqueIds, resultSig, ... } =>
++ let
++ val bodyIds = ref []
++ val startTypes = currentTypeCount()
++ val startTypeEnv = newTypeIdEnv()
++ fun sconstraintMakeTypeId (isVar, eq, isdt, desc) =
++ let
++ val newId = newTypeId(isVar, eq, isdt, desc)
++ in
++ bodyIds := newId :: ! bodyIds;
++ newId
++ end
++ fun sconstraintTypeIdEnv () n =
++ if n < startTypes then startTypeEnv n
++ else valOf(
++ List.find(fn Bound{offset, ...} => offset = n | _ => raise Subscript) (!bodyIds))
++
++ val resSig =
++ structValue(str, sconstraintMakeTypeId, currentTypeCount, sconstraintTypeIdEnv, Env env, lex, lno, structPath);
++ (* Get the explicit signature. *)
++ val explicitSig = sigVal(csig, startTypes, startTypeEnv, Env env, lex, sigLoc)
++
++ val minExplicitSig = sigMinTypes explicitSig and maxExplicitSig = sigMaxTypes explicitSig
++
++ (* Match the signature. This instantiates entries in typeMap. *)
++ val matchResults = matchSigs (resSig, explicitSig, fn n => displayStruct(str, n), sigLoc, lex, startTypeEnv, typeEnv);
++ val rSig =
++ if opaque
++ then
++ let
++ (* Construct new IDs for the generic IDs. For each ID in the signature
++ we need to make a new Local ID. *)
++ fun makeNewId(oldId as Bound { description = { name, ...}, isDatatype, ...}) =
++ let
++ val description =
++ { location = sigLoc, name = name, description = "Created from opaque signature" }
++ in
++ newTypeId(false, isEquality oldId, isDatatype, description)
++ end
++ | makeNewId _ = raise InternalError "Not Bound"
++
++ val sources = List.tabulate(maxExplicitSig-minExplicitSig, fn n => matchResults(n+minExplicitSig))
++ val dests = List.map makeNewId (sigBoundIds explicitSig)
++ (* Add the matching IDs to a list. When we create the code for
++ the structure we need to create new run-time ID values using
++ the original equality code and a new ref to hold the printer. *)
++ val () = opaqueIds := ListPair.mapEq (fn (s, d) => { source=s, dest=d }) (sources, dests)
++ (* Create new IDs for all the bound IDs in the signature. *)
++ val v = Vector.fromList dests
++
++ (* And copy it to put in the names from the structure. *)
++ val currentEnv = newTypeIdEnv()
++ fun oldMap n =
++ if n < minExplicitSig
++ then currentEnv n
++ else Vector.sub (v, n - minExplicitSig)
++ in
++ makeSignature(sigName explicitSig, sigTab explicitSig, currentTypeCount(), currentTypeCount(),
++ sigDeclaredAt explicitSig, composeMaps(sigTypeIdMap explicitSig, oldMap), [])
++ end
++ else (* Transparent: Use the IDs from the structure. *)
++ let
++ val newIdEnv = newTypeIdEnv ()
++ fun matchedIds n = if n < sigMinTypes explicitSig then newIdEnv n else matchResults n
++ in
++ (* The result signature. This needs to be able to enumerate the type IDs
++ including those we've added. *)
++ makeSignature(sigName explicitSig, sigTab explicitSig, currentTypeCount(), currentTypeCount(),
++ sigDeclaredAt explicitSig, composeMaps(sigTypeIdMap explicitSig, matchedIds), [])
++ end
++ in
++ resultSig := rSig;
++ rSig
++ end
+
+ | _ =>
+ raise InternalError "structValue: not a value"
+- end (* structValue *);
+-
+- (* compare with newTypeId above!!! *)
+- fun makeTypeId () =
+- let
+- val n = !typeNo;
+- in
+- if n < 0 then makeFreeId () else (typeNo := n + 1; makeBoundId n)
+- end;
+-
+- fun pass2StructureDec (str : structs, structList : structBind list) : unit =
+- let (* Declaration of structures. *)
+- (* The declarations must be made in parallel. i.e.
+- structure A = struct ... end and B = A; binds B to the A
+- in the PREVIOUS environment, not the A being declared. *)
+- val sEnv = (* The new names. *)
+- noDuplicates
+- (fn name =>
+- errorNear (lex, true, str, lno,
+- "Structure " ^ name ^
+- " has already been bound in this declaration")
+- );
+- (* Put the new names into this environment. *)
+-
+- fun pass2StructureBind ({name, sigStruct, value, valRef, line, opaque}) : unit=
+- let (* Each element in the list is a structure binding. *)
+- val resSig =
+- structValue value typeNo (Env env) line (strName ^ name ^".");
+-
+- val resultSig =
+- if isEmptyStruct sigStruct
+- then resSig (* No signature to match. *)
+- else let
+- (* Get the explicit signature. If we are inside a functor
+- we have to make any new bound names outside the range
+- we have already used. If !typeNo is
+- less than 0 this means we are not in a functor so we
+- actually start at 0. *)
+- val explicitSig : signatures =
+- sigVal
+- (sigStruct,
+- Int.max (!typeNo, 0),
+- Env env,
+- line,
+- strName ^ name ^ ".");
+-
+- (* Make tables to contain the matched ids. *)
+- val typeMap : typeConstrs map =
+- typeMatchTab (sigMinTypes explicitSig, sigMaxTypes explicitSig);
+-
+- fun mustCopyType (s : typeId) : bool =
+- isBoundId s andalso offsetId s >= sigMinTypes explicitSig;
+-
+- (* These maps are used to construct the resultant signature.
+- If we are using transparent matching we use the map constructed
+- from matching the signature to the structure but if we are
+- using opaque matching we need to make new instances of
+- every type. *)
+- val resTypeMap =
+- if opaque
+- then typeMatchTab (sigMinTypes explicitSig, sigMaxTypes explicitSig)
+- else typeMap;
+- in (* Match the signature. *)
+- matchSigs (resSig, explicitSig, typeMap, str, line, lex);
+- (* And copy it to put in the names from the structure. *)
+- copySig (explicitSig, mustCopyType, makeTypeId,
+- resTypeMap, strName ^ name ^ ".")
+- end;
+-
+- (* Now make a local structure variable using this signature. *)
+- val var = makeLocalStruct (name, resultSig);
+-
+- in
+- #enter sEnv (name, var);
+- valRef := var
+- end
+-
+- in
+- List.app pass2StructureBind structList;
+- (* Put them into the enclosing env. *)
+- #apply sEnv (#enterStruct env)
+- end; (* pass2StructureDec *)
+-
+- fun pass2FunctorDec (s: structs, structList : functorBind list) : unit =
+- let
+- (* There is a restriction that the same name may not be bound twice.
+- As with other bindings functor bindings happen in parallel.
+- DCJM 6/1/00. *)
+- val sEnv = (* The new names. *)
+- noDuplicates
+- (fn name =>
+- errorNear (lex, true, s, lno,
+- "Functor " ^ name ^
+- " has already been bound in this declaration")
+- );
++ end (* structValue *)
+
+- (* Put the new names into this environment. *)
+- fun pass2FunctorBind ({name, arg = FormalArg arg, body, sigStruct,
+- valRef, line, opaque}) =
+- let
+- (* We must copy the signatures to ensure that arguments with
+- the same signature are different. Make an environment to
+- contain the arguments. *)
+- val argEnv = makeEnv (makeSignatures "");
+-
+- val {name = argName, sigStruct = argSig, valRef = argVal} = arg;
+-
+- (* If it is a "spec" it must be wrapped up in sig...end.
+- We can't have a functor declaration in another functor
+- (at least in the current definition of ML so we can
+- start this at 0, rather than !typeNo). *)
+- val signat : signatures =
+- let
+- val spec =
+- case argSig of
+- SignatureIdent _ => argSig
+- | SigDec _ => argSig
+- | WhereType _ => argSig
+- | _ => mkSig [argSig]
+- in
+- sigVal (spec, 0, Env env, line, "")
+- end;
+-
+- val resArg = makeLocalStruct (argName, signat);
+- in (* Put the copied version in. *)
+- if argName <> ""
+- then #enterStruct argEnv (argName, resArg)
+- else
+- (* Open the dummy argument. Similar to "open" in treestruct. *)
+- univFold
+- (sigTab signat,
+- (fn (dName, dVal, ()) =>
+- if tagIs typeConstrVar dVal
+- then
+- #enterType argEnv
+- (dName, tagProject typeConstrVar dVal)
+-
+- else if tagIs valueVar dVal
+- then
+- #enterVal argEnv
+- (dName, mkSelectedVar (tagProject valueVar dVal, resArg))
+-
+- else if tagIs structVar dVal
+- then
+- #enterStruct argEnv
+- (dName, makeSelectedStruct (tagProject structVar dVal, resArg))
+-
+- else ()
+- ),
+- ()
+- );
+-
+- argVal := resArg;
+-
+- (* Now process the body of the functor using the environment of
+- the arguments to the functor and the global environment. *)
+- let
+- val envWithArgs =
+- {
+- lookupVal =
+- lookupDefault (#lookupVal argEnv) (#lookupVal env),
+- lookupType =
+- lookupDefault (#lookupType argEnv) (#lookupType env),
+- lookupFix = #lookupFix env,
+- lookupStruct =
+- lookupDefault (#lookupStruct argEnv) (#lookupStruct env),
+- lookupSig = #lookupSig env,
+- lookupFunct = #lookupFunct env,
+- enterVal = #enterVal env,
+- enterType = #enterType env,
+- enterFix = fn _ => (),
+- enterStruct = #enterStruct env,
+- enterSig = #enterSig env,
+- enterFunct = #enterFunct env
+- };
+-
+- (* In sigVal we will have allocated a range of bound stamps
+- for the argument signature. We need to extend the range
+- for stamps in the body. *)
+- val typeStamps = ref (sigMaxTypes signat);
+-
+- fun newTypeId () =
+- let
+- val n = !typeStamps;
+- in
+- typeStamps := n + 1;
+- makeBoundId n
+- end;
+-
+- val resSig =
+- structValue body typeStamps
+- (Env envWithArgs) line (strName ^ name ^ "().");
+-
+- val resultSig =
+- if isEmptyStruct sigStruct
+- then resSig (* No signature to match. *)
+- else let (* Get the explicit result signature. *)
+- val startTypes = sigMaxTypes signat;
+-
+- val explicitSig : signatures =
+- sigVal
+- (sigStruct,
+- startTypes,
+- Env envWithArgs,
+- line, strName ^ name ^ "().");
+-
+- (* Make tables to contain the matched names. If we have
+- a named signature we won't have copied it so the names
+- will start from zero, but since we can't have any
+- sharing with the argument there isn't a problem.
+- Otherwise we may have some sharing with the argument
+- and we have to keep the names distinct. *)
+- val fromZero = isSignatureIdent sigStruct;
+-
+- val typeMap : typeConstrs map =
+- typeMatchTab
+- (sigMinTypes explicitSig,
+- sigMaxTypes explicitSig);
+-
+- fun mustCopyType s =
+- isBoundId s andalso offsetId s >= sigMinTypes explicitSig;
+-
+- (* These maps are used to construct the resultant signature.
+- If we are using transparent matching we use the map constructed
+- from matching the signature to the structure but if we are
+- using opaque matching we need to make new instances of
+- every type. *)
+- val resTypeMap =
+- if opaque
+- then typeMatchTab (sigMinTypes explicitSig, sigMaxTypes explicitSig)
+- else typeMap
+-
+- in
+- (* Match the signature. *)
+- matchSigs (resSig, explicitSig, typeMap, s, line, lex);
+- (* And copy it to put in the names from the args and
+- generative names. All the names will normally be in
+- the table already so copySig will not make any new
+- ones, merely link up the values to their new types.
+- We have to be careful if we have names used in the
+- explicit result signature which have come from the
+- argument, particularly if there is no type constructor
+- in the result with that name. e.g.
+- functor F(type t end): sig val x: t end = ...
+- To handle that we only copy bound names actually in
+- the explicit signature. New names are generated in
+- exceptional circumstances, mainly if there has been
+- an error in matching. *)
+- (* The above comment was true when we only had transparent
+- matching. In ML 97, with opaque matching, we
+- generate new names for all types which are not
+- constrained by sharing constraints. *)
+- copySig (explicitSig, mustCopyType, newTypeId,
+- resTypeMap, strName ^ name ^ "().")
+- end;
+-
+- (* Now make a local functor variable and put it in the
+- name space. Because functors can only be declared at
+- the top level the only way it can be used is if we have
+- functor F(..) = ... functor G() = ..F.. with no semicolon
+- between them. They will then be taken as a single
+- declaration and F will be picked up as a local. *)
+- (* Set the size of the type map. *)
+- val sig' =
+- makeCopy (sigName resultSig, resultSig, 0, !typeStamps);
+-
+- val var = makeFunctor (name, resArg, sig', makeLocal ());
+-
+- in
+- #enter sEnv (name, var);
+- valRef := var
+- end
+- end
+- | pass2FunctorBind _ =
+- raise InternalError "pass2FunctorBind"
+- in
+- (* Each element in the list is a functor binding. *)
+- List.app pass2FunctorBind structList;
+- (* Put them into the enclosing env. *)
+- #apply sEnv (#enterFunct env)
+- end; (* pass2FunctorDec *)
+-
+- fun pass2SignatureDec (str: structs, structList : sigBind list) : unit =
+- let
+- (* There is a restriction that the same name may not be bound twice.
+- As with other bindings functor bindings happen in parallel.
+- DCJM 6/1/00. *)
+- val sEnv = (* The new names. *)
+- noDuplicates
+- (fn name =>
+- errorNear (lex, true, str, lno,
+- "Signature " ^ name ^
+- " has already been bound in this declaration")
+- );
++ and pass2Struct
++ (strs : structs list,
++ makeLocalTypeId : (bool * bool * bool * typeIdDescription) -> typeId,
++ makeCurrentTypeCount: unit -> int,
++ makeTypeIdEnv: unit -> int -> typeId,
++ Env env : env,
++ lex,
++ lno : LEX.location,
++ structPath: string
++ ) : unit =
++ let
++ fun pass2StructureDec (str : structs, structList : structBind list) : unit =
++ let (* Declaration of structures. *)
++ (* The declarations must be made in parallel. i.e.
++ structure A = struct ... end and B = A; binds B to the A
++ in the PREVIOUS environment, not the A being declared. *)
++ val sEnv = (* The new names. *)
++ noDuplicates
++ (fn(name, _, _) =>
++ errorNear (lex, true, fn n => displayStruct(str, n), lno,
++ "Structure " ^ name ^
++ " has already been bound in this declaration")
++ );
++ (* Put the new names into this environment. *)
++ fun pass2StructureBind ({name, value, valRef, line, ...}) : unit=
++ let (* Each element in the list is a structure binding. *)
++ val resSig =
++ structValue(value, makeLocalTypeId, makeCurrentTypeCount, makeTypeIdEnv,
++ Env env, lex, line, structPath ^ name ^ ".");
++ (* Any values in the signature are counted as exported. *)
++ val () = markValsAsExported resSig;
++ (* Now make a local structure variable using this signature. *)
++ val var = makeLocalStruct (name, resSig, [DeclaredAt line])
++ in
++ #enter sEnv (name, var);
++ valRef := var
++ end
++ in
++ List.app pass2StructureBind structList;
++ (* Put them into the enclosing env. *)
++ #apply sEnv (#enterStruct env)
++ end; (* pass2StructureDec *)
+
+- fun pass2SignatureBind ({name, sigStruct, line, sigRef}) =
+- let (* Each element in the list is a signature binding. *)
+- (* Get the signature. We can't have a declaration of a
+- signature inside a functor so we can start at 0
+- rather than !typeNo. *)
+- val resSig : signatures =
+- sigVal (sigStruct, 0, Env env, line, strName ^ name ^ ".");
+- (* Generate a signature with the new name and put it
+- in the table *)
+- val copiedSig = makeCopy (name, resSig, sigMinTypes resSig, sigMaxTypes resSig)
+- in
+- sigRef := copiedSig; (* Remember the signature for pass4. *)
+- #enter sEnv (name, copiedSig)
+- end
+- in
+- List.app pass2SignatureBind structList;
+- (* Put them into the enclosing env. *)
+- #apply sEnv (#enterSig env)
+- end; (* pass2SignatureDec *)
+-
+- fun pass2Localdec (decs : structs list, body : structs list) : unit =
+- let
+- val newEnv = makeEnv (makeSignatures "");
++ fun pass2Localdec (decs : structs list, body : structs list) : unit =
++ let
++ val newEnv = makeEnv (makeSignatureTable());
+
+ (* The environment for the local declarations. *)
+ val localEnv =
+@@ -3173,7 +1591,8 @@
+ };
+
+ (* Process the local declarations. *)
+- val U = pass2Struct (decs, typeNo, Env localEnv, lno, strName);
++ val () =
++ pass2Struct (decs, makeLocalTypeId, makeCurrentTypeCount, makeTypeIdEnv, Env localEnv, lex, lno, structPath);
+
+ (* This is the environment used for the body of the declaration.
+ Declarations are added both to the local environment and to
+@@ -3189,26 +1608,26 @@
+ lookupSig = #lookupSig localEnv,
+ lookupFunct = #lookupFunct localEnv,
+ enterVal =
+- fn (pair as (name, v)) =>
++ fn pair =>
+ (
+ #enterVal newEnv pair;
+ #enterVal env pair
+ ),
+ enterType =
+- fn (pair as (name, v)) =>
++ fn pair =>
+ (
+ #enterType newEnv pair;
+ #enterType env pair
+ ),
+ enterFix = #enterFix localEnv,
+ enterStruct =
+- fn (pair as (name, v)) =>
++ fn pair =>
+ (
+ #enterStruct newEnv pair;
+ #enterStruct env pair
+ ),
+ enterSig =
+- fn (pair as (name, v)) =>
++ fn pair =>
+ (
+ #enterSig newEnv pair;
+ #enterSig env pair
+@@ -3217,10 +1636,10 @@
+ };
+ in
+ (* Now the body. *)
+- pass2Struct (body, typeNo, Env bodyEnv, lno, strName)
++ pass2Struct (body, makeLocalTypeId, makeCurrentTypeCount, makeTypeIdEnv, Env bodyEnv, lex, lno, structPath)
+ end; (* pass2Localdec *)
+
+- fun pass2Singleton (dec : parsetree, vars, line : int) : unit =
++ fun pass2Singleton (dec : parsetree, vars) : unit =
+ let (* Single declaration - may declare several names. *)
+ (* As well as entering the declarations we must keep a list
+ of the value and exception declarations. *)
+@@ -3236,19 +1655,19 @@
+ with the same name is made. e.g.
+ local ... in val a=1; val a=2 end. *)
+ enterVal =
+- fn (pair as (name,v)) =>
++ fn (pair as (_,v)) =>
+ (
+ #enterVal env pair;
+ vars := !vars @ [CoreValue v]
+ ),
+ enterType =
+- fn (pair as (name,t)) =>
++ fn (pair as (_,t)) =>
+ (
+ #enterType env pair;
+ vars := !vars @ [CoreType t]
+ ),
+ enterFix =
+- fn (pair as (name,f)) =>
++ fn pair =>
+ (
+ #enterFix env pair;
+ vars := !vars @ [CoreFix pair]
+@@ -3256,7 +1675,7 @@
+ (* This will only be used if we do `open A' where A
+ contains sub-structures. *)
+ enterStruct =
+- fn (pair as (name,v)) =>
++ fn (pair as (_,v)) =>
+ (
+ #enterStruct env pair;
+ vars := !vars @ [CoreStruct v]
+@@ -3264,84 +1683,430 @@
+ enterSig = #enterSig env,
+ enterFunct = #enterFunct env
+ };
+-
+- val discard : types =
+- pass2 (dec, makeTypeId, Env newEnv, lex, line, strName);
++
++ (* Create a new type ID for each new datatype. Add the structure path to the
++ name. *)
++ fun makeId (eq, isdt, { location, name, description }) =
++ makeLocalTypeId(true, eq, isdt,
++ { location = location, name = structPath ^ name, description = description })
++ (* Process the body and discard the type. *)
++ val _ : types = pass2 (dec, makeId, Env newEnv, lex);
+ in
+ ()
+ end; (* pass2Singleton *)
+
+- fun pass2Dec (str : structs) : unit =
+- case str of
+- StructureDec (structList : structBind list) =>
+- pass2StructureDec (str, structList)
+-
+- | FunctorDec (structList : functorBind list) =>
+- pass2FunctorDec (str, structList)
++ fun pass2Dec (str as StructureDec (structList : structBind list, _)) =
++ pass2StructureDec (str, structList)
++
++ | pass2Dec(Localdec {decs, body, ...}) =
++ pass2Localdec (decs, body)
+
+- | SignatureDec (structList : sigBind list) =>
+- pass2SignatureDec (str, structList)
++ | pass2Dec(CoreLang {dec, vars, ...}) =
++ pass2Singleton (dec, vars)
+
+- | Localdec {decs, body, ...} =>
+- pass2Localdec (decs, body)
+-
+- | Singleton {dec, vars, line} =>
+- pass2Singleton (dec, vars, line)
+-
+- | _ => (* empty (we should check this!!!) *)
+- ();
++ | pass2Dec _ = raise InternalError "pass2Dec"
+ in
+- List.app pass2Dec strs (* Process all the top level entries. *)
+- end (* pass2Struct *);
+-
+- in (* Structures and types at the top level are free identifiers. *)
+- pass2Struct (strs, (* make free ids *) ref ~1, Env env, lineno lex, "")
+- end (*pass2Structs *);
+-
+- (* When we have done all the unification we can we need to check all
+- the values for free type variables. The arguments to this function
+- are functions which yield all the values, structures and functors
+- in the top-level environment. *)
+- fun checkForFreeTypeVars(applyVal, applyStruct, applyFunc, lex : lexan) =
+- let
++ List.app pass2Dec strs (* Process all the top level entries. *)
++ end (* pass2Struct *)
++
++
++ fun pass2Structs ((strs, _): program, lex : lexan, Env globals : env) : unit =
++ let
++ (* Create a local environment to capture declarations.
++ We don't want to add them to the global environment at this point. *)
++ val newValEnv = UTILITIES.searchList()
++ and newTypeEnv = UTILITIES.searchList()
++ and newStrEnv = UTILITIES.searchList()
++ and newSigEnv = UTILITIES.searchList()
++ and newFuncEnv = UTILITIES.searchList()
++
++ val lookupVal =
++ lookupDefault (#lookup newValEnv) (#lookupVal globals)
++ and lookupType =
++ lookupDefault (#lookup newTypeEnv) (#lookupType globals)
++ and lookupStruct =
++ lookupDefault (#lookup newStrEnv) (#lookupStruct globals)
++ and lookupSig =
++ lookupDefault (#lookup newSigEnv) (#lookupSig globals)
++ and lookupFunct =
++ lookupDefault (#lookup newFuncEnv) (#lookupFunct globals)
++
++ val env =
++ {
++ lookupVal = lookupVal,
++ lookupType = lookupType,
++ lookupFix = #lookupFix globals,
++ lookupStruct = lookupStruct,
++ lookupSig = lookupSig,
++ lookupFunct = lookupFunct,
++ enterVal = #enter newValEnv,
++ enterType = #enter newTypeEnv,
++ enterFix = fn _ => (), (* ?? Already entered by the parser. *)
++ enterStruct = #enter newStrEnv,
++ enterSig = #enter newSigEnv,
++ enterFunct = #enter newFuncEnv
++ };
++
++ (* Check for free type-variables. *)
+ (* Check the type of a value. *)
+- fun checkValue(name: string, v: values) =
+- checkForFreeTypeVariables(name, valTypeOf v, lex)
++ fun checkValueForFreeTypeVariables(name: string, v: values) =
++ checkForFreeTypeVariables(name, valTypeOf v, lex, codeForUniqueId)
+
+ (* Find all the values in the structure. *)
+- fun checkStruct(name: string, s: signatures) =
++ fun checkStructSigForFreeTypeVariables(name: string, s: signatures) =
+ let
+ fun checkEntry(dName: string, dVal: universal, ()) =
+ if tagIs structVar dVal
+- then checkStruct(name ^ dName ^ ".",
++ then checkStructSigForFreeTypeVariables(name ^ dName ^ ".",
+ structSignat((tagProject structVar) dVal))
+ else if tagIs valueVar dVal
+- then checkValue(name ^ dName, (tagProject valueVar) dVal)
++ then checkValueForFreeTypeVariables(name ^ dName, (tagProject valueVar) dVal)
+ else ()
+ in
+ univFold(sigTab s, checkEntry, ())
+ end
+- in
+- applyVal(fn (s: string, v: values) => checkValue(s, v));
+- applyStruct(
+- fn (n: string, s: structVals) =>
+- checkStruct(n^".", structSignat s));
+- (* Look at the result signature of the functor. *)
+- applyFunc(
+- fn (n: string, f: functors) => checkStruct(n^"().", functorResult f))
+- end;
+
++ (* Create the free identifiers. These are initially Bound but are replaced
++ by Free after the code has been executed and we have the values for the
++ printer and equality functions. They are only actually created in
++ strdecs but functor or signature topdecs in the same program could
++ refer to them. *)
++ local
++ val typeIds = ref []
++ in
++ fun topLevelId(isVar, eq, isdt, description) =
++ let
++ val idNumber = topLevelIdNumber()
++ val newId =
++ (if isVar then makeBoundIdWithEqUpdate else makeBoundId)
++ (Local{addr = ref 0, level = ref 0}, idNumber, eq, isdt, description)
++ in
++ typeIds := newId :: ! typeIds;
++ newId
++ end
++
++ and topLevelIdNumber() = List.length(!typeIds)
++
++ and makeTopLevelIdEnv() =
++ (* When we process a topdec we create a top-level ID environment which
++ matches any ID numbers we've already created in this "program" to the
++ actual ID. Generally this will be empty. *)
++ let
++ val typeVec = Vector.fromList(List.rev(!typeIds))
++ in
++ fn n => Vector.sub(typeVec, n)
++ end
++ end
++
++ fun pass2TopDec (StrDec(str, typeIds)) =
++ let
++ (* Remember the top-level Ids created in this strdec. *)
++ fun makeId(isVar, eq, isdt, desc) =
++ let
++ val newId = topLevelId(isVar, eq, isdt, desc)
++ in
++ typeIds := newId :: ! typeIds;
++ newId
++ end
++ in
++ (* strdec: structure or core-language topdec. *)
++ pass2Struct([str], makeId, topLevelIdNumber, makeTopLevelIdEnv, Env env, lex, location lex, "");
++ (* Check for free type variables. We have to do this after unification
++ within the strdec because later declarations may freeze earlier but
++ we must do this for each topdec. Otherwise it's possible to associate
++ a global ref with a functor argument and break the type system. *)
++ if errorOccurred lex then ()
++ else
++ (
++ #apply newValEnv
++ (fn (s: string, v: values) => checkValueForFreeTypeVariables(s, v));
++ #apply newStrEnv (
++ fn (n: string, s: structVals) =>
++ checkStructSigForFreeTypeVariables(n^".", structSignat s))
++ )
++ end
++
++ | pass2TopDec(topdec as FunctorDec (structList : functorBind list, lno)) =
++ let
++ (* There is a restriction that the same name may not be bound twice.
++ As with other bindings functor bindings happen in parallel.
++ DCJM 6/1/00. *)
++ val sEnv = (* The new names. *)
++ noDuplicates
++ (fn (name, _, _) =>
++ errorNear(lex, true, fn n => displayTopDec(topdec, n), lno,
++ "Functor " ^ name ^ " has already been bound in this declaration")
++ );
++
++ val startTopLevelIDs = topLevelIdNumber()
++ and topLevelEnv = makeTopLevelIdEnv()
++
++ (* Put the new names into this environment. *)
++ fun pass2FunctorBind
++ {name,
++ arg = {name = argName, sigStruct = argSig, valRef = argVal},
++ body, valRef, resIds, line, ...} =
++ let
++ (* When we apply a functor we share type IDs with the argument if they
++ have an ID less than sigMinTypes for the result signature and treat
++ other IDs as generative. If we don't have an explicit result
++ signature or if we have a transparent signature the type IDs in the
++ result are those returned from the body. To keep the argument IDs
++ separate from newly created IDs we start creating local IDs with
++ offsets after the args. *)
++ val typeStamps = ref startTopLevelIDs;
++ val localStamps = ref []
++
++ val argumentSignature =
++ sigVal (argSig, startTopLevelIDs, topLevelEnv, Env env, lex, line)
++
++ val resArg = makeLocalStruct (argName, argumentSignature, [DeclaredAt line]);
++
++ (* sigVal will have numbered the bound IDs to start at startTopLevelIDs. We
++ need to enter these bound IDs into the local environment but as Selected entries. *)
++ local
++ fun mkId(Bound{ eqType, isDatatype, access = Formal addr, offset,
++ description={ location, name, description }, ...}) =
++ Bound { offset = offset, eqType = eqType, isDatatype = isDatatype,
++ description =
++ {
++ location=location,
++ (* Add the structure name to the argument type IDs. *)
++ name=if argName = "" then name else argName^"."^name,
++ description=description
++ },
++ access = makeSelected(addr, resArg) }
++ | mkId _ = raise InternalError "mkId: Not Bound or not Formal"
++ in
++ (* argIDVector is part of the environment now. *)
++ val argIDVector = Vector.fromList(List.map mkId (sigBoundIds argumentSignature))
++ val () = typeStamps := !typeStamps + List.length(sigBoundIds argumentSignature)
++ end
++
++ val startBodyIDs = ! typeStamps; (* After the arguments. *)
++
++ local
++ (* We also have to apply the above map to the signature. Structures may not
++ have Formal entries for their type IDs so we must map them to the
++ Selected items. Actually, there's a nasty sort of circularity here;
++ we'd like the Selected entries to use structArg as the base but we
++ can't create it until we have its signature...which uses structArg. *)
++ val argSigWithSelected =
++ let
++ val Signatures { tab, name, declaredAt, typeIdMap, ...} = argumentSignature
++ fun mapToSelected n =
++ if n < startTopLevelIDs then topLevelEnv n
++ else Vector.sub(argIDVector, n-startTopLevelIDs)
++ in
++ makeSignature(name, tab, startBodyIDs, startBodyIDs, declaredAt,
++ composeMaps(typeIdMap, mapToSelected), [])
++ end
++ in
++ val argEnv = makeEnv (makeSignatureTable()); (* Local name space. *)
++
++ (* We may either have a single named structure in which case that is the argument or
++ effectively a sig...end block in which case we have to open a dummy structure. *)
++ val () =
++ if argName <> ""
++ then (* Named structure. *)
++ let
++ val structArg =
++ Struct { name = argName, signat = argSigWithSelected, access = structAccess resArg,
++ locations=structLocations resArg }
++ in
++ #enterStruct argEnv (argName, structArg)
++ end
++ else (* Open the dummy argument. Similar to "open" in treestruct. *)
++ COPIER.openSignature
++ (argSigWithSelected,
++ {
++ enterType =
++ fn (s,v) => #enterType argEnv (s, v),
++ enterStruct =
++ fn (name, strVal) =>
++ #enterStruct argEnv (name, makeSelectedStruct (strVal, resArg, [])),
++ enterVal =
++ fn (name, value) =>
++ #enterVal argEnv (name, mkSelectedVar (value, resArg, []))
++ },
++ "")
++ end
++
++ val () = argVal := resArg;
++
++ (* Now process the body of the functor using the environment of
++ the arguments to the functor and the global environment. *)
++ val envWithArgs =
++ {
++ lookupVal =
++ lookupDefault (#lookupVal argEnv) (#lookupVal env),
++ lookupType =
++ lookupDefault (#lookupType argEnv) (#lookupType env),
++ lookupFix = #lookupFix env,
++ lookupStruct =
++ lookupDefault (#lookupStruct argEnv) (#lookupStruct env),
++ lookupSig = #lookupSig env,
++ lookupFunct = #lookupFunct env,
++ enterVal = #enterVal env,
++ enterType = #enterType env,
++ enterFix = fn _ => (),
++ enterStruct = #enterStruct env,
++ enterSig = #enterSig env,
++ enterFunct = #enterFunct env
++ };
++
++ local
++ (* Create local IDs for any datatypes declared in the body or any generative
++ functor applications. *)
++ fun newTypeId(isVar, eq, isdt, desc) =
++ let
++ val n = !typeStamps
++ val () = typeStamps := n + 1;
++ val newId =
++ (if isVar then makeBoundIdWithEqUpdate else makeBoundId)
++ (Local{addr = ref 0, level = ref 0}, n, eq, isdt, desc)
++ in
++ localStamps := newId :: !localStamps;
++ newId
++ end
++
++ fun typeIdEnv () =
++ let
++ val localIds = Vector.fromList(List.rev(! localStamps))
++ in
++ fn n =>
++ if n < startTopLevelIDs
++ then topLevelEnv n
++ else if n < startBodyIDs
++ then Vector.sub(argIDVector, n-sigMinTypes argumentSignature)
++ else Vector.sub(localIds, n-startBodyIDs)
++ end
++ in
++ val resSig =
++ structValue(body, newTypeId, fn () => !typeStamps, typeIdEnv,
++ Env envWithArgs, lex, line, "")
++ val () =
++ if errorOccurred lex then ()
++ else checkStructSigForFreeTypeVariables(name^"().", resSig)
++ (* This counts as a reference. *)
++ val () = markValsAsExported resSig
++ end;
++
++ local
++ val startRunTimeOffsets = getNextRuntimeOffset resSig
++
++ fun convertId(n, id as Bound { offset, description, isDatatype, ...}) =
++ (* Either inherited from the argument or a new type ID. *)
++ makeBoundId (Formal(n + startRunTimeOffsets), offset, isEquality id, isDatatype, description)
++ | convertId (_, id) = id (* Free or TypeFunction. *)
++
++ val localVector = Vector.fromList(List.rev(!localStamps))
++ val bodyVec = Vector.mapi convertId localVector
++
++ val Signatures { name, tab, typeIdMap, declaredAt, ...} = resSig
++ (* These local IDs are included in the bound ID range for the result
++ signature. Since they were created in the functor new instances
++ will be generated when the functor is applied. *)
++ val newBoundIds = Vector.foldr (op ::) [] bodyVec
++
++ (* Record the ID map for code-generation. *)
++ val () =
++ resIds :=
++ Vector.foldri(fn (n, b, r) => { source=b, dest=Vector.sub(bodyVec, n)} :: r) [] localVector
++
++ fun resTypeMap n =
++ if n < startTopLevelIDs
++ then topLevelEnv n
++ else if n < startBodyIDs
++ then Vector.sub(argIDVector, n-sigMinTypes argumentSignature)
++ else Vector.sub(bodyVec, n-startBodyIDs)
++ in
++ val functorSig =
++ makeSignature(name, tab, startBodyIDs, startBodyIDs+Vector.length bodyVec,
++ declaredAt, composeMaps(typeIdMap, resTypeMap), newBoundIds)
++ end
++
++ (* Now make a local functor variable and put it in the
++ name space. Because functors can only be declared at
++ the top level the only way it can be used is if we have
++ functor F(..) = ... functor G() = ..F.. with no semicolon
++ between them. They will then be taken as a single
++ declaration and F will be picked up as a local. *)
++ (* Set the size of the type map. *)
++ val var = makeFunctor (name, resArg, functorSig, makeLocal (), line);
++ in
++ #enter sEnv (name, var);
++ valRef := var
++ end
++ in
++ (* Each element in the list is a functor binding. *)
++ List.app pass2FunctorBind structList;
++ (* Put them into the enclosing env. *)
++ #apply sEnv (#enterFunct env)
++ end (* FunctorDec *)
++
++ | pass2TopDec(topdec as SignatureDec (structList : sigBind list, lno)) =
++ let
++ (* There is a restriction that the same name may not be bound twice.
++ As with other bindings functor bindings happen in parallel.
++ DCJM 6/1/00. *)
++ val sEnv = (* The new names. *)
++ noDuplicates
++ (fn (name, _, _) =>
++ errorNear (lex, true, fn n => displayTopDec(topdec, n), lno,
++ "Signature " ^ name ^ " has already been bound in this declaration")
++ );
++
++ val startTopLevelIDs = topLevelIdNumber()
++ and topLevelEnv = makeTopLevelIdEnv()
++
++ fun pass2SignatureBind ({name, sigStruct, line, sigRef, ...}) =
++ let (* Each element in the list is a signature binding. *)
++ val Signatures { tab, typeIdMap, minTypes, maxTypes, boundIds, ...} =
++ sigVal (sigStruct, startTopLevelIDs, topLevelEnv, Env env, lex, line)
++ val namedSig = (* Put in the signature name. *)
++ makeSignature(name, tab, minTypes, maxTypes, line, typeIdMap, boundIds)
++ in
++ sigRef := namedSig; (* Remember for pass4. *)
++ #enter sEnv (name, namedSig)
++ end
++ in
++ List.app pass2SignatureBind structList;
++ (* Put them into the enclosing env. *)
++ #apply sEnv (#enterSig env)
++ end
++ in
++ List.app pass2TopDec strs;
++ (* Mark any exported values as referenced. *)
++ #apply newValEnv
++ (fn (s: string, _: values) =>
++ (
++ (* If we have exported the value we need to mark it as a
++ reference. But if the identifier has been rebound we
++ only want to mark the last reference. Looking the
++ identifier up will return only the last reference. *)
++ case #lookup newValEnv s of
++ SOME(Value { references=SOME{exportedRef, ...}, ...}) =>
++ exportedRef := true
++ | _ => ()
++ )
++ )
++ end (*pass2Structs *);
++
++
++
+
+
+ (* *
+ * Code-generation phase. *
+ * *)
+
+-
+ (* Generate code from the expressions and arrange to return the results
+ so that "pass4" can find them. *)
+- fun gencodeStructs (strs, lex) =
+- let
++ fun gencodeStructs ((strs, _), lex) =
++ let
++ val debugging = getParameter debugTag (debugParams lex)
++
+ (* Each top level declaration is assigned a distinct address. *)
+ val addresses = ref 1;
+ fun mkAddr () =
+@@ -3358,7 +2123,7 @@
+ This now threads the debugging environment through the functions so
+ the name is no longer really appropriate. DCJM 23/2/01. *)
+ fun mapPair
+- (f: 'a * debugenv -> {code: codetree list, load: codetree list, debug: debugenv})
++ (_: 'a * debugenv -> {code: codetree list, load: codetree list, debug: debugenv})
+ [] debug =
+ {
+ code = [],
+@@ -3380,348 +2145,351 @@
+ }
+ end;
+
+- (* Code-generate a structure value, and return the result
+- after matching it to the required signature. *)
+- fun structureCode (str, resultSig, strName, debugEnv) =
++ fun matchStructure (code : codetree, source : univTable, sourceIds: int*bool->valAccess, dest : signatures) =
+ let
+- (* Generate a new structure which will match the given signature.
+- A structure is represented by a vector of entries, and its
+- signature is a map which gives the offset in the vector of
+- each value. When we match a signature the candidate structure
+- will in general not have its entries in the same positions as
+- the target. We have to construct a new structure from it with
+- the entries in the correct positions. In most cases the optimiser
+- will simplify this code considerably so there is no harm in using
+- a general mechanism. *)
+- fun matchStructure (code : codetree, source : signatures, dest : signatures) =
+- ( let
+- val decs = multipleUses (code, mkAddr, !level);
+- val load = #load decs (!level); (* All local *)
++ (* Generate a new structure which will match the given signature.
++ A structure is represented by a vector of entries, and its
++ signature is a map which gives the offset in the vector of
++ each value. When we match a signature the candidate structure
++ will in general not have its entries in the same positions as
++ the target. We have to construct a new structure from it with
++ the entries in the correct positions. In most cases the optimiser
++ will simplify this code considerably so there is no harm in using
++ a general mechanism. Nevertheless, we check for the case when
++ we are building a structure which is a direct copy of the original
++ and use the original code if possible. *)
++ fun matchSubStructure (code, source, sourceIds, dest) =
++ let
++ val decs = multipleUses (code, mkAddr, !level);
++ val load = #load decs (!level); (* All local *)
+
+- (* To save taking apart a structure and then rebuilding it, if the
+- structure has not changed we just copy it. *)
+- val useOriginal = ref true;
++ (* To save taking apart a structure and then rebuilding it, if the
++ structure has not changed we just copy it. *)
++ val useOriginal = ref true;
+
+- (* We put the entries into this vector and then flatten it. *)
+- val resVec = STRETCHARRAY.stretchArray (10 (* Guess *), CodeZero);
+- val maxEntry = ref 0;
++ (* We put the entries into this vector and then flatten it. *)
++ val resVec = StretchArray.stretchArray (10 (* Guess *), NONE);
++ val maxEntry = ref 0;
+
+- fun addToList code addr =
++ fun addToList code addr =
+ (
+- STRETCHARRAY.update (resVec, addr, code);
+- (* SPF 7/6/94 fixed off-by-one *)
+- if addr >= !maxEntry then maxEntry := addr + 1 else ()
++ case StretchArray.sub(resVec, addr) of
++ NONE => StretchArray.update (resVec, addr, SOME code)
++ | SOME _ => raise InternalError ("addToList: Duplicate entry " ^ Int.toString addr ^ "\n");
++ if addr >= !maxEntry then maxEntry := addr + 1 else ()
+ );
+
+- val U : unit = (* Structures. *)
+- univFold
+- (sigTab dest,
+- (fn (dName, dVal, ()) =>
+- if tagIs structVar dVal
+- then let
+- val dval = tagProject structVar dVal;
++ fun foldEntry(dName, dVal, ()) =
++ if tagIs structVar dVal (* Structures. *)
++ then
++ let
++ val dval = tagProject structVar dVal;
+ in
+- if isFormal (structAccess dval)
+- then let
+- val destAddr = vaFormal (structAccess dval);
+- val sourceStruct =
+- valOf(univLookup (sigTab source, structVar, dName));
+-
+- val access = structAccess sourceStruct;
+- (* Since these have come from a signature we might expect all
+- the entries to be "formal". However if the structure is
+- global the entries in the signature may be global, and if
+- the structure is in a "struct .. end" it may be local. *)
+- val code =
+- if isFormal access
+- then let (* select from the code. *)
+- val U : unit =
+- if vaFormal access <> destAddr
+- then useOriginal := false
+- else ()
+- in
+- mkInd (vaFormal access, load)
+- end
+- else let
+- val U : unit = useOriginal := false;
+- in
+- codeStruct (sourceStruct, !level)
+- end;
+-
+- val matched =
+- matchStructure
+- (code,
+- structSignat sourceStruct,
+- structSignat dval);
+-
+- val U : unit =
+- if not (#unchanged matched)
+- then useOriginal := false
+- else ();
+- in
+- addToList (#code matched) destAddr
+- end
+- else ()
++ if isFormal (structAccess dval)
++ then
++ let
++ val destAddr = vaFormal (structAccess dval);
++ val sourceStruct =
++ valOf(univLookup (source, structVar, dName));
++
++ val access = structAccess sourceStruct;
++ (* Since these have come from a signature we might expect all
++ the entries to be "formal". However if the structure is
++ global the entries in the signature may be global, and if
++ the structure is in a "struct .. end" it may be local. *)
++ val code =
++ if isFormal access
++ then
++ let (* select from the code. *)
++ val () =
++ if vaFormal access <> destAddr
++ then useOriginal := false
++ else ()
++ in
++ mkInd (vaFormal access, load)
++ end
++ else
++ (
++ useOriginal := false;
++ codeStruct (sourceStruct, !level)
++ );
++ val sourceSig = structSignat sourceStruct
++ val (matched, unchanged) =
++ matchSubStructure (code, sigTab sourceSig, NONE, structSignat dval);
++
++ val () = if not unchanged then useOriginal := false else ();
++ in
++ addToList matched destAddr
++ end
++ else ()
+ end
+
+ else if tagIs valueVar dVal
+- then let (* values. *)
+- val dval = tagProject valueVar dVal;
++ then
++ let (* values. *)
++ val dval = tagProject valueVar dVal;
+ in
+- case dval of
+- Value{access=Formal addr, ...} =>
+- let
+- val sourceVal =
+- valOf(univLookup (sigTab source, valueVar, dName));
+-
+- (* If we have an exception matching a value we have to
+- generate a packet or a function yielding a packet. *)
+- val excBecomesVal =
+- case (dval, sourceVal) of
+- (Value{class=SimpleValue, ...}, Value{class=Exception, ...}) =>
+- true
+- | _ => false
+- (* Similarly, if we have a constructor which becomes a value we
+- have to extract the injection function or the value. *)
+- val constrBecomesVal =
+- case (dval, sourceVal) of
+- (Value{class=SimpleValue, ...}, Value{class=Constructor _, ...}) =>
+- true
+- | _ => false
+-
+- (* If the entry is from a signature select from the code. *)
+- val code =
+- case sourceVal of
+- Value{access=Formal svAddr, ...} =>
+- let
+- val UUU =
+- if svAddr <> addr orelse excBecomesVal orelse constrBecomesVal
+- then useOriginal := false
+- else ();
+- in
+- if excBecomesVal
+- then (* Have to make a packet or a function returning a packet. *)
+- if isEmpty (valTypeOf dval)
+- then
+- mkTuple [mkInd (svAddr, load), mkStr (valName dval), CodeZero]
+- else
+- mkProc
+- (mkTuple
+- [mkInd (svAddr, #load decs (!level + 1)),
+- mkStr (valName dval),
+- mkLoad (~1, 0)],
+- 1, 1, "")
+- else if constrBecomesVal
+- then mkInd(1, mkInd (svAddr, load))
+- else mkInd (svAddr, load)
+- end
+-
+- | _ =>
+- let
+- val UUU = useOriginal := false;
+- in
+- if excBecomesVal
+- then codeExFunction(sourceVal, !level, valTypeOf dval, lex, 0 (* line no *))
+- else let
+- val valu =
+- codeVal (sourceVal, !level, valTypeOf dval, lex, 0)
+- in
+- if constrBecomesVal
+- then mkInd(1, valu)
+- else valu
+- end
+- end;
+- in
+- addToList code addr
+- end
+- | _ => ()
+- end
+-
+- else if tagIs typeConstrVar dVal
+- then (* We need to process the value constructors. We may well process them
+- as values anyway but we don't always. *)
+- let
+- val tcons = tagProject typeConstrVar dVal;
+- val matchedType = valOf(univLookup (sigTab source, typeConstrVar, dName))
+-
+- fun processConstructor(Value{access=Formal dstAddr, ...},
+- Value{access=Formal svAddr, ...}) =
+- (* Selecting from a signature. *)
+- (
+- if svAddr <> dstAddr then useOriginal := false else ();
+- addToList (mkInd (svAddr, load)) dstAddr
+- )
+-
+- | processConstructor(Value{access=Formal dstAddr, typeOf, ...}, sourceVal) =
+- (* Any other source. *)
+- (
+- useOriginal := false;
+- addToList (codeVal (sourceVal, !level, typeOf, lex, 0)) dstAddr
+- )
+-
+- | processConstructor _ = ()
+- in
+- ListPair.app processConstructor (tcConstructors tcons, tcConstructors matchedType)
+- end
++ case dval of
++ Value{access=Formal addr, ...} =>
++ let
++ val sourceVal =
++ valOf(univLookup (source, valueVar, dName));
++
++ (* If we have an exception matching a value we have to
++ generate a packet or a function yielding a packet. *)
++ val excBecomesVal =
++ case (dval, sourceVal) of
++ (Value{class=SimpleValue, ...}, Value{class=Exception, ...}) =>
++ true
++ | _ => false
++ (* Similarly, if we have a constructor which becomes a value we
++ have to extract the injection function or the value. *)
++ val constrBecomesVal =
++ case (dval, sourceVal) of
++ (Value{class=SimpleValue, ...}, Value{class=Constructor _, ...}) =>
++ true
++ | _ => false
++
++ (* If the entry is from a signature select from the code. *)
++ val code =
++ case sourceVal of
++ Value{access=Formal svAddr, ...} =>
++ (
++ if svAddr <> addr orelse excBecomesVal orelse constrBecomesVal
++ then useOriginal := false
++ else ();
++ if excBecomesVal
++ then (* Have to make a packet or a function returning a packet. *)
++ if not (isSome(getFnArgType (valTypeOf dval)))
++ then
++ mkTuple [mkInd (svAddr, load), mkStr (valName dval), CodeZero]
++ else
++ mkProc
++ (mkTuple
++ [mkInd (svAddr, #load decs (!level + 1)),
++ mkStr (valName dval),
++ mkLoad (~1, 0)],
++ 1, 1, "")
++ else if constrBecomesVal
++ then mkInd(1, mkInd (svAddr, load))
++ else mkInd (svAddr, load)
++ )
++
++ | _ =>
++ (
++ useOriginal := false;
++ if excBecomesVal
++ then codeExFunction(sourceVal, !level, valTypeOf dval, lex, location nullLex)
++ else
++ let
++ val valu =
++ codeVal (sourceVal, !level, valTypeOf dval, lex, location nullLex)
++ in
++ if constrBecomesVal
++ then mkInd(1, valu)
++ else valu
++ end
++ );
++ in
++ addToList code addr
++ end
++ | _ => ()
++ end
+
+- else ()
+- ),
+- ()
+- );
+- in
+- (* If we have copied the original we can use it unchanged. *)
+- if !useOriginal
+- then
+- {
+- code = code,
+- unchanged = true
+- }
+- else (* Put the entries into a list for the vector. *)
+- let
+- val codeList =
+- List.tabulate (!maxEntry, fn i => STRETCHARRAY.sub (resVec,i))
+- in
+- {
+- code = mkEnv (#dec decs @ [mkTuple codeList]),
+- unchanged = false
+- }
+- end
++ else ()
++ in
++ (* Structures, values and datatypes. *)
++ univFold (sigTab dest, foldEntry, () );
++
++ (* Type Ids. Only at the top-level.*)
++ case sourceIds of
++ NONE => ()
++ | SOME sourceIds =>
++ let
++ (* Process the type IDs in the signature. We're only interested in typeIDs that are
++ marked as Formal because those are the only ones that need to be extracted from
++ the structure. *)
++ fun doTypeID (typeId as Bound{ access = Formal addr, ...}, n) =
++ let
++ (* Get the corresponding source ID. *)
++ val codedId = codeAccess(sourceIds(n, isEquality typeId), !level)
++ in
++ useOriginal := false;
++ addToList codedId addr;
++ n+1
++ end
++ | doTypeID _ = raise InternalError "doTypeID: Not Bound or not Formal"
++ in
++ List.foldl doTypeID 0 (sigBoundIds dest);
++ ()
++ end;
++
++ (* If we have copied the original we can use it unchanged. *)
++ if !useOriginal
++ then (code, true)
++ else (* Put the entries into a list for the vector. *)
++ let
++ val codeList =
++ List.tabulate (!maxEntry,
++ fn i => getOpt(StretchArray.sub (resVec,i), CodeZero))
++ in
++ (mkEnv (#dec decs @ [mkTuple codeList]), false)
++ end
+ end
+- );
+ in
+- case str of
+- FunctorAppl {name, arg, valRef} =>
++ #1 (matchSubStructure (code, source, SOME sourceIds, dest))
++ end
++
++ (* If we are declaring a structure with an opaque signature we need to create
++ the run-time IDs for newly generated IDs. *)
++ fun loadOpaqueIds opaqueIds =
++ let
++ fun decId { dest, source } =
+ let
+- val functs = !valRef;
+- val applyCode : codetree =
+- mkEval
+- (codeAccess (functorAccess functs, !level),
+- [structureCode (arg, structSignat (functorArg functs), strName, debugEnv)],
+- false);
++ val { addr=idAddr, level=idLevel } = vaLocal(idAccess dest)
++ val addr = mkAddr();
++ val () = idAddr := addr and () = idLevel := ! level;
++ val idCode = codeGenerativeId(source, isEquality dest, !level)
+ in
+- (* Evaluate the functor and match to the result. *)
+- #code (matchStructure (applyCode, functorResult functs, resultSig))
++ mkDec(addr, idCode)
+ end
++ in
++ List.map decId opaqueIds
++ end
+
+- | StructureIdent {valRef, ...} =>
+- let
+- val v = !valRef;
+- val valCode : codetree =
+- codeStruct (v, !level); (* Get the structure. *)
++ (* Code-generate a structure value. *)
++ fun structureCode (str, strName, debugEnv): { code: codetree list, load: codetree, ressig: signatures } =
++ case str of
++ FunctorAppl {arg, valRef = ref functs,
++ argIds=ref argIds, resIds=ref resIds, resultSig=ref resultSig, ...} =>
++ let
++ val {code = argCodeSource, load = argLoadSource, ressig = argCodeSig} =
++ structureCode (arg, strName, debugEnv)
++ (* Match the actual argument to the required arguments. *)
++ fun getMatchedId(n, isEq) =
++ let
++ val id = #source(List.nth (argIds, n))
++ in
++ case id of
++ TypeFunction _ => (* Have to generate a function here. *)
++ Global(codeGenerativeId(id, isEq, !level))
++ | _ => idAccess id
++ end
++ val argCode =
++ matchStructure(argLoadSource, sigTab argCodeSig, getMatchedId, structSignat (functorArg functs))
++
++ (* To produce the generative type IDs we need to save the result vector returned by the
++ functor application and then generate the new type IDs from the IDs in it. To make valid
++ source IDs we have to turn the Formal entries in the signature into Selected entries. *)
++ val resAddr = mkAddr()
++ local
++ val dummyResStruct = makeLocalStruct("", resultSig, []) (* Dummy structure. *)
++ val resl = vaLocal (structAccess dummyResStruct);
++ val () = #addr resl := resAddr;
++ val () = #level resl := !level
++ fun mkSelected {
++ source = Bound{offset = offset, eqType = eqType, access = Formal addr, description, isDatatype},
++ dest } =
++ { source = Bound { offset = offset, eqType = eqType, isDatatype = isDatatype,
++ access = makeSelected(addr, dummyResStruct), description = description },
++ dest = dest }
++ | mkSelected _ = raise InternalError "makeSelected: Not Bound or not Formal"
++ val resultIds = List.map mkSelected resIds
++ in
++ val loadIds = loadOpaqueIds resultIds
++ end
+ in
+- #code (matchStructure (valCode, structSignat v, resultSig))
++ (* Evaluate the functor. *)
++ {
++ code =
++ argCodeSource @
++ (mkDec(resAddr, mkEval (codeAccess (functorAccess functs, !level), [argCode], false)) ::
++ loadIds),
++ load = matchStructure(mkLoad(resAddr, 0), sigTab(functorResult functs), fn _ => raise Subscript, resultSig),
++ ressig = resultSig
++ }
+ end
+
+- | Localdec {decs, body = [localStr], ...} =>
++ | StructureIdent {valRef = ref v, ...} =>
++ { code = [], load = codeStruct (v, !level), ressig = structSignat v }
++
++ | Localdec {decs, body = [localStr], ...} =>
+ let (* let strdec in strexp end *)
+- (* Generate the declarations but throw away the loads. *)
+- (* TODO: Get the debug environment correct here. *)
+- val coded =
+- mapPair (fn (str, debug) => codeStrdecs (strName, str, debug))
+- decs debugEnv;
++ (* Generate the declarations but throw away the loads. *)
++ (* TODO: Get the debug environment correct here. *)
++ val coded =
++ mapPair (fn (str, debug) => codeStrdecs (strName, str, debug)) decs debugEnv;
++ val {code = bodyCode, load = bodyLoad, ressig = bodySig} =
++ structureCode (localStr, strName, #debug coded)
+ in
+- mkEnv (#code coded @
+- [structureCode (localStr, resultSig, strName, #debug coded)])
++ {
++ code = #code coded @ bodyCode,
++ load = bodyLoad,
++ ressig = bodySig
++ }
+ end
+
+- | StructDec {alist, value} =>
++ | StructDec {alist, value, resultSig=ref resultSig, ...} =>
+ let
+- val coded = mapStrdecs alist strName debugEnv;
++ val coded = mapStrdecs alist strName debugEnv;
++ (* We match to the dummy signature here. If there is a signature outside
++ we will match again. This results in double copying but that should
++ all be sorted out by the optimiser. *)
+ in
+ (* The result is a block containing the declarations and
+ code to load the results. *)
+- mkEnv (#code coded @
+- [#code (matchStructure (mkTuple (#load coded), value, resultSig))])
++ {
++ code = #code coded,
++ load = matchStructure (mkTuple (#load coded), value, fn _ => raise Subscript, resultSig),
++ ressig = resultSig
++ }
+ end
+
+- | SigConstraint { str, ... } => structureCode (str, resultSig, strName, debugEnv)
++ | SigConstraint { str, opaqueIds=ref opaqueIds, resultSig = ref resultSig, ... } =>
++ let
++ val {code = strCode, load = strLoad, ressig = strSig} = structureCode (str, strName, debugEnv)
++ val tempDecs = multipleUses (strLoad, mkAddr, !level);
++ val ids = loadOpaqueIds opaqueIds
++ in
++ {
++ code = strCode @ #dec tempDecs @ ids,
++ load = matchStructure (#load tempDecs (!level), sigTab strSig, fn _ => raise Subscript, resultSig),
++ ressig = resultSig
++ }
++ end
+
+- | _ =>
++ | _ =>
+ raise InternalError "structureCode: not a structure"
+- end (* structureCode *)
++ (* structureCode *)
+
+ (* We need to generate code for the declaration and then code to load
+ the results into a tuple. *)
+ and codeStrdecs (strName, str, debugEnv: debugenv):
+ { code: codetree list, load: codetree list, debug: debugenv} =
+- case str of
+- StructureDec (structList : structBind list) =>
+- let
+- fun codeStructureBind ({name, value, valRef, ...}: structBind, debug) =
+- let
+- (* Set the address of the variable representing this structure. *)
+- val addr = mkAddr();
+- val var = vaLocal (structAccess (!valRef));
+- val U : unit = #addr var := addr;
+- val U : unit = #level var := !level;
+- val sName = strName ^ name ^ "."
+- val strCode =
+- structureCode (value, structSignat (!valRef), sName, debug)
+- in (* Get the code and save the result in the variable. *)
+- {
+- code = [mkDec (addr, strCode)],
+- (* Load the variable. *)
+- load = [mkLoad (addr, 0)],
+- debug = debug (* We don't do structures at the moment. *)
+- }
+- end
+- in
+- (* Code-generate each declaration. *)
+- mapPair codeStructureBind structList debugEnv
+- end
+-
+- | FunctorDec (structList : functorBind list) =>
+- let
+- fun codeFunctorBind ({name, arg = FormalArg arg, body, valRef, ...}: functorBind,
+- debugEnv) =
++ case str of
++ StructureDec (structList : structBind list, _) =>
+ let
+- val {valRef = argVal, ...} = arg;
+-
+- (* Go down one level. *)
+- val U = level := !level + 1;
+-
+- (* Save the value and set to 1 *)
+- val addr = !addresses;
+- val U = addresses := 1;
+- val arg = vaLocal (structAccess (!argVal));
+- val U = #addr arg := ~1;
+- val U = #level arg := !level;
+- val func = !valRef;
+-
+- val name : string = strName ^ name;
+-
+- (* Process the body and make a procedure out of it. *)
+- val functorCode : codetree =
+- (if getParameter inlineFunctorsTag (debugParams lex) then mkMacroProc else mkProc)
+- (structureCode (body, functorResult func, name ^ "().", debugEnv),
+- !level, 1, name);
+-
+- (* Go back down a level and add 1 to address. *)
+- val U = level := !level - 1;
+- val U = addresses := addr + 1;
+-
+- (* Set the address of this variable. Because functors can only
+- be declared at the top level the only way it can be used is
+- if we have
+- functor F(..) = ... functor G() = ..F..
+- with no semicolon between them. They will then be taken as
+- a single declaration and F will be picked up as a local. *)
+- val var = vaLocal (functorAccess func);
+- val U = #addr var := addr;
+- val U = #level var := !level;
+- in
+- {
+- code = [mkDec (addr, functorCode)],
+- load = [mkLoad (addr, 0)], (* Load the variable. *)
+- debug = debugEnv
+- }
++ fun codeStructureBind ({name, value, valRef, ...}: structBind, debug) =
++ let
++ val sName = strName ^ name ^ "."
++ val {code = strCode, load = strLoad, ...} = structureCode (value, sName, debug)
++ val addr = mkAddr();
++ val var = vaLocal (structAccess (!valRef));
++ val () = #addr var := addr;
++ val () = #level var := !level;
++ in (* Get the code and save the result in the variable. *)
++ {
++ code = strCode @ [mkDec (addr, strLoad)],
++ (* Load the variable. *)
++ load = [mkLoad (addr, 0)],
++ debug = debug (* We don't do structures at the moment. *)
++ }
++ end
++ in
++ (* Code-generate each declaration. *)
++ mapPair codeStructureBind structList debugEnv
+ end
+- | codeFunctorBind _ =
+- raise InternalError "codeFunctorBind: not a FunctorBind"
+- in
+- mapPair codeFunctorBind structList debugEnv
+- end
+-
++
+ | Localdec {decs, body, ...} =>
+ let (* Accumulate the code from the declarations,
+ and the code to load the results. *)
+@@ -3731,26 +2499,32 @@
+ in (* Combine the lists. *)
+ {
+ code = #code codeDecs @ #code codeBody,
+- load = #load codeBody, (* Result is just the body. *)
++ load = #load codeBody, (* Result is the body. *)
+ debug = #debug codeBody (* TODO: This isn't correct. *)
+ }
+ end
+
+- | Singleton {dec, vars, line, ...} =>
++ | CoreLang {dec, vars=ref vars, ...} =>
+ let
+- (* Load each variable and exception that has been declared.
++ (* Code generate the declaration. This also assigns addresses so must be
++ done before we load the results. *)
++ val (code, newDebug) =
++ gencode (dec, lex, debugEnv, !level, addresses, strName)
++
++ (* Load each variable, exception and type ID (i.e. equality & print function)
++ that has been declared.
+ Since value declarations may be mutually recursive we have
+ to code-generate the declarations first then return the values. *)
+- fun filterVals (CoreValue v) = SOME(codeVal (v, !level, badType, nullLex, 0))
+- | filterVals _ = NONE
+- val (code, newDebug) =
+- gencode (dec, lex, debugEnv, !level, addresses, strName, line)
+- in
+- {
+- code = code,
+- load = List.mapPartial filterVals (!vars),
+- debug = newDebug
+- }
++ fun filterVals (CoreValue v) = SOME(codeVal (v, !level, badType, nullLex, location nullLex))
++ | filterVals (CoreStruct s) = SOME(codeStruct (s, !level))
++ | filterVals _ = NONE
++ val loadVals = List.mapPartial filterVals vars
++ in
++ {
++ code = code,
++ load = loadVals,
++ debug = newDebug
++ }
+ end
+
+ | _ => (* signature decs *)
+@@ -3765,8 +2539,110 @@
+ mapPair (fn (str, debug) => codeStrdecs (strName, str, debug))
+ strs debugEnv;
+
+- val coded = mapStrdecs strs "" ([], fn _ => CodeZero); (* Process top level list. *)
++ fun codeTopdecs (StrDec(str, ref typeIds), debugEnv) =
++ let
++ val { code, load, debug } = codeStrdecs("", str, debugEnv)
++ (* Load all the IDs created in this topdec even if they're not directly referenced. *)
++ fun loadIds id = codeId(id, !level)
++ in
++ { code = code, load = List.map loadIds typeIds @ load, debug = debug }
++ end
++
++ | codeTopdecs (FunctorDec (structList : functorBind list, _), debugEnv) =
++ let
++ fun codeFunctorBind ({name, arg = {valRef = ref argVal, ...}, body, valRef, resIds=ref resIds, ...}, debugEnv) =
++ let
++ (* Go up one level. *)
++ val () = level := !level + 1;
++
++ (* Save the value and set to 1 *)
++ val addr = !addresses;
++ val () = addresses := 1;
++ val arg = vaLocal (structAccess argVal);
++ val () = #addr arg := ~1;
++ val () = #level arg := !level;
++ val func = !valRef;
++
++ (* The debug environment has to contain at a minimum the type IDs from the arguments. *)
++ val (fBindDebugDecs, fBindDebugEnv) =
++ if not debugging then ([], debugEnv)
++ else
++ let
++ val argIds = sigBoundIds (structSignat argVal)
++
++ fun loadTypeId(id as Bound { access = Formal addr, ... }, (ctEnv, rtEnv)) =
++ let
++ (* This code will build a cons cell containing the run-time value
++ associated with the type Id as the hd and the rest of the run-time
++ environment as the tl. *)
++ val loadTypeId = mkInd(addr, mkLoad (~1, 0))
++ val newEnv = mkTuple [ loadTypeId, rtEnv(!level) ]
++ val { dec, load } = multipleUses (newEnv, mkAddr, !level)
++ in
++ (dec, (envTypeId id :: ctEnv, load))
++ end
++ | loadTypeId _ = raise InternalError "loadTypeId: Not bound"
++
++ fun foldIds(id::ids, inEnv) =
++ let
++ val (dec, outEnv) = loadTypeId(id, inEnv)
++ val (decs, newEnv) = foldIds(ids, outEnv)
++ in
++ (dec @ decs, newEnv)
++ end
++ | foldIds([], debugEnv) = ([], debugEnv)
++ in
++ foldIds(argIds, debugEnv)
++ end
++
++ (* Process the body and make a procedure out of it. *)
++ local
++ val {code = strCode, load = strLoad, ressig = strSig} = structureCode (body, name ^ "().", fBindDebugEnv)
++ fun getIds(n, isEq) =
++ let
++ val id = #source(List.nth(resIds, n))
++ in
++ case id of
++ TypeFunction _ => (* Have to generate a function here. *)
++ Global(codeGenerativeId(id, isEq, !level))
++ | _ => idAccess id
++ end
++ val matchedCode = matchStructure (strLoad, sigTab strSig, getIds, functorResult func)
++ in
++ val functorCode = (* The function that implements the functor. *)
++ (if getParameter inlineFunctorsTag (debugParams lex) then mkMacroProc else mkProc)
++ (mkEnv(fBindDebugDecs @ strCode @ [matchedCode]), !level, 1, name);
++ end
++
++ (* Go back down a level and add 1 to address. *)
++ val () = level := !level - 1;
++ val () = addresses := addr + 1;
++
++ (* Set the address of this variable. Because functors can only
++ be declared at the top level the only way it can be used is
++ if we have
++ functor F(..) = ... functor G() = ..F..
++ with no semicolon between them. They will then be taken as
++ a single declaration and F will be picked up as a local. *)
++ val var = vaLocal (functorAccess func);
++ val () = #addr var := addr;
++ val () = #level var := !level;
++ in
++ {
++ code = [mkDec (addr, functorCode)],
++ load = [mkLoad (addr, 0)], (* Load the variable. *)
++ debug = debugEnv
++ }
++ end
++ in
++ mapPair codeFunctorBind structList debugEnv
++ end
+
++ | codeTopdecs(SignatureDec _, debugEnv) = { code = [], load = [], debug = debugEnv }
++
++ val coded = (* Process top level list. *)
++ mapPair (fn (str, debug) => codeTopdecs (str, debug))
++ strs ([], fn _ => CodeZero)
+ in
+ (* The result is code for a vector containing the results of the
+ declarations which pass4 can use to pull out the values after
+@@ -3783,160 +2659,209 @@
+ (* This previously only processed declarations which required some code-generation and
+ evaluation (structures, values and functors). It now includes types, signatures and
+ fixity so that all declarations can be printed in the order of declaration. DCJM 6/6/02. *)
+- fun pass4Structs (results, strs) =
+- let
+- (* Process the datatypes in the structure and turn their value constructors
+- into Global entries. We only need this in order to be able to print values
+- of datatypes which have been produced in structures or functors with
+- opaque signatures. We could do this for other values as well but it's not
+- really necessary.
+- Because of sharing, value constructors from structures or functors
+- without opaque matching will already be global. *)
+- fun extractValsToSig (results: codetree, signat: signatures) =
+- univFold
+- (sigTab signat,
+- (fn (dName, dVal, ()) =>
+- if tagIs structVar dVal
+- then let (* Structures in the signature. *)
+- val subStr = tagProject structVar dVal;
+-
+- (* Process this signature. *)
+- val base =
+- case structAccess subStr of
+- Formal addr => mkInd (addr, results)
+- | Global code => code
+- | _ => raise InternalError "extractValsToSig: bad access";
+- in
+- (* We could create a global substructure here and enter it. *)
+- extractValsToSig (base, structSignat subStr)
+- end
+-
+-(* else if tagIs valueVar dVal
+- then let (* Values. *)
+- val v = tagProject valueVar dVal;
+- in
+- case v of
+- Value {name, typeOf, class, access = Formal addr } =>
+- let
+- val ind = mkInd (addr, results);
+- val globalVal =
+- Value{name=name, typeOf=typeOf, class=class, access=Global ind}
+- in
+- univEnter (sigTab signat, valueVar, dName, globalVal)
+- end
+- | _ => ()
+- end
+-*)
+- else if tagIs typeConstrVar dVal
+- then let (* Types. *)
+- val tcons = tagProject typeConstrVar dVal;
+- (* Update the constructor list. *)
+- fun copyAConstructor(Value{name=cName, typeOf, class, access = Formal addr}) =
+- Value{name=cName, typeOf=typeOf, class=class, access=Global(mkInd(addr, results))}
+- | copyAConstructor c = c (* Already a global. *)
+- in
+- tcSetConstructors(tcons, map copyAConstructor (tcConstructors tcons))
+- end
++ fun pass4Structs (results, (strs: topdec list, _)) =
++ let
++ fun extractStruct(str, mapTypeIds, args as (addr, { fixes, values, structures, signatures, functors, types } )) =
++ case str of
++ StructureDec (structList : structBind list, _) =>
++ let
++ fun extractStructureBind ({name, valRef, line, ...}: structBind, (addr, structures)) =
++ let
++ val structCode = mkInd (addr, results);
++ (* We need to replace type IDs with their Global versions. *)
++
++ local
++ val Signatures { name, declaredAt, typeIdMap, tab, ...} = structSignat (!valRef);
++ in
++ val resultSig =
++ makeSignature(name, tab, 0, 0, declaredAt, composeMaps(typeIdMap, mapTypeIds), [])
++ end
++ in
++ (* Make a global structure. *)
++ (addr + 1, (name, makeGlobalStruct (name, resultSig, structCode, line)) :: structures)
++ end
+
+- else () (* Anything else *)
+- ), (* end fn *)
+- ()
+- ) (* end extractValsToSig *);
+-
+- fun extractStruct(str, args as (addr, { fixes, values, structures, signatures, functors, types } )) =
+- case str of
+- FunctorDec (structList : functorBind list) =>
+- let
+- fun extractFunctorBind ({name, valRef, ...}: functorBind, (addr, funcs)) =
++ val (newAddr, newstructures) = List.foldl extractStructureBind (addr, structures) structList
++ in
++ (newAddr, { structures=newstructures, functors=functors, signatures=signatures,
++ fixes=fixes, values=values, types=types })
++ end
++
++ | Localdec {body, ...} =>
++ List.foldl (fn(s, a) => extractStruct(s, mapTypeIds, a))args body
++
++ (* Value, exception or type declaration at the top level. *)
++ | CoreLang {vars=ref vars, ...} =>
++ let (* Enter the values and exceptions. *)
++ (* Copy the types to replace the type IDs with the versions with Global access. *)
++ fun replaceTypes t =
+ let
+- val code = mkInd (addr, results);
+- val func = !valRef;
+- val funcTree =
+- makeFunctor
+- (functorName func,
+- functorArg func,
+- functorResult func,
+- makeGlobal code);
++ fun copyId(Bound{ offset, ...}) = SOME(mapTypeIds offset)
++ | copyId _ = NONE
++ fun replaceTypeConstrs tcon = copyTypeConstr (tcon, copyId, fn x => x, fn s => s)
+ in
+- (addr + 1, (name, funcTree) :: funcs)
++ copyType(t, fn tv=>tv, replaceTypeConstrs)
+ end
+- (* Get the functor values. *)
+- val (newAddr, newfunctors ) = List.foldl extractFunctorBind (addr, functors) structList
++
++ fun makeDecs (CoreValue(Value{class, name, typeOf, locations, access, ...}),
++ (addr, { fixes, values, structures, signatures, functors, types } )) =
++ let
++ (* Extract the value from the result vector except if we have a type-dependent
++ function e.g. PolyML.print where we must use the type-dependent version. *)
++ val newAccess =
++ case access of
++ Overloaded _ => access
++ | _ => Global(mkInd (addr, results))
++ (* Replace the typeIDs. *)
++ val newVal =
++ Value{class=class, name=name, typeOf=replaceTypes typeOf, access=newAccess,
++ locations=locations, references = NONE}
++ in
++ (addr+1, { fixes=fixes, values=(name, newVal) :: values, structures=structures,
++ signatures=signatures, functors=functors, types=types } )
++ end
++
++ | makeDecs (CoreStruct dec, (addr, {fixes, values, structures, signatures, functors, types})) =
++ (* If we open a structure we've created in the same "program" we may have a non-global
++ substructure. We have to process any structures. *)
++ let
++ val name = structName dec
++ val newStruct =
++ Struct { name = name, signat = structSignat dec,
++ access = Global(mkInd (addr, results)), locations = structLocations dec }
++ in
++ (addr+1, { fixes=fixes, values=values, structures=(name, newStruct) :: structures,
++ signatures=signatures, functors=functors, types=types } )
++ end
++
++ | makeDecs (CoreFix pair, (addr, {fixes, values, structures, signatures, functors, types})) =
++ (addr, { fixes=pair :: fixes, values=values, structures=structures,
++ signatures=signatures, functors=functors, types=types } )
++
++ | makeDecs (CoreType tc, (addr, {fixes, values, structures, signatures, functors, types})) =
++ let
++ val copiedTC = fullCopyDatatype(tc, mapTypeIds, "")
++ val newName = #second(splitString(tcName tc))
++ in
++ (addr, { fixes=fixes, values=values, structures=structures,
++ signatures=signatures, functors=functors, types=(newName, copiedTC) :: types } )
++ end
+ in
+- (newAddr, { functors=newfunctors, fixes=fixes, values=values,
+- signatures=signatures, structures=structures, types=types })
++ List.foldl makeDecs args vars
+ end
+-
+- | StructureDec (structList : structBind list) =>
++
++ | _ => raise InternalError "extractStruct"; (* end extractStruct *)
++
++ fun extractTopDec(str, (addr, env as { fixes, values, structures, signatures, functors, types }, nIds, mapPrevTypIds)) =
++ case str of
++ StrDec(str, ref typeIds) =>
+ let
+- fun extractStructureBind ({name, valRef, ...}: structBind, (addr, structures)) =
++ (* Create new Free IDs for top-level IDs. *)
++ fun loadId(Bound{eqType, description, ...}, (n, ids)) =
+ let
+- val resultSig = structSignat (!valRef);
+- val structCode = mkInd (addr, results)
++ val newId = makeFreeId(Global(mkInd(n, results)), pling eqType, description)
+ in
+- (* Convert the values to global. More importantly convert any datatypes
+- with non-global value constructors. *)
+- extractValsToSig (structCode, resultSig);
+- (* Make a global structure. *)
+- (addr + 1, (name, makeGlobalStruct (name, resultSig, structCode)) :: structures)
++ (n+1, newId :: ids)
+ end
+- val (newAddr, newstructures) = List.foldl extractStructureBind (addr, structures) structList
++ | loadId _ = raise InternalError "Not Bound"
++
++ (* Construct the IDs and reverse the list so the first ID is first*)
++ val (newAddr, mappedIds) = List.foldl loadId (addr, []) typeIds
++ val idMap = Vector.fromList mappedIds
++ fun mapTypeIds n =
++ if n < nIds then mapPrevTypIds n else Vector.sub(idMap, n-nIds)
++ val (resAddr, resEnv) = extractStruct (str, mapTypeIds, (newAddr, env))
+ in
+- (newAddr, { structures=newstructures, functors=functors, signatures=signatures,
+- fixes=fixes, values=values, types=types })
++ (resAddr, resEnv, nIds + Vector.length idMap, mapTypeIds)
+ end
+-
+- | Localdec {body, ...} =>
+- List.foldl extractStruct args body
+-
+- (* Value, exception or type declaration at the top level. *)
+- | Singleton {vars, ...} =>
+- let (* Enter the values and exceptions. *)
+- fun makeDecs (CoreValue dec, (addr, { fixes, values, structures, signatures, functors, types } )) =
+- ( case dec of
+- Value{access=Overloaded _, ...} => (* enter it as it is. *)
+- (addr+1, { fixes=fixes, values=(valName dec, dec) :: values, structures=structures,
+- signatures=signatures, functors=functors, types=types })
+- | Value{class, name, typeOf, ...} =>
+- (* take the value out of the result vector. *)
+- let
+- val codeVal = mkInd (addr, results);
+- val name = valName dec;
+- val val' =
+- Value{class=class, name=name, typeOf=typeOf, access=Global codeVal}
+- in
+- (addr+1, { fixes=fixes, values=(name, val') :: values, structures=structures,
+- signatures=signatures, functors=functors, types=types } )
+- end
+- )
+- | makeDecs (CoreStruct dec, (addr, {fixes, values, structures, signatures, functors, types})) =
+- (* Any structures will only come from "open A" where A contains
+- sub-structures. "A" must be global otherwise the open would
+- not be global, so all the sub-structures must be global. *)
+- (addr, { fixes=fixes, values=values, structures=(structName dec, dec) :: structures,
+- signatures=signatures, functors=functors, types=types } )
+- | makeDecs (CoreFix pair, (addr, {fixes, values, structures, signatures, functors, types})) =
+- (addr, { fixes=pair :: fixes, values=values, structures=structures,
+- signatures=signatures, functors=functors, types=types } )
+- | makeDecs (CoreType dec, (addr, {fixes, values, structures, signatures, functors, types})) =
+- (addr, { fixes=fixes, values=values, structures=structures,
+- signatures=signatures, functors=functors, types=(#second(splitString(tcName dec)), dec) :: types } )
++
++ | FunctorDec (structList : functorBind list, _) =>
++ let
++ (* Get the functor values. *)
++ fun extractFunctorBind ({name, valRef, ...}: functorBind, (addr, funcs)) =
++ let
++ val code = mkInd (addr, results);
++ val func = !valRef;
++ (* We need to convert any references to typeIDs created in strdecs in the
++ same "program". *)
++ (* The result signature shares with the argument so we only copy IDs less than
++ the min for the argument signature. *)
++
++ local
++ val fnArg = functorArg func
++ val fnArgSig = structSignat fnArg
++ val fnArgName = structName fnArg
++ val Signatures { name, tab, typeIdMap, boundIds, minTypes, maxTypes, declaredAt, ... } = fnArgSig
++ fun newMap n =
++ if n < minTypes
++ then mapPrevTypIds n
++ else List.nth(boundIds, n-minTypes)
++ in
++ val functorArgSig =
++ makeSignature(name, tab, minTypes, maxTypes, declaredAt, composeMaps(typeIdMap, newMap), boundIds)
++ val copiedArg =
++ Struct{name=fnArgName, signat=functorArgSig,
++ access=structAccess fnArg, locations=structLocations fnArg}
++ end
++ local
++ val Signatures { name, tab, typeIdMap, boundIds, minTypes, maxTypes, declaredAt, ... } =
++ functorResult func
++ val Signatures { boundIds=argBoundIds, minTypes=argMinTypes, ...} = functorArgSig
++ val fnArgName = structName(functorArg func)
++ fun newMap n =
++ if n >= minTypes
++ then List.nth(boundIds, n-minTypes)
++ else if n >= argMinTypes
++ then case List.nth(argBoundIds, n-argMinTypes) of
++ (* Add the argument structure name onto the name of type IDs in the argument. *)
++ Bound { access, offset, eqType, description={location, name, description}, isDatatype } =>
++ Bound { access=access, offset=offset, eqType=eqType, isDatatype = isDatatype,
++ description=
++ {
++ location=location, description=description,
++ name=if fnArgName = "" then name else fnArgName^"."^name
++ }
++ }
++ | _ => raise InternalError "Not bound"
++ else mapPrevTypIds n
++ in
++ val functorSigResult =
++ makeSignature(name, tab, minTypes, maxTypes, declaredAt, composeMaps(typeIdMap, newMap), boundIds)
++ end
++ val funcTree =
++ makeFunctor(functorName func, copiedArg, functorSigResult,
++ makeGlobal code, functorDeclaredAt func);
++ in
++ (addr + 1, (name, funcTree) :: funcs)
++ end
++ val (newAddr, newfunctors ) = List.foldl extractFunctorBind (addr, functors) structList
+ in
+- List.foldl makeDecs args (!vars)
++ (newAddr, { functors=newfunctors, fixes=fixes, values=values,
++ signatures=signatures, structures=structures, types=types }, nIds, mapPrevTypIds)
+ end
+
+- | SignatureDec (structList : sigBind list) =>
++ | SignatureDec (structList : sigBind list, _) =>
+ let
+- val newSigs = List.map (fn ({sigRef=ref s, name, ...}: sigBind) => (name, s)) structList
++ (* We need to convert any references to typeIDs created in strdecs in the same "program". *)
++ fun copySignature fnSig =
++ let
++ val Signatures { name, tab, typeIdMap, minTypes, maxTypes, boundIds, declaredAt, ... } = fnSig
++ fun mapIDs n =
++ if n < minTypes
++ then mapPrevTypIds n
++ else List.nth(boundIds, n-minTypes)
++ in
++ makeSignature(name, tab, minTypes, maxTypes, declaredAt, composeMaps(typeIdMap, mapIDs), boundIds)
++ end
++ val newSigs = List.map (fn ({sigRef=ref s, name, ...}: sigBind) => (name, copySignature s)) structList
+ in
+ (addr, { fixes=fixes, values=values, structures=structures,
+- signatures=newSigs @ signatures, functors=functors, types=types } )
++ signatures=newSigs @ signatures, functors=functors, types=types }, nIds, mapPrevTypIds)
+ end
+-
+- | _ => args; (* end extractStruct *)
+-
++
+ val empty = { fixes=[], values=[], structures=[], functors=[], types=[], signatures=[] }
+- val (lastAddr, result) = List.foldl extractStruct (0, empty) strs;
++
++ val (_, result, _, _) = List.foldl extractTopDec (0, empty, 0, fn _ => raise Subscript) strs;
+ (* The entries in "result" are in reverse order of declaration and may contain duplicates.
+ We need to reverse and filter the lists so that we end up with the lists in order
+ and with duplicates removed. *)
+@@ -3952,4 +2877,33 @@
+ { fixes=revFilter [] (#fixes result), values=revFilter [] (#values result), structures=revFilter [] (#structures result),
+ functors=revFilter [] (#functors result), types=revFilter [] (#types result), signatures=revFilter [] (#signatures result) }
+ end (* pass4Structs *)
++
++ structure Sharing =
++ struct
++ type structs = structs
++ type structVals = structVals
++ type types = types
++ type parsetree = parsetree
++ type lexan = lexan
++ type pretty = pretty
++ type values = values
++ type typeConstrs = typeConstrs
++ type codetree = codetree
++ type signatures = signatures
++ type functors = functors
++ type env = env
++ type sigBind = sigBind
++ and functorBind = functorBind
++ and structBind = structBind
++ type machineWord = machineWord
++ type fixStatus = fixStatus
++ type topdec = topdec
++ type program = program
++ type typeParsetree = typeParsetree
++ type formalArgStruct= formalArgStruct
++ type ptProperties = ptProperties
++ type structSigBind = structSigBind
++ type typeVarForm = typeVarForm
++ type sigs = sigs
++ end
+ end;
+Only in mlsource/MLCompiler: STRUCTVALSIG.sml
+diff -u -r mlsource/MLCompiler/STRUCT_VALS.ML mlsource/MLCompiler/STRUCT_VALS.ML
+--- mlsource/MLCompiler/STRUCT_VALS.ML 2008-04-21 13:32:11.000000000 +0200
++++ mlsource/MLCompiler/STRUCT_VALS.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -38,24 +38,16 @@
+ sig
+ type codetree
+ val CodeZero : codetree
+-end;
+
+-(*****************************************************************************)
+-(* MISC *)
+-(*****************************************************************************)
+-structure MISC :
+-sig
+- exception InternalError of string;
+-end;
+-
+-(*****************************************************************************)
+-(* UNIVERSAL *)
+-(*****************************************************************************)
+-structure UNIVERSAL :
+-sig
+- type 'a tag
+-
+- val tag : unit -> 'a tag
++ (* Temporary additions. *)
++ type machineWord = Address.machineWord
++ val mkTuple: codetree list -> codetree;
++ val mkConst: machineWord -> codetree;
++ val mkEval: codetree * codetree list * bool -> codetree;
++ val mkInlproc: codetree * int * int * string -> codetree;
++ val mkLoad: int * int -> codetree;
++ val structureEq: machineWord * machineWord -> bool;
++ val genCode: codetree * Universal.universal list -> (unit -> codetree);
+ end;
+
+ (*****************************************************************************)
+@@ -63,7 +55,7 @@
+ (*****************************************************************************)
+ structure UNIVERSALTABLE :
+ sig
+- type 'a tag;
++ type 'a tag = 'a Universal.tag;
+ type univTable;
+
+ val makeUnivTable: unit -> univTable;
+@@ -74,532 +66,184 @@
+ val univFreeze: univTable -> univTable
+ end;
+
++structure PRETTY: PRETTYSIG (* Temporary addition. *)
+
+-(*****************************************************************************)
+-(* STRUCTVALS sharing constraints *)
+-(*****************************************************************************)
+-
+-sharing type
+- UNIVERSAL.tag
+-= UNIVERSALTABLE.tag
+-
+-) :
+-
+-(*****************************************************************************)
+-(* STRUCTVALS export signature *)
+-(*****************************************************************************)
+-sig
+- (* Structures *)
+- type signatures;
+- type codetree;
+- type typeId;
+- (* type identifiers. In the old (ML90) version these were used for
+- structures as well. *)
+-
+- val unsetId: typeId;
+- val isUnsetId: typeId -> bool;
+- val isFreeId: typeId -> bool;
+- val isBoundId: typeId -> bool;
+- val isVariableId: typeId -> bool;
+- val offsetId: typeId -> int;
+- val sameTypeId: typeId * typeId -> bool;
+- val unifyTypeIds: typeId * typeId -> bool;
+-
+- val makeFreeId: unit -> typeId;
+- val makeVariableId: unit -> typeId;
+- val makeBoundId: int -> typeId;
+-
+- (* Types *)
+-
+- datatype 'a possRef = FrozenRef of 'a | VariableRef of 'a ref
+- val pling: 'a possRef -> 'a
+- val updatePR: 'a possRef * 'a -> unit
+-
+- (* Standard type constructors. *)
+-
+- type typeVarForm;
+- type typeConstrs;
+-
+- (* A type is the union of these different cases. *)
+- datatype types =
+- TypeVar of typeVarForm
+-
+- | TypeConstruction of (* typeConstructionForm *)
+- {
+- name: string,
+- value: typeConstrs possRef,
+- args: types list
+- }
+-
+- | FunctionType of (* functionTypeForm *)
+- {
+- arg: types,
+- result: types
+- }
+-
+- | LabelledType of (* labelledRecForm *)
+- {
+- recList: { name: string, typeof: types } list,
+- frozen: bool,
+- genericInstance: typeVarForm list
+- }
+-
+- | OverloadSet of (* overloadSetForm *)
+- {
+- typeset: typeConstrs list
+- }
+-
+- | BadType
+-
+- | EmptyType
+-
+- and valAccess =
+- Global of codetree
+- | Local of { addr: int ref, level: int ref }
+- | Selected of { addr: int, base: structVals }
+- | Formal of int
+- | Overloaded of typeDependent (* Values only. *)
+-
+- (* Structures. *)
+- and structVals =
+- NoStruct
+- | Struct of
+- {
+- name: string,
+- signat: signatures,
+- access: valAccess
+- }
+-
+- (* Values. *)
+- and typeDependent =
+- Print
+- | PrintSpace
+- | MakeString
+- | MakeStringSpace
+- | InstallPP
+- | Equal
+- | NotEqual
+- | AddOverload
+- | TypeDep
+-
+- and values =
+- Value of {
+- name: string,
+- typeOf: types,
+- access: valAccess,
+- class: valueClass }
+-
+- (* Classes of values. *)
+- and valueClass =
+- SimpleValue
+- | Exception
+- | Constructor of { nullary: bool }
+- ;
+-
+-
+- val badType: types;
+- val emptyType: types;
+-
+- val isBad: types -> bool;
+- val isEmpty: types -> bool;
+-
+- val tcName: typeConstrs -> string;
+- val tcArity: typeConstrs -> int;
+- val tcTypeVars: typeConstrs -> types list;
+- val tcEquivalent: typeConstrs -> types;
+- val tcSetEquivalent: typeConstrs * types -> unit;
+- val tcConstructors: typeConstrs -> values list;
+- val tcSetConstructors: typeConstrs * values list -> unit;
+- val tcEquality: typeConstrs -> bool;
+- val tcSetEquality: typeConstrs * bool -> unit;
+- val tcIdentifier: typeConstrs -> typeId;
+- val tcLetDepth: typeConstrs -> int;
+-
+- (* These are all logically equivalent but include differing numbers of refs *)
+- val makeTypeConstrs:
+- string * types list * types * typeId * bool * int-> typeConstrs;
+- val makeFrozenTypeConstrs:
+- string * types list * types * typeId * bool * int-> typeConstrs;
+-
+- val tvLevel: typeVarForm -> int;
+- val tvEquality: typeVarForm -> bool;
+- val tvNonUnifiable: typeVarForm -> bool;
+- val tvWeak: typeVarForm -> bool;
+- val tvValue: typeVarForm -> types;
+- val tvSetValue: typeVarForm * types -> unit;
+-
+- val sameTv: typeVarForm * typeVarForm -> bool;
+-
+- val makeTv: types * int * bool * bool * bool -> typeVarForm;
+-
+- val generalisable: int;
+-
+- val boolType: typeConstrs;
+- val intType: typeConstrs;
+- val charType: typeConstrs; (* added 22/8/96 SPF *)
+- val stringType: typeConstrs;
+- val wordType: typeConstrs;
+- val realType: typeConstrs;
+- val refType: typeConstrs;
+- val unitType: typeConstrs;
+- val exnType: typeConstrs;
+- val listType: typeConstrs;
+- val undefType: typeConstrs;
+-
+- (* Access to values, structures etc. *)
+-
+- val isGlobal: valAccess -> bool;
+- val isLocal: valAccess -> bool;
+- val isSelected: valAccess -> bool;
+- val isFormal: valAccess -> bool;
+-
+- val makeGlobal: codetree -> valAccess;
+- val makeLocal: unit -> valAccess;
+- val makeSelected: int * structVals -> valAccess;
+- val makeFormal: int -> valAccess;
+-
+- val vaGlobal: valAccess -> codetree;
+- val vaFormal: valAccess -> int;
+- val vaLocal: valAccess -> { addr: int ref, level: int ref };
+- val vaSelected: valAccess -> { addr: int, base: structVals };
+-
+- val undefinedStruct: structVals;
+- val isUndefinedStruct: structVals -> bool;
+- val structSignat: structVals -> signatures;
+- val structName: structVals -> string;
+- val structAccess: structVals -> valAccess;
+-
+- val makeEmptyGlobal: string -> structVals;
+- val makeGlobalStruct: string * signatures * codetree -> structVals;
+- val makeLocalStruct: string * signatures -> structVals;
+- val makeFormalStruct: string * signatures * int -> structVals;
+-
+- val makeSelectedStruct: structVals * structVals -> structVals;
+-
+- (* Functors *)
+-
+- type functors;
+-
+- val undefinedFunctor: functors;
+- val isUndefinedFunctor: functors -> bool;
+- val functorName: functors -> string;
+- val functorArg: functors -> structVals;
+- val functorResult: functors -> signatures;
+- val functorAccess: functors -> valAccess;
+-
+- val makeFunctor: string * structVals * signatures * valAccess -> functors;
+-
+- (* Signatures *)
+-
+- type univTable;
+- val sigName: signatures -> string;
+- val sigTab: signatures -> univTable;
+- val sigMinTypes: signatures -> int;
+- val sigMaxTypes: signatures -> int;
+-
+- val makeSignatures: string -> signatures;
+- val makeCopy: string * signatures * int * int -> signatures;
+-
+- (* Values. *)
+- val valName: values -> string
+- val valTypeOf: values -> types
+- val undefinedValue: values;
+- val isUndefinedValue: values -> bool;
+- val isConstructor: values -> bool;
+- val isValueConstructor: values -> bool
+-
+- val makeGlobalV: string * types * codetree -> values;
+- val makeLocalV: string * types * int ref * int ref -> values;
+- val makeFormalV: string * types * int -> values;
+- val makeFormalEx: string * types * int -> values;
+- val makeOverloaded: string * types * typeDependent -> values;
+- val makeValueConstr: string * types * bool * valAccess -> values;
+-
+- (* Infix status *)
+-
+- datatype fixStatus =
+- Infix of int
+- | InfixR of int
+- | Nonfix;
+-
+- datatype env =
+- Env of
+- {
+- lookupVal: string -> values option,
+- lookupType: string -> typeConstrs option,
+- lookupFix: string -> fixStatus option,
+- lookupStruct: string -> structVals option,
+- lookupSig: string -> signatures option,
+- lookupFunct: string -> functors option,
+- enterVal: string * values -> unit,
+- enterType: string * typeConstrs -> unit,
+- enterFix: string * fixStatus -> unit,
+- enterStruct: string * structVals -> unit,
+- enterSig: string * signatures -> unit,
+- enterFunct: string * functors -> unit
+- };
+-
+- val makeEnv: signatures -> env;
+-
+- type 'a tag;
+-
+- val valueVar: values tag;
+- val typeConstrVar: typeConstrs tag;
+- val fixVar: fixStatus tag;
+- val structVar: structVals tag;
+- val signatureVar: signatures tag;
+- val functorVar: functors tag;
+-
+-end (* STRUCTVALS export signature *) =
++) :> STRUCTVALSIG where type codetree = CODETREE.codetree and type univTable = UNIVERSALTABLE.univTable
++=
+
+ (*****************************************************************************)
+ (* STRUCTVALS functor body *)
+ (*****************************************************************************)
+ struct
+- open CODETREE;
++ open CODETREE;
+
+- open MISC;
+- open UNIVERSAL;
+- open UNIVERSALTABLE;
+-
+- (* The idea of this is reduce the number of mutable objects. *)
+- datatype 'a possRef = FrozenRef of 'a | VariableRef of 'a ref
+- fun pling(FrozenRef x) = x | pling(VariableRef(ref x)) = x
+- fun updatePR(VariableRef r, x) = r := x | updatePR(FrozenRef _, _) = raise Fail "Assignment to frozen ref"
++ open Misc;
++ open Universal;
++ open UNIVERSALTABLE;
++
++ (* Location for declarations. *)
++ type location =
++ { file: string, startLine: int, startPosition: int, endLine: int, endPosition: int }
++
++ (* The idea of this is reduce the number of mutable objects. *)
++ datatype 'a possRef = FrozenRef of 'a | VariableRef of 'a ref
++ fun pling(FrozenRef x) = x | pling(VariableRef(ref x)) = x
++ fun updatePR(VariableRef r, x) = r := x | updatePR(FrozenRef _, _) = raise Fail "Assignment to frozen ref"
++
++ (* References to identifiers. exportedRef is set to true if the identifier is exported to
++ the global environment or to a structure. localRef contains the list of local uses.
++ This is an option type because this is used only within local identifiers. *)
++ type references = { exportedRef: bool ref, localRef: location list ref } option
++
++ fun makeRef(): references = SOME { exportedRef = ref false, localRef = ref nil }
++
++ (* typeIds are used to distinguish between concrete types. Two
++ types that share will have the same identifier. If the identifiers are
++ different they are different types.
++ There are three classes of type identifier. Free identifiers are used for
++ types in the global environment. Bound identifiers occur in signatures,
++ functors and while compiling structures. Type functions arise from
++ type bindings (type abbreviations) or from "where type" definitions
++ in signatures.
++ The type identifier also contains the equality attribute.
++ In ML97 only types have these identifiers. In ML90 these were also
++ needed for structures.
++ Free and Bound IDs contain information to find the equality and
++ value-printing functions. *)
++ type typeIdDescription = { location: location, name: string, description: string }
++ datatype typeId =
++ Free of
++ { access: valAccess, uid: uniqueId, allowUpdate: bool, description: typeIdDescription }
++ | Bound of
++ { access: valAccess, offset: int, eqType: bool possRef, isDatatype: bool, description: typeIdDescription }
++ | TypeFunction of typeVarForm list * types
++
++ (* A type is the union of these different cases. *)
++ and types =
++ TypeVar of typeVarForm
++ | TypeConstruction of typeConstructionForm
++ | FunctionType of functionTypeForm
++ | LabelledType of labelledRecForm
++ | OverloadSet of overloadSetForm
++ | BadType
++ | EmptyType
++
++ and typeConstrs =
++ TypeConstrs of
++ {
++ name: string,
++ arity: int,
++ typeVars: typeVarForm list,
++ constrs: values list possRef, (* List of value constructors. *)
++ identifier: typeId,
++ letDepth: int, (* Needed to check for local datatypes. *)
++ locations: locationProp list (* Location of declaration *)
++ }
+
+- abstype uniqueId = Unique of int ref
+- with
+- fun makeUnique () = Unique (ref 0); (* REF HOTSPOT - 400 *)
++ (* Access to a value, structure or functor. *)
++ and valAccess =
++ Global of codetree
++ | Local of { addr: int ref, level: int ref }
++ | Selected of { addr: int, base: structVals }
++ | Formal of int
++ | Overloaded of typeDependent (* Values only. *)
++
++ (* Structures. *)
++ and structVals =
++ NoStruct
++ | Struct of
++ {
++ name: string,
++ signat: signatures,
++ access: valAccess,
++ locations: locationProp list
++ }
+
+- fun sameUnique (Unique a, Unique b) = (a = b);
+- end;
+-
+- (* There are three classes of structure or type identifier. Variables occur
+- in signatures and can be assigned to other variables or constants by
+- sharing constraints or by signature matching. Free constants arise from
+- top level structures or types or those in top level structures. Bound
+- constants occur in the arguments to functors or in structures or types
+- constructed inside a functor (and therefore generated when the functor
+- is applied). *)
+-
+- abstype typeId =
+- Unset
+- | Free of uniqueId
+- | Bound of int
+- | Variable of typeId ref
+-
+- with
+- (* Variable stamps: can be set to other stamps whether variable or free. *)
+- val unsetId = Unset;
+-
+- fun makeFreeId () = Free (makeUnique ());
+-
+- val makeBoundId = Bound;
+-
+- fun makeVariableId () = Variable (ref Unset); (* REF HOTSPOT - 260 *)
+-
+- (* If it is a constant or an unset variable return it,
+- otherwise return the value the variable is bound to. *)
+-
+- fun realId id =
+- (
+- case id of
+- Variable (ref v) => (case v of Unset => id | _ => realId v)
+- | _ => id
+- );
+-
+- (* Unset variable. *)
+- fun isUnsetId Unset = true | isUnsetId _ = false;
+-
+- fun isVariableId x = case (realId x) of Variable _ => true | _ => false;
+- fun isFreeId x = case (realId x) of Free _ => true | _ => false;
+- fun isBoundId x = case (realId x) of Bound _ => true | _ => false;
+-
+- (* Find the number - assuming it is bound. *)
+- fun offsetId x =
+- case (realId x) of
+- Bound i => i
+- | _ => raise InternalError "offsetId: not a Bound";
+-
+- (* Are two type constructors the same. *)
+- fun sameTypeId (cons1, cons2) =
+- let
+- val id1 = realId cons1;
+- val id2 = realId cons2;
+- in
+- case (id1, id2) of
+- (Variable a, Variable b) => (a = b)
+- | (Free a, Free b) => sameUnique (a, b)
+- | (Bound a, Bound b) => (a = b)
+- | _ => false
+- end;
+-
+- (* Do the unification and return whether they are equal. *)
+- fun unifyTypeIds (x, y) : bool =
+- let
+- val x1 = realId x;
+- val y1 = realId y;
+- in
+- case (x1, y1) of
+- (Bound a, Bound b) =>
+- a = b
+-
+- | (Free a, Free b) =>
+- sameUnique (a, b)
+-
+- | (Variable x2, Variable y2) =>
+- x2 = y2 orelse (x2 := y1; true)
+-
+- | (Variable x2, _) =>
+- (x2 := y1; true)
+-
+- | (_, Variable y2) =>
+- (y2 := x1; true)
+-
+- | _ =>
+- false
+- end;
+- end; (* typeId abstype *)
+-
+-
+- (* Used for both signatures of local structures and for global structures
+- (name spaces). Strictly signatures do not contain fix-status functors
+- or signatures but as we use these structures for top-level name-spaces
+- we have to have tables for these. *)
+- abstype signatures =
+- Signatures of
+- {
+- name: string,
+- tab: univTable,
+- minTypes: int,
+- maxTypes: int
+- }
+- with
+- fun sigName (Signatures {name,...}) = name;
+- fun sigTab (Signatures {tab,...}) = tab;
+- fun sigMinTypes (Signatures {minTypes,...}) = minTypes;
+- fun sigMaxTypes (Signatures {maxTypes,...}) = maxTypes;
+-
+- fun makeSignatures name =
+- Signatures { name = name,
+- tab = makeUnivTable(),
+- minTypes = 0,
+- maxTypes = 0 };
+-
+- (* Used when we want to give a name to a signature. *)
+- fun makeCopy (name, copy, minTypes, maxTypes) =
+- Signatures { name = name,
+- tab = univFreeze(sigTab copy),
+- minTypes = minTypes,
+- maxTypes = maxTypes };
+-
+- end; (* signatures abstype *)
+-
+- (* Types. *)
++ (* Signatures *)
++ and signatures =
++ Signatures of
++ {
++ name: string,
++ tab: univTable,
++ typeIdMap: int -> typeId,
++ minTypes: int,
++ maxTypes: int,
++ boundIds: typeId list,
++ declaredAt: location
++ }
+
+- (* Level at which type is generalisable. *)
++ (* Values. *)
++ (* The overloaded functions divide up into basically two groups: Those =,
++ <>, print and makestring which are infinitely overloaded and those
++ *, + etc which are overloaded on a limited range of types. *)
++ and typeDependent =
++ Print
++ | GetPretty
++ | MakeString
++ | InstallPP
++ | AddPretty
++ | Equal
++ | NotEqual
++ | AddOverload
++ | TypeDep
++ | GetLocation
++
++ and values =
++ Value of
++ {
++ name: string,
++ typeOf: types,
++ access: valAccess,
++ class: valueClass,
++ locations: locationProp list, (* Location of declaration *)
++ references: references
++ }
+
+- val generalisable = 9999;
+-
+- (* A type is the union of these different cases. *)
+- datatype types =
+- TypeVar of typeVarForm
+- | TypeConstruction of typeConstructionForm
+- | FunctionType of functionTypeForm
+- | LabelledType of labelledRecForm
+- | OverloadSet of overloadSetForm
+- | BadType
+- | EmptyType
+-
+- and typeConstrs =
+- TypeConstrs of
+- {
+- name: string,
+- arity: int,
+- typeVars: types list,
+- updatable: (* We have a single ref here to minimise the number of refs. *)
+- {
+- equiv: types,
+- constrs: values list, (* List of value constructors. *)
+- equal: bool
+- } possRef,
+- identifier: typeId,
+- letDepth: int (* Added 7/8/00 DCJM.
+- Needed to check for local datatypes. *)
+- }
+-
+- (* Access to a value, structure or functor. *)
+- and valAccess =
+- Global of codetree
+- | Local of { addr: int ref, level: int ref }
+- | Selected of { addr: int, base: structVals }
+- | Formal of int
+- | Overloaded of typeDependent (* Values only. *)
+-
+- (* Structures. *)
+- and structVals =
+- NoStruct
+- | Struct of
+- {
+- name: string,
+- signat: signatures,
+- access: valAccess
+- }
++ (* Classes of values. *)
++ and valueClass =
++ SimpleValue
++ | Exception
++ | Constructor of
++ {
++ nullary: bool, (* True if this is a single value (e.g. "nil") rather than a function. *)
++ ofConstrs: int (* Total number of constructors in the datatype. *)
++ }
+
+- (* Values. *)
+- (* The overloaded functions divide up into basically two groups: Those =,
+- <>, print and makestring which are infinitely overloaded and those
+- *, + etc which are overloaded on a limited range of types. *)
+- and typeDependent =
+- Print
+- | PrintSpace
+- | MakeString
+- | MakeStringSpace
+- | InstallPP
+- | Equal
+- | NotEqual
+- | AddOverload
+- | TypeDep
+-
+- and values =
+- Value of {
+- name: string,
+- typeOf: types,
+- access: valAccess,
+- class: valueClass }
+-
+- (* Classes of values. *)
+- and valueClass =
+- SimpleValue
+- | Exception
+- | Constructor of { nullary: bool }
+-
+- withtype typeConstructionForm =
+- {
++ and locationProp =
++ DeclaredAt of location
++ | OpenedAt of location
++ | StructureAt of location
++
++ withtype uniqueId = bool ref
++ (* We use a ref here both because we can then set equality if we
++ need but also because it allows us to create a unique Id. *)
++ and typeConstructionForm =
++ {
+ name: string,
+ value: typeConstrs possRef,
+- args: types list
+- }
++ args: types list,
++ locations: locationProp list
++ }
+
+- and typeVarForm =
+- {
+- value: types ref,
+- encoding: Word.word
+- }
++ and typeVarForm =
++ {
++ value: types ref,
++ encoding: Word.word
++ }
+
+- (* A function type takes two types, the argument and the result. *)
+- and functionTypeForm =
++ (* A function type takes two types, the argument and the result. *)
++ and functionTypeForm =
+ {
+- arg: types,
+- result: types
++ arg: types,
++ result: types
+ }
+
+- (* A fixed labelled record. *)
+- and labelledRecForm =
++ (* A fixed labelled record. *)
++ and labelledRecForm =
+ {
+- recList: { name: string, typeof: types } list,
+- frozen: bool,
+- genericInstance: (*typeVarForm*) { value: types ref, encoding: Word.word } list
++ recList: { name: string, typeof: types } list,
++ frozen: bool,
++ genericInstance: (*typeVarForm*) { value: types ref, encoding: Word.word } list
+ }
+
+ (* A set of type contructors. This is used only during the
+@@ -615,10 +259,88 @@
+ and will always be pointed at by a type variable so that the
+ set can be replaced by a single type construction if the unification
+ reduces to a single type. *)
+- and overloadSetForm =
++ and overloadSetForm =
+ {
+ typeset: typeConstrs list
+ }
++
++ (* Identifiers *)
++ (* REF HOTSPOT - 400 *)
++ fun makeFreeId(access, eq, desc) =
++ Free {access=access, uid = ref eq, allowUpdate=false, description = desc};
++ (* At the moment the only reason for distinguishing makeFreeId and makeFreeIdEqUpdate
++ is that it allows us to check that we're actually permitting update when needed. *)
++ fun makeFreeIdEqUpdate(access, eq, desc) =
++ Free {access=access, uid = ref eq, allowUpdate=true, description = desc};
++
++ fun makeBoundId (access, n, eq, isdt, desc) =
++ Bound{access=access, offset=n, eqType=FrozenRef eq, isDatatype = isdt, description = desc};
++
++ (* Within the body of a functor we make bound stamps but may need to
++ set the equality attribute. *)
++ fun makeBoundIdWithEqUpdate (access, n, eq, isdt, desc) =
++ Bound{access=access, offset=n, eqType=VariableRef(ref eq), isDatatype = isdt, description = desc}
++
++ (* Unset variable. *)
++ fun isFreeId (Free _ ) = true | isFreeId _ = false;
++ fun isBoundId (Bound _) = true | isBoundId _ = false;
++ fun isTypeFunction (TypeFunction _) = true | isTypeFunction _ = false;
++
++ (* Find the number - assuming it is bound. *)
++ fun offsetId (Bound {offset, ...}) = offset
++ | offsetId _ = raise InternalError "offsetId: not a Bound";
++
++ (* Are two type constructors the same? *)
++ fun sameTypeId (Free{uid = a, ...}, Free {uid = b, ...}) = a = b
++ | sameTypeId (Bound{offset=a, ...}, Bound{offset=b, ...}) = a = b
++ | sameTypeId _ = false (* Includes type functions. *)
++
++ fun idAccess (Free { access, ...}) = access
++ | idAccess (Bound{ access, ...}) = access
++ | idAccess (TypeFunction _) = raise InternalError "idAccess: TypeFunction"
++
++ fun isEquality (Free{uid = ref eq, ...}) = eq
++ | isEquality (Bound{eqType, ...}) = pling eqType
++ | isEquality (TypeFunction _) =
++ raise InternalError "isEquality: TypeFunction" (* Requires analysis of the type function. *)
++
++ (* Set the equality property. Currently, free IDs are used for abstypes and
++ datatypes that are local to a function as well as the usual case of using them
++ for top-level types. *)
++ fun setEquality(Free{uid, allowUpdate=true, ...}, eq) = uid := eq
++ | setEquality(Bound{eqType=VariableRef id, ...}, eq) = id := eq
++ | setEquality _ = raise InternalError "setEquality: can't set equality attribute"
++
++ (* Signatures: Used for both signatures of local structures and for global structures
++ (name spaces). Strictly signatures do not contain fix-status functors
++ or signatures but as we use these structures for top-level name-spaces
++ we have to have tables for these. *)
++ fun sigName (Signatures {name,...}) = name;
++ fun sigTab (Signatures {tab,...}) = tab;
++ fun sigMinTypes (Signatures {minTypes,...}) = minTypes;
++ fun sigMaxTypes (Signatures {maxTypes,...}) = maxTypes;
++ fun sigDeclaredAt (Signatures {declaredAt,...}) = declaredAt;
++ fun sigTypeIdMap (Signatures {typeIdMap, ...}) = typeIdMap;
++ fun sigBoundIds (Signatures {boundIds, ...}) = boundIds;
++
++ val makeSignatureTable = makeUnivTable
++
++ (* Make a signature, freezing the table. *)
++ fun makeSignature (name, table, minTypes, maxTypes, location, typeIdMap, boundIds) =
++ Signatures { name = name,
++ tab = univFreeze table,
++ typeIdMap = typeIdMap,
++ minTypes = minTypes,
++ maxTypes = maxTypes,
++ boundIds = boundIds,
++ declaredAt = location };
++
++ (* Types. *)
++
++ (* Level at which type is generalisable. *)
++
++ val generalisable = 9999;
++
+
+ (* Destructors, constructors and predicates for types *)
+ val emptyType = EmptyType;
+@@ -627,13 +349,15 @@
+ fun isEmpty EmptyType = true | isEmpty _ = false;
+ fun isBad BadType = true | isBad _ = false;
+
+- fun makeValueConstr (name, typeOf, nullary, access) : values =
++ fun makeValueConstr (name, typeOf, nullary, constrs, access, locations) : values =
+ Value
+ {
+ name = name,
+ typeOf = typeOf,
+ access = access,
+- class = Constructor { nullary = nullary }
++ class = Constructor { nullary = nullary, ofConstrs = constrs },
++ locations = locations,
++ references = NONE
+ };
+
+
+@@ -663,29 +387,23 @@
+ fun sameTv (a : typeVarForm, b : typeVarForm) : bool =
+ #value a = #value b; (* If the same ref it must be the same *)
+
+- (* To save space "equality", "nonunifiable" and "weak"
+- are encoded together with the level.
+- *)
+-
+ local
+ open Word
+ infix 8 >> <<
+ infix 7 andb
+ infix 6 orb
+ in
+- fun makeTv (t : types, lev, equality, nonunifiable, weak) : typeVarForm =
++ fun makeTv (t : types, lev, equality, nonunifiable) : typeVarForm =
+ { value = ref t, (* REF HOTSPOT - 400 *)
+ encoding = (fromInt lev << 0w3)
+ orb (if equality then 0w4 else 0w0)
+- orb (if nonunifiable then 0w2 else 0w0)
+- orb (if weak then 0w1 else 0w0) };
++ orb (if nonunifiable then 0w2 else 0w0) };
+
+ fun tvSetValue ({ value, ...} : typeVarForm, t : types) = value := t;
+ fun tvValue ({value = ref v, ...} : typeVarForm) : types = v;
+ fun tvLevel ({encoding, ...} : typeVarForm) : int = Word.toInt(encoding >> 0w3);
+ fun tvEquality ({encoding, ...} : typeVarForm) = encoding andb 0w4 <> 0w0;
+ fun tvNonUnifiable ({encoding, ...} : typeVarForm) = encoding andb 0w2 <> 0w0;
+- fun tvWeak ({encoding, ...} : typeVarForm) = encoding andb 0w1 <> 0w0;
+ end;
+
+ (* Type constructors are identifiers which take zero or more types and yield a
+@@ -701,113 +419,191 @@
+ fun tcArity (TypeConstrs {arity,...} : typeConstrs) = arity;
+ fun tcTypeVars (TypeConstrs {typeVars,...} : typeConstrs) = typeVars;
+ fun tcIdentifier (TypeConstrs {identifier,...} : typeConstrs) = identifier;
++ fun tcLocations (TypeConstrs {locations, ...}) = locations
+
+- local
+- fun getUpdatable (TypeConstrs {updatable,...} : typeConstrs) = pling updatable;
+- in
+- val tcEquivalent = #equiv o getUpdatable
+- val tcConstructors = #constrs o getUpdatable
+- val tcEquality = #equal o getUpdatable;
+-
+- fun tcSetEquivalent (TypeConstrs {updatable,...}, t) =
+- let
+- val v = pling updatable
+- in
+- updatePR(updatable, { equiv = t, constrs = #constrs v, equal = #equal v})
+- end
+-
+- fun tcSetConstructors (TypeConstrs {updatable,...}, constrs) =
+- let
+- val v = pling updatable
+- in
+- updatePR(updatable, { equiv = #equiv v, constrs = constrs, equal = #equal v})
+- end
+-
+- fun tcSetEquality (TypeConstrs {updatable,...}, eq) =
+- let
+- val v = pling updatable
+- in
+- updatePR(updatable, { equiv = #equiv v, constrs = #constrs v, equal = eq})
+- end
+- end
++ fun tcConstructors (TypeConstrs {constrs,...} : typeConstrs) = pling constrs;
++
++ (* Is this a type function? N.B. It is possible, though unlikely, that it
++ is a datatype as well i.e. has value constructors. *)
++ fun tcIsAbbreviation (TypeConstrs {identifier,...}) = isTypeFunction identifier
++
++ (* Equality and "equivalence" are now properties of the type id. Retain these functions for the moment. *)
++ (* This definition of tcEquivalent is a hack but it should simplify conversion. *)
++ fun tcEquivalent tycons =
++ case tcIdentifier tycons of
++ TypeFunction(_, result) => result
++ | _ => EmptyType
++
++ val tcEquality = isEquality o tcIdentifier;
++ fun tcSetEquality(tc, eq) = setEquality(tcIdentifier tc, eq)
++
++ fun tcSetConstructors (TypeConstrs {constrs, name, ...}, newConstrs) =
++ updatePR(constrs, newConstrs) handle Fail _ => raise Fail ("SetConstructors:" ^ name)
+
+- fun tcLetDepth (TypeConstrs {letDepth,...} : typeConstrs) = letDepth;
++ fun tcLetDepth (TypeConstrs {letDepth,...} : typeConstrs) = letDepth;
++
++ (* Construct a datatype. The value constructors can be added on later. *)
++ fun makeDatatypeConstr (name, typeVars, uid, depth, locations) =
++ TypeConstrs
++ {
++ name = name,
++ arity = length typeVars,
++ typeVars = typeVars,
++ constrs = VariableRef (ref []), (* REF HOTSPOT - 690 refs here. *)
++ identifier = uid,
++ letDepth = depth,
++ locations = locations
++ };
++
++ (* Construct a type abbreviation. *)
++ fun makeTypeAbbreviation(name, typeVars, typeResult, locations) =
++ TypeConstrs
++ {
++ name = name,
++ arity = length typeVars,
++ typeVars = typeVars,
++ constrs = FrozenRef [],
++ identifier = TypeFunction(typeVars, typeResult),
++ letDepth = 0,
++ locations = locations
++ };
++
++ (* Construct a type constructor that cannot have value constructors added. This is
++ primarily used in Initialise for base types such as "int". *)
++ fun makeFrozenTypeConstrs (name, typeVars, uid, depth, locations) =
++ TypeConstrs
++ {
++ name = name,
++ arity = length typeVars,
++ typeVars = typeVars,
++ constrs = FrozenRef [],
++ identifier = uid,
++ letDepth = depth,
++ locations = locations
++ };
++
++ val inBasis =
++ { file = "Standard Basis", startLine = 0, startPosition = 0, endLine = 0, endPosition = 0}
++ fun basisDescription name = { location = inBasis, description = "In Basis", name = name }
++
++ (* Eqtypes with built-in equality functions. *)
++ local
++ open Address PRETTY RuntimeCalls
++ fun defaultPrinter _ _ _ = PrettyString "?"
++
++ fun eqAndPrintCode eqFun =
++ let
++ (* The structure equality function takes a pair of arguments. We need a
++ function that takes two Poly-style arguments. *)
++ val defaultEqCode =
++ mkInlproc(
++ mkConst (toMachineWord(RunCall.run_call1 POLY_SYS_io_operation eqFun)),
++ 0, 0, "eq-helper()")
++ val code =
++ mkTuple[
++ defaultEqCode,
++ mkConst (toMachineWord (ref defaultPrinter))
++ ]
++ in
++ Global (genCode(code, []) ())
++ end
+
+- fun makeTypeConstrs (name, typeVars, equivalent, uid, equ, depth) =
+- TypeConstrs
+- {
+- name = name,
+- arity = length typeVars,
+- typeVars = typeVars,
+- updatable =
+- VariableRef (ref (* REF HOTSPOT - 690 refs here. *)
+- {
+- equiv = equivalent,
+- constrs = [],
+- equal = equ
+- }),
+- identifier = uid,
+- letDepth = depth
+- };
+-
+- fun makeFrozenTypeConstrs (name, typeVars, equivalent, uid, equ, depth) =
+- TypeConstrs
+- {
+- name = name,
+- arity = length typeVars,
+- typeVars = typeVars,
+- updatable =
+- FrozenRef
+- {
+- equiv = equivalent,
+- constrs = [],
+- equal = equ
+- },
+- identifier = uid,
+- letDepth = depth
+- };
+-
+- fun baseType name eq =
+- makeFrozenTypeConstrs (name, [], EmptyType, makeFreeId (), eq, 0);
+-
+- val boolType = makeTypeConstrs ("bool", [], EmptyType, makeFreeId (), true, 0);
+- val intType = baseType "int" true;
+- val charType = baseType "char" true;
+- val stringType = baseType "string" true;
+- val wordType = baseType "word" true;
+- val realType = baseType "real" false; (* Not an eqtype in ML97. *)
+- val exnType = baseType "exn" false;
+- (* The unit type is equivalent to the empty record. *)
+- val unitType =
+- makeFrozenTypeConstrs ("unit", [],
++
++ fun makeType(name, eqFun) =
++ makeFrozenTypeConstrs (name, [],
++ makeFreeId(eqAndPrintCode eqFun, true, basisDescription name),
++ 0, [DeclaredAt inBasis]);
++ in
++ val intType = makeType("int", POLY_SYS_equala) (* Need arbitrary precision equality *)
++ val charType = makeType("char", POLY_SYS_int_eq) (* Always short *)
++ val stringType = makeType("string", POLY_SYS_teststreq)
++ val wordType = makeType("word", POLY_SYS_word_eq)
++
++ (* Ref is a datatype with a single constructor. The constructor is added in INITIALISE.
++ Equality is special for "'a ref", "'a array" and "'a Array2.array". They permit equality
++ even if the 'a is not an eqType. *)
++ val refType =
++ makeDatatypeConstr
++ ("ref", [makeTv (EmptyType, generalisable, false, false)],
++ makeFreeId(eqAndPrintCode POLY_SYS_word_eq, true, basisDescription "ref"),
++ 0, [DeclaredAt inBasis]);
++ val arrayType =
++ makeFrozenTypeConstrs
++ ("array", [makeTv (EmptyType, generalisable, false, false)],
++ makeFreeId(eqAndPrintCode POLY_SYS_word_eq, true, basisDescription "Array.array"),
++ 0, [DeclaredAt inBasis]);
++ val array2Type =
++ makeFrozenTypeConstrs
++ ("array", [makeTv (EmptyType, generalisable, false, false)],
++ makeFreeId(eqAndPrintCode POLY_SYS_word_eq, true, basisDescription "Array2.array"),
++ 0, [DeclaredAt inBasis]);
++ (* Bool is a datatype. The constructors are added in INITIALISE. *)
++ val boolType =
++ makeDatatypeConstr
++ ("bool", [], makeFreeId(eqAndPrintCode POLY_SYS_int_eq, true, basisDescription "bool"),
++ 0, [DeclaredAt inBasis]);
++ end
++
++ (* These polytypes allow equality even if the type argument is not an equality type. *)
++ fun isPointerEqType id =
++ sameTypeId (id, tcIdentifier refType) orelse
++ sameTypeId (id, tcIdentifier arrayType) orelse
++ sameTypeId (id, tcIdentifier array2Type)
++
++ (* Non-eqtypes *)
++ local
++ open Address PRETTY;
++
++ fun makeType name =
++ let
++ fun defaultPrinter _ _ _ = PrettyString "?"
++ val code =
++ mkTuple[
++ CodeZero (* No equality. *),
++ mkConst (toMachineWord (ref defaultPrinter))
++ ]
++ in
++ makeFrozenTypeConstrs (
++ name, [], makeFreeId(Global (genCode(code, []) ()), false, basisDescription name),
++ 0, [DeclaredAt inBasis])
++ end
++ in
++ val realType = makeType "real"; (* Not an eqtype in ML97. *)
++ val exnType = makeType "exn";
++ end
++
++ local
++ open Address PRETTY;
++
++ fun defaultPrinter _ _ _ = PrettyString "?"
++ val code =
++ mkTuple[
++ CodeZero (* No equality. *),
++ mkConst (toMachineWord (ref defaultPrinter))
++ ]
++ in
++ (* "undefType" is used as a place-holder during parsing for the actual type constructor.
++ If the type constructor is not found this may appear in an error message. *)
++ val undefType =
++ makeFrozenTypeConstrs (
++ "undefined", [], makeFreeId(Global (genCode(code, []) ()), false,
++ { location = inBasis, description = "Undefined", name = "undefined" }),
++ 0, [DeclaredAt inBasis])
++ end
++
++
++ (* The unit type is equivalent to the empty record. *)
++ val unitType =
++ makeTypeAbbreviation ("unit", [],
+ LabelledType {recList = [], frozen = true, genericInstance = []},
+- makeFreeId (), true, 0);
+-
+- val listType =
+- makeTypeConstrs
+- ("list",
+- [TypeVar (makeTv (EmptyType, generalisable, false, false, false))],
+- EmptyType,
+- makeFreeId (),
+- true, 0);
+-
+- val refType =
+- makeTypeConstrs
+- ("ref",
+- [TypeVar (makeTv (EmptyType, generalisable, false, false, false))],
+- EmptyType,
+- makeFreeId (),
+- true, 0);
+-
+- val undefType =
+- makeFrozenTypeConstrs ("undefined", [], EmptyType, unsetId, false, 0);
++ [DeclaredAt inBasis]);
+
+- (* Infix status. *)
++ (* Infix status. *)
+
+- datatype fixStatus =
+- Infix of int
+- | InfixR of int
+- | Nonfix;
++ datatype fixStatus =
++ Infix of int
++ | InfixR of int
++ | Nonfix;
+
+
+ fun isGlobal (Global _) = true | isGlobal _ = false;
+@@ -828,8 +624,8 @@
+ fun makeSelected (addr, base) =
+ Selected { addr = addr, base = base };
+
+- fun makeStruct (name, signat, access) =
+- Struct { name = name, signat = signat, access = access };
++ fun makeStruct (name, signat, access, locations) =
++ Struct { name = name, signat = signat, access = access, locations = locations };
+
+ val undefinedStruct = NoStruct;
+
+@@ -841,63 +637,76 @@
+
+ fun structAccess NoStruct = raise Match
+ | structAccess (Struct {access,...}) = access;
+-
++
++ fun structLocations NoStruct = raise Match
++ | structLocations (Struct {locations,...}) = locations;
++
+ (* Return the signature. *)
+- fun structSignat NoStruct = makeSignatures "" (* only if an error *)
+-
++ fun structSignat NoStruct =
++ makeSignature("", makeSignatureTable(), 0, 0, inBasis, fn _ => raise Subscript, []) (* only if an error *)
+ | structSignat (Struct {signat,...}) = signat;
+
+ (* Global structure *)
+- fun makeGlobalStruct (name, signat, code) =
+- makeStruct (name, makeCopy("", signat, sigMinTypes signat, sigMaxTypes signat), makeGlobal code);
++ fun makeGlobalStruct (name, signat, code, location) =
++ makeStruct (name, signat, makeGlobal code, [DeclaredAt location]);
+
+- (* This is used for the top-level name space so must be mutable. *)
++ (* These are used in INITIALISE so must be mutable. *)
+ fun makeEmptyGlobal name =
+- makeStruct (name, makeSignatures "", makeGlobal CodeZero);
++ makeStruct (name,
++ Signatures { name = "",
++ tab = makeUnivTable(),
++ typeIdMap = fn _ => raise Subscript,
++ minTypes = 0,
++ maxTypes = 0,
++ boundIds = [],
++ declaredAt = inBasis },
++ makeGlobal CodeZero, [DeclaredAt inBasis]);
+
+ (* Local structure. *)
+- fun makeLocalStruct (name, signat) =
+- makeStruct (name, signat, makeLocal ());
++ fun makeLocalStruct (name, signat, location) =
++ makeStruct (name, signat, makeLocal (), location);
+
+ (* Structure in a local structure or a functor argument. *)
+- fun makeSelectedStruct (selected, base) =
++ fun makeSelectedStruct (selected, base, openLocs) =
+ (
+ case structAccess selected of
+ Formal sel =>
+- makeStruct
+- (structName selected,
+- structSignat selected,
+- makeSelected (sel, base))
+- | _ => selected
++ makeStruct(structName selected, structSignat selected, makeSelected (sel, base),
++ openLocs @ structLocations selected)
++ | Global code => (* Need to add the locations. *)
++ makeStruct(structName selected, structSignat selected, Global code,
++ openLocs @ structLocations selected)
++ | _ => selected
+ );
+
+- fun makeFormalStruct (name, signat, addr) =
+- makeStruct (name, signat, makeFormal addr);
++ fun makeFormalStruct (name, signat, addr, location) =
++ makeStruct (name, signat, makeFormal addr, location);
+
+ (* Values. *)
+
+- fun makeGlobalV (name, typeOf, code) : values =
+- Value{ name = name, typeOf = typeOf, access = Global code, class = SimpleValue };
++ fun makeGlobalV (name, typeOf, code, locations) : values =
++ Value{ name = name, typeOf = typeOf, access = Global code, class = SimpleValue,
++ locations = locations, references = NONE };
+
+- fun makeLocalV (name, typeOf, addr, level) : values =
++ fun makeLocalV (name, typeOf, addr, level, locations) : values =
+ Value{ name = name, typeOf = typeOf, access = Local {addr = addr, level = level},
+- class = SimpleValue };
++ class = SimpleValue, locations = locations, references = makeRef() };
+
+- fun makeFormalV (name, typeOf, addr) : values =
+- Value{ name = name, typeOf = typeOf, access = Formal addr, class = SimpleValue };
++ fun makeFormalV (name, typeOf, addr, locations) : values =
++ Value{ name = name, typeOf = typeOf, access = Formal addr, class = SimpleValue, locations = locations, references = NONE };
+
+- fun makeFormalEx (name, typeOf, addr) : values =
+- Value{ name = name, typeOf = typeOf, access = Formal addr, class = Exception };
++ fun makeFormalEx (name, typeOf, addr, locations) : values =
++ Value{ name = name, typeOf = typeOf, access = Formal addr, class = Exception, locations = locations, references = NONE };
+
+ fun makeOverloaded (name, typeOf, operation) : values =
+- Value{ name = name, typeOf = typeOf, access = Overloaded operation, class = SimpleValue};
++ Value{ name = name, typeOf = typeOf, access = Overloaded operation, class = SimpleValue,
++ locations = [DeclaredAt inBasis], references = NONE};
+
+- val undefinedValue = makeGlobalV("<undefined>", BadType, CodeZero);
++ val undefinedValue = makeGlobalV("<undefined>", BadType, CodeZero, [DeclaredAt inBasis]);
+
+ fun isUndefinedValue(Value{name = "<undefined>", ...}) = true | isUndefinedValue _ = false
+
+ fun valName (Value{name, ...}) = name
+-
+ fun valTypeOf (Value{typeOf, ...}) = typeOf
+
+ fun isConstructor (Value{class=Constructor _, ...}) = true
+@@ -916,16 +725,18 @@
+ name: string,
+ arg: structVals,
+ result: signatures,
+- access: valAccess
++ access: valAccess,
++ declaredAt: location
+ }
+ with
+- fun makeFunctor (name, arg, result, access) =
++ fun makeFunctor (name, arg, result, access, location) =
+ Functor
+ {
+ name = name,
+ arg = arg,
+ result = result,
+- access = access
++ access = access,
++ declaredAt = location
+ };
+
+ val undefinedFunctor = NoFunctor;
+@@ -944,6 +755,9 @@
+
+ fun functorAccess NoFunctor = raise Match
+ | functorAccess (Functor {access,...}) = access;
++
++ fun functorDeclaredAt NoFunctor = raise Match
++ | functorDeclaredAt (Functor {declaredAt,...}) = declaredAt;
+ end; (* functors abstype *)
+
+ val valueVar: values tag = tag();
+@@ -976,12 +790,9 @@
+ enterFunct: string * functors -> unit
+ };
+
+- (* This creates functions for entering and looking up names. *)
+- fun makeEnv s =
+- let
+- val tab = sigTab s;
+- in
+- Env { lookupVal = makeLook valueVar tab,
++ (* This creates functions for entering and looking up names. *)
++ fun makeEnv tab =
++ Env { lookupVal = makeLook valueVar tab,
+ lookupType = makeLook typeConstrVar tab,
+ lookupFix = makeLook fixVar tab,
+ lookupStruct = makeLook structVar tab,
+@@ -994,5 +805,22 @@
+ enterSig = makeEnter signatureVar tab,
+ enterFunct = makeEnter functorVar tab
+ }
+- end;
++
++ structure Sharing =
++ struct
++ type codetree = codetree
++ and signatures = signatures
++ and types = types
++ and values = values
++ and typeId = typeId
++ and structVals = structVals
++ and valAccess = valAccess
++ and typeConstrs= typeConstrs
++ and env = env
++ and univTable = univTable
++ and fixStatus = fixStatus
++ and functors = functors
++ and locationProp = locationProp
++ and typeVarForm = typeVarForm
++ end
+ end (* STRUCTVALS *);
+Only in mlsource/MLCompiler: SignaturesStruct.sml
+diff -u -r mlsource/MLCompiler/StructVals.ML mlsource/MLCompiler/StructVals.ML
+--- mlsource/MLCompiler/StructVals.ML 2005-09-17 18:39:59.000000000 +0200
++++ mlsource/MLCompiler/StructVals.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -22,7 +22,6 @@
+ STRUCT_VALS
+ (
+ structure CODETREE = CodeTree
+- structure MISC = Misc
+- structure UNIVERSAL = Universal
+ structure UNIVERSALTABLE = UniversalTable
++ structure PRETTY = Pretty
+ );
+diff -u -r mlsource/MLCompiler/Structures.ML mlsource/MLCompiler/Structures.ML
+--- mlsource/MLCompiler/Structures.ML 2008-03-18 08:49:07.000000000 +0100
++++ mlsource/MLCompiler/Structures.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -26,11 +26,13 @@
+ structure TYPETREE = TypeTree
+ structure PARSETREE = ParseTree
+ structure UTILITIES = Utilities
+- structure PRETTYPRINTER = PrettyPrinter
+- structure MISC = Misc
+- structure UNIVERSAL = Universal
++ structure PRETTY = Pretty
+ structure UNIVERSALTABLE = UniversalTable
+ structure DEBUG = Debug
+- structure STRETCHARRAY = StretchArray
+ structure DEBUGGER = Debugger
++ structure EXPORTTREE = ExportTreeStruct
++ structure COPIER = CopierStruct
++ structure TYPEIDCODE = TypeIDCodeStruct
++ structure SIGNATURES = SignaturesStruct
++ structure DEBUGGER = Debugger
+ );
+diff -u -r mlsource/MLCompiler/Symbols.ML mlsource/MLCompiler/Symbols.ML
+--- mlsource/MLCompiler/Symbols.ML 2008-04-21 13:36:11.000000000 +0200
++++ mlsource/MLCompiler/Symbols.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -279,7 +279,7 @@
+ val table: sys hash = hashMake (4 * down maxsym);
+
+ (* Enter each reserved word in the hash table *)
+- val U : unit =
++ val () =
+ forsucc succ (op leq) abstypeSy colonGt
+ (fn sym => hashSet (table, repr sym, sym));
+ in
+Only in mlsource/MLCompiler: TYPEIDCODE.sml
+Only in mlsource/MLCompiler: TYPEIDCODESIG.sml
+Only in mlsource/MLCompiler: TYPETREESIG.sml
+diff -u -r mlsource/MLCompiler/TYPE_TREE.ML mlsource/MLCompiler/TYPE_TREE.ML
+--- mlsource/MLCompiler/TYPE_TREE.ML 2008-04-21 13:36:11.000000000 +0200
++++ mlsource/MLCompiler/TYPE_TREE.ML 2009-09-15 08:56:47.000000000 +0200
+@@ -12,7 +12,7 @@
+ Cambridge University Technical Services Limited
+
+ Further development:
+- Copyright (c) 2000-8 David C.J. Matthews
++ Copyright (c) 2000-9 David C.J. Matthews
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+@@ -36,7 +36,7 @@
+ (*****************************************************************************)
+ structure ADDRESS :
+ sig
+- val wordEq: 'a * 'a -> bool
++ val wordEq: 'a * 'a -> bool
+ end;
+
+ (*****************************************************************************)
+@@ -44,7 +44,6 @@
+ (*****************************************************************************)
+ structure DEBUG :
+ sig
+- val ml90Tag: bool Universal.tag
+ val errorDepthTag: int Universal.tag
+ val getParameter :
+ 'a Universal.tag -> Universal.universal list -> 'a
+@@ -53,120 +52,12 @@
+ (*****************************************************************************)
+ (* LEX *)
+ (*****************************************************************************)
+-structure LEX :
+-sig
+- type lexan;
+- type prettyPrinter;
+-
+- val errorProc: lexan * int * (prettyPrinter -> unit) -> unit;
+- val errorMessage: lexan * int * string -> unit;
+- val warningMessage: lexan * int * string -> unit;
+- val lineno: lexan -> int;
+-
+- val debugParams: lexan -> Universal.universal list
+-end;
++structure LEX : LEXSIG
+
+ (*****************************************************************************)
+ (* STRUCTVALS *)
+ (*****************************************************************************)
+-structure STRUCTVALS :
+-sig
+- type values;
+- type typeConstrs;
+- type typeId;
+-
+- datatype 'a possRef = FrozenRef of 'a | VariableRef of 'a ref
+- val pling: 'a possRef -> 'a
+- val updatePR: 'a possRef * 'a -> unit
+-
+- (* A type is the union of these different cases. *)
+- type typeVarForm;
+- datatype types =
+- TypeVar of typeVarForm
+-
+- | TypeConstruction of (* typeConstructionForm *)
+- {
+- name: string,
+- value: typeConstrs possRef,
+- args: types list
+- }
+-
+- | FunctionType of (* functionTypeForm *)
+- {
+- arg: types,
+- result: types
+- }
+-
+- | LabelledType of (* labelledRecForm *)
+- {
+- recList: { name: string, typeof: types } list,
+- frozen: bool,
+- genericInstance: typeVarForm list
+- }
+-
+- | OverloadSet of (* overloadSetForm *)
+- {
+- typeset: typeConstrs list
+- }
+-
+- | BadType
+-
+- | EmptyType
+- ;
+-
+-
+- val valName: values -> string
+- val valTypeOf: values -> types
+-
+- val isUnsetId: typeId -> bool;
+- val isBoundId: typeId -> bool;
+- val isVariableId: typeId -> bool;
+- val sameTypeId : typeId * typeId -> bool;
+- val unifyTypeIds: typeId * typeId -> bool;
+- val makeFreeId: unit -> typeId;
+-
+- val tcName: typeConstrs -> string;
+- val tcArity: typeConstrs -> int;
+- val tcTypeVars: typeConstrs -> types list;
+- val tcEquivalent: typeConstrs -> types;
+- val tcSetEquivalent: typeConstrs * types -> unit;
+- val tcConstructors: typeConstrs -> values list;
+- val tcEquality: typeConstrs -> bool;
+- val tcSetEquality: typeConstrs * bool -> unit;
+- val tcIdentifier: typeConstrs -> typeId;
+- val tcLetDepth: typeConstrs -> int;
+-
+- val makeTypeConstrs:
+- string * types list * types * typeId * bool * int-> typeConstrs;
+- val makeFrozenTypeConstrs:
+- string * types list * types * typeId * bool * int-> typeConstrs;
+-
+- val emptyType: types;
+-
+- val tvLevel: typeVarForm -> int;
+- val tvEquality: typeVarForm -> bool;
+- val tvNonUnifiable: typeVarForm -> bool;
+- val tvWeak: typeVarForm -> bool;
+- val tvValue: typeVarForm -> types;
+- val tvSetValue: typeVarForm * types -> unit;
+-
+- val sameTv: typeVarForm * typeVarForm -> bool;
+-
+- val makeTv: types * int * bool * bool * bool -> typeVarForm;
+-
+- (* Standard type constructors. *)
+- val generalisable: int;
+-
+- val boolType: typeConstrs;
+- val intType: typeConstrs;
+- val charType: typeConstrs;
+- val stringType: typeConstrs;
+- val wordType: typeConstrs;
+- val realType: typeConstrs;
+- val unitType: typeConstrs;
+- val exnType: typeConstrs;
+- val undefType: typeConstrs;
+-end;
++structure STRUCTVALS : STRUCTVALSIG;
+
+ (*****************************************************************************)
+ (* UTILITIES *)
+@@ -179,17 +70,9 @@
+ end;
+
+ (*****************************************************************************)
+-(* PRETTYPRINTER *)
++(* PRETTY *)
+ (*****************************************************************************)
+-structure PRETTYPRINTER :
+-sig
+- type prettyPrinter
+-
+- val ppAddString : prettyPrinter -> string -> unit
+- val ppBeginBlock : prettyPrinter -> int * bool -> unit
+- val ppEndBlock : prettyPrinter -> unit -> unit
+- val ppBreak : prettyPrinter -> int * int -> unit
+-end;
++structure PRETTY : PRETTYSIG
+
+ (*****************************************************************************)
+ (* MISC *)
+@@ -202,16 +85,6 @@
+ end;
+
+ (*****************************************************************************)
+-(* PRINTTABLE *)
+-(*****************************************************************************)
+-structure PRINTTABLE :
+-sig
+- type typeConstrs
+- type codetree
+- val getOverload: string * typeConstrs * (unit->codetree) -> codetree
+-end;
+-
+-(*****************************************************************************)
+ (* CODETREE *)
+ (*****************************************************************************)
+ structure CODETREE :
+@@ -223,177 +96,29 @@
+ end;
+
+ (*****************************************************************************)
+-(* TYPETREE sharing constraints *)
++(* EXPORTTREE *)
+ (*****************************************************************************)
+
+-sharing type
+- LEX.prettyPrinter
+-= PRETTYPRINTER.prettyPrinter
+-
+-sharing type
+- PRINTTABLE.codetree
+-= CODETREE.codetree
+-
+-sharing type
+- PRINTTABLE.typeConstrs
+-= STRUCTVALS.typeConstrs
+-
+-
+-) :
+-
+-(*****************************************************************************)
+-(* TYPETREE exports signature *)
+-(*****************************************************************************)
+-sig
+- type types;
+- type values;
+- type typeConstrs;
+- type lexan;
+- type prettyPrinter;
+- type typeId;
+-
+- val mkTypeVar: int * bool * bool * bool -> types;
+- val mkTypeConstruction: string * typeConstrs * types list -> types;
+- val mkProductType: types list -> types;
+- val mkFunctionType: types * types -> types;
+- val mkLabelled: {name: string, typeof: types } list * bool -> types;
+- val mkLabelEntry: string * types -> {name: string, typeof: types };
+- val mkOverloadSet: typeConstrs list -> types;
+- val sortLabels: {name: string, typeof: types } list * (string -> unit) ->
+- {name: string, typeof: types } list;
+- val entryNumber: string * types -> int;
+- val recordNotFrozen: types -> bool;
+- val recordWidth: types -> int;
+- val makeEquivalent: typeConstrs * types list -> types;
+- val firstArg: types -> types;
+-
+- (* Unify two type variables which would otherwise be non-unifiable. *)
+- val linkTypeVars: types * types -> unit;
+- val setTvarLevel: types * int -> unit;
+-
+- (* Get the constructor list from a type. *)
+- val getConstrList: types -> values list;
+-
+- (* Fill in the values of type variables and make checks. *)
+- val assignTypes: types * (string -> typeConstrs) * lexan * int -> unit;
+-
+- (* Copy a type. *)
+- val copyType: types * (types -> types) * (typeConstrs -> typeConstrs) -> types;
++structure EXPORTTREE: EXPORTTREESIG;
+
+- (* Print it out prettily *)
+- val display: types * int * prettyPrinter * bool -> unit;
+-
+- (* Print out a type constructor. *)
+- val displayTypeConstrs: typeConstrs * int * prettyPrinter * bool -> unit;
+-
+- (* A list of type variables. *)
+- val displayTypeVariables: types list * int * prettyPrinter * bool -> unit;
+-
+- (* Create an instance of an overloaded type. *)
+- val generaliseOverload: types * typeConstrs list * bool -> types;
+-
+- (* Returns the preferred type constructor from an overload. *)
+- val typeConstrFromOverload: types * bool -> typeConstrs;
+-
+- (* Error message when overloading cannot be resolved. It is put in this
+- module because we want the message to refer to the argument. *)
+- val overloadError: types * string * string * lexan * int -> unit;
+-
+- val genEqualityFunctions: typeConstrs list * (string -> unit) * bool -> unit;
+-
+- (* Checking procedures *)
+-
+- (* Match a candidate to a target type. *)
+- val matchTypes: types * types * (typeId -> typeConstrs option) *
+- lexan * int * (prettyPrinter -> unit) -> unit;
+-
+- (* Unify two type structures to give a unified type. *)
+- val unify: types * types * lexan * int * (prettyPrinter -> unit) -> unit;
+-
+- (* Apply a function to an argument and yield a result type. *)
+- val apply: types * types * lexan * int * (prettyPrinter -> unit) -> types;
+-
+- (* Used to establish sharing constraints between type constructors. *)
+- val linkTypeConstructors: typeConstrs * typeConstrs * (string -> unit) -> unit;
+-
+- (* Used to link a type constructor to a type as the result of a "where type"
+- construction. *)
+- val setWhereType: typeConstrs * typeConstrs * (string -> unit) -> unit;
+-
+- (* Check that a type constructor permits equality. *)
+- val permitsEquality: typeConstrs -> bool;
+-
+- (* Generate new copies of all unbound type variables - this is used on all
+- non-local values or constructors so that, for example, each occurence of
+- "hd", which has type 'a list -> 'a, can be separately bound to types.
+- isExp is false if we are processing a pattern. If we have "ref" as a
+- constructor in a pattern we do not need to introduce imperative type
+- variables. *)
+- val generalise: types * bool -> types;
+-
+- (* Release type variables at this nesting level. *)
+- val allowGeneralisation: types * int * bool *
+- lexan * int * (prettyPrinter -> unit) -> unit;
+-
+- (* Check for a local datatype "escaping". Added for ML97. *)
+- val checkForLocalDatatypes: types * int * (string -> unit) -> unit;
+-
+- (* Check for free type variables. Added for ML97. *)
+- val checkForFreeTypeVariables: string * types * lexan -> unit;
+-
+- val constructorResult: types * types list -> types;
+-
+- val checkWellFormed: types * (string -> unit) -> unit;
+-
+- val findValueConstructor: values -> values;
+-
+- val copyTypeConstr:
+- typeConstrs * (typeId -> bool) * (unit -> typeId) *
+- {enter: typeId * typeConstrs -> unit,
+- lookup: typeId -> typeConstrs option} *
+- (types -> types) * string ->
+- typeConstrs;
+-
+- val setTypeConstr: typeConstrs * (typeConstrs -> typeId) -> unit;
+-
+- val enterTypeConstrs: typeConstrs * typeConstrs *
+- { enter: typeId * typeConstrs -> unit,
+- lookup: typeId -> typeConstrs option} -> unit;
+-
+- val identical: types * types -> bool;
+- val identicalConstr: typeConstrs * typeConstrs -> bool;
+- val identicalList: types list * types list -> bool;
+-
+- val boolType: types;
+- val intType: types;
+- val charType: types;
+- val stringType: types;
+- val realType: types;
+- val unitType: types;
+- val exnType: types;
+- val wordType: types;
+-
+- (* added 6/12/95 SPF *)
+- val badType: types;
++sharing LEX.Sharing = PRETTY.Sharing = EXPORTTREE.Sharing = STRUCTVALS.Sharing
++ = CODETREE
+
+- (* added SPF 16/4/95 *)
+- val sameTypeVar : types * types -> bool;
+-end (* TYPETREE export signature *) =
++) : TYPETREESIG =
+
+ (*****************************************************************************)
+ (* TYPETREE functor body *)
+ (*****************************************************************************)
+ struct
+ open MISC;
+- open PRETTYPRINTER;
++ open PRETTY;
+
+ open STRUCTVALS;
+ open LEX;
+ open UTILITIES;
+ open CODETREE;
+- open PRINTTABLE;
++ open EXPORTTREE
+
+- (* added 6/12/95 SPF *)
+ val badType : types = BadType;
+
+ (* added 16/4/96 SPF *)
+@@ -401,49 +126,20 @@
+ | sameTypeVar _ = false;
+
+
+-(************* "types" constructors copied here to reduce garbage *********)
+ fun isTypeVar (TypeVar _) = true
+ | isTypeVar _ = false;
+
+- fun isTypeConstruction (TypeConstruction _) = true
+- | isTypeConstruction _ = false;
+-
+ fun isFunctionType (FunctionType _) = true
+ | isFunctionType _ = false;
+-
+- fun isLabelled (LabelledType _) = true
+- | isLabelled _ = false;
+-
++
+ fun isEmpty EmptyType = true
+ | isEmpty _ = false;
+
+- fun isBad BadType = true
+- | isBad _ = false;
++ fun isBadType BadType = true
++ | isBadType _ = false;
+
+ val emptyType = EmptyType;
+
+- type typeConstructionForm =
+- {
+- name: string,
+- value: typeConstrs ref,
+- args: types list
+- }
+-
+-
+- (* A function type takes two types, the argument and the result. *)
+- and functionTypeForm =
+- {
+- arg: types,
+- result: types
+- }
+-
+- (* A fixed labelled record. *)
+- and labelledRecForm =
+- {
+- recList: {name: string, typeof: types} list,
+- frozen: bool
+- };
+-
+ fun typesTypeVar (TypeVar x) = x
+ | typesTypeVar _ = raise Match;
+
+@@ -452,10 +148,7 @@
+
+ fun typesFunctionType (FunctionType x) = x
+ | typesFunctionType _ = raise Match;
+-
+- fun typesLabelled (LabelledType x) = x
+- | typesLabelled _ = raise Match;
+-
++
+ (* A type construction is the application of a type constructor to
+ a sequence of types to yield a type. A construction may have a nil
+ list if it is a single type identifier such as ``int''. *)
+@@ -466,25 +159,12 @@
+
+ (*************)
+
+- fun mkTypeVar (level, equality, nonunifiable, weak) =
+- TypeVar (makeTv (emptyType, level, equality, nonunifiable, weak));
+-
+- fun mkTypeConstruction (name, typc, args) =
+- let
+- (* If we're building a type construction from a known constructor
+- set it now and freeze it. If we need to find it in a later
+- pass make it a real ref. The idea is to avoid having unnecessary
+- mutable objects. *)
+- (* This is the ref hotspot in this module but has been reduced
+- considerably now we copy types before entering them in signatures.
+- It may be possible to reduce it further by copying datatype constructors. *)
+- val typeCons =
+- if isUnsetId (tcIdentifier typc)
+- then VariableRef (ref typc)
+- else FrozenRef typc
+- in
+- TypeConstruction {name = name, value = typeCons, args = args}
+- end;
++ fun mkTypeVar (level, equality, nonunifiable) =
++ TypeVar (makeTv (emptyType, level, equality, nonunifiable));
++
++ fun mkTypeConstruction (name, typc, args, locations) =
++ TypeConstruction {name = name, value = FrozenRef typc,
++ args = args, locations = locations}
+
+ local
+ (* Turn a tuple into a record of the form {1=.., 2=... }*)
+@@ -503,12 +183,12 @@
+ fun mkOverloadSet [constr] =
+ (* If there is just a single constructor in the set we make
+ a type construction from it. *)
+- mkTypeConstruction(tcName constr, constr, nil)
++ mkTypeConstruction(tcName constr, constr, nil, [])
+ | mkOverloadSet constrs =
+ let
+ (* Make a type variable and point this at the overload set
+ so we can narrow down the overloading. *)
+- val var = mkTypeVar (generalisable, false, false, false);
++ val var = mkTypeVar (generalisable, false, false);
+ val set = OverloadSet {typeset=constrs};
+ in
+ tvSetValue (typesTypeVar var, set);
+@@ -522,8 +202,8 @@
+ if frozen
+ then lab
+ else let (* Use a type variable so that the record can be expanded. *)
+- val var = mkTypeVar (generalisable, false, false, false);
+- val U : unit =
++ val var = mkTypeVar (generalisable, false, false);
++ val () =
+ if isTypeVar var
+ then tvSetValue (typesTypeVar var, lab)
+ else ();
+@@ -532,41 +212,61 @@
+ end
+ end;
+
+- (* Must remove leading zeros because the labels are compared by
+- string comparison. *)
+-
+- fun mkLabelEntry (name, t) =
+- let
+- fun stripZeros s =
+- if size s <= 1 orelse String.str(String.sub(s, 0)) <> "0"
+- then s
+- else stripZeros (String.substring(s, 1, size s-1));
+- in
+- {name = stripZeros name, typeof = t}
+- end;
++ (* Must remove leading zeros because the labels are compared by
++ string comparison. *)
++ fun mkLabelEntry (name, t) =
++ let
++ fun stripZeros s =
++ if size s <= 1 orelse String.str(String.sub(s, 0)) <> "0"
++ then s
++ else stripZeros (String.substring(s, 1, size s-1));
++ in
++ {name = stripZeros name, typeof = t}
++ end;
+
+ (* Type identifiers bound to standard type constructors. *)
+
+- val unitType = mkTypeConstruction ("unit", unitType, []);
++ val unitType = mkTypeConstruction ("unit", unitType, [], []);
+
+- val intType = mkTypeConstruction ("int", intType, []);
+- val realType = mkTypeConstruction ("real", realType, []);
+- val charType = mkTypeConstruction ("char", charType, []);
+- val stringType = mkTypeConstruction ("string", stringType, []);
+- val boolType = mkTypeConstruction ("bool", boolType, []);
+- val exnType = mkTypeConstruction ("exn", exnType, []);
+- val wordType = mkTypeConstruction ("word", wordType, []);
++ val intType = mkTypeConstruction ("int", intType, [], []);
++ val realType = mkTypeConstruction ("real", realType, [], []);
++ val charType = mkTypeConstruction ("char", charType, [], []);
++ val stringType = mkTypeConstruction ("string", stringType, [], []);
++ val boolType = mkTypeConstruction ("bool", boolType, [], []);
++ val exnType = mkTypeConstruction ("exn", exnType, [], []);
++ val wordType = mkTypeConstruction ("word", wordType, [], []);
+
+- fun isUndefined cons = isUnsetId (tcIdentifier cons);
++ fun isUndefined cons = sameTypeId (tcIdentifier cons, tcIdentifier undefType);
++ val isUndefinedTypeConstr = isUndefined
+
+- (* Similar to alphabetic ordering except that shorter labels come before longer ones.
+- This has the advantage that numerical labels are compared by their numerical order
+- i.e. 1 < 2 < 10 whereas alphabetic ordering puts "1" < "10" < "2". *)
+- fun compareLabels (a : string, b : string) : int =
++ (* Test if a type is the undefined constructor. *)
++ fun isUndefinedType(TypeConstruction{value, ...}) = isUndefined(pling value)
++ | isUndefinedType _ = false
++
++ (* Similar to alphabetic ordering except that shorter labels come before longer ones.
++ This has the advantage that numerical labels are compared by their numerical order
++ i.e. 1 < 2 < 10 whereas alphabetic ordering puts "1" < "10" < "2". *)
++ fun compareLabels (a : string, b : string) : int =
+ if size a = size b
+ then if a = b then 0 else if a < b then ~1 else 1
+ else if size a < size b then ~1 else 1;
+
++ (* Sort using the label ordering.
++ A simple sort routine - particularly if the list is already sorted. *)
++ fun sortLabels [] = []
++ | sortLabels (s::rest) =
++ let
++ fun enter s _ [] = [s]
++ | enter s name (l as ( (h as {name=hname, ...}) :: t)) =
++ let
++ val comp = compareLabels (name, hname);
++ in
++ if comp <= 0 then s :: l else h :: enter s name t
++ end;
++ in
++ enter s (#name s) (sortLabels rest)
++ end;
++
+ (* Chains down a list of type variables returning the type they are
+ bound to. As a side-effect it also points all the type variables
+ at this type to reduce the need for future chaining and to free
+@@ -585,10 +285,10 @@
+ val newVal = eventual oldVal; (* Search that *)
+ in
+ (* Update the type variable to point to the last in the chain.
+- Note: We don't do this if the value hasn't changed. It would
+- seem that doing so ought to be perfectly harmless but it
+- results in large number of expensive assignments to database
+- variables. *)
++ We don't do this if the value hasn't changed. The reason for
++ that was that assignment to refs in the database in the old
++ persistent store system was very expensive and we wanted to avoid
++ unnecessary assignments. This special case could probably be removed. *)
+ if ADDRESS.wordEq(oldVal, newVal)
+ then ()
+ else tvSetValue (tv, newVal); (* Put it on *)
+@@ -608,10 +308,8 @@
+ "createNewField:",
+ "Generic - equality=", Bool.toString(tvEquality gtv),
+ " level=", Int.toString(tvLevel gtv),
+- " weakness=", Bool.toString(tvWeak gtv),
+ " Instance - equality=", Bool.toString(tvEquality tv),
+ " level=", Int.toString(tvLevel tv),
+- " weakness=", Bool.toString(tvWeak tv),
+ "\n"
+ ]);*)
+ { name = name,
+@@ -620,8 +318,7 @@
+ unified with this instance.
+ The level is inherited from the instance since the generic
+ will always have level = generalisable. Nonunifiable must be false. *)
+- typeof = mkTypeVar (tvLevel tv, tvEquality tv orelse tvEquality gtv,
+- false, tvWeak gtv orelse tvWeak tv)
++ typeof = mkTypeVar (tvLevel tv, tvEquality tv orelse tvEquality gtv, false)
+ }
+ )
+ | createNewField _ = raise InternalError "createNewField: New field is not a type var"
+@@ -687,7 +384,7 @@
+ foldT arg (foldT result res)
+
+ | LabelledType {recList,...} =>
+- List.foldr (fn ({ name, typeof }, v) => foldT typeof v) res recList
++ List.foldr (fn ({ typeof, ... }, v) => foldT typeof v) res recList
+
+ | BadType =>
+ res
+@@ -705,21 +402,24 @@
+ (NOT type variables) *)
+ fun assignTypes
+ (t : types,
+- lookupType : string -> typeConstrs,
+- lex : lexan,
+- lineno : int)
++ lookupType : string * location -> typeConstrs,
++ lex : lexan)
+ : unit =
+ let
+ fun assTypes (typ : types) () : unit =
+ case typ of
+- TypeConstruction {name: string, value, args: types list} =>
++ TypeConstruction {name: string, value, args: types list, locations} =>
+ (* Assign constructor, then the parameters. *)
+ if isUndefined (pling value)
+ then
+- let
++ let
++ val location =
++ case List.find(fn (DeclaredAt _) => true | _ => false) locations of
++ SOME(DeclaredAt loc) => loc
++ | _ => LEX.nullLocation
+ (* Must check that it has not already been set -
+ We might have unitType from an empty record. *)
+- val constructor : typeConstrs = lookupType name;
++ val constructor : typeConstrs = lookupType (name, location);
+ in
+ updatePR(value, constructor);
+ (* Check that it has the correct arity. *)
+@@ -731,7 +431,7 @@
+ in
+ if arity <> num
+ then (* Give an error message *)
+- errorMessage (lex, lineno,
++ errorMessage (lex, location,
+ String.concat["Type constructor (", tcName constructor,
+ ") requires ", Int.toString arity, " type(s) not ",
+ Int.toString num])
+@@ -751,252 +451,341 @@
+ considered as tuples. *)
+ fun isProductType(LabelledType{recList=recList as _::_::_, frozen=true, ...}) =
+ let
+- fun isRec [] n = true
+- | isRec ({name, typeof} :: l) n =
++ fun isRec [] _ = true
++ | isRec ({name, ...} :: l) n =
+ name = Int.toString n andalso isRec l (n+1)
+ in
+ isRec recList 1
+ end
+ | isProductType _ = false;
+
++
++ (* Test to see is a type constructor is in an overload set. *)
++ fun isInSet(tcons: typeConstrs, (H::T): typeConstrs list) =
++ sameTypeId (tcIdentifier tcons, tcIdentifier H) orelse isInSet(tcons, T)
++ | isInSet(_, []: typeConstrs list) = false
++
++ (* Returns the preferred overload if there is one. *)
++ fun preferredOverload typeset =
++ if isInSet(STRUCTVALS.intType, typeset)
++ then SOME STRUCTVALS.intType
++ else if isInSet(STRUCTVALS.realType, typeset)
++ then SOME STRUCTVALS.realType
++ else if isInSet(STRUCTVALS.wordType, typeset)
++ then SOME STRUCTVALS.wordType
++ else if isInSet(STRUCTVALS.charType, typeset)
++ then SOME STRUCTVALS.charType
++ else if isInSet(STRUCTVALS.stringType, typeset)
++ then SOME STRUCTVALS.stringType
++ else NONE
++
++
+ (* Basic procedure to print a type structure. *)
++ type printTypeEnv =
++ { lookupType: string -> (typeConstrs * (int->typeId) option) option,
++ lookupStruct: string -> (structVals * (int->typeId) option) option}
++
++ val emptyTypeEnv = { lookupType = fn _ => NONE, lookupStruct = fn _ => NONE }
+
+- (* prints a block of items *)
+- fun tDisp
+- (t : types,
+- depth : int,
+- pprint: prettyPrinter,
+- typeVarName : typeVarForm -> string,
+- withStructName)
+- : unit =
+- let
+ (* prints a block of items *)
+- fun dispP (t : types, depth : int) : unit =
++ fun tDisp (t : types, depth : int, typeVarName : typeVarForm -> string, env: printTypeEnv,
++ sigMap: (int->typeId)option) : pretty =
+ let
+- (* prints a block of items *)
+- fun parenthesise depth t =
+- if depth <= 1
+- then ppAddString pprint "..."
+- else
+- (
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint "(";
+- ppBreak pprint (0, 0);
+- dispP (t, depth - 1);
+- ppBreak pprint (0, 0);
+- ppAddString pprint ")";
+- ppEndBlock pprint ()
+- );
+-
+- (* prints a sequence of items *)
+- fun prettyList [] depth separator = ()
+-
+- | prettyList [H] depth separator =
+- let
+- val v = eventual H;
+- in
+- if separator = "*" andalso
+- (isFunctionType v orelse isProductType v)
+- then (* Must bracket the expression *) parenthesise depth v
+- else dispP (v, depth)
+- end
++ (* prints a block of items *)
++ fun dispP (t : types, depth : int) : pretty =
++ let
++ (* prints a block of items *)
++ fun parenthesise depth t =
++ if depth <= 1
++ then PrettyString "..."
++ else
++ PrettyBlock (0, false, [],
++ [
++ PrettyString "(",
++ PrettyBreak (0, 0),
++ dispP (t, depth - 1),
++ PrettyBreak (0, 0),
++ PrettyString ")"
++ ]);
++
++ (* prints a sequence of items *)
++ fun prettyList [] _ _: pretty list = []
+
+- | prettyList (H :: T) depth separator =
+- if depth <= 0
+- then ppAddString pprint "..."
+- else let
+- val v = eventual H;
+- in
+- ppBeginBlock pprint (0, false);
+-
+- if separator = "*" andalso
+- (isFunctionType v orelse isProductType v)
+- then (* Must bracket the expression *) parenthesise depth v
+- else dispP (v, depth);
+-
+- ppBreak pprint (if separator = "," then 0 else 1, 0);
+- ppAddString pprint separator;
+- ppEndBlock pprint ();
+-
+- ppBreak pprint (1, 0);
+- prettyList T (depth - 1) separator
+- end;
++ | prettyList [H] depth separator =
++ let
++ val v = eventual H;
++ in
++ if separator = "*" andalso
++ (isFunctionType v orelse isProductType v)
++ then (* Must bracket the expression *) [parenthesise depth v]
++ else [dispP (v, depth)]
++ end
++
++ | prettyList (H :: T) depth separator =
++ if depth <= 0
++ then [PrettyString "..."]
++ else
++ let
++ val v = eventual H;
++ in
++ PrettyBlock (0, false, [],
++ [(if separator = "*" andalso
++ (isFunctionType v orelse isProductType v)
++ then (* Must bracket the expression *) parenthesise depth v
++ else dispP (v, depth)),
++ PrettyBreak (if separator = "," then 0 else 1, 0),
++ PrettyString separator
++ ]) ::
++ PrettyBreak (1, 0) ::
++ prettyList T (depth - 1) separator
++ end;
+
+- val typ = eventual t; (* Find the real type structure *)
+- in
+- case typ of
+- TypeVar tyVar =>
+- let
+- val tyVal : types = tvValue tyVar;
+- in
+- case tyVal of
+- EmptyType => ppAddString pprint (typeVarName tyVar)
+- | _ => dispP (tyVal, depth)
+- end
++ val typ = eventual t; (* Find the real type structure *)
++ in
++ case typ of
++ TypeVar tyVar =>
++ let
++ val tyVal : types = tvValue tyVar;
++ in
++ case tyVal of
++ EmptyType => PrettyString (typeVarName tyVar)
++ | _ => dispP (tyVal, depth)
++ end
+
+- (* Type construction with no arguments *)
+- | TypeConstruction {args = [], name, value, ...} =>
+- let
+- val constrName = if isUndefined(pling value) then name else tcName(pling value)
+- in
+- (* When printing a type constructor we remove any structure name if the option
+- is not set. *)
+- ppAddString pprint
+- (if withStructName then constrName else #second(splitString constrName))
+- end
+-
+- (* Type construction with one or more arguments - print out as (a, b, c) cons *)
+- | TypeConstruction {args, name, value, ...} =>
+- if depth <= 0
+- then ppAddString pprint "..."
+- else
+- let
+- val argVal = eventual (hd args);
+- val T = tl args;
+- (* Use the name of the type constructor to which this is bound
+- if it is defined. *)
+- val tcName =
+- if isUndefined(pling value) then name else tcName(pling value)
+- in
+- ppBeginBlock pprint (0, false);
+-
+- if not (null T) orelse
+- isProductType argVal orelse
+- isFunctionType argVal
+- then (* parenthesise if there is more than one
+- or if it is a product or function type. *)
+- if depth <= 1
+- then ppAddString pprint "..."
+- else
+- (
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint "(";
+- ppBreak pprint (0, 0);
+- prettyList args (depth - 1) ",";
+- ppBreak pprint (0, 0);
+- ppAddString pprint ")";
+- ppEndBlock pprint ()
+- )
+- else dispP (argVal, depth - 1);
+-
+- ppBreak pprint (1, 0);
+- ppAddString pprint tcName;
+- ppEndBlock pprint ()
+- end
++ (* Type construction. *)
++ | TypeConstruction {args, name, value, ...} =>
++ let
++ val typeConstructor = pling value
++ val constrName = (* Use the type constructor name unless we're had an error. *)
++ if isUndefined typeConstructor then name else tcName typeConstructor
++
++ val mappedTypeId =(*tcIdentifier typeConstructor*)
++ case (sigMap, tcIdentifier typeConstructor) of
++ (SOME map, Bound{offset, ...}) => map offset
++ | (_, id) => id
++
++ (* If we're printing a value that refers to a type constructor we
++ want to print the correct amount of any structure prefix for the
++ current context. *)
++ fun findType (_, []) = false
++ | findType ({ lookupType, ... }, [typeName]) =
++ (
++ (* This must be the name of a type. *)
++ case lookupType typeName of
++ SOME (t, map) =>
++ (* TODO: If these are type-functions they won't match. *)
++ let
++ val typeId = tcIdentifier t
++ val mId =
++ case (map, typeId) of
++ (SOME map, Bound { offset, ... }) => map offset
++ | (_, id) => id
++ in
++ sameTypeId(mId, mappedTypeId)
++ (* sameTypeId always returns false for TypeFunction. *)
++ end
++ | NONE => false
++ )
++ | findType ({ lookupStruct, ... }, structName :: tail) =
++ (
++ (* This must be the name of a structure. Does it contain our type? *)
++ case lookupStruct structName of
++ SOME(str, map) =>
++ let
++ val Signatures { tab, typeIdMap, ...} = structSignat str
++ val Env { lookupType, lookupStruct, ...} = makeEnv tab
++ val newMap =
++ case map of
++ SOME map =>
++ (
++ (* This is a reduced version of COPIER.composeMaps that
++ doesn't handle TypeFunctions. That's not a problem
++ since sameTypeId doesn't work for TypeFunction. *)
++ fn n =>
++ case typeIdMap n of
++ Bound { offset, ...} => map offset
++ | id => id
++ )
++ | NONE => typeIdMap
++ fun subLookupType s =
++ case lookupType s of NONE => NONE | SOME t => SOME(t, SOME newMap)
++ fun subLookupStruct s =
++ case lookupStruct s of NONE => NONE | SOME t => SOME(t, SOME newMap)
++ in
++ findType({lookupType=subLookupType, lookupStruct=subLookupStruct}, tail)
++ end
++ | NONE => false
++ )
++
++ (* See if we have this type in the current environment or in some structure in
++ the current environment. The name we have may be a full structure path. *)
++ fun nameToList ("", l) = (l, false) (* Not there. *)
++ | nameToList (s, l) =
++ let
++ val { first, second } = splitString s
++ val currentList = second :: l
++ in
++ if findType(env, currentList)
++ then (currentList, true)
++ else nameToList(first, currentList)
++ end
++ (* TODO: If this is a type function it won't have matched. *)
++ (* Because of delayed copying the constructor name is not likely to be
++ qualified. That could well be a problem for type functions in particular
++ because we don't have a type identifier to fall back on. *)
++ val names =
++ case nameToList(constrName, []) of
++ (names, true) => names (* Found the type constructor name. *)
++ | (names, false) =>
++ let
++ (* Try the type identifier name. *)
++ val idName =
++ case mappedTypeId of
++ Free { description = { name, ...}, ...} => name
++ | Bound { description = { name, ...}, ...} => name
++ | TypeFunction _ => ""
++ in
++ if idName = "" then names
++ else
++ case nameToList(idName, []) of
++ (idNames, true) => idNames
++ | (_, _) => names (*@ ["(*N*)"]*) (* Temporary marker *)(* Use the type constructor name anyway. *)
++ end
++ val newName = String.concatWith "." names
++ (* TODO: If we don't find the type we want we should:
++ 1. If it's a type equivalence apply that.
++ 2. Report this in much more detail. Perhaps the type has
++ been hidden e.g. by a type with the same name. *)
++ (* Get the declaration position for the type constructor. *)
++ val constrContext =
++ if isUndefined(pling value) then []
++ else
++ (
++ case List.find(fn DeclaredAt _ => true | _ => false) (tcLocations(pling value)) of
++ SOME(DeclaredAt loc) => [ContextLocation loc]
++ | _ => []
++ )
++ val constructorEntry =
++ PrettyBlock(0, false, constrContext, [PrettyString newName(*constrName*)])
++ in
++ case args of
++ [] => constructorEntry
++ | args as hd :: tl =>
++ let
++ val argVal = eventual hd;
++ in
++ PrettyBlock (0, false, [],
++ [
++ (* If we have just a single argument and it's just a type constructor
++ or a construction we don't need to parenthesise it. *)
++ if null tl andalso not (isProductType argVal orelse isFunctionType argVal)
++ then dispP (argVal, depth - 1)
++ else if depth <= 1
++ then PrettyString "..."
++ else PrettyBlock(0, false, [],
++ [PrettyString "(", PrettyBreak (0, 0)]
++ @ prettyList args (depth - 1) ","
++ @ [PrettyBreak (0, 0), PrettyString ")"]
++ ),
++ PrettyBreak(1, 0),
++ constructorEntry (* The constructor. *)
++ ])
++ end
++ end
+
+- | FunctionType {arg, result} =>
+- if depth <= 0
+- then ppAddString pprint "..."
+- else
+- (* print out in infix notation *)
+- let
+- val evArg = eventual arg;
+- in
+- ppBeginBlock pprint (0, false);
+-
+- (* If the argument is a function it must be printed as (a-> b)->.. *)
+- if isFunctionType evArg
+- then parenthesise depth evArg
+- else dispP (evArg, depth - 1);
+-
+- ppBreak pprint (1, 0);
+- ppAddString pprint "->";
+- ppBreak pprint (1, 0);
+- dispP (result, depth - 1);
+-
+- ppEndBlock pprint ()
+- end
++ | FunctionType {arg, result} =>
++ if depth <= 0
++ then PrettyString "..."
++ else (* print out in infix notation *)
++ let
++ val evArg = eventual arg;
++ in
++ PrettyBlock (0, false, [],
++ [
++ (* If the argument is a function it must be printed as (a-> b)->.. *)
++ if isFunctionType evArg
++ then parenthesise depth evArg
++ else dispP (evArg, depth - 1),
++ PrettyBreak(1, 0),
++ PrettyString "->",
++ PrettyBreak (1, 0),
++ dispP (result, depth - 1)
++ ])
++ end
+
+- | LabelledType {recList, frozen, ...} =>
+- if depth <= 0
+- then ppAddString pprint "..."
+- else if isProductType typ
+- then (* Print as a product *)
+- (
+- ppBeginBlock pprint (0, false) (* Print them as t1 * t2 * t3 .... *);
+- prettyList (map (fn {name, typeof} => typeof) recList) depth "*";
+- ppEndBlock pprint ()
+- )
+- else (* Print as a record *)
+- (
+- ppBeginBlock pprint (2, false);
+- ppAddString pprint "{";
+- let
+- fun pRec [] depth = ()
+- | pRec ({name, typeof} :: T) depth =
+- if depth <= 0 then ppAddString pprint "..."
+- else
+- (
+- ppBeginBlock pprint (0, false);
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint (name ^ ":");
+- ppBreak pprint (1, 0);
+- dispP (typeof, depth - 1);
+- ppEndBlock pprint ();
+- if null T then ()
+- else
+- (
+- ppBreak pprint (0, 0);
+- ppAddString pprint ","
+- );
+-
+- ppEndBlock pprint ();
+- if null T then ()
+- else
+- (
+- ppBreak pprint (1, 0);
+- pRec T (depth-1)
+- )
+- )
+- in
+- pRec recList (depth - 1)
+- end;
+-
+- if not frozen
+- then let
+- val dots =
+- case recList of
+- [] => "..."
+- | _ => ", ..."
+- in
+- ppAddString pprint dots
+- end
+- else ();
+-
+- ppAddString pprint "}";
+- ppEndBlock pprint ()
+- )
++ | LabelledType {recList, frozen, ...} =>
++ if depth <= 0
++ then PrettyString "..."
++ else if isProductType typ
++ then (* Print as a product *)
++ PrettyBlock (0, false, [], (* Print them as t1 * t2 * t3 .... *)
++ prettyList (map (fn {typeof, ...} => typeof) recList) depth "*")
++ else (* Print as a record *)
++ PrettyBlock (2, false, [],
++ PrettyString "{" ::
++ (let
++ fun pRec [] _ = []
++ | pRec ({name, typeof} :: T) depth =
++ if depth <= 0 then [PrettyString "..."]
++ else
++ [
++ PrettyBlock(0, false, [],
++ [
++ PrettyBlock(0, false, [],
++ [
++ PrettyString (name ^ ":"),
++ PrettyBreak(1, 0),
++ dispP(typeof, depth - 1)
++ ] @
++ (if null T then [] else [PrettyBreak (0, 0), PrettyString ","])
++ )
++ ]@
++ (if null T then [] else PrettyBreak (1, 0) :: pRec T (depth-1))
++ )
++ ]
++ in
++ pRec recList (depth - 1)
++ end) @
++ [ PrettyString (if frozen then "}" else case recList of [] => "...}" | _ => ", ...}")]
++ )
+
+- | OverloadSet {typeset = []} => ppAddString pprint "no type"
++ | OverloadSet {typeset = []} => PrettyString "no type"
+
+- | OverloadSet {typeset = tconslist} =>
+- (* Just print the type constructors separated by / *)
+- let
+- fun printTCcons [] = ()
+- | printTCcons [tcons] = ppAddString pprint (tcName tcons)
+- | printTCcons (tcons::rest) =
+- (
+- ppAddString pprint (tcName tcons);
+- ppBreak pprint (0, 0);
+- ppAddString pprint "/";
+- printTCcons rest
+- )
+- in
+- ppBeginBlock pprint (0, false);
+- printTCcons tconslist;
+- ppEndBlock pprint ()
+- end
++ | OverloadSet {typeset = tconslist} =>
++ (* This typically arises when printing error messages in the second pass because
++ the third pass will select a single type e.g. int where possible. To
++ simplify the messages select a single type if possible. *)
++ (
++ case preferredOverload tconslist of
++ SOME tcons => dispP(mkTypeConstruction (tcName tcons, tcons,[], []), depth)
++ | NONE =>
++ (* Just print the type constructors separated by / *)
++ let
++ fun constrLocation tcons =
++ case List.find(fn DeclaredAt _ => true | _ => false) (tcLocations tcons) of
++ SOME(DeclaredAt loc) => [ContextLocation loc]
++ | _ => []
++ (* Type constructor with context. *)
++ fun tconsItem tcons =
++ PrettyBlock(0, false, constrLocation tcons, [PrettyString(tcName tcons)])
++
++ fun printTCcons [] = []
++ | printTCcons [tcons] = [tconsItem tcons]
++ | printTCcons (tcons::rest) =
++ tconsItem tcons :: PrettyBreak (0, 0) ::
++ PrettyString "/" :: printTCcons rest
++ in
++ PrettyBlock (0, false, [], printTCcons tconslist)
++ end
++ )
+
+- | EmptyType =>
+- ppAddString pprint "no type"
++ | EmptyType => PrettyString "no type"
+
+- | BadType =>
+- ppAddString pprint "bad"
+- end (* dispP *)
+- in
+- dispP (t, depth)
+- end (* tDisp *);
+-
++ | BadType => PrettyString "bad"
++ end (* dispP *)
++ in
++ dispP (t, depth)
++ end (* tDisp *);
+
+ (* Generate unique type-variable names. *)
+
+@@ -1018,8 +807,7 @@
+ fun name num = (if num >= 26 then name (num div 26 - 1) else "")
+ ^ String.str (Char.chr (num mod 26 + Char.ord #"a"));
+ val () = nameNum := !nameNum + 1;
+- val n = (if tvEquality var then "''" else "'") ^
+- (*(if ml90 lex andalso tvWeak var then "_" else "") ^*) name(!nameNum);
++ val n = (if tvEquality var then "''" else "'") ^ name(!nameNum);
+ (* Should explicit type variables be distinguished? *)
+ in
+ gNameList := Names{name=n, entry=var} :: !gNameList;
+@@ -1031,194 +819,320 @@
+
+
+ (* Print a type (as a block of items) *)
+- fun display (t : types, depth : int, pprint : prettyPrinter, withStruct) =
+- tDisp (t, depth, pprint, varNameSequence (), withStruct)
+-
++ fun displayWithMap (t : types, depth : int, env, sigMap) =
++ tDisp (t, depth, varNameSequence (), env, sigMap)
++ and display (t : types, depth : int, env) =
++ tDisp (t, depth, varNameSequence (), env, NONE)
+
+ (* Print out one or more type variables (unblocked) *)
+ fun printTypeVars
+- (vars : types list,
++ (vars : typeVarForm list,
+ depth : int,
+- typeV : typeVarForm -> string,
+- pprint : prettyPrinter,
+- withStruct)
+- : unit =
++ typeV : typeVarForm -> string)
++ : pretty list =
+ let
+ val numOfVars = length vars;
+ in
+ (* Just print the variable *)
+ if numOfVars = 1
+ then
+- (
+- tDisp (hd vars, depth, pprint, typeV, withStruct);
+- ppBreak pprint (1, 0)
+- )
+- else
+- (
+- if numOfVars > 1
+- then (* Must parenthesise them. *)
+- if depth <= 1
+- then ppAddString pprint "..."
+- else
+- (
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint "(";
+- ppBreak pprint (0, 0);
+- let
+- fun pVars vars depth =
+- if depth <= 0 then ppAddString pprint "..."
+- else if not (null vars)
+- then
+- (
+- tDisp (hd vars, depth, pprint, typeV, withStruct);
+- ppBreak pprint (0, 0);
+- if not (null (tl vars))
+- then
+- (
+- ppAddString pprint ",";
+- ppBreak pprint (1, 0);
+- pVars (tl vars) (depth - 1)
+- )
+- else ()
+- )
+- else ()
+- in
+- pVars vars depth
+- end;
++ [
++ tDisp (TypeVar(hd vars), depth, typeV, emptyTypeEnv, NONE),
++ PrettyBreak (1, 0)
++ ]
++ else if numOfVars > 1
++ then (* Must parenthesise them. *)
++ if depth <= 1 then [PrettyString "..."]
++ else
++ [
++ PrettyBlock(0, false, [],
++ PrettyString "(" ::
++ PrettyBreak(0, 0) ::
++ (let
++ fun pVars vars depth: pretty list =
++ if depth <= 0 then [PrettyString "..."]
++ else if null vars then []
++ else
++ [
++ tDisp (TypeVar(hd vars), depth, typeV, emptyTypeEnv, NONE),
++ PrettyBreak (0, 0)
++ ] @
++ (if null (tl vars) then []
++ else PrettyString "," :: PrettyBreak (1, 0) :: pVars (tl vars) (depth - 1)
++ )
++ in
++ pVars vars depth
++ end) @ [PrettyString ")"]
++ ),
++ PrettyBreak (1, 0)
++ ]
+
+- ppAddString pprint ")";
+- ppEndBlock pprint ();
+- ppBreak pprint (1, 0)
+- )
+- else ()
+- )
++ else (* numVars < 1 *) []
+ end (* printTypeVars *);
+
+
+ (* Version used in parsetree. *)
+- fun displayTypeVariables
+- (vars : types list,
+- depth : int,
+- pprint : prettyPrinter, withStruct)
+- : unit =
+- printTypeVars (vars, depth, varNameSequence (), pprint, withStruct);
++ fun displayTypeVariables (vars : typeVarForm list, depth : int) =
++ printTypeVars (vars, depth, varNameSequence ())
+
+
+ (* Prints out a type constructor e.g. type 'a fred = 'a * 'a
+ or datatype 'a joe = bill of 'a list | mary of 'a * int or
+ simply type 'a abs if the type is abstract. *)
+- fun displayTypeConstrs
+- (tCons : typeConstrs,
+- depth : int,
+- pprint : prettyPrinter,
+- withStruct)
+- : unit =
++ fun displayTypeConstrsWithMap (tCons : typeConstrs, depth : int, typeEnv, sigMap) : pretty =
+ let
+ val typeV : typeVarForm -> string = varNameSequence ();
+ in
+ if depth <= 0
+- then ppAddString pprint "..."
++ then PrettyString "..."
+ else if not (null (tcConstructors tCons))
+ then let (* It has constructors - datatype declaration *)
+ (* Print a single constructor (blocked) *)
+- fun pValConstr (first, name, typeOf, depth) =
+- let
+- val U : unit =
+- if first then ppBreak pprint (1, 2) else ppBreak pprint (1, 0)
+- in
+- (* 1 *) ppBeginBlock pprint (0, false);
+-
+- (* 2 *) ppBeginBlock pprint (0, false);
+- if first
+- then ppBreak pprint (0, 2)
+- else let
+- in
+- (* 3 *) ppBeginBlock pprint (0, false);
+- ppAddString pprint "|";
+- ppBreak pprint (1, 2);
+- (* 3 *) ppEndBlock pprint ()
+- end;
+-
+- if depth <= 0
+- then ppAddString pprint "..."
+- else let
+- in
+- ppAddString pprint name;
+-
+- (* Function - get the argument type *)
+- if isFunctionType typeOf
+- then
+- (
+- ppBreak pprint (1, 4);
+- ppAddString pprint "of"
+- )
+- else ()
+- end;
+- (* 2 *) ppEndBlock pprint ();
+-
+-
+- if isFunctionType typeOf andalso depth > 0
+- then
+- (
+- ppBreak pprint (1, 4);
+- (* print the type as a single block of output *)
+- tDisp (#arg (typesFunctionType typeOf), depth - 1, pprint, typeV, withStruct)
+- )
+- else ();
+-
+- (* 1 *) ppEndBlock pprint ()
+- end; (* pValConstr *)
++ fun pValConstr (first, name, typeOf, depth): pretty list =
++ [
++ PrettyBreak (1, if first then 2 else 0),
++ PrettyBlock (0, false, [],
++ PrettyBlock (0, false, [],
++ (if first then PrettyBreak (0, 2)
++ else PrettyBlock (0, false, [], [PrettyString "|", PrettyBreak(1, 2)])
++ ) ::
++ (if depth <= 0 then [PrettyString "..."]
++ else
++ PrettyString name ::
++ ( (* Function - get the argument type *)
++ if isFunctionType typeOf
++ then [PrettyBreak (1, 4), PrettyString "of"]
++ else []
++ )
++ )
++ ) ::
++ (if isFunctionType typeOf andalso depth > 0
++ then
++ [
++ PrettyBreak (1, 4),
++ (* print the type as a single block of output *)
++ tDisp (#arg (typesFunctionType typeOf), depth - 1, typeV, typeEnv, sigMap)
++ ]
++ else [])
++ )
++ ]; (* pValConstr *)
+
+ (* Print a sequence of constructors (unblocked) *)
+- fun pValConstrRest ([], depth) = ()
+- | pValConstrRest (H :: T, depth) =
+- if depth < 0
+- then ()
+- else let
+- in
+- pValConstr (false, valName H, valTypeOf H, depth);
+- pValConstrRest (T, depth - 1)
+- end;
++ fun pValConstrRest ([], _ ): pretty list = []
++ | pValConstrRest (H :: T, depth): pretty list =
++ if depth < 0 then []
++ else
++ pValConstr (false, valName H, valTypeOf H, depth) @
++ pValConstrRest (T, depth - 1)
+
+- fun pValConstrList ([], depth) = () (* shouldn't occur *)
++ fun pValConstrList ([], _ ) = PrettyString "" (* shouldn't occur *)
+ | pValConstrList (H :: T, depth) =
+- let
+- in
+- ppBeginBlock pprint (2, true);
+- pValConstr (true, valName H, valTypeOf H, depth);
+- pValConstrRest (T, depth - 1);
+- ppEndBlock pprint ()
+- end;
+- (* Remove any structure name. *)
+- val tcname = #second(splitString(tcName tCons))
+- in
+- ppBeginBlock pprint (0, false);
+-
+- ppAddString pprint "datatype";
+- ppBreak pprint (1, 2);
+- printTypeVars (tcTypeVars tCons, depth, typeV, pprint, withStruct);
+- ppAddString pprint (tcname ^ " =");
+- pValConstrList (tcConstructors tCons, depth - 1);
+-
+- ppEndBlock pprint ()
+- end
+-
+- else (* Either direct type equivalent, or an abstract type *)
+- let
+- (* Remove any structure name. *)
+- val tcname = #second(splitString(tcName tCons))
+- in
+- ppBeginBlock pprint (3, false);
+- ppAddString pprint (if tcEquality tCons then "eqtype" else "type");
+- ppBreak pprint (1, 0);
+- printTypeVars (tcTypeVars tCons, depth, typeV, pprint, withStruct);
+- ppAddString pprint tcname;
+- (* Don't try to print the type it is equivalent to, it will probably
+- be confusing if this is the result of a functor application. *)
+- ppEndBlock pprint ()
++ PrettyBlock (2, true, [],
++ pValConstr (true, valName H, valTypeOf H, depth) @
++ pValConstrRest (T, depth - 1)
++ )
++
++ in
++ PrettyBlock(0, false, [],
++ [
++ PrettyBlock(0, false, [],
++ PrettyString "datatype" ::
++ PrettyBreak (1, 2) ::
++ printTypeVars (tcTypeVars tCons, depth, typeV) @
++ [ PrettyString(#second(splitString(tcName tCons))), PrettyBreak(1, 0), PrettyString "=" ]
++ ),
++ pValConstrList (tcConstructors tCons, depth - 1)
++ ]
++ )
+ end
+- end (* displayTypeConstrs *);
+
++ else if tcIsAbbreviation tCons
++ then
++ let
++ val typeV = varNameSequence () (* Local sequence for this binding. *)
++ in
++ PrettyBlock (3, false, [],
++ PrettyString (
++ if not(tcIsAbbreviation tCons) andalso tcEquality tCons then "eqtype" else "type") ::
++ PrettyBreak (1, 0) ::
++ printTypeVars (tcTypeVars tCons, depth, typeV) @
++ [
++ PrettyString (#second(splitString(tcName tCons))),
++ PrettyBreak(1, 0),
++ PrettyString "=",
++ PrettyBreak(1, 0),
++ tDisp(tcEquivalent tCons, depth-1, typeV, typeEnv, sigMap)
++ ]
++ )
++ end
++ else (* An abstract type or a type bound to another type name. *)
++ PrettyBlock (3, false, [],
++ PrettyString (
++ if tcEquality tCons then "eqtype" else "type") ::
++ PrettyBreak (1, 0) ::
++ printTypeVars (tcTypeVars tCons, depth, typeV) @
++ [PrettyString (#second(splitString(tcName tCons)))]
++ )
++ end (* displayTypeConstrsWithMap *);
++
++ fun displayTypeConstrs (tCons : typeConstrs, depth : int, typeEnv) : pretty =
++ displayTypeConstrsWithMap(tCons, depth, typeEnv, NONE)
++
++ (* Parse tree for types. This is used to represent types in the source. *)
++ datatype typeParsetree =
++ ParseTypeConstruction of
++ { typeof: types, args: typeParsetree list,
++ location: location, nameLoc: location, argLoc: location }
++ | ParseTypeProduct of
++ { typeof: types, fields: typeParsetree list, location: location }
++ | ParseTypeFunction of
++ { typeof: types, argType: typeParsetree, resultType: typeParsetree, location: location }
++ | ParseTypeLabelled of
++ { typeof: types, fields: ((string * location) * typeParsetree * location) list,
++ frozen: bool, location: location }
++ | ParseTypeId of
++ { typeof: types, location: location }
++ | ParseTypeBad (* Place holder for errors. *)
++
++ fun typeFromTypeParse(ParseTypeConstruction{ typeof, ...}) = typeof
++ | typeFromTypeParse(ParseTypeProduct{ typeof, ...}) = typeof
++ | typeFromTypeParse(ParseTypeFunction{ typeof, ...}) = typeof
++ | typeFromTypeParse(ParseTypeLabelled{ typeof, ...}) = typeof
++ | typeFromTypeParse(ParseTypeId{ typeof, ...}) = typeof
++ | typeFromTypeParse(ParseTypeBad) = BadType
++
++ fun makeParseTypeConstruction((constrName, nameLoc), (args, argLoc), location) =
++ let
++ val argTypes = List.map typeFromTypeParse args
++ val construction =
++ TypeConstruction {name = constrName, value = VariableRef (ref undefType),
++ args = argTypes, locations = [DeclaredAt location]}
++ in
++ ParseTypeConstruction{
++ typeof = construction, nameLoc = nameLoc, args = args, argLoc = argLoc, location = location }
++ end
++
++ fun makeParseTypeProduct(fieldList, location) =
++ let
++ val fieldTypes = List.map typeFromTypeParse fieldList
++ val tuple = mkProductType fieldTypes
++ in
++ ParseTypeProduct{ typeof = tuple, fields = fieldList, location = location }
++ end
++
++ fun makeParseTypeFunction(arg, result, location) =
++ let
++ val function =
++ mkFunctionType(typeFromTypeParse arg, typeFromTypeParse result)
++ in
++ ParseTypeFunction{ typeof = function, argType = arg, resultType = result, location = location }
++ end
++
++ fun makeParseTypeLabelled(fieldList, frozen, location) =
++ let
++ fun makeField((name, _), t, _) = mkLabelEntry(name, typeFromTypeParse t)
++ val fieldTypes = sortLabels(List.map makeField fieldList)
++ val labelled = mkLabelled(fieldTypes, frozen)
++ in
++ ParseTypeLabelled{ typeof = labelled, fields = fieldList, frozen = frozen, location = location }
++ end
++
++ fun makeParseTypeId(types, location) =
++ ParseTypeId{ typeof = TypeVar types, location = location }
++
++ fun unitTree location =
++ ParseTypeConstruction{
++ typeof = unitType, args = [], argLoc = location, location = location, nameLoc = location }
++
++ (* Build an export tree from the parse tree. *)
++ fun typeExportTree(navigation, p: typeParsetree) =
++ let
++ val typeof = typeFromTypeParse p
++
++ (* Common properties for navigation and printing. *)
++ val commonProps =
++ PTprint(fn d => display(typeof, d, emptyTypeEnv)) ::
++ PTtype typeof ::
++ exportNavigationProps navigation
++
++ fun asParent () = typeExportTree(navigation, p)
++
++ in
++ case p of
++ ParseTypeConstruction{ location, typeof, nameLoc, args, argLoc, ...} =>
++ let
++ (* If the constructor has been bound return the declaration location. *)
++ val (name, decLoc) =
++ case typeof of
++ TypeConstruction { value, name, ...} =>
++ if isUndefined (pling value)
++ then (name, [])
++ else (name, mapLocationProps(tcLocations(pling value)))
++ | _ => ("", []) (* Error? *)
++ val navNameAndArgs =
++ (* Separate cases for nullary, unary and higher type constructions. *)
++ case args of
++ [] => [] (* Singleton e.g. int *)
++ | [oneArg] =>
++ let (* Single arg e.g. int list. *)
++ (* Navigate between the type constructor and the argument.
++ Since the arguments come before the constructor we go there first. *)
++ fun getArg () =
++ typeExportTree({parent=SOME asParent, previous=NONE, next=SOME getName}, oneArg)
++ and getName () =
++ getStringAsTree({parent=SOME asParent, previous=SOME getArg, next=NONE},
++ name, nameLoc, [])
++ in
++ [PTfirstChild getArg]
++ end
++ | args =>
++ let (* Multiple arguments e.g. (int, string) pair *)
++ fun getArgs () =
++ (argLoc,
++ exportList(typeExportTree, SOME getArgs) args @
++ exportNavigationProps{parent=SOME asParent, previous=NONE, next=SOME getName})
++ and getName () =
++ getStringAsTree({parent=SOME asParent, previous=SOME getArgs, next=NONE},
++ name, nameLoc, [])
++ in
++ [PTfirstChild getArgs]
++ end
++ in
++ (location, navNameAndArgs @ decLoc @ commonProps)
++ end
++
++ | ParseTypeProduct{ location, fields, ...} =>
++ (location, exportList(typeExportTree, SOME asParent) fields @ commonProps)
++
++ | ParseTypeFunction{ location, argType, resultType, ...} =>
++ (location, exportList(typeExportTree, SOME asParent) [argType, resultType] @ commonProps)
++
++ | ParseTypeLabelled{ location, fields, ...} =>
++ let
++ fun exportField(navigation, label as ((name, nameLoc), t, fullLoc)) =
++ let
++ (* The first position is the label, the second the type *)
++ fun asParent () = exportField (navigation, label)
++ fun getLab () =
++ getStringAsTree({parent=SOME asParent, next=SOME getType, previous=NONE},
++ name, nameLoc, [PTtype(typeFromTypeParse t)])
++ and getType () =
++ typeExportTree({parent=SOME asParent, previous=SOME getLab, next=NONE}, t)
++ in
++ (fullLoc, PTfirstChild getLab :: exportNavigationProps navigation)
++ end
++ in
++ (location, exportList(exportField, SOME asParent) fields @ commonProps)
++ end
++
++ | ParseTypeId{ location, ...} =>
++ (location, commonProps)
++
++ | ParseTypeBad =>
++ (nullLocation, commonProps)
++ end
++
++
+ (* When we have finished processing a list of patterns we need to check
+ that the record is now frozen. *)
+
+@@ -1228,38 +1142,6 @@
+ | recordNotFrozen (LabelledType { frozen, ... }) = not frozen
+ | recordNotFrozen _ = false (* record or type alias *);
+
+-
+- fun matchError
+- (s1 : string, alpha : types, s2 : string, beta : types, s3 : string,
+- lex : lexan, lineno : int, moreInfo : prettyPrinter -> unit) : unit =
+- (
+- errorProc (lex, lineno,
+- fn (pprint : prettyPrinter) =>
+- let
+- (* Use a single sequence. *)
+- val vars : typeVarForm -> string = varNameSequence ();
+- open DEBUG
+- val parameters = LEX.debugParams lex
+- val errorDepth = getParameter errorDepthTag parameters
+- in
+- ppBeginBlock pprint (3, false);
+- ppAddString pprint s1;
+- ppBreak pprint (1, 0);
+- tDisp (alpha, errorDepth, pprint, vars, true);
+- ppBreak pprint (1, 0);
+- ppAddString pprint s2;
+- ppBreak pprint (1, 0);
+- tDisp (beta, errorDepth, pprint, vars, true);
+- ppBreak pprint (1, 0);
+- ppAddString pprint s3;
+- ppBreak pprint (1, 0);
+- moreInfo pprint;
+- ppEndBlock pprint ()
+- end
+- )
+- ) (* matchError *);
+-
+-
+ (* True if two types are equal. Used to reduce the storage required
+ when copying signatures. Rewritten using pattern-matching.
+ SPF 17/11/94. *)
+@@ -1294,9 +1176,6 @@
+ #name x = #name y andalso
+ equalTypes(#typeof x) (#typeof y) andalso equalRecordLists xs ys
+ | equalRecordLists _ _ = false;
+-
+-
+- fun trivMap (t : types) : types = t;
+
+ (* See if the types are the same. This is a bit of a fudge, but saves carrying
+ around a flag saying whether the structures were copied. This is only an
+@@ -1344,7 +1223,7 @@
+ TypeVar _ => (* Unbound type variable, flexible record or overloading. *)
+ copyTypeVar atyp
+
+- | TypeConstruction {name, value, args} =>
++ | TypeConstruction {value, args, locations, ...} =>
+ let
+ val copiedArgs = copyList args;
+ val copiedConstr = copyTypeConstr (pling value);
+@@ -1362,7 +1241,7 @@
+ andalso (case value of FrozenRef _ => true | _ => false)
+ then atyp
+ else (* Must copy it. *)
+- mkTypeConstruction (copiedName, copiedConstr, copiedArgs)
++ mkTypeConstruction (copiedName, copiedConstr, copiedArgs, locations)
+ end
+
+ | FunctionType {arg, result} =>
+@@ -1396,89 +1275,13 @@
+ raise InternalError "copyType: OverloadSet found"
+
+ end (* copyType *);
+-
+-
+- (* Copy a type constructor and any types it uses in its "equivalent" list.
+- Does not copy value constructors. *)
+- fun copyTypeConstr (tcon, mustCopy, makeId, typeMap as {enter,lookup},
+- copyTypeVar, strName) =
+- let
+- val id = tcIdentifier tcon;
+- val equiv = tcEquivalent tcon;
+- (* Now copy any equivalent and put it on. *)
+- val copiedEquiv =
+- if isEmpty equiv then equiv
+- else
+-(* Back out the change needed for free type variables. DCJM 12/4/00. *)
+-(*
+- let
+- (* We apply copyTypeVar to free type variables but not to bound vars. *)
+- val boundTVs = tcTypeVars tcon
+- fun copyFreeTVs tv =
+- first(fn t => sameTypeVar(t, tv)) (fn _ => tv)
+- (fn () => copyTypeVar tv) (overList boundTVs)
+- fun copyTC tcon =
+- copyTypeConstr (tcon, mustCopy, makeId, typeMap, copyFreeTVs)
+- in
+- copyType (equiv, copyFreeTVs, copyTC)
+- end
+-*)
+- copyType
+- (equiv,
+- trivMap, (* Don't bother with type variables. *)
+- fn tcon => copyTypeConstr (tcon, mustCopy, makeId, typeMap, trivMap, strName));
+- in
+- (* Now copy the type constructor if either the id of this constructor
+- must be copied or if its equivalent must be copied. It is possible
+- that we may have to copy the constructor even if its equivalent has
+- not changed (e.g. this constructor shares with a free type). We
+- still copy it to make sure that the length of bound stamps is right. *)
+- (* DCJM 17/2/00. If we have a type (rather than a datatype) and the
+- "equivalent" has changed we must ensure that we always get a new copy.
+- This is essential if the type has free variables. *)
+- (* DCJM 9/5/00. Now backed out this change because it seems that the
+- change to the definition which would allow free type variables is
+- actually a mistake. *)
+- if mustCopy id orelse not (identical (equiv, copiedEquiv))
+- then (* If it is the appropriate type of identifier. *)
+- (* We share occurences of type constructors (not just their
+- identifiers) so that if we have a value of a type which is a
+- datatype we can find the constructors when we need to print it. *)
+- case lookup id of (* Return it if it is in the table. *)
+- SOME i => i
+- | NONE =>
+- let (* Not there, so copy it. *)
+- (* Replace any signature name by the given structure name unless this is
+- is a type equivalence. It may be that the type is not actually
+- declared in this structure. *)
+- val newName =
+- if isEmpty equiv
+- then strName ^ #second(splitString(tcName tcon))
+- else tcName tcon
+- val r =
+- makeTypeConstrs
+- (newName,
+- tcTypeVars tcon,
+- copiedEquiv,
+- makeId (),
+- tcEquality tcon,
+- 0 (* Always global. *));
+-
+- (* And put it in the table *)
+- val U : unit = enter (id, r);
+- in
+- r
+- end
+- else tcon
+- end (* copyTypeConstr *);
+
+-
+- datatype match = Matched of {old: typeVarForm, new: types};
++ datatype match = Matched of {old: typeVarForm, new: types};
+
+
+ (* Generate a mapping from one set of type variables to another. *)
+
+- fun tvarSequence (matched : match list, isExp : bool) : types -> types =
++ fun tvarSequence (matched : match list) : types -> types =
+ let
+ val madeList = ref matched (* List of tyVars. *);
+ in
+@@ -1492,8 +1295,7 @@
+ (* Make a unifiable type variable even if the original
+ is nonunifiable. *)
+ val n : types =
+- mkTypeVar (generalisable, tvEquality tyVar,
+- false, tvWeak tyVar andalso isExp);
++ mkTypeVar (generalisable, tvEquality tyVar, false);
+ in
+ (* Set the new variable to have the same value as the
+ existing. That is only really needed if we have an
+@@ -1510,9 +1312,9 @@
+ end
+ end (* tvarSequence *);
+
+- fun generaliseTypes (atyp : types, matched : match list, isExp : bool) : types =
++ fun generaliseTypes (atyp : types, matched : match list) : types =
+ let
+- val tvs : types -> types = tvarSequence (matched, isExp);
++ val tvs : types -> types = tvarSequence matched;
+
+ fun copyTypeVar (atyp as TypeVar tyVar) =
+ if tvLevel tyVar <> generalisable
+@@ -1540,19 +1342,6 @@
+ newTv
+ end
+ | copyTypeVar atyp = atyp
+-
+- (* We only copy type constructors if their "equivalent" has changed which
+- will only happen if they contain a free type variable. *)
+- (* I'm using makeFreeId here but I'm not convinced that's right. DCJM 17/2/00. *)
+- (* I've now backed this change out because it seems that the "change" to
+- the definition which would allow free type variables was actually a
+- mistake. DCJM 12/4/00 *)
+-(*
+- fun copyTCons tcon =
+- copyTypeConstr(tcon, fn _ => false, makeFreeId,
+- {enter = fn _ => (), lookup = fn _ => raise ValueMissing "" },
+- copyTypeVar)
+-*)
+ in
+ (* Only process type variables. Return type constructors unchanged. *)
+ copyType (atyp, copyTypeVar, fn t => t (*copyTCons*))
+@@ -1560,8 +1349,7 @@
+
+
+ (* Exported wrapper for generaliseTypes. *)
+- fun generalise (atyp : types, isExp : bool) : types =
+- generaliseTypes (atyp, [], isExp);
++ fun generalise (atyp : types) : types = generaliseTypes (atyp, []);
+
+ fun checkForLocalDatatypes(ty: types, depth: int, errorFn: string->unit) : unit =
+ let
+@@ -1583,10 +1371,10 @@
+
+ (* Make a match list from a list of type variables and types. *)
+
+- fun copyVars (varlist : types list, arglist : types list) : match list =
++ fun copyVars (varlist : typeVarForm list, arglist : types list) : match list =
+ case (varlist, arglist) of
+ (var::vars, arg::args) =>
+- Matched {old = typesTypeVar var, new = arg} :: copyVars (vars, args)
++ Matched {old = var, new = arg} :: copyVars (vars, args)
+ | _ => [] (* These will normally be nil at the same time but if we have
+ had an error they may not be. *)
+
+@@ -1602,19 +1390,17 @@
+ in
+ generaliseTypes
+ (#arg constrFun,
+- copyVars (#args (typesTypeConstruction (#result constrFun)), typeArgs),
+- true)
++ copyVars (List.map typesTypeVar (#args (typesTypeConstruction (#result constrFun))), typeArgs))
+ end;
+
+ (* If we have a type construction which is an alias for another type
+ we construct the alias by first instantiating all the type variables
+ and then copying the type. *)
+-
+- fun makeEquivalent (atyp, args) =
+- generaliseTypes
+- (tcEquivalent atyp,
+- copyVars (tcTypeVars atyp, args),
+- true);
++ fun makeEquivalent (atyp, args) =
++ case tcIdentifier atyp of
++ TypeFunction(typeArgs, typeResult) =>
++ generaliseTypes(typeResult, copyVars (typeArgs, args))
++ | _ => raise InternalError "makeEquivalent: Not a type function";
+
+ (* This 3-valued logic is used because in a few cases we may not be sure
+ if equality testing is allowed. If we have 2 mutually recursive datatypes
+@@ -1682,48 +1468,42 @@
+ No (* No equality on function types! *)
+
+ | TypeConstruction {value, args, ...} =>
+- let
+- val constr = pling value;
+- in
+- if isUndefined constr
+- then No
++ let
++ val constr = pling value;
++ in
++ if isUndefined constr
++ then No
+
+- (* ref - Equality is permitted on refs of all types *)
+- (* The Definition of Standard ML says that ref is the ONLY type
+- constructor which is treated in this way. The standard basis
+- library says that other mutable types such as array should
+- also work this way. We allow this by searching for an overloaded
+- equality operation on the type. If it is there we treat the
+- type as admitting equality whether it is monomorphic or
+- polymorphic and whatever the types it is applied to. *)
+- else if not (isCodeNil(getOverload("=", constr, fn()=>CodeNil)))
+- then Yes
+-
+- (* "real" is an equality type in ML90 but not in ML97. *)
+- else if sameTypeId (tcIdentifier constr, tcIdentifier STRUCTVALS.realType)
+- then (*if ml90 lex then Yes else *)No
+-
+- (* Others apart from ref and real *)
+- else if tcEquality constr (* Equality allowed. *)
+- then eqForList (args, Yes) (* Must be allowed for all the args *)
++ else if tcIsAbbreviation constr
++ then (* May be an alias for a type that allows equality. *)
++ equality (makeEquivalent (constr, args), search, lookupTypeVar)
++
++ (* ref - Equality is permitted on refs of all types *)
++ (* The Definition of Standard ML says that ref is the ONLY type
++ constructor which is treated in this way. The standard basis
++ library says that other mutable types such as array should
++ also work this way. *)
++ else if isPointerEqType(tcIdentifier constr)
++ then Yes
++
++ (* Others apart from ref and real *)
++ else if tcEquality constr (* Equality allowed. *)
++ then eqForList (args, Yes) (* Must be allowed for all the args *)
+
+- else if isEmpty (tcEquivalent constr)
+- then let (* Not an alias. - Look it up. *)
+- val s = search (tcIdentifier constr);
+- in
+- if s = No then No else eqForList (args, s)
+- end
+-
+- (* May be an alias for a type that allows equality. *)
+- else
+- equality (makeEquivalent (constr, args), search, lookupTypeVar)
+- end (* TypeConstruction *)
++ else
++ let (* Not an alias. - Look it up. *)
++ val s = search (tcIdentifier constr);
++ in
++ if s = No then No else eqForList (args, s)
++ end
++
++ end (* TypeConstruction *)
+
+ | LabelledType {recList, ...} => (* Record equality if all subtypes are (ignore frozen!) *)
+ (* TODO: Avoid copying the list? *)
+- eqForList (map (fn{name,typeof}=>typeof) recList, Yes)
++ eqForList (map (fn{typeof, ...}=>typeof) recList, Yes)
+
+- | OverloadSet {typeset} =>
++ | OverloadSet _ =>
+ (* This should not happen because all overload sets should be pointed
+ to by type variables and so should be handled in the TypeVar case. *)
+ raise InternalError "equality - Overloadset found"
+@@ -1739,175 +1519,155 @@
+ types are mutually recursive so value constructors of one type may
+ take arguments involving values of any of the others. *)
+
+- fun genEqualityFunctions (types, errorMessage, inSignature) =
+- let
+- datatype state =
+- Processed of tri (* Already processed or processing. *)
+- | NotSeen of typeConstrs list (* Value is list of constrs. *);
+-
+- (* This table tells us, for each type constructor, whether it definitely
+- admits equality, definitely does not or whether we have yet to look
+- at it. *)
+-
+- fun isProcessed (Processed _) = true | isProcessed _ = false;
+- fun isNotSeen (NotSeen _) = true | isNotSeen _ = false;
+-
+- fun stateProcessed (Processed x) = x | stateProcessed _ = raise Match;
+- fun stateNotSeen (NotSeen x) = x | stateNotSeen _ = raise Match;
+-
+- val {enter:typeId * state -> unit,lookup} = mapTable sameTypeId;
+-
+- (* Look at each of the constructors in the list. Equality testing is
+- only allowed if it is allowed for each of the alternatives. *)
+- fun constrEq constructor [] soFar = soFar (* end of list - all o.k. *)
+- | constrEq constructor (h :: t) soFar =
+- (* The constructor may be a constant e.g.
+- datatype 'a list = nil | ... or a function e.g.
+- datatype 'a list = ... cons of 'a * 'a list. *)
+- if not (isFunctionType (valTypeOf h)) (* Constant *)
+- then constrEq constructor t soFar (* Go on to the next. *)
++ fun computeDatatypeEqualities types =
++ let
++ datatype state =
++ Processed of tri (* Already processed or processing. *)
++ | NotSeen of typeConstrs list (* Value is list of constrs. *);
++
++ (* This table tells us, for each type constructor, whether it definitely
++ admits equality, definitely does not or whether we have yet to look
++ at it. *)
++
++ fun isProcessed (Processed _) = true | isProcessed _ = false;
++
++ fun stateProcessed (Processed x) = x | stateProcessed _ = raise Match;
++ fun stateNotSeen (NotSeen x) = x | stateNotSeen _ = raise Match;
++
++ val {enter:typeId * state -> unit,lookup} = mapTable sameTypeId;
++
++ (* Look at each of the constructors in the list. Equality testing is
++ only allowed if it is allowed for each of the alternatives. *)
++ fun constrEq _ [] soFar = soFar (* end of list - all o.k. *)
++ | constrEq constructor (h :: t) soFar =
++ (* The constructor may be a constant e.g.
++ datatype 'a list = nil | ... or a function e.g.
++ datatype 'a list = ... cons of 'a * 'a list. *)
++ if not (isFunctionType (valTypeOf h)) (* Constant *)
++ then constrEq constructor t soFar (* Go on to the next. *)
+
+- else let
+- (* Function - look at the argument type. *)
+- (* Search the list for the type variable. If it is there it is a formal
+- parameter to a datatype so equality testing will be allowed if it is
+- allowed for the actual parameter. *)
+-
+- val eq =
+- equality
+- (#arg (typesFunctionType (valTypeOf h)),
+- genEquality,
+- fn tyVar =>
+- if List.exists (fn v => sameTv (typesTypeVar v, tyVar))
+- (tcTypeVars constructor)
+- then Yes else No
+- );
+- in
+- if eq = No
+- then (* Not allowed. *) No
+- else (* O.k. - go on to the next. *)
+- constrEq constructor t (if eq = Maybe then Maybe else soFar)
+- end (* constrEq *)
+-
+- (* This procedure checks to see if equality is allowed for this datatype. *)
+- and genEquality constructorId =
+- let
+- (* Look it up to see if we have already done it. It may fail because
+- we may have constructors that do not admit equality. *)
+- val thisState = getOpt(lookup constructorId, Processed No);
+- in
+- if isProcessed thisState
+- then stateProcessed thisState (* Have either done it already or are currently doing it. *)
+- else (* notSeen - look at it now. *)
+- (
+- (* Equality is allowed for this datatype only if all of them admit it.
+- There are various other alternatives but this is what the standard says.
+- If the "name" is rigid (free) we must not grant equality if it is not
+- already there although that is not an error. *)
+- (* Set the state to "Maybe". This prevents infinite recursion. *)
+- enter (constructorId, Processed Maybe);
+- let
+- val eq =
+- List.foldl
+- (fn (cons, t) =>
+- if t = No
+- then No
+- else if inSignature andalso
+- not (isVariableId constructorId) andalso
+- not (tcEquality cons)
+- then No
+- else constrEq cons (tcConstructors cons) t)
+- Yes
+- (stateNotSeen thisState);
+- in
+- (* Set the state we have found if it is "yes" or "no". If it is
+- maybe we have a recursive reference which appears to admit
+- equality, but may not. E.g. if we have
+- datatype t = A of s | B of int->int and s = C of t
+- if we start processing "t" we will go on to "s" and do that
+- before returning to "t". It is only later we find that "t" does
+- not admit equality. If we get "Maybe" as the final result when
+- all the recursion has been unwound we can set the result to
+- "yes", but any intermediate "Maybe"s have to be done again. *)
+- enter (constructorId, if eq = Maybe then thisState else Processed eq);
+- eq
+- end
+- )
+- end (* genEquality *);
+- in
+- (* If we have an eqtype we set it to true, otherwise we set all of them
+- to "notSeen" with the constructor as value. *)
+- List.app
+- (fn dec =>
+- let (* If we have two datatypes which share we may already have
+- one in the table. We have to link them together. *)
+- val tclist =
+- case lookup (tcIdentifier dec) of
+- NONE => [dec]
+- | SOME l =>
+- let
+- val others = stateNotSeen l
+- val newList = dec :: others;
+- in
+- (* If any of these are already equality types (i.e. share with an eqtype)
+- then they all must be. *)
+- if tcEquality dec orelse tcEquality (hd others)
+- then List.app (fn d => tcSetEquality (d, true)) newList
+- else ();
+- newList
+- end
+- in
+- enter (tcIdentifier dec, NotSeen tclist)
+- end) types;
+-
+- (* Apply genEquality to each element of the list. *)
+- List.app (fn constructor =>
+- let
+- val constructorId = tcIdentifier constructor;
+- val eqForCons = genEquality constructorId;
+- in
+- (* If the result is "Maybe" it involves a recursive reference, but
+- the rest of the type allows equality. The type admits equality. *)
+- if eqForCons = No
+- then (* Equality not allowed *)
+- ( (* If it has been shared with an eqtype it will have the equality
+- flag set. If it does not admit equality it is an error. *)
+- if tcEquality constructor
+- then errorMessage ("Type (" ^ tcName constructor ^ ") does not respect equality")
+- else ()
+- )
+ else
+- ( (* Turn on equality. *)
+- enter (constructorId, Processed Yes);
+- tcSetEquality (constructor, true)
+- )
+- end) types
+- end (* genEqualityFunctions *);
+-
+- (* Test to see is a type constructor is in an overload set. *)
+- fun isInSet(tcons: typeConstrs, (H::T): typeConstrs list) =
+- sameTypeId (tcIdentifier tcons, tcIdentifier H) orelse isInSet(tcons, T)
+- | isInSet(tcons: typeConstrs, []: typeConstrs list) = false
+-
+- (* Type matching algorithm for both unification and signature matching. *)
+- fun typeMatch
+- (Atype : types, (* candidate type when signature matching *)
+- Btype : types, (* target type when signature matching *)
+- (* mapA : types -> types, *) (* As this was always trivmap I've removed it *)
+- mapB : types -> types, (* Map type constructors in the target. *)
+- cantMatch : types * types * string -> unit)
+- : unit =
+- let
+- fun match
+- (Atype : types,
+- Btype : types,
+- (* mapA : types -> types, *)
+- mapB : types -> types)
+- : unit =
++ let
++ (* Function - look at the argument type. *)
++ (* Equality is allowed for any type-variable. The only type variables
++ allowed are parameters to the datatype so if we have a type variable
++ then equality is allowed for this datatype. *)
++ val eq =
++ equality (#arg (typesFunctionType (valTypeOf h)),
++ genEquality, fn _ => Yes);
++ in
++ if eq = No
++ then (* Not allowed. *) No
++ else (* O.k. - go on to the next. *)
++ constrEq constructor t (if eq = Maybe then Maybe else soFar)
++ end (* constrEq *)
++
++ (* This procedure checks to see if equality is allowed for this datatype. *)
++ and genEquality constructorId =
++ let
++ (* Look it up to see if we have already done it. It may fail because
++ we may have constructors that do not admit equality. *)
++ val thisState = getOpt(lookup constructorId, Processed No);
++ in
++ if isProcessed thisState
++ then stateProcessed thisState (* Have either done it already or are currently doing it. *)
++ else (* notSeen - look at it now. *)
++ let
++ (* Equality is allowed for this datatype only if all of them admit it.
++ There are various other alternatives but this is what the standard says.
++ If the "name" is rigid (free) we must not grant equality if it is not
++ already there although that is not an error. *)
++ (* Set the state to "Maybe". This prevents infinite recursion. *)
++ val () = enter (constructorId, Processed Maybe);
++ val eq =
++ List.foldl
++ (fn (cons, t) =>
++ if t = No
++ then No
++ else constrEq cons (tcConstructors cons) t)
++ Yes
++ (stateNotSeen thisState);
++ in
++ (* Set the state we have found if it is "yes" or "no". If it is
++ maybe we have a recursive reference which appears to admit
++ equality, but may not. E.g. if we have
++ datatype t = A of s | B of int->int and s = C of t
++ if we start processing "t" we will go on to "s" and do that
++ before returning to "t". It is only later we find that "t" does
++ not admit equality. If we get "Maybe" as the final result when
++ all the recursion has been unwound we can set the result to
++ "yes", but any intermediate "Maybe"s have to be done again. *)
++ enter (constructorId, if eq = Maybe then thisState else Processed eq);
++ eq
++ end
++ end (* genEquality *);
++ in
++ (* If we have an eqtype we set it to true, otherwise we set all of them
++ to "notSeen" with the constructor as value. *)
++ List.app
++ (fn dec =>
++ let (* If we have two datatypes which share we may already have
++ one in the table. We have to link them together. *)
++ val tclist =
++ case lookup (tcIdentifier dec) of
++ NONE => [dec]
++ | SOME l =>
++ let
++ val others = stateNotSeen l
++ val newList = dec :: others;
++ in
++ (* If any of these are already equality types (i.e. share with an eqtype)
++ then they all must be. *)
++ if tcEquality dec orelse tcEquality (hd others)
++ then List.app (fn d => tcSetEquality (d, true)) newList
++ else ();
++ newList
++ end
++ in
++ enter (tcIdentifier dec, NotSeen tclist)
++ end) types;
++
++ (* Apply genEquality to each element of the list. *)
++ List.app
++ (fn constructor =>
++ let
++ val constructorId = tcIdentifier constructor;
++ val eqForCons = genEquality constructorId;
++ in
++ (* If the result is "Maybe" it involves a recursive reference, but
++ the rest of the type allows equality. The type admits equality. *)
++ if eqForCons = No
++ then () (* Equality not allowed *)
++ else
++ ( (* Turn on equality. *)
++ enter (constructorId, Processed Yes);
++ tcSetEquality (constructor, true)
++ )
++ end) types
++ end (* computeDatatypeEqualities *);
++
++ datatype matchResult =
++ SimpleError of types * types * string
++ | TypeConstructorError of types * types * typeConstrs * typeConstrs
++
++ (* Type matching algorithm for both unification and signature matching. *)
++ (* The mapping has now been moved out of here. Instead when signature matching the
++ target signature is copied before this is called which means that this
++ process is now symmetric. There may be some redundant tests left in here. *)
++ fun unifyTypes(Atype : types, Btype : types) : matchResult option =
++ let
++ (* Get the result in here. This isn't very ML-like but it greatly
++ simplifies converting the code. *)
++ val matchResult: matchResult option ref = ref NONE
++ fun matchError error = (* Only report one error. *)
++ case matchResult of ref (SOME _) => () | r => r := SOME error
++ fun cantMatch(alpha, beta, text) = matchError(SimpleError(alpha, beta, text))
++
++ fun match (Atype : types, Btype : types) : unit =
+ let (* Check two records/tuples and return the combined type. *)
+- fun unifyRecords (recA as {frozen=typAFrozen, recList=typAlist, genericInstance = gA},
+- recB as {frozen=typBFrozen, recList=typBlist, genericInstance = gB},
+- typA : types, typB : types, (*mapA, *)mapB) : types =
++ fun unifyRecords ({frozen=typAFrozen, recList=typAlist, genericInstance = gA},
++ {frozen=typBFrozen, recList=typBlist, genericInstance = gB},
++ typA : types, typB : types) : types =
+ let
+ (* If we add a field to the instance we have to add a corresponding type variable to
+ the generic. *)
+@@ -1920,15 +1680,14 @@
+ "newEntry:",
+ "equality=", Bool.toString(tvEquality generic),
+ " level=", Int.toString(tvLevel generic),
+- " weakness=", Bool.toString(tvWeak generic),
+ "\n"
+ ]);*)
+ { name = field,
+- (* The entry must at least inherit the equality attribute (and weakness?).
++ (* The entry must at least inherit the equality attribute.
+ We should have tvLevel generic = generalisable and tvNonUnifiable generic
+ = false. *)
+ typeof = mkTypeVar(tvLevel generic, tvEquality generic,
+- tvNonUnifiable generic, tvWeak generic)}
++ tvNonUnifiable generic)}
+ )
+ fun addEntry [] = [newEntry]
+ | addEntry ((ge as {name, typeof = _}) :: geRest) =
+@@ -1956,7 +1715,7 @@
+ I don't really understand this and I don't know whether it's
+ actually possible to have a missing field at this point. *)
+ fun checkEntries [] = ()
+- | checkEntries ((ge as {name, typeof = _}) :: geRest) =
++ | checkEntries (({name, typeof = _}) :: geRest) =
+ let
+ val order = compareLabels (name, field)
+ in
+@@ -1964,7 +1723,7 @@
+ then ()
+ else if order < 0
+ then checkEntries geRest
+- else cantMatch (typA, mapB typB, "(Field " ^ name ^ " missing)")
++ else cantMatch (typA, typB, "(Field " ^ name ^ " missing)")
+ end
+ in
+ checkEntries recList
+@@ -1986,17 +1745,17 @@
+ | matchLabelled ([], bList as {name=bName, ...} :: _) =
+ (
+ if typAFrozen
+- then cantMatch (typA, mapB typB, "(Field " ^ bName ^ " missing)")
++ then cantMatch (typA, typB, "(Field " ^ bName ^ " missing)")
+ else (* Add all the extra fields in bList to all the generics for A. *)
+- List.app(fn {name, typeof} => List.app (addFieldToGeneric name) gA) bList;
++ List.app(fn {name, ...} => List.app (addFieldToGeneric name) gA) bList;
+ bList (* return the remainder of the list *)
+ )
+
+ | matchLabelled (aList as {name=aName, ...} :: _, []) = (* Something left in bList *)
+ (
+ if typBFrozen
+- then cantMatch (typA, mapB typB, "(Field " ^ aName ^ " missing)")
+- else List.app(fn {name, typeof} => List.app (addFieldToGeneric name) gB) aList;
++ then cantMatch (typA, typB, "(Field " ^ aName ^ " missing)")
++ else List.app(fn {name, ...} => List.app (addFieldToGeneric name) gB) aList;
+ aList (* the rest of aList *)
+ )
+
+@@ -2009,7 +1768,7 @@
+ if order = 0 (* equal *)
+ then (* same name - must be unifiable types *)
+ ( (* The result is (either) one of these with the rest of the list. *)
+- match (aType, bType, mapB);
++ match (aType, bType);
+ aVal :: matchLabelled (aRest, bRest)
+ )
+ else if order < 0 (* aName < bName *)
+@@ -2017,7 +1776,7 @@
+ ( (* The entries in each list are in order so this means that this
+ entry is not in bList. If the typeB is frozen this is an error. *)
+ if typBFrozen (* Continue with the entry removed. *)
+- then (cantMatch (typA, mapB typB, "(Field " ^ aName ^ " missing)"); aList)
++ then (cantMatch (typA, typB, "(Field " ^ aName ^ " missing)"); aList)
+ else
+ (
+ List.app (addFieldToGeneric aName) gB;
+@@ -2026,7 +1785,7 @@
+ )
+ else (* aName > bName *)
+ if typAFrozen
+- then (cantMatch (typA, mapB typB, "(Field " ^ bName ^ " missing)"); bList)
++ then (cantMatch (typA, typB, "(Field " ^ bName ^ " missing)"); bList)
+ else
+ (
+ List.app (addFieldToGeneric bName) gA;
+@@ -2035,7 +1794,14 @@
+ end (* not nil *);
+
+ (* Return the combined list. Only actually used if both are flexible. *)
+- val result = matchLabelled (typAlist, typBlist)
++ val result =
++ if typAFrozen andalso typBFrozen andalso List.length typAlist <> List.length typBlist
++ then (* Don't attempt to unify the fields if we have the wrong number of items.
++ If we've added or removed an item from a tuple e.g. a function with
++ multiple arguments, it's more useful to know this than to get unification
++ errors on fields that don't match. *)
++ (cantMatch (typA, typB, "(Different number of fields)"); [])
++ else matchLabelled (typAlist, typBlist)
+ (* We append the generic instances. This may create duplicates if, for example,
+ we are unifying a record with itself. *)
+ in
+@@ -2060,22 +1826,18 @@
+ N.B. It does not propagate equality status. The reason is that
+ if we are unifying ''a with '_b ref, the '_b does NOT become
+ an equality type var. In all other cases it would. *)
+- fun checkForLoops t false = false
++ fun checkForLoops _ false = false
+ | checkForLoops (TypeVar tvar) true =
+ let
+ (* The level is the minimum of the two, and if we are unifying with
+ an equality type variable we must make this into one. *)
+ val minLev = Int.min (tvLevel var, tvLevel tvar);
+- (* Make the resultant type variable weak unless we are really
+- unifying it with an overload set. *)
+- val isWeak = ((tvWeak var) orelse (tvWeak tvar))
+- andalso (case tvValue tvar of OverloadSet _ => false | _ => true)
+ in
+- if (tvLevel tvar <> minLev) orelse (tvWeak tvar <> isWeak)
++ if tvLevel tvar <> minLev
+ then
+ (* If it is nonunifiable we cannot make its level larger. *)
+ if tvNonUnifiable tvar
+- then cantMatch (Atype, mapB Btype,
++ then cantMatch (Atype, Btype,
+ "(Type variable is free in surrounding scope)")
+ else let
+ (* Must make a new type var with the right properties *)
+@@ -2083,8 +1845,7 @@
+ case we have to save the record and put it on the new
+ type variable. foldType will apply checkForLoops to the
+ record. *)
+- val newTv =
+- mkTypeVar (minLev, tvEquality tvar, false, isWeak);
++ val newTv = mkTypeVar (minLev, tvEquality tvar, false);
+ in
+ tvSetValue (typesTypeVar newTv, tvValue tvar);
+ tvSetValue (tvar, newTv)
+@@ -2100,13 +1861,13 @@
+ case varVal of
+ LabelledType _ =>
+ (* Flexible record. Check that the records are compatible. *)
+- match (varVal, t, (*trivMap, *)trivMap)
++ match (varVal, t)
+ | OverloadSet _ =>
+ (* OverloadSet. Check that the sets match. This is only in the
+ case where t is something other than an overload set since
+ we remove the overload set from a variable when unifying two
+ sets. *)
+- match (varVal, t, (*trivMap, *)trivMap)
++ match (varVal, t)
+ | _ => ();
+
+ (* If this type variable was put in explicitly then it can't be
+@@ -2125,7 +1886,7 @@
+ let
+ val constr = pling value
+ in
+- isEmpty (tcEquivalent constr) orelse
++ not (tcIsAbbreviation constr) orelse
+ let
+ (* expand type constructor to get its body *)
+ val equiv = eventual (makeEquivalent (constr, args));
+@@ -2148,7 +1909,7 @@
+ then "(Cannot unify with explicit type variable)"
+ else "(Type variable to be unified occurs in type)";
+ in
+- cantMatch (Atype, mapB Btype, msg)
++ cantMatch (Atype, Btype, msg)
+ end
+ else ()
+ end
+@@ -2167,8 +1928,7 @@
+ fields in the flexible record admit equality and ALSO that any
+ additional fields we may add by unification with other records
+ also admit equality. *)
+- val newTv =
+- mkTypeVar (tvLevel tvar, true, false, tvWeak tvar);
++ val newTv = mkTypeVar (tvLevel tvar, true, false);
+ val oldValue = tvValue tvar
+ in
+ tvSetValue (tvar, newTv);
+@@ -2176,15 +1936,6 @@
+ don't admit equality. *)
+ case oldValue of
+ OverloadSet{typeset} =>
+- (*if ml90 lex
+- then (* real admits equality in ML90 but not in ML97. I am
+- assuming here that we will not try overloading on any
+- other type which would not admit equality. *)
+- (
+- tvSetValue (typesTypeVar newTv, oldValue);
+- Yes
+- )
+- else*)
+ let
+ (* Remove any types which do not admit equality. *)
+ fun filter [] = []
+@@ -2196,7 +1947,7 @@
+ | [constr] =>
+ ( (* Turn a singleton into a type construction. *)
+ tvSetValue (typesTypeVar newTv,
+- mkTypeConstruction(tcName constr, constr, nil));
++ mkTypeConstruction(tcName constr, constr, nil, []));
+ Yes
+ )
+ | newset =>
+@@ -2217,7 +1968,7 @@
+ we must ensure that equality is allowed for that type. This
+ will turn most type variables into equality type vars. *)
+ if tvEquality var andalso equality (t, fn _ => No, canMkEqTv) = No
+- then cantMatch (Atype, mapB Btype, "(Requires equality type)")
++ then cantMatch (Atype, Btype, "(Requires equality type)")
+ (* TODO: This can result in an unhelpful message if var is bound
+ to a flexible record since there is no indication in the
+ printed type that the flexible record is an equality type.
+@@ -2231,7 +1982,12 @@
+ or a combination of the fields of var and t. Likewise if
+ var was previously an overload set this may replace the set
+ by a single type construction. *)
+- tvSetValue (var, t)
++ (* If we have had an error don't make the assignment. At the very least
++ it could prevent us producing useful error information and it could
++ also result in unnecessary consequential errors. *)
++ case !matchResult of
++ NONE => tvSetValue (var, t)
++ | SOME _ => ()
+ end
+ end (* assign *);
+
+@@ -2240,85 +1996,86 @@
+ val tA = eventual Atype;
+ val tB = eventual Btype;
+
+- in (* start of "match" *)
++ in (* start of "match" *)
++ if isUndefinedType tA orelse isUndefinedType tB
++ then () (* If either of these was an undefined type constructor don't try to match.
++ TODO: There are further tests below for this which are now redundant. *)
++ else
+ case (tA, tB) of
+ (BadType, _) => () (* If either is an error don't try to match *)
+ | (_, BadType) => ()
+
+- | (TypeVar typeAVar, TypeVar _) =>
+- (* Unbound type variable, flexible record or overload set. *)
+- let
+- (* Even if this is a one-way match we can allow type variables
+- in the typeA to be instantiated to anything in the typeB. *)
+- val typeAVal = tvValue typeAVar;
+- (* We have two unbound type variables or flex. records. *)
+- val typB = mapB tB
+- in
+- case typB of
+- TypeVar typeBVar =>
+- if sameTv (typeAVar, typeBVar) (* same type variable? *)
+- then ()
+- else (* no - assign one to the other *)
+- if tvNonUnifiable typeAVar
+- (* If we have a nonunifiable type variable we want to assign
+- the typeB to it. If the typeB is nonunifiable as well we
+- will get an error message. *)
+- then assign (typeBVar, tA)
+- else let
+- (* If they are both flexible records we first set the typeB
+- to the union of the records, and then set the typeA to
+- that. In that way we propagate properties such as
+- equality and level between the two variables. *)
+- val typBVal = tvValue typeBVar
+- in
+- case (typeAVal, typBVal) of
+- (LabelledType recA, LabelledType recB) =>
+- (
+- (* Turn these back into simple type variables to save
+- checking the combined record against the originals
+- when we make the assignment.
+- (Would be safe but redundant). *)
+- tvSetValue (typeBVar, emptyType);
+- tvSetValue (typeAVar, emptyType);
+- assign (typeBVar,
+- unifyRecords (recA, recB, typeAVal, typBVal, (*trivMap, *)trivMap));
+- assign (typeAVar, typB)
+- )
+- | (OverloadSet{typeset=setA}, OverloadSet{typeset=setB}) =>
+- let
+- (* The lists aren't ordered so we just have to go
+- through by hand. *)
+- fun intersect(a, []) = []
+- | intersect(a, H::T) =
+- if isInSet(H, a) then H::intersect(a, T) else intersect(a, T)
+- val newSet = intersect(setA, setB)
+- in
+- case newSet of
+- [] => cantMatch (Atype, mapB Btype, "(Incompatible overloadings)")
+- | _ =>
+- (
+- tvSetValue (typeBVar, emptyType);
+- tvSetValue (typeAVar, emptyType);
+- (* I've changed this from OverloadSet{typeset=newset}
+- to use mkOverloadSet. The main reason was that it
+- fixed a bug which resulted from a violation of the
+- assumption that "equality" would not be passed an
+- overload set except when pointed to by a type variable.
+- It also removed the need for a separate test for
+- singleton sets since mkOverloadSet deals with them.
+- DCJM 1/9/00. *)
+- assign (typeBVar, mkOverloadSet newSet);
+- assign (typeAVar, typB)
+- )
+- end
+- | (EmptyType, _) => (* A is not a record or an overload set. *)
+- assign (typeAVar, typB)
+- | (_, EmptyType) => (* A is a record but B isn't *)
+- assign (typeBVar, tA) (* typeB is ordinary type var. *)
+- | _ => (* Bad combination of labelled record and overload set *)
+- cantMatch (Atype, mapB Btype, "(Incompatible types)")
+- end
+- | typB => match (tA, typB, (*trivMap, *)trivMap)
++ | (TypeVar typeAVar, TypeVar typeBVar) =>
++ (* Unbound type variable, flexible record or overload set. *)
++ let
++ (* Even if this is a one-way match we can allow type variables
++ in the typeA to be instantiated to anything in the typeB. *)
++ val typeAVal = tvValue typeAVar;
++ (* We have two unbound type variables or flex. records. *)
++ in
++ if sameTv (typeAVar, typeBVar) (* same type variable? *)
++ then ()
++ else (* no - assign one to the other *)
++ if tvNonUnifiable typeAVar
++ (* If we have a nonunifiable type variable we want to assign
++ the typeB to it. If the typeB is nonunifiable as well we
++ will get an error message. *)
++ then assign (typeBVar, tA)
++ else
++ let
++ (* If they are both flexible records we first set the typeB
++ to the union of the records, and then set the typeA to
++ that. In that way we propagate properties such as
++ equality and level between the two variables. *)
++ val typBVal = tvValue typeBVar
++ in
++ case (typeAVal, typBVal) of
++ (LabelledType recA, LabelledType recB) =>
++ (
++ (* Turn these back into simple type variables to save
++ checking the combined record against the originals
++ when we make the assignment.
++ (Would be safe but redundant). *)
++ tvSetValue (typeBVar, emptyType);
++ tvSetValue (typeAVar, emptyType);
++ assign (typeBVar,
++ unifyRecords (recA, recB, typeAVal, typBVal));
++ assign (typeAVar, tB)
++ )
++ | (OverloadSet{typeset=setA}, OverloadSet{typeset=setB}) =>
++ let
++ (* The lists aren't ordered so we just have to go
++ through by hand. *)
++ fun intersect(_, []) = []
++ | intersect(a, H::T) =
++ if isInSet(H, a) then H::intersect(a, T) else intersect(a, T)
++ val newSet = intersect(setA, setB)
++ in
++ case newSet of
++ [] => cantMatch (Atype, Btype, "(Incompatible overloadings)")
++ | _ =>
++ (
++ tvSetValue (typeBVar, emptyType);
++ tvSetValue (typeAVar, emptyType);
++ (* I've changed this from OverloadSet{typeset=newset}
++ to use mkOverloadSet. The main reason was that it
++ fixed a bug which resulted from a violation of the
++ assumption that "equality" would not be passed an
++ overload set except when pointed to by a type variable.
++ It also removed the need for a separate test for
++ singleton sets since mkOverloadSet deals with them.
++ DCJM 1/9/00. *)
++ assign (typeBVar, mkOverloadSet newSet);
++ assign (typeAVar, tB)
++ )
++ end
++ | (EmptyType, _) => (* A is not a record or an overload set. *)
++ assign (typeAVar, tB)
++ | (_, EmptyType) => (* A is a record but B isn't *)
++ assign (typeBVar, tA) (* typeB is ordinary type var. *)
++ | _ => (* Bad combination of labelled record and overload set *)
++ cantMatch (Atype, Btype, "(Incompatible types)")
++ end
+ end
+
+ | (TypeVar typeAVar, _) =>
+@@ -2334,25 +2091,25 @@
+ let
+ val constr = pling value
+ in
+- if isUndefined constr orelse isEmpty (tcEquivalent constr)
++ if isUndefined constr orelse not (tcIsAbbreviation constr)
+ then
+ (
+- case mapB tB of
++ case tB of
+ TypeConstruction {value, args, ...} =>
+ let
+ val constr = pling value
+ in
+- if isUndefined constr orelse isEmpty (tcEquivalent constr)
+- then assign (typeAVar, mapB tB)
+- else match(tA, eventual (makeEquivalent (constr, args)), trivMap)
++ if isUndefined constr orelse not (tcIsAbbreviation constr)
++ then assign (typeAVar, tB)
++ else match(tA, eventual (makeEquivalent (constr, args)))
+ end
+- | _ => assign (typeAVar, mapB tB)
++ | _ => assign (typeAVar, tB)
+ )
+- else match(tA, eventual (makeEquivalent (constr, args)), mapB)
++ else match(tA, eventual (makeEquivalent (constr, args)))
+ end
+- | _ => assign (typeAVar, mapB tB)
++ | _ => assign (typeAVar, tB)
+ )
+- else assign (typeAVar, mapB tB)
++ else assign (typeAVar, tB)
+ )
+
+ | (_, TypeVar typeBVar) => (* and typeA is not *)
+@@ -2366,89 +2123,89 @@
+ let
+ val constr = pling value
+ in
+- if isUndefined constr orelse isEmpty (tcEquivalent constr)
++ if isUndefined constr orelse not (tcIsAbbreviation constr)
+ then
+ (
+- case mapB tB of
++ case tB of
+ TypeVar tv =>
+ (* This will fail if we are matching a signature because the
+ typeB will be non-unifiable. *)
+- assign (tv, mapB tA) (* set typeB to typeA *)
+- | typB => match (tA, typB, (*mapA, *)trivMap)
++ assign (tv, tA) (* set typeB to typeA *)
++ | typB => match (tA, typB)
+ )
+- else match(eventual (makeEquivalent (constr, args)), tB, mapB)
++ else match(eventual (makeEquivalent (constr, args)), tB)
+ end
+ | _ =>
+ (
+- case mapB tB of
++ case tB of
+ TypeVar tv =>
+ (* This will fail if we are matching a signature because the
+ typeB will be non-unifiable. *)
+- assign (tv, mapB tA) (* set typeB to typeA *)
+- | typB => match (tA, typB, (*mapA, *)trivMap)
++ assign (tv, tA) (* set typeB to typeA *)
++ | typB => match (tA, typB)
+ )
+ )
+ else
+ (
+- case mapB tB of
++ case tB of
+ TypeVar tv =>
+ (* This will fail if we are matching a signature because the
+ typeB will be non-unifiable. *)
+- assign (tv, mapB tA) (* set typeB to typeA *)
+- | typB => match (tA, typB, (*mapA, *)trivMap)
++ assign (tv, tA) (* set typeB to typeA *)
++ | typB => match (tA, typB)
+ )
+ )
+
+ | (TypeConstruction({value = valueA, args=tAargs, ...}),
+ TypeConstruction ({value = valueB, args=tBargs, ...})) =>
+- let
+- val tACons = pling valueA and tBCons = pling valueB
+- in
+- (* We may have a number of possibilities here.
+- a) If tA is an alias we simply expand it out and recurse (even
+- if tB is the same alias). e.g. if we have string t where
+- type 'a t = int*'a we expand string t into int*string and
+- try to unify that.
+- b) map it and see if the result is an alias. -- NOW REMOVED
+- c) If tB is a type construction and it is an alias we expand
+- that e.g. unifying "int list" and "int t" where type
+- 'a t = 'a list (particularly common in signature/structure
+- matching.)
+- d) Finally we try to unify the stamps and the arguments. *)
+- if not (isUndefined tACons orelse isEmpty (tcEquivalent tACons))
+- (* Candidate is an alias - expand it. *)
+- then match (makeEquivalent (tACons, tAargs), tB, (*mapA, *)mapB)
+- else if not (isUndefined tBCons orelse isEmpty (tcEquivalent tBCons))
+- then match (tA, makeEquivalent (tBCons, tBargs), (*trivMap, *)mapB)
+- else case mapB tB of
+- (typB as TypeConstruction({value=valueB, args=typeBargs, ...})) =>
++ let
++ val tACons = pling valueA and tBCons = pling valueB
++ in
++ (* We may have a number of possibilities here.
++ a) If tA is an alias we simply expand it out and recurse (even
++ if tB is the same alias). e.g. if we have string t where
++ type 'a t = int*'a we expand string t into int*string and
++ try to unify that.
++ b) map it and see if the result is an alias. -- NOW REMOVED
++ c) If tB is a type construction and it is an alias we expand
++ that e.g. unifying "int list" and "int t" where type
++ 'a t = 'a list (particularly common in signature/structure
++ matching.)
++ d) Finally we try to unify the stamps and the arguments. *)
++ if isUndefined tACons orelse isUndefined tBCons
++ then () (* If we've had an undefined type constructor don't try to check further. *)
++ else if tcIsAbbreviation tACons
++ (* Candidate is an alias - expand it. *)
++ then match (makeEquivalent (tACons, tAargs), tB)
++ else if tcIsAbbreviation tBCons
++ then match (tA, makeEquivalent (tBCons, tBargs))
++ else
+ let
+- val typeBCons = pling valueB
+- in
+- (* If the typeB is an alias it must be expanded. *)
+- if not(isUndefined typeBCons) andalso
+- not(isEmpty (tcEquivalent typeBCons))
+- then match (tA, makeEquivalent (typeBCons, typeBargs),
+- (*trivMap, *)trivMap)
++ val typeBCons = pling valueB
++ in
++ (* If the typeB is an alias it must be expanded. *)
++ if tcIsAbbreviation typeBCons
++ then match (tA, makeEquivalent (typeBCons, tBargs))
+ else if sameTypeId (tcIdentifier tACons, tcIdentifier typeBCons)
+- then let (* Same type constructor - do the arguments match? *)
++ then
++ let (* Same type constructor - do the arguments match? *)
+ fun matchLists [] [] = ()
+ | matchLists (a::al) (b::bl) =
+ (
+- match (a, b, (*trivMap, *)trivMap);
++ match (a, b);
+ matchLists al bl
+ )
+ | matchLists _ _ = (* This should only happen as a result of
+ a different error. *)
+- cantMatch (Atype, mapB Btype, "(Different numbers of arguments)")
+- in
+- matchLists tAargs typeBargs
+- end
+- else cantMatch (tA, typB, "(Different type constructors)")
++ cantMatch (Atype, Btype, "(Different numbers of arguments)")
++ in
++ matchLists tAargs tBargs
++ end
++
++ (* When we have different type constructors, especially two with the same name,
++ we try to produce more information. *)
++ else matchError(TypeConstructorError(tA, tB, tACons, typeBCons))
+ end
+- | typB => (* Mapping the construction gave us something
+- other than a construction. *)
+- match (tA, typB, (*trivMap, *)trivMap)
+ end
+
+ | (OverloadSet {typeset}, TypeConstruction {value=valueB, args=tBargs, ...}) =>
+@@ -2457,41 +2214,54 @@
+ let
+ val tBCons = pling valueB
+ in
+- if not (isUndefined tBCons orelse isEmpty (tcEquivalent tBCons))
+- then match (tA, makeEquivalent (tBCons, tBargs), (*mapA, *)mapB)
++ if not (isUndefined tBCons orelse not (tcIsAbbreviation tBCons))
++ then match (tA, makeEquivalent (tBCons, tBargs))
+ else
+- (
+- case mapB tB of
+- typB as TypeConstruction{value=valueB, args=typeBargs, ...} =>
+- let
+- val typeBCons = pling valueB
+- in
+- if isUndefined typeBCons
+- then ()
+- else if not(isEmpty (tcEquivalent typeBCons))
+- then match (tA, makeEquivalent (typeBCons, typeBargs), trivMap)
+- else (* See if the target type is among those in the overload set. *)
+- if null typeBargs (* Must be a nullary type constructor. *)
+- andalso isInSet(tBCons, typeset)
+- then () (* ok. *)
+- else cantMatch (tA, typB, "(Overloading does not include type)")
+- end
+- | typB => match (tA, typB, (*mapA,*) trivMap)
+- )
++ let
++ val typeBCons = pling valueB
++ in
++ if isUndefined typeBCons
++ then ()
++ else if tcIsAbbreviation typeBCons
++ then match (tA, makeEquivalent (typeBCons, tBargs))
++ else (* See if the target type is among those in the overload set. *)
++ if null tBargs (* Must be a nullary type constructor. *)
++ andalso isInSet(tBCons, typeset)
++ then () (* ok. *)
++ (* Overload sets arise primarily with literals such as "1" and it's
++ most likely that the error is a mismatch between int and another
++ type rather than that the user assumed that the literal was
++ overloaded on a type it actually wasn't. *)
++ else
++ case preferredOverload typeset of
++ NONE => cantMatch (tA, tB, "(Different type constructors)")
++ | SOME prefType =>
++ matchError(
++ TypeConstructorError(
++ mkTypeConstruction (tcName prefType, prefType,[], []),
++ tB, prefType, typeBCons))
++ end
+ end
+
+ | (TypeConstruction {value=valueA, args=tAargs, ...}, OverloadSet {typeset}) =>
+ let
+ val tACons = pling valueA
+ in
+- if not (isUndefined tACons orelse isEmpty (tcEquivalent tACons))
+- then match (makeEquivalent (tACons, tAargs), tB, (*mapA, *)mapB)
++ if not (isUndefined tACons orelse not (tcIsAbbreviation tACons))
++ then match (makeEquivalent (tACons, tAargs), tB)
+ (* We should never find an overload set as the target for a signature
+ match but it is perfectly possible for tB to be an overload set
+ when unifying two types. *)
+ else if null tAargs andalso isInSet(tACons, typeset)
+ then () (* ok. *)
+- else cantMatch (tA, mapB tB, "(Overloading does not include type)")
++ else
++ case preferredOverload typeset of
++ NONE => cantMatch (tA, tB, "(Different type constructors)")
++ | SOME prefType =>
++ matchError(
++ TypeConstructorError(
++ tA, mkTypeConstruction (tcName prefType, prefType,[], []),
++ tACons, prefType))
+ end
+
+ (* (OverloadSet , OverloadSet) should not occur because that should be
+@@ -2501,11 +2271,11 @@
+ let
+ val tACons = pling valueA
+ in
+- if not (isUndefined tACons orelse isEmpty (tcEquivalent tACons))
++ if not (isUndefined tACons orelse not (tcIsAbbreviation tACons))
+ (* Candidate is an alias - expand it. *)
+- then match (makeEquivalent (tACons, tAargs), tB, mapB)
++ then match (makeEquivalent (tACons, tAargs), tB)
+ else (* typB not a construction (but typeA is) *)
+- cantMatch (tA, mapB tB, "(Incompatible types)")
++ cantMatch (tA, tB, "(Incompatible types)")
+ end
+
+ | (_, TypeConstruction {value=valueB, args=tBargs, ...}) => (* and typeA is not. *)
+@@ -2516,33 +2286,28 @@
+ let
+ val tBCons = pling valueB
+ in
+- if not (isUndefined tBCons orelse isEmpty (tcEquivalent tBCons))
+- then match (tA, makeEquivalent (tBCons, tBargs), mapB)
+- else
+- (
+- case mapB tB of
+- typB as TypeConstruction{value = valueB, args=typeBargs, ...} =>
+- let
+- val typeBCons = pling valueB
+- in
+- if isUndefined typeBCons
+- then ()
+- else if not(isEmpty (tcEquivalent typeBCons))
+- then match (tA, makeEquivalent (typeBCons, typeBargs), trivMap)
+- else cantMatch (typB, tA, "(Incompatible types)")
+- end
+- | typB => match (tA, typB, trivMap)
+- )
++ if not (isUndefined tBCons orelse not (tcIsAbbreviation tBCons))
++ then match (tA, makeEquivalent (tBCons, tBargs))
++ else
++ let
++ val typeBCons = pling valueB
++ in
++ if isUndefined typeBCons
++ then ()
++ else if tcIsAbbreviation typeBCons
++ then match (tA, makeEquivalent (typeBCons, tBargs))
++ else cantMatch (tB, tA, "(Incompatible types)")
++ end
+ end
+
+ | (FunctionType {arg=typAarg, result=typAres, ...},
+ FunctionType {arg=typBarg, result=typBres, ...}) =>
+ ( (* must be unifiable functions *)
+- (* In principle it doesn't matter whether we unify arguments or
+- results first but it could affect the error messages. Is this
+- the best way to do it? *)
+- match (typAarg, typBarg, (*mapA, *) mapB);
+- match (typAres, typBres, (*mapA, *) mapB)
++ (* In principle it doesn't matter whether we unify arguments or
++ results first but it could affect the error messages. Is this
++ the best way to do it? *)
++ match (typAarg, typBarg);
++ match (typAres, typBres)
+ )
+
+ | (EmptyType, EmptyType) => ()
+@@ -2551,41 +2316,91 @@
+ | (LabelledType recA, LabelledType recB) =>
+ (* Unify the records, but discard the result because at least one of the
+ records is frozen. *)
+- (unifyRecords (recA, recB, tA, tB, (*mapA, *) mapB); ())
++ (unifyRecords (recA, recB, tA, tB); ())
+
+-(* | (LabelledType recA, _) =>
+- (
+- (* DCJM: Why do we map labelled records when we don't map functions?
+- Is it something to do with flexible records? Try commenting this
+- out. *)
+- case mapB tB of
+- LabelledType recB =>
+- (unifyRecords (recA, recB, tA, tB, trivMap); ())
+- | typB => cantMatch (tA, typB, "")
+- )
+-*)
+- | _ => cantMatch (tA, mapB tB, "(Incompatible types)")
++ | _ => cantMatch (tA, tB, "(Incompatible types)")
+
+ end; (* match *)
+- in
+- match (Atype, Btype, (*mapA, *)mapB)
+- end; (* typeMatch *)
+
+- fun unify
+- (alpha : types,
+- beta : types,
+- lex : lexan,
+- lineno : int,
+- moreInfo : prettyPrinter -> unit)
+- : unit =
+- let
+- fun cantMatch (typeA, typeB, reason) =
+- matchError ("Can't unify", typeA, "with", typeB, reason,
+- lex, lineno, moreInfo);
+-
+- in
+- typeMatch (alpha, beta, (*trivMap, *)trivMap, cantMatch)
+- end;
++ in
++ match (Atype, Btype);
++ ! matchResult
++ end; (* unifyTypes *)
++
++ (* Turn a result from matchTypes into a pretty structure so that it
++ can be included in a message. *)
++ fun unifyTypesErrorReport (_, alphaTypeEnv, betaTypeEnv, what) =
++ let
++ fun reportError(SimpleError(alpha: types, beta: types, reason)) =
++ (* This previously used a single type variable sequence for
++ both types. It may be that this is needed to make
++ sensible error messages. *)
++ PrettyBlock(3, false, [],
++ [
++ PrettyString ("Can't " ^ what (* "match" if a signature, "unify" if core lang. *)),
++ PrettyBreak (1, 0),
++ display (alpha, 1000 (* As deep as necessary *), alphaTypeEnv),
++ PrettyBreak (1, 0),
++ PrettyString "to",
++ PrettyBreak (1, 0),
++ display (beta, 1000 (* As deep as necessary *), betaTypeEnv),
++ PrettyBreak (1, 0),
++ PrettyString reason
++ ])
++
++ | reportError(TypeConstructorError(alpha: types, beta: types, alphaCons, betaCons)) =
++ let
++ fun expandedTypeConstr(ty, tyEnv, tyCons) =
++ let
++ fun lastPart name = #second(splitString name)
++
++ (* Print the type which includes the type constructor name with as
++ much additional information as we can. *)
++ fun printWithDesc{ location, name, description } =
++ PrettyBlock(3, false, [],
++ [ display (ty, 1000, tyEnv) ]
++ @ (if lastPart name = lastPart(tcName tyCons) then []
++ else
++ [
++ PrettyBreak(1, 0),
++ PrettyString "=",
++ PrettyBreak(1, 0),
++ PrettyBlock(0, false, [ContextLocation location], [PrettyString name])
++ ]
++ )
++ @ (if description = "" then []
++ else
++ [
++ PrettyBreak(1, 0),
++ PrettyBlock(0, false, [ContextLocation location],
++ [PrettyString ("(*" ^ description ^ "*)")])
++ ]
++ )
++ )
++ in
++ case tcIdentifier tyCons of
++ Free { description, ...} => printWithDesc description
++ | Bound { description, ...} => printWithDesc description
++ | TypeFunction _ => display (ty, 1000, tyEnv) (* Perhaps display *)
++ end
++ in
++ PrettyBlock(3, false, [],
++ [
++ PrettyString ("Can't " ^ what (* "match" if a signature, "unify" if core lang. *)),
++ PrettyBreak (1, 0),
++ expandedTypeConstr(alpha, alphaTypeEnv, alphaCons),
++ PrettyBreak (1, 0),
++ PrettyString (if what = "unify" then "with" else "to"),
++ PrettyBreak (1, 0),
++ expandedTypeConstr(beta, betaTypeEnv, betaCons),
++ PrettyBreak (1, 0),
++ PrettyString "(Different type constructors)"
++ ])
++ end
++
++ in
++ reportError
++ end
+
+ (* Given a function type returns the first argument if the
+ function takes a tuple otherwise returns the only argument.
+@@ -2595,7 +2410,7 @@
+ LabelledType { recList = {typeof, ...} ::_, ...}, ...}) =
+ eventual typeof
+ | firstArg(FunctionType{arg, ...}) = eventual arg
+- | firstArg t = eventual t
++ | firstArg t = t
+
+ (* Returns the result type of a function. *)
+ fun getResult(FunctionType{result, ...}) = eventual result
+@@ -2615,17 +2430,17 @@
+ (* The argument should be a type variable, possibly set to
+ an empty overload set. This should be replaced by
+ the current overload set in the copied function type. *)
+- generaliseTypes(t,
+- [Matched{old=tv, new=mkOverloadSet constrs}], true)
++ generaliseTypes(t, [Matched{old=tv, new=mkOverloadSet constrs}])
+ | _ => raise InternalError "generaliseOverload - arg is not a type var"
+ end
+
+- (* Return a type constructor from an overload. If there are
+- several (i.e. the overloading has not resolved to a single type)
+- it returns the "best". Returns undefType if there is no suitable
+- type or if there is more than one type in ML 90. *)
+- fun typeConstrFromOverload(f, isConverter) =
+- let
++ (* Return a type constructor from an overload. If there are
++ several (i.e. the overloading has not resolved to a single type)
++ it returns the "best". This is called in the third pass so it
++ should never be called if there is not at least one type that
++ is possible. *)
++ fun typeConstrFromOverload(f, _) =
++ let
+ fun prefType(TypeVar tvar) =
+ ( (* If we still have an overload set that's because it has
+ not reduced to a single type. In ML 97 we default to
+@@ -2642,121 +2457,72 @@
+ fun freezeType tcons =
+ (
+ tvSetValue(tvar,
+- mkTypeConstruction(tcName tcons, tcons, []));
++ mkTypeConstruction(tcName tcons, tcons, [], []));
+ tcons
+ )
+ in
+- (*if ml90 lex andalso not isConverter
+- then undefType (* No defaulting on functions in ML 90
+- but allow defaulting on literals *)
+- else *)if isInSet(STRUCTVALS.intType, typeset)
+- then freezeType STRUCTVALS.intType
+- else if isInSet(STRUCTVALS.realType, typeset)
+- then freezeType STRUCTVALS.realType
+- else if isInSet(STRUCTVALS.wordType, typeset)
+- then freezeType STRUCTVALS.wordType
+- else if isInSet(STRUCTVALS.charType, typeset)
+- then freezeType STRUCTVALS.charType
+- else if isInSet(STRUCTVALS.stringType, typeset)
+- then freezeType STRUCTVALS.stringType
+- else undefType
++ case preferredOverload typeset of
++ SOME tycons => freezeType tycons
++ | NONE => raise InternalError "typeConstrFromOverload: No matching type"
+ end
+- | _ => undefType (* Unbound or flexible record. *)
++ | _ => raise InternalError "typeConstrFromOverload: No matching type" (* Unbound or flexible record. *)
+ )
+ | prefType(TypeConstruction{value, args, ...}) =
+ let
+ val constr = pling value
+ in
+- if isEmpty (tcEquivalent constr)
++ if not (tcIsAbbreviation constr)
+ then constr (* Generally args will be nil in this case but
+ in the special case of looking for an equality
+ function for 'a ref or 'a array it may not be. *)
+ else prefType (makeEquivalent (constr, args))
+ end
+- | prefType _ = undefType
+- in
+- prefType(firstArg f)
+- end;
+-
+- (* Error message about overloading. *)
+-
+- fun overloadError (t : types, opName : string, types : string,
+- lex : lexan, lineno : int) : unit =
+- (* Find the argument type of the function. *)
+- let
+- (* Get the first arg if there are more than one, and see if
+- it is matched to anything. *)
+- val arg = firstArg t
+- open DEBUG
+- val parameters = debugParams lex
+- val errorDepth = getParameter errorDepthTag parameters
+- in
+- if isTypeVar arg (* Unresolved *)
+- then errorMessage (lex, lineno, "Unable to resolve overloading for " ^ opName)
+- else
+- errorProc (lex, lineno,
+- fn (pprint:prettyPrinter) =>
+- (
+- ppBeginBlock pprint (3, true);
+- ppAddString pprint
+- (opName ^ " is overloaded on " ^ types ^ " but not ");
+- display (arg, errorDepth, pprint, true);
+- ppEndBlock pprint ()
+- ))
+- end (* overloadError *);
+-
+- fun apply (f, arg, lex, lineno, moreInfo) =
+- let
+- val ef = eventual f;
+- in
+- if isFunctionType ef
+- then (* Special case for functions. *)
+- let
+- val funType = typesFunctionType ef;
+- val U : unit = unify (#arg funType, arg, lex, lineno, moreInfo);
+- in
+- #result funType
+- end
+- else (* Type variables etc. - Use general case. *)
+- let (* Make arg->'a, and unify with the function. *)
+- val resType = mkTypeVar (generalisable, false, false, false);
+- val fType = mkFunctionType (arg, resType);
+-
+- (* This may involve more than just assigning the type to "ef". *)
+- val U : unit = unify (ef, fType, lex, lineno, moreInfo);
++ | prefType _ = raise InternalError "typeConstrFromOverload: No matching type"
+ in
+- resType (* The result is the type variable unified to the result. *)
+- end
+- end (* apply *);
++ prefType(firstArg(eventual f))
++ end;
++
++ (* Return the result type of a function. Also used to test if the value is
++ a function type. *)
++ fun getFnArgType t =
++ case eventual t of
++ FunctionType {arg, ... } => SOME arg
++ | _ => NONE
++
+
+ (* Assigns type variables to variables with generalisation permitted
+ if their level is at least that of the current level.
+- In ML90 mode this produces an error message for any top-level
++ In ML90 mode this produced an error message for any top-level
+ free imperative type variables. We don't do that in ML97 because
+ it is possible that another declaration may "freeze" the type variable
+ before the composite expression reaches the top level. *)
+- fun allowGeneralisation (t, level, nonExpansive, lex, lineno, moreInfo) =
++ fun allowGeneralisation (t, level, nonExpansive, lex, location, moreInfo, typeEnv) =
+ let
+ fun giveError(s1: string, s2: string) =
+- errorProc(lex, lineno,
+- fn (pprint: prettyPrinter) =>
+- let
+- (* Use a single sequence. *)
+- val vars : typeVarForm -> string = varNameSequence ();
+- open DEBUG
+- val parameters = debugParams lex
+- val errorDepth = getParameter errorDepthTag parameters
+- in
+- ppBeginBlock pprint (3, false);
+- ppAddString pprint s1;
+- ppBreak pprint (1, 0);
+- tDisp (t, errorDepth, pprint, vars, true);
+- ppBreak pprint (1, 0);
+- ppAddString pprint s2;
+- ppBreak pprint (1, 0);
+- moreInfo pprint;
+- ppEndBlock pprint ()
+- end);
++ let
++ (* Use a single sequence. *)
++ val vars : typeVarForm -> string = varNameSequence ();
++ open DEBUG
++ val parameters = debugParams lex
++ val errorDepth = getParameter errorDepthTag parameters
++ in
++ reportError lex
++ {
++ hard = true,
++ location = location,
++ message =
++ PrettyBlock (3, false, [],
++ [
++ PrettyString s1,
++ PrettyBreak (1, 0),
++ tDisp (t, errorDepth, vars, typeEnv, NONE),
++ PrettyBreak (1, 0),
++ PrettyString s2
++ ]
++ ),
++ context = SOME(moreInfo ())
++ }
++ end
+
+ fun general (TypeVar tvar) showError =
+ if tvLevel tvar >= level andalso
+@@ -2768,7 +2534,7 @@
+ OverloadSet _ => true
+ | _ => false
+
+- (* Make a new generisable type variable, except that weak type
++ (* Make a new generisable type variable, except that type
+ variables in an expansive context cannot be generalised.
+ We also don't generalise if this is an overload set.
+ The reason for that is that it allows us to get overloading
+@@ -2776,14 +2542,10 @@
+ e.g. let fun f x y = x+y in f 2.0 end. An alternative
+ would be take the default type (in this case int).
+ DCJM 1/9/00. *)
+- val ml90 = DEBUG.getParameter DEBUG.ml90Tag (debugParams lex)
+- val nonCopiable =
+- (not nonExpansive andalso (tvWeak tvar orelse not ml90))
+- orelse isOverloadSet;
++ val nonCopiable = not nonExpansive orelse isOverloadSet;
+ val newLevel =
+ if nonCopiable then level-1 else generalisable (* copiable *);
+
+- val ml90 = DEBUG.getParameter DEBUG.ml90Tag (debugParams lex)
+ val isOk =
+ (* If the type variable has top-level scope then we have
+ a free type variable. We only want to generate this
+@@ -2797,19 +2559,11 @@
+ giveError("Type", "includes a free type variable");
+ false
+ )
+- else if newLevel = 1 andalso showError andalso ml90
+- andalso not isOverloadSet
+- then
+- (
+- giveError ("Type", "includes a free imperative type variable");
+- false
+- )
+ else showError;
+ val newVal =
+ mkTypeVar
+ (newLevel, tvEquality tvar,
+- if nonCopiable then (tvNonUnifiable tvar) else false,
+- tvWeak tvar)
++ if nonCopiable then (tvNonUnifiable tvar) else false)
+ in
+ (* If an explicit type variable is going out of scope we can
+ generalise it, except if it is nonunifiable. *)
+@@ -2834,7 +2588,7 @@
+ code from evaluating, to giving a warning and setting the type
+ variables to unique type variables. That allows, for example,
+ fun f x = raise x; f Subscript; to work. DCJM 8/3/01. *)
+- fun checkForFreeTypeVariables(valName: string, ty: types, lex: lexan) : unit =
++ fun checkForFreeTypeVariables(valName: string, ty: types, lex: lexan, printAndEqCode) : unit =
+ let
+ (* Generate new names for the type constructors. *)
+ val count = ref 0
+@@ -2848,432 +2602,61 @@
+ an overload set) and it is not generic i.e. it
+ must have come from an expansive expression. *)
+ let
+- val name = "_" ^ genName(!count)
+- val _ = count := !count + 1;
+- val tCons =
+- makeFrozenTypeConstrs (name, [], emptyType, makeFreeId(),
+- tvEquality tvar, 0);
+- val newVal = mkTypeConstruction(name, tCons, [])
+- in
+- warningMessage(lex, lineno lex,
+- concat["The type of (", valName,
+- ") contains a free type variable.\n",
+- "Setting it to a unique monotype."]);
+- tvSetValue (tvar, newVal)
+- end
+- else ()
+- | checkTypes _ () = ()
+-
+- in
+- foldType checkTypes ty ();
+- ()
+- end
+-
++ val name = "_" ^ genName(!count)
++ val _ = count := !count + 1;
++ val declLoc = location lex (* Not correct but OK for the moment. *)
++ val declDescription =
++ { location = declLoc, name = name, description = "Constructed from a free type variable." }
++ val tCons =
++ makeFrozenTypeConstrs (name, [],
++ makeFreeId(Global(printAndEqCode()), tvEquality tvar, declDescription),
++ 0, [DeclaredAt declLoc]);
++ val newVal = mkTypeConstruction(name, tCons, [], [])
++ in
++ warningMessage(lex, location lex,
++ concat["The type of (", valName,
++ ") contains a free type variable. Setting it to a unique monotype."]);
++ tvSetValue (tvar, newVal)
++ end
++ else ()
++ | checkTypes _ () = ()
+
+- (* Sets any variable stamps in the type to new bound stamps. This is used
+- in the final phase of compiling a signature when we need to turn variable
+- stamps into bound stamps. *)
+- fun setTypeConstr (tcon, makeId) =
+- let
+- val id = tcIdentifier tcon;
+- val equiv = tcEquivalent tcon;
+ in
+- if not (isEmpty equiv) then setTypes (equiv, makeId) else ();
+- if isVariableId id then (unifyTypeIds (id, makeId tcon); ()) else ()
++ foldType checkTypes ty ();
++ ()
+ end
+
+- (* Applies setTypeConstr to every type constructor. *)
+-
+- and setTypes (t, makeId) =
+- let
+- fun setTypeConstrVal t () =
+- if isTypeConstruction t
+- then setTypeConstr(pling (#value (typesTypeConstruction t)), makeId)
+- else ();
+- in
+- foldType setTypeConstrVal t ()
+- end
+-
+- (* Enter a type constructor into the match table. *)
+- (* We should simply have to enter the candidate type against the target
+- identifier in the table, but unfortunately it is not always that simple.
+- It is possible that the target has an "equivalent" which is no longer
+- in the signature and so will not match up to a candidate. e.g.
+- sig type a type b sharing type a=b type b end
+- could end up with a pointing to b which is no longer there. *)
+- (* Put the candidate against this entry in the table and also against
+- any equivalents of this target which are not already matched. *)
+-
+- fun enterTypeConstrs (target, candidate, matchTab as {enter,lookup}) =
+- let
+- val equiv = tcEquivalent target;
+- in
+- if isBoundId (tcIdentifier target)
+- then #enter matchTab (tcIdentifier target, candidate)
+- else ();
+-
+- if isTypeConstruction equiv
+- then let
+- val t = pling (#value (typesTypeConstruction equiv));
+- (* Is it in the table already? If so don't overwrite it. *)
+- in
+- case #lookup matchTab (tcIdentifier t) of
+- SOME _ => ()
+- | NONE => enterTypeConstrs (t, candidate, matchTab)
+- end
+- else ()
+- end;
+-
+- (* Check that two types match. *)
+- fun matchTypes
+- (candidate : types,
+- target : types,
+- targMap : typeId -> typeConstrs option,
+- lex : lexan,
+- lineno : int,
+- moreInfo : prettyPrinter -> unit)
+- : unit =
+- let
+- fun copyTarget t =
+- (* Don't bother with type variables. *)
+- copyType (t, trivMap,
+- fn tcon =>
+- ( (* Copy it if it is in the map. *)
+- copyTypeConstr
+- (tcon,
+- (fn id => case targMap id of SOME _ => true | NONE => false),
+- makeFreeId, (* Not used. *)
+- {lookup = targMap, enter = (fn (id, tc) => ())},
+- trivMap, ""
+- )
+- ));
+-
+- (* Do the match to a version of the candidate with copies of the
+- type variables so that we can instantiate them. We could do
+- this by passing in a mapping function but the problem is that
+- if we have a type variable that gets unified to another variable
+- we will not map it properly if it occurs again (we call "eventual"
+- and get the second tv before calling the map function so we get a
+- second copy and not the first copy).
+- *)
+-
+- val copiedCandidate : types = generalise (candidate, true);
+-
+- fun cantMatch (candidate, target, reason) =
+- matchError ("Can't match", candidate, "to", target, reason,
+- lex, lineno, moreInfo);
+- in
+- typeMatch (copiedCandidate, target, copyTarget, cantMatch)
+- end;
+-
+ (* Returns true if a type constructor permits equality. *)
+
+ fun permitsEquality constr =
+- if tcEquality constr then true
+- else if isEmpty(tcEquivalent constr) then false
+- else not (equality
+- (mkTypeConstruction (tcName constr, constr, tcTypeVars constr),
+- fn tri => No,
+- fn tri => Yes)
+- = No);
+-
+- (* Try to set one type constructor to point to the other. It may not
+- succeed if they are both already assigned to other types in which
+- case no error message is produced. These errors are detected by a
+- second pass using matchTypes later on. This is used to establish
+- sharing constraints, which can be a problem since either type
+- constructor could be a variable or rigid depending on other sharing. *)
+- fun linkTypeConstructors (typeA, typeB, cantMatch) =
+- let
+- (* Set the equivalent field of a type constructor to a type. *)
+- fun setEquiv toSet v =
+- let
+- (* Make a type construction out of constructor,
+- using type variables from "toSet". *)
+- val construction = mkTypeConstruction (tcName v, v, tcTypeVars toSet);
+- (* If "toSet" is an eqtype we need to check that the "v" also is one.
+- If we are establishing a sharing constraint between two variable
+- types one of which is an eqtype we have to make them all eqtypes. *)
+- in
+- if tcEquality toSet
+- then
+- if isVariableId (tcIdentifier v) andalso isEmpty (tcEquivalent v)
+- then tcSetEquality (v, true)
+- else if not (permitsEquality v)
+- then cantMatch ("Cannot share: (" ^ tcName v ^ ") is not an eqtype")
+- else ()
+- else ();
+-
+- (* Set the "equivalent" to the value. We can't simply set the stamps
+- to be the same because the equality attribute is held in the
+- type constructor instead (as the semantics says) in the name.
+- We would have a problem if we shared a type with a datatype that
+- was later found to be an eqtype. *)
+- tcSetEquivalent (toSet, construction)
+- end (* setEquiv *);
+- in
+- if isUndefined typeA orelse isUndefined typeB
+- then ()
+- else
+- if tcArity typeA <> tcArity typeB (* Check arity. *)
+- then
+- cantMatch ("Cannot share: Types (" ^ tcName typeA ^ ") have different arities.")
+- else let
+- (* The argument lists must be identical lists of type variables. *)
+- fun eqArgs [] [] = true
+- | eqArgs (TypeVar ta :: al) (TypeVar tb :: bl) =
+- sameTv (ta, tb) andalso eqArgs al bl
+- | eqArgs _ _ = false;
+-
+- (* First see if either has been matched to another type. If what it
+- has been matched to is a type constructor then we look at that. *)
+- val AEquiv = tcEquivalent typeA;
+- val BEquiv = tcEquivalent typeB;
+- in
+- if not (isEmpty AEquiv)
+- then (* This type is matched to something else. This could have arisen
+- either from a previous sharing constraint or from a type
+- abbreviation. This is only allowed if it is another
+- type constructor. In ML90, where we can share with rigid types,
+- this could also arise as a result of sharing with a rigid
+- type construction. We ignore that, since we're not trying to
+- maintain full compatibility with ML90, and generate an error
+- message anyway. *)
+- (
+- if isTypeConstruction AEquiv andalso
+- eqArgs (#args (typesTypeConstruction AEquiv)) (tcTypeVars typeA)
+- then linkTypeConstructors (pling (#value (typesTypeConstruction AEquiv)),
+- typeB, cantMatch)
+- else cantMatch ("Cannot share: (" ^ tcName typeA ^ ") is a type function")
+- )
+- else if not (isEmpty BEquiv)
+- then (* ditto for type B *)
+- (
+- if isTypeConstruction BEquiv andalso
+- eqArgs (#args (typesTypeConstruction BEquiv)) (tcTypeVars typeB)
+- then linkTypeConstructors (typeA,
+- pling (#value (typesTypeConstruction BEquiv)), cantMatch)
+- else cantMatch ("Cannot share: (" ^ tcName typeB ^ ") is a type function")
+- )
+-
+- (* Neither A nor B can already be matched to anything. *)
+- else if sameTypeId (tcIdentifier typeA, tcIdentifier typeB)
+- (* Are they the same already? If so skip all this. *)
+- then ()
+- else let (* Not there. *)
+- val AIsDatatype = not (null(tcConstructors typeA));
+- val BIsDatatype = not (null(tcConstructors typeB));
+- (* If we have a variable type constructor which is a type or eqtype
+- (but not a datatype) we can set its "equivalent" field to the
+- other type constr. *)
+- in
+- (* In ML90 we are allowed to unify a rigid and a flexible type.
+- In ML97 both must be flexible. *)
+- if not (isVariableId (tcIdentifier typeA)) (*andalso not (ml90 lex)*)
+- then cantMatch ("Cannot share: (" ^ tcName typeA ^ ") is not flexible")
+-
+- else if not (isVariableId (tcIdentifier typeB)) (*andalso not (ml90 lex)*)
+- then cantMatch ("Cannot share: (" ^ tcName typeB ^ ") is not flexible")
+-
+- else if isVariableId (tcIdentifier typeA) andalso not AIsDatatype
+- then setEquiv typeA typeB
+-
+- else if isVariableId (tcIdentifier typeB) andalso not BIsDatatype
+- then setEquiv typeB typeA
+-
+- (* We have two type constructors in which neither has an
+- equivalent field which is set or can be set. They must
+- either be datatypes or rigid (non-variable) abstract types.
+- We just try to link their stamps. We check by a later pass
+- that this has succeeded. *)
+- else if isVariableId (tcIdentifier typeA) orelse
+- isVariableId (tcIdentifier typeB)
+- then let
+- (* If they are both rigid this is not going to work.
+- Skip it and report the error later. *)
+- (* Equality status. If either has equality status then the
+- result should have equality, except that we can't change the
+- equality status of a rigid (free) stamp. We have to do this
+- before unifying the stamps because that could change the
+- kind of stamp. *)
+- val AEq = permitsEquality typeA;
+- val BEq = permitsEquality typeB;
+- in
+- (
+- if AEq andalso not BEq
+- then (* Want to set B to be an eqtype as well. *)
+- if isVariableId (tcIdentifier typeB)
+- then (tcSetEquality (typeB, true); true)
+- else (cantMatch ("Cannot share: (" ^ tcName typeB ^ ") is not an eqtype"); false)
+-
+- else if BEq andalso not AEq
+- then (* Want to set A to be an eqtype as well. *)
+- if isVariableId (tcIdentifier typeA)
+- then (tcSetEquality (typeA, true); true)
+- else (cantMatch ("Cannot share: (" ^ tcName typeA ^ ") is not an eqtype"); false)
+-
+- else true
+- ) andalso
+- (* Unify the type "names" (unique ids). *)
+- unifyTypeIds (tcIdentifier typeA, tcIdentifier typeB);
+- ()
+- end
+- else
+- (* Both are rigid. This case can only occur if ml90 is true.
+- We've already checked that they don't have the same type
+- name so we can just generate an error message. *)
+- cantMatch ("Cannot share: (" ^ tcName typeA ^ ") and (" ^
+- tcName typeB ^ ") are different types")
+- end
+- end
+- end (* linkTypeConstructors *);
+-
++ if tcIsAbbreviation constr
++ then typePermitsEquality(
++ mkTypeConstruction (tcName constr, constr, List.map TypeVar (tcTypeVars constr), []))
++ else tcEquality constr
++
++ and typePermitsEquality ty = equality (ty, fn _ => No, fn _ => Yes) <> No
+
+- (* Set a type constructor looked up in the signature to a dummy type
+- constructor representing the type realisation. The reason for
+- using a dummy type constructor is that it allows us to match up
+- the type variables used in the original declaration of the type
+- with the type variables used in the realisation. It also means
+- that the code is very similar to the old (ML90) version of
+- linkTypeConstructors which worked with rigid type constructors
+- as well as flexible. *)
+- fun setWhereType (tcToSet, equivTc, cantSet) =
+- let
+- (* Set the equivalent field of a type constructor to a type. *)
+- fun setEquiv toSet v =
++ (* See if a type abbreviation or "where type" has the form type t = s or
++ type 'a t = 'a s etc and so is simply giving a new name to the type
++ constructor. If it is it then checks that the type constructor used
++ (s in this example) is just a simple type name. *)
++ fun typeNameRebinding(typeArgs, typeResult): typeId option =
+ let
+- (* Make a type construction out of constructor,
+- using type variables from "toSet". *)
+- val construction = mkTypeConstruction (tcName v, v, tcTypeVars toSet);
+- (* If "toSet" is an eqtype we need to check that the "v" also is one.
+- If we are establishing a sharing constraint between two variable
+- types one of which is an eqtype we have to make them all eqtypes. *)
++ fun eqTypeVar(TypeVar ta, tb) = sameTv (ta, tb)
++ | eqTypeVar _ = false
+ in
+- if tcEquality toSet
+- then
+- if isVariableId (tcIdentifier v) andalso isEmpty (tcEquivalent v)
+- then tcSetEquality (v, true)
+- else if not (permitsEquality v)
+- then cantSet ("(" ^ tcName v ^ ") is not an eqtype")
+- else ()
+- else ();
+-
+- (* Set the "equivalent" to the value. We can't simply set the stamps
+- to be the same because the equality attribute is held in the
+- type constructor instead (as the semantics says) in the name.
+- We would have a problem if we shared a type with a datatype that
+- was later found to be an eqtype. *)
+- tcSetEquivalent (toSet, construction)
+- end (* setEquiv *)
+- in
+- if isUndefined tcToSet
+- then () (* Probably because looking up the type constructor name failed. *)
+-
+- else if tcArity tcToSet <> tcArity equivTc (* Check arity. *)
+- then cantSet ("Cannot apply type realisation: Types (" ^
+- tcName tcToSet ^ ") have different arities.")
+- else let
+- (* The argument lists must be identical lists of type variables. *)
+- fun eqArgs [] [] = true
+- | eqArgs (TypeVar ta :: al) (TypeVar tb :: bl) =
+- sameTv (ta, tb) andalso eqArgs al bl
+- | eqArgs _ _ = false;
+-
+- (* First see if either has been matched to another type. If what it
+- has been matched to is a type constructor then we look at that. *)
+- val toSetEquiv = tcEquivalent tcToSet;
+- val equivEquiv = tcEquivalent equivTc;
+- in
+- if not (isEmpty toSetEquiv)
+- then
+- (* It's bound to something. I really don't know if this is legal or not.
+- If it is legal it's only legal if it's bound to another type name.
+- This might arise as a result of a sharing constraint. *)
+- (
+- case toSetEquiv of
+- TypeConstruction {value, args, ... } =>
+- if eqArgs args (tcTypeVars tcToSet)
+- then setWhereType (pling value, equivTc, cantSet)
+- else cantSet ("Cannot apply type realisation: (" ^
+- tcName tcToSet ^ ") is a type function")
+- | _ => cantSet ("Cannot apply type realisation: (" ^
+- tcName tcToSet ^ ") is a type function")
+- )
+-
+- (* If the type we are trying to assign is a simple construction
+- of a type constructor with matching type variables then we try
+- to match to that. (e.g. where type 'a A.t = 'a s). In this
+- case only it is possible for A.t to be a datatype if s is
+- also a datatype. *)
+- else if isTypeConstruction equivEquiv andalso
+- eqArgs (#args (typesTypeConstruction equivEquiv)) (tcTypeVars equivTc)
+- then setWhereType (tcToSet,
+- pling (#value (typesTypeConstruction equivEquiv)), cantSet)
+-
+- (* It must have a variable stamp. The only way I can see that
+- it might not be would be if another "where type" has already
+- been applied to this type. *)
+- else if not (isVariableId (tcIdentifier tcToSet))
+- then cantSet ("Cannot apply type realisation: (" ^
+- tcName tcToSet ^ ") is already free.")
+-
+- (* If it's an eqtype then the type function must admit equality. Again, I
+- don't know if it's legal to use "where type" to set the "equivalent"
+- of an eqtype at all. *)
+- else if tcEquality tcToSet andalso not (permitsEquality equivTc)
+- then cantSet ("Cannot apply type realisation: (" ^
+- tcName tcToSet ^
+- ") is an eqtype but the type does not permit equality.")
+-
+- (* Check if it's a datatype. If we need to get the effect of
+- a "where type" constraint with a datatype we have to use
+- datatype replication. *)
+- (* It's not clear at the moment whether this is allowed or not.
+- I'm going to allow it for the moment. N.B. We don't check the
+- constructors. That's because we can't be sure that there aren't
+- other datatypes which already share with this one and they are
+- allowed to have different constructors in ML97.
+- e.g. sig datatype t = A|B of int datatype s = X of real
+- sharing type s = t end
+- is legal in ML97, although unmatchable. If we apply a
+- "where type" constraint to, say s, e.g. where type s = bool,
+- we don't check it. *)
+- else if not (null(tcConstructors tcToSet))
+- then
+- (*
+- cantSet ("Cannot apply type realisation: (" ^
+- tcName tcToSet ^ ") is a datatype.")
+- *)
+- if null(tcConstructors equivTc)
+- then
+- cantSet ("Cannot apply type realisation: (" ^
+- tcName tcToSet ^ ") is a datatype but (" ^
+- tcName equivTc ^ ") is not.")
+- else (unifyTypeIds(tcIdentifier tcToSet, tcIdentifier equivTc); ())
+-
+- else (* Just set the equivalent field to point to the type. *)
+- setEquiv tcToSet equivTc
++ case typeResult of
++ TypeConstruction {value, args, ... } =>
++ if not (ListPair.allEq eqTypeVar(args, typeArgs))
++ then NONE
++ else
++ (
++ case tcIdentifier (pling value) of
++ TypeFunction _ => NONE
++ | tId => SOME tId
++ )
++ | _ => NONE
+ end
+- end (* setWhereType *);
+-
+-
+- (* A simple sort routine - particularly if the list is already sorted.
+- Reports duplicate names. *)
+- fun sortLabels ([], duplicate) = []
+- | sortLabels (s::rest, duplicate) =
+- let
+- fun enter s name [] = [s]
+- | enter s name (l as ( (h as {name=hname, typeof}) :: t)) =
+- let
+- val comp = compareLabels (name, hname);
+- in
+- if comp = 0 (* Equal. *)
+- then duplicate ("Label (" ^ name ^ ") appears more than once.") else ();
+- if comp <= 0 then s :: l else h :: enter s name t
+- end;
+- in
+- enter s (#name s) (sortLabels (rest, duplicate))
+- end;
+
+ (* Returns the number of the entry in the list. Used to find out the
+ location of fields in a labelled record for expressions and pattern
+@@ -3281,7 +2664,7 @@
+
+ fun entryNumber (label, LabelledType{recList, ...}) =
+ let (* Count up the list. *)
+- fun entry ({name, typeof}::l) n =
++ fun entry ({name, ...}::l) n =
+ if name = label then n else entry l (n + 1)
+ | entry [] _ = raise Match
+ in
+@@ -3294,7 +2677,7 @@
+ | entryNumber (label, TypeConstruction{value, ...}) = (* Type alias *)
+ entryNumber (label, tcEquivalent(pling value))
+
+- | entryNumber (label, _) =
++ | entryNumber _ =
+ raise InternalError "entryNumber - not a record"
+
+ (* Size of a labelled record. *)
+@@ -3316,86 +2699,37 @@
+ as a global one. *)
+ fun linkTypeVars (a, b) =
+ let
+- val ta = typesTypeVar (eventual a); (* Must both be type vars. *)
+- val tb = typesTypeVar (eventual b);
++ val ta = typesTypeVar (eventual(TypeVar a)); (* Must both be type vars. *)
++ val tb = typesTypeVar (eventual(TypeVar b));
+ in (* Set the one with the higher level to point to the one with the
+ lower, so that the effective level is the lower. *)
+ if (tvLevel ta) > (tvLevel tb)
+- then tvSetValue (ta, b)
+- else tvSetValue (tb, a)
++ then tvSetValue (ta, TypeVar b)
++ else tvSetValue (tb, TypeVar a)
+ end;
+
+ (* Set its level by setting it to a new type variable. *)
+ fun setTvarLevel (typ, level) =
+ let
+- val tv = typesTypeVar (eventual typ); (* Must be type var. *)
++ val tv = typesTypeVar (eventual(TypeVar typ)); (* Must be type var. *)
+ in
+- tvSetValue (tv, mkTypeVar (level, tvEquality tv, true, tvWeak tv))
+- end;
+-
+- (* Checks that every type identifier mentioned is rigid. Used when we
+- have unified a rigid and a flexible structure. *)
+- fun checkWellFormed (t, errorMessage) =
+- let
+- fun check typ () =
+- if isTypeConstruction typ
+- then let
+- val cons = typesTypeConstruction typ;
+- val constructor = pling (#value cons);
+- val equiv = tcEquivalent constructor;
+- in
+- if not (isEmpty equiv)
+- then checkWellFormed (equiv, errorMessage)
+- else if isVariableId (tcIdentifier constructor)
+- then
+- errorMessage
+- ("Ill-formed signature - type ("
+- ^ tcName constructor
+- ^") is not rigid.")
+- else ()
+- end
+- else ();
+- in (* Apply this to all the types. *)
+- foldType check t ()
++ tvSetValue (tv, mkTypeVar (level, tvEquality tv, true))
+ end;
+
+- (* Applied to type constructions (e.g. 'a list) to get the value
+- constructors for the type constructor. Used in the match compiler
+- to find the number of constructors in a datatype. *)
+- fun getConstrList (TypeConstruction{value, args, ...}) =
+- let
+- val constr = pling value
+- val l = tcConstructors constr
+- in
+- (* In a few cases it is possible for the value to be an equivalent. *)
+- if null l andalso not(isEmpty(tcEquivalent constr))
+- then getConstrList (makeEquivalent (constr, args))
+- else l
++ structure Sharing =
++ struct
++ type types = types
++ and values = values
++ and typeId = typeId
++ and structVals = structVals
++ and typeConstrs= typeConstrs
++ and typeParsetree = typeParsetree
++ and locationProp = locationProp
++ and pretty = pretty
++ and lexan = lexan
++ and ptProperties = ptProperties
++ and typeVarForm = typeVarForm
++ and codetree = codetree
++ and matchResult = matchResult
+ end
+- | getConstrList (FunctionType{result, ...}) =
+- (* May be the type of a constructor - look at result type *)
+- getConstrList result
+- | getConstrList _ = [];
+-
+- (* Find a value constructor in the list of constructors for the datatype.
+- This is used in structures.copySig to reduce the amount of space used *)
+- fun findValueConstructor copied =
+- let
+- val t = valTypeOf copied;
+- val name = valName copied;
+- (* The value constructor's type may be a value of the datatype or
+- a function returning a value. *)
+- val construction =
+- if isFunctionType t then #result(typesFunctionType t) else t;
+- val constructor = pling (#value (typesTypeConstruction construction));
+- (* If the value constructor is in the list return it otherwise return
+- the copied version. In fact the only case when it will not be in
+- the list is if the list is empty. We have to check the types are
+- the same because we also use this when copying datatypes. *)
+- in
+- case List.find (fn v => valName v = name)
+- (tcConstructors constructor) of
+- SOME v => if equalTypes (valTypeOf v) t then v else copied
+- | NONE => copied
+- end;
+ end (* TYPETREE *);
+Only in mlsource/MLCompiler: TypeIDCodeStruct.sml
+diff -u -r mlsource/MLCompiler/TypeTree.ML mlsource/MLCompiler/TypeTree.ML
+--- mlsource/MLCompiler/TypeTree.ML 2006-09-26 15:38:31.000000000 +0200
++++ mlsource/MLCompiler/TypeTree.ML 2009-09-15 08:56:47.000000000 +0200
+@@ -26,7 +26,7 @@
+ structure STRUCTVALS = StructVals
+ structure UTILITIES = Utilities
+ structure MISC = Misc
+- structure PRETTYPRINTER = PrettyPrinter
+- structure CODETREE = CodeTree
+- structure PRINTTABLE = PrintTable
++ structure PRETTY = Pretty
++ structure CODETREE = CodeTree
++ structure EXPORTTREE = ExportTreeStruct
+ ) ;
+diff -u -r mlsource/MLCompiler/UTILITIES_.ML mlsource/MLCompiler/UTILITIES_.ML
+--- mlsource/MLCompiler/UTILITIES_.ML 2008-03-14 08:40:24.000000000 +0100
++++ mlsource/MLCompiler/UTILITIES_.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -28,12 +28,7 @@
+ (*****************************************************************************)
+ (* LEX *)
+ (*****************************************************************************)
+-structure LEX :
+-sig
+- type lexan;
+-
+- val errorMessage: lexan * int * string -> unit;
+-end
++structure LEX : LEXSIG
+
+ ) :
+
+@@ -42,8 +37,10 @@
+ (*****************************************************************************)
+ sig
+ type lexan;
++ type location =
++ { file: string, startLine: int, startPosition: int, endLine: int, endPosition: int }
+
+- val noDuplicates: (string -> unit) ->
++ val noDuplicates: (string * 'a * 'a -> unit) ->
+ { apply: (string * 'a -> unit) -> unit,
+ enter: string * 'a -> unit,
+ lookup: string -> 'a option };
+@@ -52,12 +49,18 @@
+ enter: string * 'a -> unit,
+ lookup: string -> 'a option};
+
+- val checkForDots: string * lexan * int -> unit;
++ val checkForDots: string * lexan * location -> unit;
+
+ val mapTable: ('a * 'a -> bool) ->
+ {enter: 'a * 'b -> unit, lookup: 'a -> 'b option};
+
+ val splitString: string -> { first:string,second:string }
++
++ structure Sharing:
++ sig
++ type lexan = lexan
++ end
++
+ end (* UTILITIES export signature *) =
+
+
+@@ -90,7 +93,7 @@
+ fun enter (name : string, value) =
+ let
+ fun look [] = variable := (name,value) :: !variable
+- | look ((n,_)::T) = if n = name then fail name else look T;
++ | look ((n,old)::T) = if n = name then fail(name, old, value) else look T;
+ in
+ look (!variable)
+ end;
+@@ -139,13 +142,13 @@
+ { apply = apply, enter = enter, lookup = lookup }
+ end; (* searchList *)
+
+- fun checkForDots (name, lex, lineno) =
++ fun checkForDots (name, lex, location) =
+ let
+ fun check i =
+ if i > size name
+ then ()
+ else if String.str(String.sub(name, i-1)) = "."
+- then errorMessage (lex, lineno,
++ then errorMessage (lex, location,
+ "qualified name " ^ name ^ " illegal here")
+ else check (i + 1)
+ in
+@@ -162,13 +165,13 @@
+
+ (* Don't allow duplicate keys in the list! *)
+ local
+- fun member (x, [] : ('a * 'b) list) = false
+- | member (x, h::t) = same (#1 h, x) orelse member (x, t);
++ fun member (_, [] : ('a * 'b) list) = false
++ | member (x, h::t) = same (#1 h, x) orelse member (x, t);
+
+- fun delete (x, [] : ('a * 'b) list) = []
+- | delete (x, h::t) = if same (#1 h, x) then t else h :: delete (x, t);
++ fun delete (_, [] : ('a * 'b) list) = []
++ | delete (x, h::t) = if same (#1 h, x) then t else h :: delete (x, t);
+ in
+- fun enter (entry as (a: 'a, b: 'b)) : unit =
++ fun enter (entry as (a: 'a, _: 'b)) : unit =
+ let
+ val list = !table;
+ val newList = if member (a, list) then delete (a, list) else list;
+@@ -207,5 +210,10 @@
+ second = Substring.string second }
+ end
+
++ structure Sharing =
++ struct
++ type lexan = lexan
++ end
++
+ end;
+
+Only in mlsource/MLCompiler: VALUEOPSSIG.sml
+diff -u -r mlsource/MLCompiler/VALUE_OPS.ML mlsource/MLCompiler/VALUE_OPS.ML
+--- mlsource/MLCompiler/VALUE_OPS.ML 2008-04-21 13:36:11.000000000 +0200
++++ mlsource/MLCompiler/VALUE_OPS.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -1,22 +1,22 @@
+ (*
+- Copyright (c) 2000
+- Cambridge University Technical Services Limited
++ Copyright (c) 2000
++ Cambridge University Technical Services Limited
+
+- Modified David C.J. Matthews 2008.
++ Modified David C.J. Matthews 2008-9.
+
+- This library is free software; you can redistribute it and/or
+- modify it under the terms of the GNU Lesser General Public
+- License as published by the Free Software Foundation; either
+- version 2.1 of the License, or (at your option) any later version.
+-
+- This library is distributed in the hope that it will be useful,
+- but WITHOUT ANY WARRANTY; without even the implied warranty of
+- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+- Lesser General Public License for more details.
+-
+- You should have received a copy of the GNU Lesser General Public
+- License along with this library; if not, write to the Free Software
+- Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
++ This library is free software; you can redistribute it and/or
++ modify it under the terms of the GNU Lesser General Public
++ License as published by the Free Software Foundation; either
++ version 2.1 of the License, or (at your option) any later version.
++
++ This library is distributed in the hope that it will be useful,
++ but WITHOUT ANY WARRANTY; without even the implied warranty of
++ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
++ Lesser General Public License for more details.
++
++ You should have received a copy of the GNU Lesser General Public
++ License along with this library; if not, write to the Free Software
++ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+ *)
+
+ (*
+@@ -27,277 +27,21 @@
+
+ functor VALUE_OPS (
+
+-(*****************************************************************************)
+-(* LEX *)
+-(*****************************************************************************)
+-structure LEX :
+-sig
+- type lexan
+-
+- val nullLex: lexan
+- val debugParams: lexan -> Universal.universal list
+-end;
+-
+-(*****************************************************************************)
+-(* CODETREE *)
+-(*****************************************************************************)
+-structure CODETREE :
+-sig
+- type machineWord
+- type codetree
+-
+- val CodeNil: codetree;
+- val CodeTrue: codetree;
+- val CodeZero: codetree;
+- val isCodeNil: codetree -> bool;
+- val mkTuple: codetree list -> codetree;
+- val mkRecLoad: int -> codetree;
+- val mkLoad: int * int -> codetree;
+- val mkInd: int * codetree -> codetree;
+- val mkConst: machineWord -> codetree;
+- val mkEnv: codetree list -> codetree;
+- val mkProc: codetree * int * int * string -> codetree;
+- val mkInlproc: codetree * int * int * string -> codetree;
+- val mkEval: codetree * codetree list * bool -> codetree;
+- val mkStr: string -> codetree;
+- val mkRaise: codetree -> codetree;
+- val mkNot: codetree -> codetree;
+- val mkTestnull: codetree -> codetree;
+- val mkTestnotnull: codetree -> codetree;
+- val mkTestinteq: codetree * codetree -> codetree;
+- val mkTestptreq: codetree * codetree -> codetree;
+- val mkCand: codetree * codetree -> codetree;
+- val mkCor: codetree * codetree -> codetree;
+- val mkMutualDecs: codetree list -> codetree;
+- val mkIf: codetree * codetree * codetree -> codetree;
+- val mkDec: int * codetree -> codetree;
+- val evalue: codetree -> machineWord;
+-
+- val structureEq: machineWord * machineWord -> bool
+-
+- val genCode: codetree * Universal.universal list -> unit -> codetree
+-end;
+-
+-(*****************************************************************************)
+-(* STRUCTVALS *)
+-(*****************************************************************************)
+-structure STRUCTVALS :
+-sig
+- type structVals
+- type codetree
+- type signatures
+- type typeConstrs
+-
+- type univTable
+- val sigName: signatures -> string
+- val sigTab: signatures -> univTable
+-
+- type typeId
+- val isUnsetId: typeId -> bool
+- val sameTypeId: typeId * typeId -> bool
+-
+- type typeVarForm
+-
+- type 'a possRef
+- val pling: 'a possRef -> 'a
+-
+- (* A type is the union of these different cases. *)
+- datatype types =
+- TypeVar of typeVarForm
+-
+- | TypeConstruction of (* typeConstructionForm *)
+- {
+- name: string,
+- value: typeConstrs possRef,
+- args: types list
+- }
+-
+- | FunctionType of (* functionTypeForm *)
+- {
+- arg: types,
+- result: types
+- }
+-
+- | LabelledType of (* labelledRecForm *)
+- {
+- recList: { name: string, typeof: types } list,
+- frozen: bool,
+- genericInstance: typeVarForm list
+- }
+-
+- | OverloadSet of (* overloadSetForm *)
+- {
+- typeset: typeConstrs list
+- }
+-
+- | BadType
+-
+- | EmptyType
+- ;
+-
+- datatype valAccess =
+- Global of codetree
+- | Local of { addr: int ref, level: int ref }
+- | Selected of { addr: int, base: structVals }
+- | Formal of int
+- | Overloaded of typeDependent (* Values only. *)
+-
+- and typeDependent =
+- Print
+- | PrintSpace
+- | MakeString
+- | MakeStringSpace
+- | InstallPP
+- | Equal
+- | NotEqual
+- | AddOverload
+- | TypeDep
+-
+- and values =
+- Value of {
+- name: string,
+- typeOf: types,
+- access: valAccess,
+- class: valueClass }
+-
+- (* Classes of values. *)
+- and valueClass =
+- SimpleValue
+- | Exception
+- | Constructor of { nullary: bool }
+-
+- val tvValue: typeVarForm -> types
+- val sameTv: typeVarForm * typeVarForm -> bool;
+-
+- val tcName: typeConstrs -> string
+- val tcTypeVars: typeConstrs -> types list
+- val tcEquivalent: typeConstrs -> types
+- val tcConstructors: typeConstrs -> values list
+- val tcIdentifier: typeConstrs -> typeId
+- val tcEquality: typeConstrs -> bool;
+- val tcLetDepth: typeConstrs -> int;
+- val tcSetConstructors: typeConstrs * values list -> unit;
+-
+- val makeTypeConstrs:
+- string * types list * types * typeId * bool * int -> typeConstrs;
+-
+- val isFreeId: typeId -> bool;
+-
+- val boolType: typeConstrs
+- val intType: typeConstrs
+- val charType: typeConstrs
+- val stringType: typeConstrs
+- val wordType: typeConstrs;
+- val realType: typeConstrs
+- val unitType: typeConstrs
+- val exnType: typeConstrs
+- val listType: typeConstrs
+- val refType: typeConstrs
+- val undefType: typeConstrs
+-
+- val undefinedStruct: structVals
+- val isUndefinedStruct: structVals -> bool
+- val structSignat: structVals -> signatures
+- val structName: structVals -> string
+- val structAccess: structVals -> valAccess
+- val makeSelectedStruct: structVals * structVals -> structVals
+-
+- type functors
+- val functorName: functors -> string
+- val functorArg: functors -> structVals
+- val functorResult: functors -> signatures
+-
+- val undefinedValue: values
+-
+- val makeValueConstr: string * types * bool * valAccess -> values
+- val makeGlobalV: string * types * codetree -> values
+- val makeLocalV: string * types * int ref * int ref -> values
+- val valName: values -> string
+- val valTypeOf: values -> types
+-
+- datatype fixStatus =
+- Infix of int
+- | InfixR of int
+- | Nonfix;
+-
+- datatype env =
+- Env of
+- {
+- lookupVal: string -> values option,
+- lookupType: string -> typeConstrs option,
+- lookupFix: string -> fixStatus option,
+- lookupStruct: string -> structVals option,
+- lookupSig: string -> signatures option,
+- lookupFunct: string -> functors option,
+- enterVal: string * values -> unit,
+- enterType: string * typeConstrs -> unit,
+- enterFix: string * fixStatus -> unit,
+- enterStruct: string * structVals -> unit,
+- enterSig: string * signatures -> unit,
+- enterFunct: string * functors -> unit
+- };
+-
+- val makeEnv: signatures -> env;
+-
+- type 'a tag = 'a Universal.tag;
+-
+- val signatureVar: signatures tag
+- val structVar: structVals tag
+- val typeConstrVar: typeConstrs tag
+- val valueVar: values tag
+- val fixVar: fixStatus tag
+-end;
++structure LEX : LEXSIG;
++structure CODETREE : CODETREESIG
++structure STRUCTVALS : STRUCTVALSIG;
++structure TYPESTRUCT : TYPETREESIG
+
+-(*****************************************************************************)
+-(* TYPESTRUCT *)
+-(*****************************************************************************)
+-structure TYPESTRUCT :
+-sig
+- type typeConstrs
+- type types
+- type lexan
+- type prettyPrinter
+- type values
+-
+- val mkTypeConstruction: string * typeConstrs * types list -> types
+- val mkFunctionType: types * types -> types
+- val mkProductType: types list -> types
+-
+- val generalise: types * bool -> types;
+- val overloadError: types * string * string * lexan * int -> unit
+- val generaliseOverload: types * typeConstrs list * bool -> types;
+- val typeConstrFromOverload: types * bool -> typeConstrs;
+- val makeEquivalent: typeConstrs * types list -> types
+- val constructorResult: types * types list -> types
+- val display: types * int * prettyPrinter * bool -> unit
+- val displayTypeConstrs: typeConstrs * int * prettyPrinter * bool -> unit
+- val sameTypeVar : types * types -> bool;
+- val firstArg: types -> types;
+-
+- val copyType:types * (types -> types) * (typeConstrs -> typeConstrs) -> types;
+-end;
+-
+-(*****************************************************************************)
+-(* PRINTTABLE *)
+-(*****************************************************************************)
+ structure PRINTTABLE :
+ sig
+- type machineWord
+- type typeId
+- type prettyPrinter
+ type typeConstrs
+ type codetree
+
+- val addPp: typeId * (prettyPrinter -> int -> machineWord -> machineWord -> unit) -> unit
+- val getPrint: typeId -> (prettyPrinter -> int -> machineWord -> machineWord -> unit)
+ val addOverload: string * typeConstrs * codetree -> unit
+ val getOverloads: string -> (typeConstrs * codetree) list
+ val getOverload: string * typeConstrs * (unit->codetree) -> codetree
+ end;
+
+-(*****************************************************************************)
+-(* UNIVERSALTABLE *)
+-(*****************************************************************************)
+ structure UNIVERSALTABLE:
+ sig
+ type universal = Universal.universal
+@@ -307,20 +51,14 @@
+ val univOver: univTable -> (string * universal) iter;
+ end;
+
+-(*****************************************************************************)
+-(* DEBUG *)
+-(*****************************************************************************)
+ structure DEBUG :
+ sig
+ val printDepthFunTag : (unit->int) Universal.tag
+- val printStringTag : (string->unit) Universal.tag
++ val errorDepthTag: int Universal.tag
+ val getParameter :
+ 'a Universal.tag -> Universal.universal list -> 'a
+ end;
+
+-(*****************************************************************************)
+-(* MISC *)
+-(*****************************************************************************)
+ structure MISC :
+ sig
+ exception InternalError of string; (* compiler error *)
+@@ -332,26 +70,8 @@
+ val iterList : 'a iter -> 'a list
+ end;
+
++structure PRETTY : PRETTYSIG;
+
+-(*****************************************************************************)
+-(* PRETTYPRINTER *)
+-(*****************************************************************************)
+-structure PRETTYPRINTER :
+-sig
+- type prettyPrinter
+-
+- val ppAddString : prettyPrinter -> string -> unit
+- val ppBeginBlock : prettyPrinter -> int * bool -> unit
+- val ppEndBlock : prettyPrinter -> unit -> unit
+- val ppBreak : prettyPrinter -> int * int -> unit
+-
+- val prettyPrint : int * (string -> unit) -> prettyPrinter;
+- val uglyPrint : (string -> unit) -> prettyPrinter;
+-end;
+-
+-(* DCJM 8/8/00. Previously Address was a global but we aren't allowed
+- to have sharing constraints with globals in ML97. We could use a
+- "where type" constraint but then we couldn't bootstrap from ML90. *)
+ structure ADDRESS :
+ sig
+ type machineWord; (* any legal bit-pattern (tag = 0 or 1) *)
+@@ -385,376 +105,132 @@
+ val F_mutable : Word8.word;
+ end;
+
+-(*****************************************************************************)
+-(* UTILITIES *)
+-(*****************************************************************************)
+ structure UTILITIES :
+ sig
+ val splitString: string -> { first:string,second:string }
+ end;
+
+-(*****************************************************************************)
+-(* VALUEOPS sharing constraints *)
+-(*****************************************************************************)
+-
+-sharing type
+- CODETREE.codetree
+-= STRUCTVALS.codetree
+-= PRINTTABLE.codetree
+-
+-sharing type
+- STRUCTVALS.typeConstrs
+-= TYPESTRUCT.typeConstrs
+-= PRINTTABLE.typeConstrs
+-
+-sharing type
+- STRUCTVALS.types
+-= TYPESTRUCT.types
+-
+-sharing type
+- STRUCTVALS.values
+-= TYPESTRUCT.values
+-
+-sharing type
+- STRUCTVALS.typeId
+-= PRINTTABLE.typeId
+-
+-sharing type
+- LEX.lexan
+-= TYPESTRUCT.lexan
+-
+-sharing type
+- PRINTTABLE.prettyPrinter
+-= TYPESTRUCT.prettyPrinter
+-= PRETTYPRINTER.prettyPrinter
+-
+-sharing type
+- UNIVERSALTABLE.iter
+-= MISC.iter
+-
+-sharing type
+- ADDRESS.machineWord
+-= CODETREE.machineWord
+-= PRINTTABLE.machineWord
+-
+-sharing type
+- UNIVERSALTABLE.univTable
+-= STRUCTVALS.univTable
+-) :
+-
+-(*****************************************************************************)
+-(* VALUEOPS exports signature *)
+-(*****************************************************************************)
+-sig
+- type machineWord
+- type lexan
+- type prettyPrinter
+- type codetree
+- type types
+- type values
+- type structVals
+- type functors
+- type valAccess
+- type typeConstrs
+- type signatures
+- type fixStatus
+- type univTable
+-
+- val exnId : exn -> machineWord
+- val exnName : exn -> string
+- val exnValue : exn -> machineWord
+-
+- val overloadType: values * bool -> types
+-
+- val chooseConstrRepr : (string*types) list -> codetree list
++structure COPIER: COPIERSIG
+
+- (* Construction functions. *)
+- val mkGvar: string * types * codetree -> values
+- val mkVar: string * types -> values
+- val mkSelectedVar: values * structVals -> values
+- val mkGconstr: string * types * codetree * bool -> values
+- val mkGex: string * types * codetree -> values
+- val mkEx: string * types -> values
+-
+- val mkSelectedType: typeConstrs * string * structVals option -> typeConstrs
++structure TYPEIDCODE: TYPEIDCODESIG
+
+- (* Standard values *)
+- val nilConstructor: values;
+- val consConstructor: values;
+-
++sharing STRUCTVALS.Sharing = TYPESTRUCT.Sharing = LEX.Sharing = PRETTY.Sharing
++ = COPIER.Sharing = CODETREE.Sharing = PRINTTABLE = ADDRESS = UNIVERSALTABLE = MISC
++ = TYPEIDCODE.Sharing
+
+- type nameSpace =
+- {
+- lookupVal: string -> values option,
+- lookupType: string -> typeConstrs option,
+- lookupFix: string -> fixStatus option,
+- lookupStruct: string -> structVals option,
+- lookupSig: string -> signatures option,
+- lookupFunct: string -> functors option,
+-
+- enterVal: string * values -> unit,
+- enterType: string * typeConstrs -> unit,
+- enterFix: string * fixStatus -> unit,
+- enterStruct: string * structVals -> unit,
+- enterSig: string * signatures -> unit,
+- enterFunct: string * functors -> unit,
+-
+- allVal: unit -> (string*values) list,
+- allType: unit -> (string*typeConstrs) list,
+- allFix: unit -> (string*fixStatus) list,
+- allStruct: unit -> (string*structVals) list,
+- allSig: unit -> (string*signatures) list,
+- allFunct: unit -> (string*functors) list
+- };
+-
+-
+- (* Print values. *)
+- val displayFixStatus: fixStatus * int * prettyPrinter -> unit
+- val displaySignatures: signatures * int * prettyPrinter * nameSpace * bool -> unit
+- val displayStructures: structVals * int * prettyPrinter * nameSpace * bool -> unit
+- val displayFunctors: functors * int * prettyPrinter * nameSpace * bool -> unit
+- val displayValues: values * int * prettyPrinter * nameSpace * bool -> unit
+- val printStruct: machineWord * types * int * prettyPrinter * nameSpace -> unit
+- val printValues: values * int * prettyPrinter * nameSpace -> unit
+-
+- val printSpaceTag: nameSpace Universal.tag
+- val nullEnvironment : nameSpace
+-
+- val codeStruct: structVals * int -> codetree
+- val codeAccess: valAccess * int -> codetree
+- val mkExIden: unit -> codetree
+- val codeVal: values * int * types * lexan * int -> codetree
+- val codeExFunction: values * int * types * lexan * int -> codetree
+- val applyFunction: values * codetree * int * types * lexan * int -> codetree
+- val getOverloadInstance: string * types * bool * lexan * int -> codetree*string
+- val isTheSameException: values * values -> bool
+- val raiseBind: codetree
+- val raiseMatch: codetree
+- val makeGuard: values * codetree * int -> codetree
+- val makeInverse: values * codetree * int -> codetree
+-
+- val lookupAny: string * (string -> 'a option) * (string -> structVals option) *
+- (structVals -> string -> 'a option) * string * 'a * (string -> unit) -> 'a
+-
+- val lookupStructure: string * {lookupStruct: string -> structVals option} *
+- string * (string -> unit) -> structVals
+-
+- val lookupStructureDirectly: string * {lookupStruct: string -> structVals option} *
+- string * (string -> unit) -> structVals
+-
+- val lookupValue: string * {lookupVal: string -> values option, lookupStruct: string -> structVals option} *
+- string * (string -> unit) -> values
+-
+- val lookupTyp: {lookupType: string -> typeConstrs option,
+- lookupStruct: string -> structVals option} *
+- string * (string -> unit) -> typeConstrs
+-
+- type representations
+- val RefForm: representations;
+- val BoxedForm: representations;
+- val EnumForm: int -> representations;
+-
+- val createNullaryConstructor: representations * string -> codetree
+- val createUnaryConstructor: representations * string -> codetree
+-
+-end (* VALUEOPS exports signature *) =
++) : VALUEOPSSIG =
+
+ (*****************************************************************************)
+ (* VALUEOPS functor body *)
+ (*****************************************************************************)
+ struct
+ open MISC;
+- open PRETTYPRINTER;
++ open PRETTY;
+
+ open LEX;
+ open CODETREE;
++ open TYPESTRUCT; (* Open this first because unitType is in STRUCTVALS as well. *)
++ open Universal; (* for tag etc. *)
+ open STRUCTVALS;
+- open TYPESTRUCT;
+ open PRINTTABLE;
+ open DEBUG;
+ open ADDRESS;
+ open UNIVERSALTABLE;
+- open Universal; (* for tag etc. *)
+ open RuntimeCalls; (* for POLY_SYS and EXC numbers *)
+ open UTILITIES;
++ open TYPEIDCODE
++ open COPIER
+
+- val lengthW = ADDRESS.length;
+ val length = List.length;
+
+ (* gets a value from the run-time system;
+ usually this is a closure, but sometimes it's an int. *)
+ val ioOp : int -> machineWord = RunCall.run_call1 POLY_SYS_io_operation;
+
+- val andb = Word8.andb and orb = Word8.orb
+- infix 6 andb;
++ val orb = Word8.orb
+ infix 7 orb;
+-
+-(************* "types" constructors copied here to reduce garbage *********)
+- fun isTypeVar (TypeVar _) = true
+- | isTypeVar _ = false;
+-
+- fun isTypeConstruction (TypeConstruction _) = true
+- | isTypeConstruction _ = false;
+-
+- fun isFunctionType (FunctionType _) = true
+- | isFunctionType _ = false;
+-
+- fun isLabelled (LabelledType _) = true
+- | isLabelled _ = false;
+-
+- fun isEmpty EmptyType = true
+- | isEmpty _ = false;
+-
+- val emptyType = EmptyType;
+-
+- val badType = BadType;
+-
+- type typeConstructionForm =
+- {
+- name: string,
+- value: typeConstrs ref,
+- args: types list
+- }
+-
+-
+- (* A function type takes two types, the argument and the result. *)
+-
+- and functionTypeForm =
+- {
+- arg: types,
+- result: types
+- }
+-
+- (* An entry in a labelled record type. *)
+-
+- and labelledRecEntry =
+- {
+- name: string,
+- typeOf: types
+- }
+-
+- (* A fixed labelled record. *)
+-
+- and labelledRecForm =
+- {
+- recList: { name: string, typeof: types } list,
+- frozen: bool
+- };
+-
+- fun typesTypeVar (TypeVar x) = x
+- | typesTypeVar _ = raise Match;
+-
+- fun typesTypeConstruction (TypeConstruction x) = x
+- | typesTypeConstruction _ = raise Match;
+-
+- fun typesFunctionType (FunctionType x) = x
+- | typesFunctionType _ = raise Match;
+-
+- fun typesLabelled (LabelledType x) = x
+- | typesLabelled _ = raise Match;
+-
+- fun ffArg ({arg,...} : functionTypeForm) = arg;
+- fun ffResult ({result,...} : functionTypeForm) = result;
+-
+- fun lreName ({name,...} : labelledRecEntry) = name;
+- fun lreTypeOf ({typeOf,...} : labelledRecEntry) = typeOf;
+-
+- fun lrfFrozen ({frozen,...} : labelledRecForm) = frozen;
+- fun lrfRecList ({recList,...} : labelledRecForm) = recList;
+-
+- fun tcfArgs ({args,...} : typeConstructionForm) = args;
+- fun tcfName ({name,...} : typeConstructionForm) = name;
+- fun tcfValue ({value,...} : typeConstructionForm) = !value;
+-(*************)
+-
+ (* Functions to construct the values. *)
+
+- fun mkGconstr (name, typeof, code, nullary) =
+- makeValueConstr (name, typeof, nullary, Global code);
++ fun mkGconstr (name, typeof, code, nullary, constrs, location) =
++ makeValueConstr (name, typeof, nullary, constrs, Global code, location);
+
+- (* Global variable *)
+- val mkGvar = makeGlobalV
++ (* Global variable *)
++ val mkGvar = makeGlobalV
+
+- (* Local variable - Generated by the second pass. *)
+- fun mkVar (name, typeof) = makeLocalV (name, typeof, ref 0, ref 0);
++ (* Local variable - Generated by the second pass. *)
++ fun mkVar (name, typeof, locations) = makeLocalV (name, typeof, ref 0, ref 0, locations);
+
+- (* Value in a local structure or a functor argument. May be simple value, exception
+- or constructor. *)
+- fun mkSelectedVar (Value { access = Formal addr, name, typeOf, class}, base) =
+- (* If the argument is "formal" set the base to the base structure. *)
+- Value{name=name, typeOf=typeOf, class=class, access=Selected{addr=addr, base=base}}
+-
+- | mkSelectedVar(selected, _) = selected (* global or overloaded? *);
+-
+- (* Construct a global exception. *)
+- fun mkGex (name, typeof, code) =
+- Value{ name = name, typeOf = typeof, access = Global code, class = Exception }
++ (* Value in a local structure or a functor argument. May be simple value, exception
++ or constructor. *)
++ fun mkSelectedVar (Value { access = Formal addr, name, typeOf, class, locations, ...}, base, openLocs) =
++ (* If the argument is "formal" set the base to the base structure. *)
++ Value{name=name, typeOf=typeOf, class=class,
++ access=Selected{addr=addr, base=base}, locations=openLocs @ locations, references = NONE}
++
++ | mkSelectedVar (Value { access = Global code, name, typeOf, class, locations, ...}, _, openLocs) =
++ (* Global: We need to add the location information. *)
++ Value{name=name, typeOf=typeOf, class=class, access=Global code,
++ locations=openLocs @ locations, references = NONE}
++
++ | mkSelectedVar(selected, _, _) = selected (* Overloaded? *);
++
++ (* Construct a global exception. *)
++ fun mkGex (name, typeof, code, locations) =
++ Value{ name = name, typeOf = typeof, access = Global code,
++ class = Exception, locations = locations, references = NONE }
+
+- (* Construct a local exception. *)
+- fun mkEx (name, typeof) =
+- Value{ name = name, typeOf = typeof,
+- access = Local{addr = ref 0, level = ref 0},
+- class = Exception }
++ (* Construct a local exception. *)
++ fun mkEx (name, typeof, locations) =
++ Value{ name = name, typeOf = typeof,
++ access = Local{addr = ref 0, level = ref 0},
++ class = Exception, locations=locations, references = NONE }
+
+ (* Copy a datatype (if necessary), converting the constructors to selections on
+ a base structure. This is used both when opening a structure and also for
+- replicating a datatype. *)
+- fun mkSelectedType(tcons: typeConstrs, newName: string, baseStruct: structVals option): typeConstrs =
+- let
+- (* Create a new constructor with the same unique ID. *)
+- val typeID = tcIdentifier tcons;
+- val newTypeCons =
+- makeTypeConstrs(newName, tcTypeVars tcons, EmptyType, typeID,
+- tcEquality tcons, tcLetDepth tcons);
+-
+- (* Copy the value constructors. *)
+- fun copyAConstructor(Value{name=cName, typeOf, class, access}) =
+- let
+- (* Copy the types of value constructors replacing
+- occurrences of the old type with the new one.
+- This is not strictly necessary but improves printing.
+- e.g. local datatype X = A | B in datatype Y = datatype X end;
+- A; prints A: Y rather than A: X *)
+- fun copyTypeCons (tcon : typeConstrs) : typeConstrs =
+- if sameTypeId(tcIdentifier tcon, typeID)
+- then newTypeCons
+- else tcon;
+- fun copyTyp (t : types) : types =
+- copyType (t, fn x => x, (* Don't bother with type variables. *)
+- copyTypeCons);
+- val newType = copyTyp typeOf;
+- val newAccess =
+- case (access, baseStruct) of
+- (* If we are opening a structure we must have a base structure
+- and we turn Formal entries into Selected. If we are replicating
+- a datatype within a signature the original constructors will
+- be Formal. *)
+- (Formal addr, SOME base) => Selected{base=base, addr=addr}
+- | (Formal _, NONE) => access
+- | _ => access; (* Probably already a global. *)
+- in
+- Value{name=cName, typeOf=newType, class=class, access=newAccess}
+- end
+-
+- val newValConstrs = map copyAConstructor (tcConstructors tcons)
+- in
+- tcSetConstructors(newTypeCons, newValConstrs);
+- newTypeCons
+- end
+-
+-(*****************************************************************************)
+-(* Representation of Exceptions (incomplete!) *)
+-(*****************************************************************************)
+- fun exnId (value : exn) : machineWord =
+- loadWord (toAddress value, 0w0);
+-
+- fun exnName (value : exn) : string =
+- unsafeCast (loadWord (toAddress value, 0w1));
+-
+- fun exnValue (value : exn) : machineWord =
+- unsafeCast (loadWord (toAddress value, 0w2));
+-
+- val toExn : machineWord -> exn = unsafeCast;
++ replicating a datatype. *)
++ fun mkSelectedType(tcons: typeConstrs, newName: string, baseStruct: structVals option, locations): typeConstrs =
++ let
++ (* Create a new constructor with the same unique ID. *)
++ val typeID = tcIdentifier tcons;
++ val newTypeCons =
++ makeDatatypeConstr(newName, tcTypeVars tcons, typeID,
++ tcLetDepth tcons, locations);
++
++ (* Copy the value constructors. *)
++ fun copyAConstructor(Value{name=cName, typeOf, class, access, ...}) =
++ let
++ (* Copy the types of value constructors replacing
++ occurrences of the old type with the new one.
++ This is not strictly necessary but improves printing.
++ e.g. local datatype X = A | B in datatype Y = datatype X end;
++ A; prints A: Y rather than A: X *)
++ fun copyTypeCons (tcon : typeConstrs) : typeConstrs =
++ if sameTypeId(tcIdentifier tcon, typeID)
++ then newTypeCons
++ else tcon;
++ fun copyTyp (t : types) : types =
++ copyType (t, fn x => x, (* Don't bother with type variables. *)
++ copyTypeCons);
++ val newType = copyTyp typeOf;
++ val newAccess =
++ case (access, baseStruct) of
++ (* If we are opening a structure we must have a base structure
++ and we turn Formal entries into Selected. If we are replicating
++ a datatype within a signature the original constructors will
++ be Formal. *)
++ (Formal addr, SOME base) => Selected{base=base, addr=addr}
++ | (Formal _, NONE) => access
++ | _ => access; (* Probably already a global. *)
++ in
++ Value{name=cName, typeOf=newType, class=class, access=newAccess, locations=locations,
++ references = NONE}
++ end
++
++ val newValConstrs = map copyAConstructor (tcConstructors tcons)
++ in
++ tcSetConstructors(newTypeCons, newValConstrs);
++ newTypeCons
++ end
+
+ (*****************************************************************************)
+ (* Representation of Datatype Constructors *)
+@@ -772,10 +248,10 @@
+
+ | ConstForm of machineWord (* Constant - argument is a tagged value. *)
+ | TaggedBox of int (* Union - tagged and boxed. i.e. the representation is a
+- pair whose first word is the tag and second is the value. *)
++ pair whose first word is the tag and second is the value. *)
+ | TaggedTuple of int * int (* Union - tagged but with in-line tuple. i.e. for a
+- tuple of size n the representation is a tuple of size n+1
+- whose first word contains the tag. *)
++ tuple of size n the representation is a tuple of size n+1
++ whose first word contains the tag. *)
+
+
+ (* This makes the isConsTest "fn x => not (isShort x)" rather than
+@@ -804,14 +280,21 @@
+ or not I don't know. DCJM Sept 2000. *)
+
+ val arg1 = mkLoad (~1, 0); (* saves a lot of garbage *)
+- val arg2 = mkLoad (~2, 0);
++
++ val mutableFlags = F_words orb F_mutable;
++
++ (* allocate 1 mutable word, initialise to "v"; do not evaluate "early" *)
++ fun refApplyCode (v: codetree) =
++ mkEval
++ (mkConst (ioOp POLY_SYS_alloc_store),
++ [mkConst (toMachineWord 1), mkConst (toMachineWord mutableFlags), v],
++ false);
+
+ (* Don't do this ...
+ val OnlyOne = UnboxedForm;
+ ... because that gives the wrong test if the value isn't boxed. SPF 22/10/94 *)
+
+ local
+- val mutableFlags = F_words orb F_mutable;
+
+ fun abstract (doIt: codetree -> codetree) (name : string) : codetree =
+ mkInlproc (doIt arg1, 0, 1, name);
+@@ -824,33 +307,6 @@
+ fun loadTag (u: machineWord) : machineWord =
+ loadWord (toAddress u, 0w0); (* tag is first field *)
+
+- (* get the data from a TaggedBox *)
+- fun loadTaggedBoxedValue (u: machineWord) : machineWord =
+- loadWord (toAddress u, 0w1); (* contents is second field *)
+-
+- (* get the data from a BoxedForm or a RefForm *)
+- fun loadBoxedValue (u: machineWord) : machineWord = loadWord (toAddress u, 0w0);
+-
+- fun loadTaggedTupleValue (n: int) (u : machineWord) : machineWord =
+- let
+- val vec = alloc (toShort n, mutableFlags, toMachineWord 0);
+-
+- fun copyField i =
+- let
+- val w : machineWord = loadWord (toAddress u, toShort (i + 1));
+- in
+- assignWord (toAddress vec, toShort i, w)
+- end;
+-
+- fun copyFields i =
+- if i < n then (copyField i; copyFields (i + 1)) else ();
+-
+- val U : unit = copyFields 0;
+- val U : unit = lock vec;
+- in
+- toMachineWord vec
+- end;
+-
+ fun identityApplyCode v = v; (* no-op *)
+ fun boxApplyCode v = mkTuple [v];
+
+@@ -869,7 +325,7 @@
+ let
+ (* copy n data fields out of ordinary record *)
+ fun getFields i =
+- if i < n then mkInd (i, arg1) :: getFields (i + 1) else [];
++ if i < n then mkInd (i, arg1) :: getFields (i + 1) else [];
+ in
+ mkInlproc (mkTuple (mkTag tag :: getFields 0), 0, 1, name)
+ end;
+@@ -881,20 +337,13 @@
+ let
+ (* copy n data fields out of tagged record *)
+ fun getFields i =
+- if i <= n then mkInd (i, arg1) :: getFields (i + 1) else [];
+-
++ if i <= n then mkInd (i, arg1) :: getFields (i + 1) else [];
++
+ val proc = mkInlproc (mkTuple (getFields 1), 0, 1, "")
+ in
+ mkEval (proc, [arg], true)
+ end;
+
+- (* allocate 1 mutable word, initialise to "v"; do not evaluate "early" *)
+- fun refApplyCode (v: codetree) =
+- mkEval
+- (mkConst (ioOp POLY_SYS_alloc_store),
+- [mkConst (toMachineWord 1), mkConst (toMachineWord mutableFlags), v],
+- false);
+-
+ (* If we need to make a "real" functions, here's how *)
+ val refCode = abstract refApplyCode "ref";
+ (* val consCode = abstract identityApplyCode "::" *);
+@@ -956,7 +405,7 @@
+ | TaggedTuple (tag, n) => tagTupleApplyCode tag n
+ | OnlyOne => identityApplyCode
+ | _ =>
+- (fn arg => raise InternalError "constant can't be applied")
++ (fn _ => raise InternalError "constant can't be applied")
+
+ (* The run-time test whether a value matches a constructor. *)
+ fun constrMatch (test: representations) (value:codetree) : codetree =
+@@ -966,7 +415,7 @@
+ | RefForm => CodeTrue
+ | EnumForm tag => testTag tag value
+ | TaggedBox tag => testBoxedTag tag value
+- | TaggedTuple (tag, n) => testBoxedTag tag value
++ | TaggedTuple (tag, _) => testBoxedTag tag value
+ | ConstForm c => testBoxedTag (Word.toIntX (* May be signed. *) (toShort (loadTag c))) value
+ | OnlyOne => CodeTrue
+ | UnitForm => CodeTrue
+@@ -994,11 +443,11 @@
+ UnboxedForm => identityApplyCode value
+ | BoxedForm => boxedDestructCode value
+ | RefForm => refDestructCode value
+- | TaggedBox tag => taggedBoxDestructCode value
+- | TaggedTuple (tag, n) => taggedTupleDestructCode n value
++ | TaggedBox _ => taggedBoxDestructCode value
++ | TaggedTuple (_, n) => taggedTupleDestructCode n value
+ | OnlyOne => identityApplyCode value
+- | EnumForm tag => CodeZero (* To keep optimiser happy. *)
+- | ConstForm c => CodeZero (* (rather than raising an exception) *)
++ | EnumForm _ => CodeZero (* To keep optimiser happy. *)
++ | ConstForm _ => CodeZero (* (rather than raising an exception) *)
+ | UnitForm => CodeZero
+ ;
+
+@@ -1018,55 +467,53 @@
+ *)
+
+ in
+- (* Constructors are now represented as run-time values. A nullary constructor is
+- a pair consisting of a test function and the constructor value. A unary
+- constructor is a triple: a test function, an injection function and a
+- projection function.
+- Previously constructors were handled entirely at compile with the appropriate
+- functions inserted whenever a constructor was used. This worked fine except
+- in one case: when a datatype was used in a structure we couldn't use the optimal
+- representation because it might match a datatype in a signature and we needed
+- the same representation in both cases. This arises if we have a datatype
+- such as
+- type t = int * int datatype s = X | Y of t
+- We can use an optimised representation because we know that Y constructors are
+- always boxed. If we have
+- type t = int datatype s = X | Y of t
+- we can't do that and have to create tagged pairs for Y values. Unfortunately
+- we could pass either of these to a functor expecting a signature of the form
+- sig type t datatype s = X | Y of t end
+- If we handle constructors entirely at compile time we are forced to use the
+- same representation for Y constructors in both cases. By passing the
+- constructors as run-time values we can use different representations.
+- This actually costs very little at run-time because functor are inlined
+- so the constructor functions become inserted inline. DCJM 18/5/01. *)
+-
+- fun createNullaryConstructor (test: representations, name: string): codetree =
+- let
+- val code =
+- mkTuple[mkInlproc(constrMatch test arg1, 0, 1, name), (* Test function. *)
+- constrMake test name (* Value. *)]
+- in
+- (* Code generate the tuple now. This saves us having multiple occurrences of
+- the code but more importantly allows us to be able to print values of
+- this datatype (printstruct uses evalue and that only works if we have
+- a constant). *)
+- genCode (code, [] (* No debugging output *)) ()
+- end
+-
+- fun createUnaryConstructor(test: representations, name: string): codetree =
+- let
+- val code =
+- mkTuple[mkInlproc(constrMatch test arg1, 0, 1, name), (* Test function. *)
+- mkInlproc(constrApply test arg1, 0, 1, name), (* Injection function. *)
+- mkInlproc(constrDestruct test arg1, 0, 1, name) (* Projection function. *)]
+- in
+- (* Code generate the tuple now. *)
+- genCode (code, [] (* No debugging output *)) ()
+- end
++ (* Constructors are now represented as run-time values. A nullary constructor is
++ a pair consisting of a test function and the constructor value. A unary
++ constructor is a triple: a test function, an injection function and a
++ projection function.
++ Previously constructors were handled entirely at compile with the appropriate
++ functions inserted whenever a constructor was used. This worked fine except
++ in one case: when a datatype was used in a structure we couldn't use the optimal
++ representation because it might match a datatype in a signature and we needed
++ the same representation in both cases. This arises if we have a datatype
++ such as
++ type t = int * int datatype s = X | Y of t
++ We can use an optimised representation because we know that Y constructors are
++ always boxed. If we have
++ type t = int datatype s = X | Y of t
++ we can't do that and have to create tagged pairs for Y values. Unfortunately
++ we could pass either of these to a functor expecting a signature of the form
++ sig type t datatype s = X | Y of t end
++ If we handle constructors entirely at compile time we are forced to use the
++ same representation for Y constructors in both cases. By passing the
++ constructors as run-time values we can use different representations.
++ This actually costs very little at run-time because functor are inlined
++ so the constructor functions become inserted inline. DCJM 18/5/01. *)
++
++ fun createNullaryConstructor (test: representations, name: string): codetree =
++ let
++ val code =
++ mkTuple[mkInlproc(constrMatch test arg1, 0, 1, name), (* Test function. *)
++ constrMake test name (* Value. *)]
++ in
++ (* Code generate the tuple now. This saves us having multiple occurrences of
++ the code but more importantly allows us to be able to print values of
++ this datatype (printstruct uses evalue and that only works if we have
++ a constant). *)
++ genCode (code, [] (* No debugging output *)) ()
++ end
++
++ fun createUnaryConstructor(test: representations, name: string): codetree =
++ let
++ val code =
++ mkTuple[mkInlproc(constrMatch test arg1, 0, 1, name), (* Test function. *)
++ mkInlproc(constrApply test arg1, 0, 1, name), (* Injection function. *)
++ mkInlproc(constrDestruct test arg1, 0, 1, name) (* Projection function. *)]
++ in
++ (* Code generate the tuple now. *)
++ genCode (code, [] (* No debugging output *)) ()
++ end
+
+- (* Construct a nex execption identifier - it's really just a unit ref. *)
+- fun mkExIden () : codetree = refApplyCode CodeZero;
+ end;
+
+ (*
+@@ -1123,7 +570,7 @@
+ (* In the new datatype format, I've moved the tag word, so
+ we only need a one-word object. SPF 26/5/95 *)
+ val vec : address = alloc (0w1, F_words, toMachineWord n);
+- val U : unit = lock vec;
++ val () = lock vec;
+ in
+ ConstForm (toMachineWord vec)
+ end;
+@@ -1139,29 +586,29 @@
+
+ (* We use this version if all the constructors are nullary (i.e. constants)
+ except possibly one. The (at most one) unary constructor is represented
+- by the boxed value and the nullary constructors by untagged integers. *)
++ by the boxed value and the nullary constructors by untagged integers. *)
+ (* Note that "UnaryTupled 0" (which would arise as a result of a declaration of the
+ form datatype t = A of () | ... ) can't be represented as "UnboxedForm"
+ because "{}" is represented as a short (unboxed) integer. *)
+- fun chooseOptimisedRepr1 n [] = []
++ fun chooseOptimisedRepr1 _ [] = []
+ | chooseOptimisedRepr1 n (h :: t) =
+ case h of
+ (Nullary, name) =>
+- createNullaryConstructor(EnumForm n, name) :: chooseOptimisedRepr1 (nextTag n) t
++ createNullaryConstructor(EnumForm n, name) :: chooseOptimisedRepr1 (nextTag n) t
+ | (UnaryGeneric, name) =>
+- createUnaryConstructor(BoxedForm, name) :: chooseOptimisedRepr1 n t
++ createUnaryConstructor(BoxedForm, name) :: chooseOptimisedRepr1 n t
+ | (UnaryFunction, name) =>
+- createUnaryConstructor(UnboxedForm, name) :: chooseOptimisedRepr1 n t
++ createUnaryConstructor(UnboxedForm, name) :: chooseOptimisedRepr1 n t
+ | (UnaryTupled 0, name) =>
+- createUnaryConstructor(BoxedForm, name) :: chooseOptimisedRepr1 n t
++ createUnaryConstructor(BoxedForm, name) :: chooseOptimisedRepr1 n t
+ | (UnaryTupled _, name) =>
+- createUnaryConstructor(UnboxedForm, name) :: chooseOptimisedRepr1 n t
++ createUnaryConstructor(UnboxedForm, name) :: chooseOptimisedRepr1 n t
+
+ (* We use this version there's more than 1 unary constructor. *)
+ (* With this representation constructors of small tuples make tuples of
+ size n+1 whose first word is the tag. Nullary constructors are represented
+- by single word objects containing the tag. *)
+- fun chooseOptimisedRepr2 n [] = []
++ by single word objects containing the tag. *)
++ fun chooseOptimisedRepr2 _ [] = []
+ | chooseOptimisedRepr2 n (h :: t) =
+ let
+ val repr =
+@@ -1170,77 +617,76 @@
+ | (UnaryGeneric, name) => createUnaryConstructor(TaggedBox n, name)
+ | (UnaryFunction, name) => createUnaryConstructor(TaggedBox n, name)
+ | (UnaryTupled i, name) =>
+- createUnaryConstructor(
+- if i <= 4 (*!maxPacking*) then TaggedTuple (n, i) else TaggedBox n, name)
++ createUnaryConstructor(
++ if i <= 4 (*!maxPacking*) then TaggedTuple (n, i) else TaggedBox n, name)
+ in
+ repr :: chooseOptimisedRepr2 (nextTag n) t
+ end;
+
+- fun getTupleKind t =
+- case t of
+- LabelledType {recList = [{typeof=t', ...}], frozen = true, ...} =>
+- (* Singleton records are always represented simply by the value. *)
+- getTupleKind t'
+-
+- | LabelledType {recList, frozen = true, ...} =>
+- UnaryTupled (length recList)
+-
+- | FunctionType _ =>
+- UnaryFunction
+-
+- | TypeConstruction {name, value, args} =>
+- let
+- val cons = pling value
+- val equiv = tcEquivalent cons;
+- in
+- (* We may have a type equivalence or this may be a datatype. *)
+- if not (isEmpty equiv)
+- then getTupleKind (makeEquivalent(cons, args))
+- else if sameTypeId (tcIdentifier cons, tcIdentifier refType)
+- then UnaryGeneric (* A tuple ref is NOT the same as the tuple. *)
+- else (* Datatype. For the moment we only consider datatypes with a
+- single constructor since we want to find the width of the
+- tuple. At present we simply return UnaryGeneric for all
+- other cases but it might be helpful to return a special
+- result when we have a datatype which we know will always
+- be boxed. *)
+- case tcConstructors cons of
+- [Value{typeOf, class=Constructor{nullary=false}, ...}] =>
+- (* This may be a polymorphic datatype in which case
+- we have to invert the constructor to find the base type.
+- e.g. we may have an instance (int*int) t where t was
+- declared as datatype 'a t = X of 'a .*)
+- getTupleKind(constructorResult(typeOf, args))
+- | _ => UnaryGeneric
+- end
+-
+- | _ =>
+- UnaryGeneric
++ fun getTupleKind t =
++ case t of
++ LabelledType {recList = [{typeof=t', ...}], frozen = true, ...} =>
++ (* Singleton records are always represented simply by the value. *)
++ getTupleKind t'
++
++ | LabelledType {recList, frozen = true, ...} =>
++ UnaryTupled (length recList)
++
++ | FunctionType _ =>
++ UnaryFunction
++
++ | TypeConstruction {value, args, ...} =>
++ let
++ val cons = pling value
++ in
++ (* We may have a type equivalence or this may be a datatype. *)
++ if tcIsAbbreviation cons
++ then getTupleKind (makeEquivalent(cons, args))
++ else if sameTypeId (tcIdentifier cons, tcIdentifier refType)
++ then UnaryGeneric (* A tuple ref is NOT the same as the tuple. *)
++ else (* Datatype. For the moment we only consider datatypes with a
++ single constructor since we want to find the width of the
++ tuple. At present we simply return UnaryGeneric for all
++ other cases but it might be helpful to return a special
++ result when we have a datatype which we know will always
++ be boxed. *)
++ case tcConstructors cons of
++ [Value{typeOf, class=Constructor{nullary=false, ...}, ...}] =>
++ (* This may be a polymorphic datatype in which case
++ we have to invert the constructor to find the base type.
++ e.g. we may have an instance (int*int) t where t was
++ declared as datatype 'a t = X of 'a .*)
++ getTupleKind(constructorResult(typeOf, args))
++ | _ => UnaryGeneric
++ end
++
++ | _ =>
++ UnaryGeneric
+
+ (* This now creates the functions as well as choosing the representation. *)
+- fun chooseConstrRepr cs =
+- let
+- fun checkArgKind (name, EmptyType) = (Nullary, name)
+- | checkArgKind (name, argType) = (getTupleKind argType, name)
+- val kinds = map checkArgKind cs;
+-
+- fun chooseRepr [(Nullary, name)] = [createNullaryConstructor(UnitForm, name)]
+- | chooseRepr [(UnaryGeneric, name)] = [createUnaryConstructor(OnlyOne, name)]
+- | chooseRepr [(UnaryFunction, name)] = [createUnaryConstructor(OnlyOne, name)]
+- | chooseRepr [(UnaryTupled _, name)] = [createUnaryConstructor(OnlyOne, name)]
+- | chooseRepr l =
+- let
+- val unaryCount = List.foldl(fn((Nullary, _), n) => n | (_,n) => n+1) 0 l
+- in
+- (* tags now allocated from 0 (SPF 22/10/94) *)
+- if unaryCount <= 1
+- then chooseOptimisedRepr1 0 l (* can save the box *)
+- else chooseOptimisedRepr2 0 l (* can use tagged tuples *)
+- end;
+-
+- in
+- chooseRepr kinds
+- end;
++ fun chooseConstrRepr cs =
++ let
++ fun checkArgKind (name, EmptyType) = (Nullary, name)
++ | checkArgKind (name, argType) = (getTupleKind argType, name)
++ val kinds = map checkArgKind cs;
++
++ fun chooseRepr [(Nullary, name)] = [createNullaryConstructor(UnitForm, name)]
++ | chooseRepr [(UnaryGeneric, name)] = [createUnaryConstructor(OnlyOne, name)]
++ | chooseRepr [(UnaryFunction, name)] = [createUnaryConstructor(OnlyOne, name)]
++ | chooseRepr [(UnaryTupled _, name)] = [createUnaryConstructor(OnlyOne, name)]
++ | chooseRepr l =
++ let
++ val unaryCount = List.foldl(fn((Nullary, _), n) => n | (_,n) => n+1) 0 l
++ in
++ (* tags now allocated from 0 (SPF 22/10/94) *)
++ if unaryCount <= 1
++ then chooseOptimisedRepr1 0 l (* can save the box *)
++ else chooseOptimisedRepr2 0 l (* can use tagged tuples *)
++ end;
++
++ in
++ chooseRepr kinds
++ end;
+
+ (* RefForm, NilForm and ConsForm are only used for built-in types *)
+
+@@ -1249,130 +695,281 @@
+ (* Standard values and exceptions. *)
+ (*****************************************************************************)
+
+- (* Nil and :: are used in parsetree for lists constructed
+- using [ ... ] and are also used for initialisation. *)
+- local
+- val listTypeVars = tcTypeVars listType;
+- val alpha = hd listTypeVars;
+- val alphaList = mkTypeConstruction ("list", listType, listTypeVars);
+- val consType = mkFunctionType (mkProductType [alpha, alphaList], alphaList);
+- in
+- val nilConstructor =
+- mkGconstr ("nil", alphaList, createNullaryConstructor(NilForm, "nil"), true);
+- val consConstructor =
+- mkGconstr ("::", consType, createUnaryConstructor(ConsForm, "::"), false);
+- end;
+-
+- (* Create exception values - Small integer values are used for
+- run-time system exceptions but only (currently) up to 22. *)
+- val bindExceptionVal = mkConst (toMachineWord EXC_Bind);
+- val matchExceptionVal = mkConst (toMachineWord EXC_Match);
+-
+-(*****************************************************************************)
++ (* Build a datatype within the basis. *)
++ fun buildBasisDatatype(tcName, tIdPath, tyVars, isEqType: bool,
++ mkValConstrs: typeConstrs -> values list) =
++ let
++ (* Create a temporary datatype. The "name" we put in here is usually the
++ same as the type constructor name except for datatypes in the PolyML structure
++ which have the PolyML prefix. *)
++ val description = basisDescription tIdPath
++ val id =
++ makeBoundId(Local{addr = ref 0, level = ref 0}, 0 (* IdNumber*), isEqType, true, description)
++ val dtype = makeDatatypeConstr (tcName, tyVars, id, 0, [DeclaredAt inBasis]);
++ (* Build the constructors. *)
++ val valConstrs = mkValConstrs dtype
++ (* The constructors have to be ordered as in genValueConstrs in PARSE_TREE. *)
++ fun leq (Value{name=xname, ...}) (Value{name=yname, ...}) = xname < yname;
++ val sortedConstrs = quickSort leq valConstrs;
++ val () = tcSetConstructors(dtype, sortedConstrs)
++ val addrs = ref 0
++ fun mkAddrs() = ! addrs before (addrs := !addrs+1)
++ (* Create the datatype. Sets the address of the local in "id". *)
++ val dtCode = createDatatypeFunctions([dtype], [isEqType], mkAddrs, 0)
++ (* Compile and execute the code to build the functions and extract the result. *)
++ val globalCode = genCode(mkEnv(dtCode @ [codeId(id, 0)]), [])()
++ val newId = makeFreeId(Global globalCode, isEqType, description)
++ (* Finally copy the datatype to put in the code. *)
++ in
++ fullCopyDatatype(dtype, fn 0 => newId | _ => raise Subscript, "")
++ end
++
++ (* Nil and :: are used in parsetree for lists constructed
++ using [ ... ] and are also used for initialisation. *)
++ local
++ fun makeConsAndNil listType =
++ let
++ val listTypeVars = tcTypeVars listType;
++ val alpha = TypeVar(hd listTypeVars);
++ val alphaList = mkTypeConstruction ("list", listType, [alpha], [DeclaredAt inBasis]);
++ val consType = mkFunctionType (mkProductType [alpha, alphaList], alphaList);
++ val nilConstructor =
++ mkGconstr ("nil", alphaList, createNullaryConstructor(NilForm, "nil"), true, 2, [DeclaredAt inBasis]);
++ val consConstructor =
++ mkGconstr ("::", consType, createUnaryConstructor(ConsForm, "::"), false, 2, [DeclaredAt inBasis]);
++ in
++ [nilConstructor, consConstructor]
++ end
++ in
++ val listType =
++ buildBasisDatatype("list", "list",
++ [makeTv (EmptyType, generalisable, false, false)], true, makeConsAndNil)
++ val (nilConstructor, consConstructor) =
++ case tcConstructors listType of
++ [consC as Value{name="::", ...}, nilC as Value{name="nil", ...}] => (nilC, consC)
++ | _ => raise InternalError "nil and cons in wrong order"
++ end
++
++ local
++ fun makeNoneAndSome optionType =
++ let
++ val optionTypeVars = tcTypeVars optionType;
++ val alpha = TypeVar(hd optionTypeVars);
++ val alphaOption = mkTypeConstruction ("option", optionType, [alpha], [DeclaredAt inBasis]);
++ val someType = mkFunctionType (alpha, alphaOption);
++ val noneConstructor =
++ mkGconstr ("NONE", alphaOption,
++ createNullaryConstructor(EnumForm 0, "NONE"), true, 2, [DeclaredAt inBasis]);
++ val someConstructor =
++ mkGconstr ("SOME", someType,
++ createUnaryConstructor(BoxedForm, "SOME"), false, 2, [DeclaredAt inBasis]);
++ in
++ [noneConstructor, someConstructor]
++ end
++ in
++ val optionType =
++ buildBasisDatatype("option", "option",
++ [makeTv (EmptyType, generalisable, false, false)], true, makeNoneAndSome)
++ val (noneConstructor, someConstructor) =
++ case tcConstructors optionType of
++ [noneC as Value{name="NONE", ...}, someC as Value{name="SOME", ...}] => (noneC, someC)
++ | _ => raise InternalError "NONE and SOME in wrong order"
++ end
++
++ (* Construct an exception identifier - This is a ref (so we can uniquely
++ identify it) containing a print function for the type. *)
++ fun mkExIden(ty, level) =
++ let
++ val makeSome = case someConstructor of Value { access, ...} => vaGlobal access
++ val makeNone = case noneConstructor of Value { access, ...} => vaGlobal access
++ val printerCode =
++ case ty of
++ FunctionType { arg, ...} =>
++ mkEval(mkInd(1, makeSome), [printerForType(arg, level)], true)
++ | _ => mkInd(1, makeNone)
++ in
++ refApplyCode printerCode
++ end
++
++ (* Locations in exception packets. In order to have a defined ordering of the fields,
++ when we put the location in an exception packet we use this datatype rather than
++ the "location" type. *)
++ (* *)
++ datatype RuntimeLocation =
++ NoLocation
++ | SomeLocation of
++ (* file: *) string *
++ (*startLine:*) int * (*startPosition:*) int *
++ (*endLine:*) int * (*endPosition:*) int
++
++ fun codeLocation({file="", startLine=0, startPosition=0, ...}) =
++ mkConst(toMachineWord NoLocation) (* No useful information *)
++ | codeLocation({file, startLine, startPosition, endLine, endPosition}) =
++ mkConst(toMachineWord(file, startLine, startPosition, endLine, endPosition))
+
++(*****************************************************************************)
+ (* Look-up functions. *)
+- fun mkEnv x = let val Env e = makeEnv x in e end
+-
+- (* Look up a structure. *)
+- fun lookupStructure (kind, {lookupStruct:string -> structVals option},
+- name, errorMessage) =
+- let
+- fun lookupStr name secondary =
++
++ (* Look up a structure. *)
++ fun lookupStructure (kind, {lookupStruct:string -> structVals option},
++ name, errorMessage) =
+ let
+- val {first = prefix, second = suffix} = splitString name;
+- val strLookedUp =
+- if prefix = "" then lookupStruct suffix
+- else let (* Look up the first part in the structure environment. *)
+- val str =
+- lookupStructure
+- ("Structure", {lookupStruct=lookupStruct}, prefix, errorMessage);
+- in
+- (* If the structure is not there the value can't be. *)
+- if isUndefinedStruct str
+- then SOME undefinedStruct
+- else secondary str suffix (* Look up in it and select. *)
+- end
++ val {first = prefix, second = suffix} = splitString name;
++ val strLookedUp =
++ if prefix = ""
++ then lookupStruct suffix
++ else
++ let (* Look up the first part in the structure environment. *)
++ val str =
++ lookupStructure
++ ("Structure", {lookupStruct=lookupStruct}, prefix, errorMessage);
++ in
++ if isUndefinedStruct str
++ then SOME undefinedStruct (* Error somewhere else? *)
++ else
++ let
++ val Signatures { tab, typeIdMap, minTypes, maxTypes, ... } = structSignat str
++ val Env{lookupStruct, ...} = makeEnv tab
++ (* If we have a DeclaredAt location for the structure use this as the StructureAt.*)
++ val baseLoc =
++ case List.find (fn DeclaredAt _ => true | _ => false) (structLocations str) of
++ SOME (DeclaredAt loc) => [StructureAt loc]
++ | _ => []
++ in
++ case lookupStruct suffix of
++ SOME structFound =>
++ let
++ val Signatures { name, tab, typeIdMap = childMap, declaredAt, ... } = structSignat structFound
++ (* We need to apply the map from the parent structure to the child. *)
++ val copiedSig =
++ makeSignature(name, tab, minTypes, maxTypes, declaredAt, composeMaps(childMap, typeIdMap), [])
++ (* Convert Formal access to Selected and leave the others (Global?). *)
++ val newAccess =
++ case structAccess structFound of
++ Formal sel => makeSelected (sel, str)
++ | access => access
++
++ val newStruct =
++ Struct { name = structName structFound, signat = copiedSig,
++ access = newAccess, locations = baseLoc @ structLocations structFound}
++ in
++ SOME newStruct
++ end
++ | NONE => NONE
++ end
++ end
+ in
+ case strLookedUp of
+ SOME s => s
+ | NONE =>
+- (* Not declared? *)
++ (* Not declared? *)
+ (errorMessage (kind ^ " (" ^ suffix ^ ") has not been declared" ^
+- (if prefix = "" then "" else " in structure " ^ prefix));
++ (if prefix = "" then "" else " in structure " ^ prefix));
+ undefinedStruct)
+- end (* lookupStr *)
+- in
+- lookupStr name
+- (fn baseStruct =>
+- let
+- val look = #lookupStruct (mkEnv (structSignat baseStruct));
+- in
+- fn name => case look name of SOME s => SOME(makeSelectedStruct (s, baseStruct)) | NONE => NONE
+- end)
+- end;
+-
+- fun lookupAny
+- (name : string,
+- primary: string -> 'a option,
+- lookupStruct:string -> structVals option,
+- secondary: structVals -> string -> 'a option,
+- kind,
+- undefined:'a,
+- errorMessage)
+- : 'a =
+- let
+- val {first = prefix, second = suffix} = splitString name;
+- val found =
+- if prefix = "" then primary suffix
+- else let (* Look up the first part in the structure environment. *)
+- val str =
+- lookupStructure
+- ("Structure", {lookupStruct=lookupStruct}, prefix, errorMessage);
+- in
++ end;
++
++ fun mkEnv x = let val Env e = makeEnv x in e end
++
++ (* Look up a structure but ignore the access. This is used in sharing constraints
++ where we're only interested in the signature. *)
++ (* It's simpler to use the common code for this. *)
++ fun lookupStructureAsSignature (lookupStruct, name, errorMessage) =
++ lookupStructure("Structure", { lookupStruct = lookupStruct}, name, errorMessage)
++
++ (* Look up a value, possibly in a structure. If it is in
++ a structure we may have to apply a selection. *)
++ fun lookupValue (kind, {lookupVal,lookupStruct}, name, errorMessage) =
++ let
++ val {first = prefix, second = suffix} = splitString name;
++ val found =
++ if prefix = "" then lookupVal suffix
++ else
++ let (* Look up the first part in the structure environment. *)
++ val baseStruct =
++ lookupStructure
++ ("Structure", {lookupStruct=lookupStruct}, prefix, errorMessage);
++ in
++ (* If the structure is not there the value can't be. *)
++ if isUndefinedStruct baseStruct
++ then SOME undefinedValue
++ else
++ let
++ val Signatures { tab, typeIdMap, ...} = structSignat baseStruct
++ (* If we have a DeclaredAt location for the structure use this as the StructureAt.*)
++ val baseLoc =
++ case List.find (fn DeclaredAt _ => true | _ => false) (structLocations baseStruct) of
++ SOME (DeclaredAt loc) => [StructureAt loc]
++ | _ => []
++ in
++ case #lookupVal (mkEnv tab) suffix of
++ SOME (Value{ name, typeOf, access, class, locations, ... }) =>
++ let
++ fun copyId(Bound{ offset, ...}) = SOME(typeIdMap offset)
++ | copyId _ = NONE
++ val copiedType =
++ copyType (typeOf, fn x => x,
++ fn tcon =>
++ copyTypeConstr (tcon, copyId, fn x => x, fn s => prefix^"."^s))
++ in
++ SOME(mkSelectedVar (
++ Value{ name=name, typeOf=copiedType, access=access, class=class, locations=locations,
++ references = NONE },
++ baseStruct, baseLoc))
++ end
++ | NONE => NONE
++ end
++ end
++ in
++ case found of
++ SOME v => v
++ | NONE => (* Not declared? *)
++ (
++ errorMessage (kind ^ " (" ^ suffix ^ ") has not been declared" ^
++ (if prefix = "" then "" else " in structure " ^ prefix));
++ undefinedValue
++ )
++ end
++
++ fun lookupTyp ({lookupType,lookupStruct}, name, errorMessage) =
++ let
++ val {first = prefix, second = suffix} = splitString name;
++ val found =
++ if prefix = "" then lookupType suffix
++ else
++ let (* Look up the first part in the structure environment. *)
++ val str =
++ lookupStructure
++ ("Structure", {lookupStruct=lookupStruct}, prefix, errorMessage);
++ in
+ (* If the structure is not there the value can't be. *)
+ if isUndefinedStruct str
+- then SOME undefined
+- else secondary str suffix (* Look up in it and select. *)
+- end
+- in
+- case found of
+- SOME v => v
+- | NONE => (* Not declared? *)
+- (errorMessage (kind ^ " (" ^ suffix ^ ") has not been declared" ^
++ then SOME undefType
++ else
++ let
++ val Signatures { tab, typeIdMap, ...} = structSignat str
++ in
++ case #lookupType (mkEnv tab) suffix of
++ SOME typeConstr => SOME(fullCopyDatatype(typeConstr, typeIdMap, prefix^"."))
++ | NONE => NONE
++ end
++ end
++ in
++ case found of
++ SOME v => v
++ | NONE => (* Not declared? *)
++ (
++ errorMessage ("Type constructor" ^ " (" ^ suffix ^ ") has not been declared" ^
+ (if prefix = "" then "" else " in structure " ^ prefix));
+- undefined)
+- end (* lookupAny *)
+-
+- (* Look up a structure but return the actual structure even if it is a formal. *)
+- fun lookupStructureDirectly (kind, {lookupStruct}, name, errorMessage) =
+- lookupAny (name, lookupStruct, lookupStruct,
+- fn baseStruct => #lookupStruct (mkEnv (structSignat baseStruct)),
+- kind, undefinedStruct, errorMessage);
+-
+- (* Look up a value, possibly in a structure. If it is in
+- a structure we may have to apply a selection. *)
+- fun lookupValue (kind, {lookupVal,lookupStruct}, name, errorMessage) =
+- lookupAny (name, lookupVal, lookupStruct,
+- fn baseStruct =>
+- let
+- val look = #lookupVal (mkEnv (structSignat baseStruct));
+- in
+- (fn name => case look name of SOME v => SOME(mkSelectedVar (v, baseStruct)) | NONE => NONE)
+- end,
+- kind, undefinedValue, errorMessage);
+-
+- fun lookupTyp ({lookupType,lookupStruct}, name, errorMessage) =
+- lookupAny (name, lookupType, lookupStruct,
+- (* Types do not require a selection from the source
+- structure since there is no actual value. *)
+- fn s => #lookupType (mkEnv (structSignat s)),
+- "Type constructor", undefType, errorMessage);
+-
+-
+-
++ undefType
++ )
++ end
++
+
+ (* Printing. *)
+
++ (* This name space is used to help find type identifiers.
++ However, because the functions are passed through to the resulting environment
++ by INITIALISE we have to use the same type as the normal top-level environment. *)
+ type nameSpace =
+ {
+ lookupVal: string -> values option,
+@@ -1399,12 +996,12 @@
+
+ val nullEnvironment : nameSpace =
+ {
+- lookupVal = fn (s: string) => NONE,
+- lookupType = fn (s: string) => NONE,
+- lookupFix = fn (s: string) => NONE,
+- lookupStruct = fn (s: string) => NONE,
+- lookupSig = fn (s: string) => NONE,
+- lookupFunct = fn (s: string) => NONE,
++ lookupVal = fn _ => NONE,
++ lookupType = fn _ => NONE,
++ lookupFix = fn _ => NONE,
++ lookupStruct = fn _ => NONE,
++ lookupSig = fn _ => NONE,
++ lookupFunct = fn _ => NONE,
+ enterVal = fn _ => (),
+ enterType = fn _ => (),
+ enterFix = fn _ => (),
+@@ -1419,608 +1016,306 @@
+ allFunct = fn () => []
+ }
+
+- (* Debug tag for the name space for the printer environment. *)
+- val printSpaceTag: nameSpace tag = Universal.tag()
+-
+- (* Checks to see whether a labelled record is in the form of
+- a product i.e. 1=, 2= We only need this for prettyprinting. *)
+- fun isProductType(LabelledType{recList, frozen=true, ...}) =
+- let
+- fun isRec [] n = true
+- | isRec ({name, typeof} :: l) n =
+- name = Int.toString n andalso isRec l (n+1)
+- in
+- isRec recList 1
+- end
+- | isProductType _ = false;
+-
+- (* Find an exception with the given identifier. *)
+- fun findException (allValues: values list, allStructs: structVals list) (w: machineWord): values option =
++ (* Print a value given its type. *)
++ fun printValueForType (value:machineWord, types, depth): pretty =
+ let
+- fun searchList f [] = NONE
+- | searchList f (hd::tl) =
+- case f hd of
+- NONE => searchList f tl
+- | result => result
+-
+- open ADDRESS
+-
+- (* Test a value to see if it's the exception we want. *)
+- fun testValue base valu =
+- case valu of
+- (* Top-level exception *)
+- Value{class = Exception, access = Global code, ...} =>
+- if wordEq(evalue code, w) then SOME valu else NONE
+-
+- (* Exception in a structure. *)
+- | Value{class = Exception, access=Formal addr, ...} =>
+- if wordEq(loadWord(toAddress base, toShort addr), w)
+- then SOME valu else NONE
+-
+- | _ => NONE
+-
+- (* Search for the exception in a structure. *)
+- fun searchSpace(u: univTable, base: machineWord) =
+- let
+- (* Get a list of all the entries in this space. *)
+- val decList = iterList (univOver u)
+-
+- fun findItem (s: string, u: universal): values option =
+- if tagIs valueVar u (* Values *)
+- then testValue base (tagProject valueVar u)
+-
+- else if tagIs structVar u
+- then (* Search this structure recursively. *)
+- let
+- val str = tagProject structVar u
+- val access = structAccess str
+- in
+- case access of
+- Global code => (* Top-level structures. *)
+- searchSpace(sigTab (structSignat str), evalue code)
+-
+- | Formal addr => (* Sub-structures. *)
+- searchSpace(sigTab (structSignat str),
+- loadWord(toAddress base, toShort addr))
+-
+- | _ => NONE
+- end
+-
+- else NONE (* Not a structure or a value. *)
+- in
+- searchList findItem decList
+- end
+-
+- val globalBase = ADDRESS.toMachineWord 0 (* Unused. *)
++ (* Constuct printer code applied to the argument and the depth.
++ Code-generate and evaluate it. *)
++ val printerCode =
++ mkEval(
++ printerForType(types, 0),
++ [mkTuple[mkConst value, mkConst(toMachineWord depth)]],
++ false)
++ val pretty = RunCall.unsafeCast(evalue(genCode(printerCode, [])()))
+ in
+- (* First try the global values. *)
+- case searchList (testValue globalBase) allValues of
+- ex as SOME _ => ex (* found *)
+- | NONE => (* Not found; try in the structures. *)
+- searchList (
+- fn s =>
+- case structAccess s of
+- Global code =>
+- searchSpace(sigTab (structSignat s), evalue code)
+- | _ => NONE (* Should just be globals. *))
+- allStructs
+- end
+-
+- (* This module prints a structure by following the type structure. *)
+- fun printStruct (value:machineWord, types, depth, pprint:prettyPrinter, nameSpace: nameSpace) =
+- let
+- fun exceptionSearch (w: machineWord) : values option =
+- let
+- val values = #allVal nameSpace ()
+- and strs = #allStruct nameSpace ()
+- (* Filter out the strings. Order doesn't matter. *)
+- fun getVal [] l = l
+- | getVal ((_, v) :: r) l = getVal r (v::l)
+- in
+- findException(getVal values [], getVal strs []) w
+- end
+- val { lookupFix, lookupExnById} = { lookupFix = #lookupFix nameSpace, lookupExnById = exceptionSearch }
+-
+- fun pVec (num, value : machineWord, [], separator, leftPrec, rightPrec, depth) doPrint = ()
+-
+- | pVec (num, value : machineWord, [t], separator, leftPrec, rightPrec, depth) doPrint =
+- if num = 0 (* optimised unary tuples - no indirection! *)
+- then doPrint (value, t, depth, rightPrec)
+- else let
+- val addr : address = toAddress value;
+- val entryValue : machineWord = loadWord (addr, toShort num);
+- in
+- doPrint (entryValue, t, depth, rightPrec)
+- end
+-
+- | pVec (num, value, t::ts, separator, leftPrec, rightPrec, depth) doPrint =
+- if depth <= 0
+- then ppAddString pprint "..."
+- else
+- let
+- val addr : address = toAddress value;
+- val entryValue : machineWord = loadWord (addr, toShort num);
+- in
+- doPrint (entryValue, t, depth, leftPrec);
+-
+- (* Preceed infix ops by a space. *)
+- if separator <> ","
+- then ppBreak pprint (1, 0)
+- else ();
+-
+- ppAddString pprint separator;
+- ppBreak pprint (1, 0);
+- pVec (num + 1, value, ts, separator, leftPrec, rightPrec, depth-1) doPrint
+- end (* pVec *);
+-
+- fun prints (value : machineWord, types, depth, precedence, objList) : unit =
+- let (* Print out the contents of a tuple or labelled record. *)
+-
+- (* Print the constructor in infix notation if appropriate. *)
+- fun printInfixed(constrName, argType, args, objList) =
+- let
+- val maxPrec = 999;
+- val thisPrecedence =
+- getOpt(lookupFix constrName, Nonfix);
+-
+- (* Some of these need to be parenthesised. We replace values at
+- level 1 by "..." rather than printing "(...)". *)
+- fun mayParenthesise true f =
+- if depth <= 1
+- then ppAddString pprint "..."
+- else
+- (
+- ppAddString pprint "(";
+- f (depth-1);
+- ppAddString pprint ")"
+- )
+- | mayParenthesise false f = f depth
++ pretty
++ end
+
+- in
+- ppBeginBlock pprint (3, false);
+- case (thisPrecedence, argType) of
+- (Infix precNo,
+- LabelledType{recList=recList as [{name="1", ...}, {name="2", ...}], ...}) =>
+- mayParenthesise (precNo < precedence)
+- (fn depth =>
+- pVec (0, args, recList, constrName, precNo, precNo + 1, depth)
+- (fn (value, {name, typeof}, depth, precedence) =>
+- prints (value, typeof, depth, precedence, objList)
+- ))
+-
+- | (InfixR precNo,
+- LabelledType{recList=recList as [{name="1", ...}, {name="2", ...}], ...}) =>
+- mayParenthesise (precNo < precedence)
+- (fn depth =>
+- pVec (0, args, recList, constrName, precNo + 1, precNo, depth)
+- (fn (value, {name, typeof}, depth, precedence) =>
+- prints (value, typeof, depth, precedence, objList)
+- ))
+-
+- | _ =>
+- (* This constructor is not infix - print it in prefix notation.
+- If the constructor is already applied to something we must
+- parenthesise it. The argument precedence is set to infinity
+- - i.e. any constructors must be in parentheses. *)
+- mayParenthesise (precedence = maxPrec)
+- (fn depth =>
+- (
+- (* Must precede infix constructors by ``op''. *)
+- case thisPrecedence of
+- Nonfix => ()
+- | _ => (ppAddString pprint "op"; ppBreak pprint (1, 0));
+-
+- ppAddString pprint constrName;
+- ppBreak pprint (1, 0);
+- prints (args, argType, depth, maxPrec, objList)
+- )) ;
+- ppEndBlock pprint ()
+- end (* printInfixed *);
+-
+- (* Prints out a type construction by undoing the value constructors *)
+- fun printConstruction typeArgs [] =
+- raise InternalError "none matches" (* Shouldn't happen *)
+-
+- | printConstruction typeArgs
+- (Value{name, typeOf, access=Global code, class = Constructor{nullary}} :: constrs) =
+- let (* Try this constructor *)
+- open ADDRESS
+- val base = toAddress (evalue code)
+- val test = loadWord(base, 0w0) (* First word is the test. *)
+- val matches: bool = unsafeCast test value
+- in
+- if not matches (* try the next *) then printConstruction typeArgs constrs
+-
+- (* matches *)
+- else if nullary then (* Just a constant *) ppAddString pprint name
+-
+- (* Not just a constant. *)
+- else if depth <= 0
+- then ppAddString pprint "..."
+- else let
+- (* The test succeeded so this is the constructor that made
+- this value - get the value out. *)
+- val project = loadWord(base, 0w2) (* Third word is projection fn. *)
+- val v : machineWord = unsafeCast project value
+-
+- (* Find the argument type which gives this result when the
+- constructor is applied. If we have, for example, a value of
+- type int list and we have discovered that this is a `::' node
+- we have to work back by comparing the type of `::'
+- ('a * 'a list -> 'a list) to find the argument of the
+- constructor (int * int list) and hence how to print it.
+- (Actually `list' is treated specially). *)
+- val resType = constructorResult (typeOf, typeArgs);
+- (* If the value we get back from undoing the constructor
+- is the same as the constructed value, i.e. applying the
+- constructor simply returns the argument, we don't want to
+- add this value to the list. If we do we won't be able to
+- print the constructed value. *)
+- val newList =
+- if ADDRESS.wordEq(v, value) then objList
+- else value :: objList
+- in
+- printInfixed(name, resType, v, newList)
+- end
+- end
++ fun displayFixStatus Nonfix = PrettyString "nonfix"
++ | displayFixStatus (Infix prec) =
++ PrettyBlock(0, false, [],
++ [ PrettyString "infix", PrettyBreak (1, 0), PrettyString (Int.toString prec) ])
++ | displayFixStatus (InfixR prec) =
++ PrettyBlock(0, false, [],
++ [ PrettyString "infixr", PrettyBreak (1, 0), PrettyString (Int.toString prec) ])
++
++ (* Returns the declaration location as the location for the context. *)
++ fun getLocation locations =
++ case List.find(fn DeclaredAt _ => true | _ => false) locations of
++ SOME(DeclaredAt loc) => [ContextLocation loc]
++ | _ => []
+
+- (* Normally a datatype constructor will be global. If, though, we
+- call PolyML.print within a functor on a datatype passed in as
+- a functor argument the code to test for constructor will be
+- in the actual argument. We could generate code to handle that
+- case but it's probably not worth it. *)
+- | printConstruction typeArgs _ = ppAddString pprint "?"
+- (* printConstruction *)
+
++ (* displays value as a block, with no external formatting *)
++ fun displayValues (Value{name, typeOf, class, access, locations, ...}, depth, nameSpace, sigMap): pretty =
++ let
++ (* Create the "val X =" part. *)
++ fun valPart equOrColon =
++ PrettyBlock (0, false, [],
++ [
++ PrettyString "val",
++ PrettyBreak (1, 0),
++ PrettyBlock(0, false, getLocation locations, [PrettyString name]),
++ PrettyBreak (1, 0),
++ PrettyString equOrColon
++ ]
++ )
++ val typeEnv = (* Environment to check for type constructors. *)
++ { lookupType = #lookupType nameSpace, lookupStruct = #lookupStruct nameSpace}
+ in
+- (* If we have a circular structure we could end up looping until
+- we reach the maximum depth. Instead we check for any structure
+- we've seen before and just print .... We really only need to include
+- mutable structures in the list because only they can form loops
+- but it's easier to include everything. *)
+- if List.exists (fn v => ADDRESS.wordEq(value, v)) objList
+- then ppAddString pprint "..."
+-
+- else case types of
+- TypeVar tyVar =>
+- let
+- (* The type variable may be bound to something *)
+- val tyVal = tvValue tyVar
+- in
+- if isEmpty tyVal then ppAddString pprint "?"
+- else prints (value, tyVal, depth, precedence, objList)
+- end
+-
+- | TypeConstruction{value=tval, args, ...} =>
+- let
+- val constr = pling tval
+- in
+- if isUnsetId (tcIdentifier constr)
+- then ppAddString pprint "?"
+-
+- (* Type-specific printing is all handled by the libraries now. *)
+- (* Although unit is a type construction it is treated as
+- equivalent to the empty labelled record. That means we
+- can't install a pretty printer for it using install_pp. *)
+- else if sameTypeId (tcIdentifier constr, tcIdentifier unitType)
+- then ppAddString pprint "()"
+-
+- (* Leave this one, at least for the moment, since we need to be able
+- to look the exception up in the environment. *)
+- else if sameTypeId (tcIdentifier constr, tcIdentifier exnType)
+- then let (* Exception. *)
+- val exn : exn = unsafeCast value;
+- val name : string = exnName exn;
+- (* In order to be able to print this exception we need to find the type of
+- any arguments. Previously we used the name to search for a global
+- exception with that name but that doesn't help if the exception is in
+- a structure. We now do a search of the complete name space. *)
+- in
+- case lookupExnById (exnId exn) of
+- SOME exc =>
+- let
+- val typeof = valTypeOf exc
+- in
+- if isEmpty typeof
+- then ppAddString pprint name
+- else printInfixed(name, typeof, exnValue exn, value::objList)
+- end
+- | NONE => ppAddString pprint name (* Just put the name. *)
+- end
+-
+- else (* All the others. *)
+- let (* Use the given print function if it is in the table,
+- otherwise use the default. *)
+- (* If we have a print function installed for this type constructor
+- we have to pass it the functions to print the argument types
+- (if any). *)
+- fun makeArg argType =
+- let
+- fun printArg(v, depth) = prints(v, argType, depth, ~1, value::objList)
+- in
+- mkConst(toMachineWord printArg)
+- end
+- (* The easiest way to make a tuple is to use Codetree.mkTuple
+- which makes a tuple immediately if all the arguments
+- are constants. *)
+- val argTuple =
+- case args of
+- [] => CodeZero
+- | [t] => makeArg t
+- | args => mkTuple(map makeArg args)
+- in
+- getPrint (tcIdentifier constr) pprint depth (evalue argTuple) value
+- handle Subscript =>
+- ( if not (null (tcConstructors constr))
+- then printConstruction args (tcConstructors constr)
+- else if not (isEmpty (tcEquivalent constr)) (* May be an alias *)
+- then prints (value, makeEquivalent (constr, args), depth, precedence, objList)
+- else ppAddString pprint "?"
+- )
+- end
+- (* isTypeConstruction *)
+- end
+-
+- | FunctionType _ => ppAddString pprint "fn"
+-
+- | LabelledType {recList, ...} =>
+- if depth <= 0
+- then ppAddString pprint "..."
+- else if isProductType types
+- then (* If it is a record of the form {1=, 2=, ... } *)
+- ( ppBeginBlock pprint (3, true); (* Print them as (t1, t2, t3) .... *)
+- ppAddString pprint "(";
+- pVec (0, value, recList, ",", ~1, ~1, depth)
+- (fn (value, {name, typeof}, depth, precedence) =>
+- prints (value, typeof, depth, precedence, objList)
+- );
+- ppAddString pprint ")";
+- ppEndBlock pprint ()
+- )
+-
+- else
+- ( ppBeginBlock pprint (3, true); (* Print them as ( a = X, b = Y ... ) *)
+- ppAddString pprint "{";
+- pVec (0, value, recList, ",", ~1, ~1, depth)
+- (fn (value : machineWord, {name, typeof}, depth, precedence) =>
+- (
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint (name ^ " =");
+- ppBreak pprint (1, 0);
+- (* Don't add the current value to objList here. We may have an
+- optimised unary tuple in which case the value will be the
+- same as the one we've just had. Since we're only really
+- concerned about references making loops that should be fine. *)
+- prints (value, typeof, depth - 1, ~1, objList);
+- ppEndBlock pprint ()
+- )
+- );
+- ppAddString pprint "}";
+- ppEndBlock pprint ()
+- )
+-
+- | _ => ppAddString pprint "<empty>"
+- end (* prints *);
+- in
+- prints (value, types, depth, ~1, [])
+- end (* printStruct *);
++
++ if depth <= 0
++ then PrettyString "..."
+
+- fun displayFixStatus (Nonfix, _, pprint: prettyPrinter) =
+- ppAddString pprint "nonfix"
+- | displayFixStatus (Infix prec, _, pprint) =
+- (
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint "infix";
+- ppBreak pprint (1, 0);
+- ppAddString pprint (Int.toString prec);
+- ppEndBlock pprint ()
+- )
+- | displayFixStatus (InfixR prec, _, pprint) =
+- (
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint "infixr";
+- ppBreak pprint (1, 0);
+- ppAddString pprint (Int.toString prec);
+- ppEndBlock pprint ()
+- );
+-
+- (* displays value as a block, with no external formatting *)
+- fun displayValues (Value{name, typeOf, class, access}, depth, pprint: prettyPrinter, nameSpace, parameters) =
+- if depth <= 0
+- then ppAddString pprint "..."
+-
+- else case (class, access) of
+- (SimpleValue, Global code) =>
+- (
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint "val";
+- ppBreak pprint (1, 0);
+- ppAddString pprint (name ^ " =");
+- ppBreak pprint (1, 3);
+- printStruct (evalue code, typeOf, depth, pprint, nameSpace)
+- handle SML90.Interrupt => raise SML90.Interrupt | _ => ppAddString pprint "<undefined>";
+- (* evalue will fail for "undefined" *)
+-
+- ppBreak pprint (1, 0);
+- (* Put in a block to keep the colon with the type if we've had
+- to break the block. *)
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint ":";
+- ppBreak pprint (1, 3);
+- display (typeOf, depth, pprint, parameters);
+- ppEndBlock pprint ();
+- ppEndBlock pprint ()
+- )
+-
+- | (SimpleValue, _) =>
+- (* overloaded values only arise if we open PolyML. *)
+- (
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint ("val " ^ name ^ " :");
+- ppBreak pprint (1, 3);
+- display (typeOf, depth, pprint, parameters);
+- ppEndBlock pprint ()
+- )
+-
+- | (Exception, _) =>
+- (
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint "exception";
+- ppBreak pprint (1, 1);
+- ppAddString pprint name;
+- if not (isEmpty typeOf)
+- then (* May not be parameterised. *)
+- (
+- ppBreak pprint (1, 1);
+- ppAddString pprint "of";
+- ppBreak pprint (1, 3);
+- display (typeOf, depth, pprint, parameters)
+- )
+- else ();
+- ppEndBlock pprint ()
+- )
++ else
++ case (class, access) of
++ (SimpleValue, Global code) => (* Normal top-level values *)
++ PrettyBlock (3, false, [],
++ [
++ valPart "=",
++ PrettyBreak (1, 0),
++ printValueForType (evalue code, typeOf, depth),
++ PrettyBreak (1, 0),
++ PrettyBlock (3, false, [],
++ [ PrettyString ":", PrettyBreak (1, 3), displayWithMap (typeOf, depth, typeEnv, sigMap) ])
++ ])
++
++ | (SimpleValue, _) => (* Values in structures and overloaded values (from PolyML). *)
++ (* We can't get a value to print in this case. *)
++ PrettyBlock (3, false, [],
++ [ valPart ":", PrettyBreak (1, 0), displayWithMap (typeOf, depth, typeEnv, sigMap) ])
++
++ | (Exception, _) => (* exceptions *)
++ PrettyBlock (0, false, [],
++ PrettyBlock (0, false, [],
++ [
++ PrettyString "exception",
++ PrettyBreak (1, 0),
++ PrettyBlock(0, false, getLocation locations, [PrettyString name])
++ ]
++ )
++ ::
++ (
++ case getFnArgType typeOf of
++ NONE => []
++ | SOME excType =>
++ [ PrettyBreak (1, 1), PrettyString "of", PrettyBreak (1, 3), displayWithMap (excType, depth, typeEnv, sigMap) ]
++ )
++ )
+
+- | _ => ()
++ | _ => PrettyString "" (* ??? *)
++ end;
+
+ (* Print global values. This is passed through the bootstrap and used in the debugger. *)
+- fun printValues (Value{name, typeOf, class, access}, depth, pprint: prettyPrinter, nameSpace) =
++ fun printValues (Value{typeOf, class, access, ...}, depth, _) =
+ case (class, access) of
+- (SimpleValue, Global code) =>
+- printStruct (evalue code, typeOf, depth, pprint, nameSpace)
+- | _ => ()
++ (SimpleValue, Global code) => printValueForType (evalue code, typeOf, depth)
++ | _ => PrettyString "" (* Probably shouldn't occur. *)
+
+- (* Prints "sig ... end" as a block, with no external formatting *)
+- fun displaySig (str, depth : int, pprint: prettyPrinter, space : int, nameSpace, parameters) : unit =
+- let
+- fun break () : unit = ppBreak pprint (1, 2);
+-
+- fun displaySpec (name, value) : unit =
+- if (tagIs signatureVar value)
+- then
+- (
+- break ();
+- displaySignatures (tagProject signatureVar value, depth - 1, pprint, nameSpace, parameters)
+- )
+-
+- else if (tagIs structVar value)
+- then
+- (
+- break ();
+- displayStructures (tagProject structVar value, depth - 1, pprint, nameSpace, parameters)
+- )
+-
+- else if (tagIs typeConstrVar value)
+- then
+- (
+- break ();
+- displayTypeConstrs (tagProject typeConstrVar value, depth, pprint, parameters)
+- )
++ (* Prints "sig ... end" as a block, with no external formatting *)
++ fun displaySig (Signatures{tab, typeIdMap, ...}, depth : int, _ : int,
++ { lookupType, lookupStruct, ...}, sigMap: (int-> typeId) option) : pretty =
++ let
++ (* Construct an environment for the types. *)
++
++ val Env { lookupType = strType, lookupStruct = strStr, ...} = makeEnv tab
++
++ (* Construct a map for types. *)
++ val innerMap =
++ case sigMap of
++ NONE => SOME typeIdMap
++ | SOME outerMap => SOME(composeMaps(typeIdMap, outerMap))
++
++ val compositeEnv =
++ {
++ lookupType =
++ fn s => case strType s of NONE => lookupType s | SOME t => SOME (t, innerMap),
++ lookupStruct =
++ fn s => case strStr s of NONE => lookupStruct s | SOME s => SOME (s, innerMap)
++ }
++
++ val typeEnv: printTypeEnv =
++ { lookupType = #lookupType compositeEnv, lookupStruct = #lookupStruct compositeEnv }
++
++ fun displaySpec (_, value) : pretty list =
++ if (tagIs signatureVar value)
++ then (* Not legal ML97 *)
++ [ PrettyBreak(1,2), displaySignatures (tagProject signatureVar value, depth - 1, compositeEnv)]
++
++ else if (tagIs structVar value)
++ then
++ [ PrettyBreak(1,2), displayStructures (tagProject structVar value, depth - 1, compositeEnv, innerMap)]
++
++ else if (tagIs typeConstrVar value)
++ then
++ [ PrettyBreak(1,2), displayTypeConstrsWithMap (tagProject typeConstrVar value, depth, typeEnv, innerMap) ]
+
+- else if (tagIs valueVar value)
+- then let
+- (* Only print variables. Constructors are printed with their type. *)
+- val value = tagProject valueVar value;
+- in
+- case value of
+- Value{class = Constructor _, ...} => ()
+- | _ =>
+- (
+- break ();
+- (* We lookup the infix status and any exception in the global environment
+- only. Infix status isn't a property of a structure and it's too
+- much trouble to look up exceptions in the structure. *)
+- displayValues (value, depth, pprint, nameSpace, parameters)
+- )
+- end
++ else if (tagIs valueVar value)
++ then
++ let
++ (* Only print variables. Constructors are printed with their type. *)
++ val value = tagProject valueVar value;
++ in
++ case value of
++ Value{class = Constructor _, ...} => []
++ | _ =>
++ [ PrettyBreak(1,2),
++ (* We lookup the infix status and any exception in the global environment
++ only. Infix status isn't a property of a structure and it's too
++ much trouble to look up exceptions in the structure. *)
++ displayValues (value, depth, compositeEnv, innerMap)
++ ]
++ end
+
+- else if (tagIs fixVar value)
+- then
+- (
+- break ();
+- displayFixStatus (tagProject fixVar value, depth, pprint)
+- )
++ else if (tagIs fixVar value)
++ then (* Not legal ML97 *)
++ [ PrettyBreak(1,2), displayFixStatus (tagProject fixVar value) ]
+
+- else ()
++ else []
+ (* end displaySpec *)
+- in
+- ppBeginBlock pprint (0, true);
+- ppAddString pprint "sig";
+-
+- if depth <= 1 (* If the depth is 1 each of the calls to displaySpec will
+- print "..." so we replace them all by a single "..." here. *)
+- then (ppBreak pprint (1, 0); ppAddString pprint "...")
+- else
+- let
+- val declist = ref nil : (string * universal) list ref
+- fun addToList nv = declist := nv :: !declist
+- (* For the moment order them by name. We may change this to
+- order primarily by kind and secondarily by name. *)
+- fun order (s1: string, _) (s2: string, _) = s1 <= s2
+- in
+- (* Put all the entries into a list. *)
+- for (univOver (sigTab str)) addToList;
+- (* Sort the list and print it. *)
+- List.app displaySpec (quickSort order (!declist))
+- end;
+-
+- ppBreak pprint (1, 0);
+- ppAddString pprint "end";
+-
+- ppEndBlock pprint ()
+- end (* displaySig *)
++ in
++ PrettyBlock (2, true, [],
++ PrettyString "sig" ::
++ (
++ (
++ if depth <= 1 (* If the depth is 1 each of the calls to displaySpec will
++ print "..." so we replace them all by a single "..." here. *)
++ then [PrettyBreak (1, 0), PrettyString "..."]
++ else
++ let
++ val declist = ref nil : (string * universal) list ref
++ fun addToList nv = declist := nv :: !declist
++ (* For the moment order them by name. We may change this to
++ order primarily by kind and secondarily by name. *)
++ fun order (s1: string, _) (s2: string, _) = s1 <= s2
++ in
++ (* Put all the entries into a list. *)
++ for (univOver tab) addToList;
++ (* Sort the list and print it. *)
++ List.foldl
++ (fn (a, l) => displaySpec a @ l)
++ [] (quickSort order (!declist))
++ end
++ )
++ @ [PrettyBreak (1, 0), PrettyString "end"]
++ )
++ )
++ end (* displaySig *)
+
+ (* Print: signature S = sig .... end *)
+- and displaySignatures (str, depth : int, pprint: prettyPrinter, nameSpace, parameters) : unit =
+- if depth <= 0 then ppAddString pprint "..."
++ and displaySignatures (str, depth : int, nameSpace) : pretty =
++ if depth <= 0 then PrettyString "..."
+ else
+- (
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint ("signature " ^ sigName str ^ " =");
+- ppBreak pprint (1, 2);
+- displaySig (str, depth, pprint, 1, nameSpace, parameters);
+- ppEndBlock pprint ()
+- )
++ PrettyBlock(0, false, [],
++ [
++ PrettyBlock(0, false, [],
++ [
++ PrettyString "signature",
++ PrettyBreak(1, 0),
++ PrettyBlock(0, false,
++ [ContextLocation(sigDeclaredAt str)],
++ [PrettyString(sigName str)]
++ ),
++ PrettyBreak(1, 0),
++ PrettyString "="
++ ]
++ ),
++ PrettyBreak (1, 2),
++ displaySig (str, depth, 1, nameSpace, NONE)
++ ])
+
+ (* print structure in a block (no external spacing) *)
+- and displayStructures (str, depth, pprint: prettyPrinter, nameSpace, parameters) =
+- let
+- in
+- if depth <= 0 then ppAddString pprint "..."
+- else if isUndefinedStruct str then ppAddString pprint "<bad>"
+- else let
+- val structureName = structName str;
+- val signatureName = sigName (structSignat str);
++ and displayStructures (str, depth, nameSpace, sigMap): pretty =
++ if depth <= 0 then PrettyString "..."
++ else if isUndefinedStruct str then PrettyString "<bad>"
++ else
++ let
++ val structureName = structName str;
+ in
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint ("structure " ^ structureName ^ " :");
+- ppBreak pprint (1, 2);
+- if signatureName <> ""
+- then ppAddString pprint signatureName
+- else displaySig (structSignat str, depth - 1, pprint, 1, nameSpace, parameters);
+- ppEndBlock pprint ()
++ PrettyBlock (0, false, [],
++ [
++ PrettyBlock(0, false, [],
++ [
++ PrettyString "structure",
++ PrettyBreak(1, 0),
++ PrettyBlock(0, false,
++ getLocation(structLocations str),
++ [PrettyString structureName]
++ ),
++ PrettyBreak(1, 0),
++ PrettyString ":"
++ ]
++ ),
++ PrettyBreak(1, 2),
++ displayNamedSig(structSignat str, depth - 1, 1, nameSpace, sigMap)
++ ])
+ end
+- end;
+
+- fun displayFunctors (funct, depth, pprint: prettyPrinter, nameSpace, parameters) =
+- if depth <= 0 then ppAddString pprint "..."
+- else
+- (
+- ppBeginBlock pprint (0, false);
+- ppAddString pprint ("functor " ^ (functorName funct) ^ " (");
+- ppBreak pprint (0, 0);
+- if structName (functorArg funct) <> ""
+- then
+- (
+- ppAddString pprint ((structName (functorArg funct)) ^ " :");
+- ppBreak pprint (1, 3)
+- )
+- else ();
+- displaySig (structSignat (functorArg funct), depth - 1, pprint, 0, nameSpace, parameters);
+- ppAddString pprint ") :";
+- ppBreak pprint (1, 3);
+- displaySig (functorResult funct, depth - 1, pprint, 1, nameSpace, parameters);
+- ppEndBlock pprint ()
+- );
++ (* Internal function for printing structures and functors. If a signature has a
++ name print the name rather than the contents. *)
++ and displayNamedSig(sign as Signatures{name = "", ...}, depth, space, nameSpace, sigMap) =
++ displaySig (sign, depth, space, nameSpace, sigMap)
++ | displayNamedSig(Signatures{name, ...}, _, _, _, _) = PrettyString name
++
++ fun displayFunctors (funct, depth, nameSpace) =
++ if depth <= 0 then PrettyString "..."
++ else
++ PrettyBlock (0, false, [],
++ PrettyBlock(0, false, [],
++ [
++ PrettyString "functor",
++ PrettyBreak(1, 0),
++ PrettyBlock(0, false,
++ [ContextLocation(functorDeclaredAt funct)],
++ [PrettyString(functorName funct)]
++ ),
++ PrettyBreak(1, 0),
++ PrettyString "("
++ ]) ::
++ PrettyBreak(0, 2) ::
++ let
++ val arg = functorArg funct
++ val argName = structName arg
++ in
++ (if argName <> ""
++ then [ PrettyString(argName ^ " :"), PrettyBreak(1, 2) ]
++ else []) @
++ [
++ displayNamedSig (structSignat arg, depth - 1, 0, nameSpace, NONE),
++ PrettyString ") :",
++ PrettyBreak(1, 2),
++ let
++ (* Include the argument structure name in the type environment. *)
++ val argEnv =
++ if argName = ""
++ then
++ let
++ val Env { lookupType=lt, lookupStruct=ls, ...} =
++ makeEnv(sigTab(structSignat arg))
++ in
++ {
++ lookupType =
++ fn s => case lt s of NONE => #lookupType nameSpace s | SOME t => SOME(t, NONE),
++ lookupStruct =
++ fn s => case ls s of NONE => #lookupStruct nameSpace s | SOME s => SOME(s, NONE)
++ }
++ end
++ else
++ {
++ lookupType = #lookupType nameSpace,
++ lookupStruct =
++ fn s => if s = argName then SOME(arg, NONE) else #lookupStruct nameSpace s
++ }
++ in
++ displayNamedSig (functorResult funct, depth - 1, 1, argEnv, NONE)
++ end
++ ]
++ end
++ )
++
++ (* Exported version. *)
++ val displayValues = fn (value, depth, nameSpace) => displayValues (value, depth, nameSpace, NONE)
++ and displayStructures = fn (str, depth, nameSpace) => displayStructures (str, depth, nameSpace, NONE)
+
+ (* Code-generation. *)
+
+@@ -2046,451 +1341,67 @@
+ | codeAccess (Selected{addr, base}, level) = (* Select from a structure. *)
+ mkInd (addr, codeStruct (base, level))
+
+- | codeAccess (acc, level) = raise InternalError "No access"
++ | codeAccess _ = raise InternalError "No access"
+ (* codeAccess *);
+
+- (* Raises an exception. *)
+- fun raiseException exName exIden parm =
+- mkRaise (mkTuple [exIden,mkStr exName,parm]);
+-
+- (* Raise match and bind exceptions. *)
+- val raiseMatch = raiseException "Match" matchExceptionVal CodeZero;
+- val raiseBind = raiseException "Bind" bindExceptionVal CodeZero;
+-
+-(*****************************************************************************)
+-(* Equality function compiler *)
+-(*****************************************************************************)
+-
+-(*
+- This generates code to handle equality (i.e. = and <>) by generating functions
+- based on the type of the arguments to be compared. For parameterised datatypes
+- (e.g. 'a list) that means generating functions which are parameterised on the
+- equality function for 'a. In a few cases (e.g where the type is a functor
+- argument) we can't generate the function and we fall back to the general purpose
+- structure equality function. The optimiser (codetree) does a good job of optimising
+- the code and turning the functions into loops.
+-*)
+-
+- fun genEqualityFunction(instance: types, level: int): codetree =
+- let
+- (* To reduce the size of the code we pass down the kind of
+- result we want. *)
+- datatype reskind =
+- ApplyFun of ({level:int, myAddr: int}->codetree)*({level:int, myAddr: int}->codetree)
+- | MakeFun
+- (* If we get a function back it may take a pair as an argument or
+- it may take two arguments. *)
+- datatype resfun =
+- PairArg of {level:int, myAddr: int} -> codetree
+- | TwoArgs of {level:int, myAddr: int} -> codetree
+-
+- val baseLevel = level+1
+- local
+- val addrs = ref 0
+- in
+- fun mkaddrs () = (addrs := !addrs + 1; !addrs)
+- end
+-
+- (* The list of functions. These are potentially mutually recursive. *)
+- val generatedFuns: codetree list ref = ref []
+- (* The list of addresses of functions for datatypes. This allows us
+- to make recursive calls for recursive datatypes and also to avoid
+- generating the same function twice.
+- e.g. datatype t = A of s | B and s = C of t | D. *)
+- val datatypeList: (int * typeId) list ref = ref []
+-
+- (* If we have a function we either return it or we apply it. The
+- function will always take a single argument as a tuple. *)
+- fun returnFun (f: resfun, MakeFun) = f
+- | returnFun (TwoArgs f, ApplyFun(a1, a2)) =
+- PairArg(fn lA => mkEval(f lA, [a1 lA, a2 lA], true))
+- | returnFun (PairArg f, ApplyFun(a1, a2)) =
+- PairArg(fn lA => mkEval(f lA, [mkTuple[a1 lA, a2 lA]], true))
+-
+- (* If we have a piece of code we may need to wrap it in a function.
+- This is generally used to create the code for handling tuples.
+- When creating a function this previously attempted to add the function to
+- the generatedFuns list but that turned out to have a bug. If we have
+- a tuple inside a parameterised datatype e.g. datatype 'a t = X of 'a * ... then
+- we must make sure that we create the tuple equality function inside the equality
+- function for t otherwise it won't be able to find the equality function for 'a. *)
+- fun returnCode(mkCode, ApplyFun(a1, a2)) =
+- PairArg(fn l => mkCode(a1, a2, l))
+- | returnCode(mkCode, MakeFun) =
+- let
+- fun wrappedCode {level, myAddr} =
+- let
+- val addr = mkaddrs() (* Should never be used since this isn't directly recursive. *)
+- val newLevel = level+1
+-
+- val code = mkCode(fn {level=l, ...} => mkLoad(~1, l-newLevel),
+- fn {level=l, ...} => mkLoad(~2, l-newLevel),
+- {level=newLevel, myAddr=addr});
+- in
+- mkProc(code, newLevel, 2, "eq{...}(2)")
+- end
+- in
+- TwoArgs wrappedCode
+- end
+-
+- val default = PairArg(fn _ => mkConst (toMachineWord structureEq))
+-
+- fun makeEq(ty: types, resKind: reskind,
+- findTyVars: typeVarForm -> resfun): resfun =
+- let
+-
+- fun equalityForDatatype(constr, vConstrs) : {level:int, myAddr: int} -> codetree =
+- let
+- val id = tcIdentifier constr
+- val typeName = tcName constr
+- val addr = mkaddrs()
+- (* We need to record this address in the list. *)
+- val _ = datatypeList := (addr, id) :: !datatypeList;
+- (* If this is a polymorphic type constructor (e.g. 'a list)
+- we have to pass the equality functions for the argument
+- type (e.g. int if we have int list) as arguments to the
+- equality function. *)
+- val constructorTypeVars = tcTypeVars constr
+- val nTypeVars = List.length constructorTypeVars
+-
+- val outerFunLevel = baseLevel+1
+- val newLevel =
+- if nTypeVars = 0 then outerFunLevel else outerFunLevel+1
+-
+- fun newTvFun tv =
+- let
+- fun findTv [] n = findTyVars tv (* Not in this list. *)
+- | findTv (TypeVar tv' :: tvs) n =
+- if sameTv(tv, tv')
+- then TwoArgs(fn {level, ...} => mkLoad(n, level-outerFunLevel))
+- else findTv tvs (n+1)
+- | findTv _ _ =
+- raise InternalError "findTv: not a type variable"
+- in
+- findTv constructorTypeVars (~nTypeVars)
+- end
+-
+- (* Filter out the EnumForm constructors. They arise
+- in situations such as datatype t = A of int*int | B | C
+- i.e. where we have only one non-nullary constructor
+- and it is a tuple. In this case we can deal with all
+- the nullary constructors simply by testing whether
+- the two arguments are the same. We don't have to
+- discriminate the individual cases. *)
+- fun isEnum(Value{class=Constructor{nullary=true}, access=Global code, ...}) =
+- let
+- open ADDRESS
+- in
+- (* If the value is a short integer then we can check
+- for equality using pointer equality. *)
+- isShort(loadWord(toAddress(evalue code), 0w1))
+- end
+- | isEnum _ = false
+-
+- fun processConstrs [] =
+- (* The last of the alternatives is false *) CodeZero
+-
+- | processConstrs ((vConstr as Value{class, access, typeOf, name=tempConstrName, ...}) ::rest) =
+- if isEnum vConstr then processConstrs rest
+- else
+- let
+- val base = codeAccess(access, newLevel)
+- fun matches arg =
+- mkEval(mkInd(0, base) (* Test function. *), [arg], true)
+- in
+- case class of
+- Constructor{nullary=true} =>
+- mkIf(matches arg1, matches arg2, processConstrs rest)
+- | _ => (* We have to unwrap the value. *)
+- let
+- (* Get the constructor argument given
+- the result type. We might actually be
+- able to take the argument type off directly
+- but there's some uncertainty about whether
+- we use the same type variables for the
+- constructors as for the datatype. (This only
+- applies for polytypes). *)
+- val resType =
+- constructorResult(typeOf, constructorTypeVars)
+-
+- (* Code to extract the value. *)
+- fun destruct argNo {level=l, ...} =
+- mkEval(mkInd(2, codeAccess(access, l)) (* projection function. *),
+- [mkLoad(argNo, l-newLevel)], true)
+-
+- (* Test whether the values match. *)
+- val eqValue =
+- applyEq(resType, destruct ~1, destruct ~2,
+- {level=newLevel, myAddr=addr}, newTvFun)
+- in
+- (* We have equality if both values match
+- this constructor and the values within
+- the constructor match. *)
+- mkIf(matches arg1,
+- mkCand(matches arg2, eqValue),
+- processConstrs rest)
+- end
+- end
+-
+- (* We previously only tested for bit-wise (pointer) equality if we had
+- at least one "enum" constructor in which case the test would eliminate
+- all the enum constructors. I've now extended this to all cases where
+- there is more than one constructor. The idea is to speed up equality
+- between identical data structures. *)
+- val eqCode =
+- case vConstrs of
+- [vcons] => (* Single constructor. *)
+- if isEnum vcons
+- then CodeTrue (* Return true here: processConstrs would return false. *)
+- else processConstrs vConstrs
+- | _ => (* More than one constructor: should never be zero. *)
+- mkCor(mkTestptreq(arg1, arg2), processConstrs vConstrs)
+- val eqFun =
+- mkProc(eqCode, newLevel, 2, "eq-" ^ typeName ^ "(2)")
+- (* If this is a monotype we can return it directly otherwise we
+- need to wrap it up in a function to take the equality functions
+- for the argument types. *)
+- val resFun =
+- if nTypeVars = 0 then eqFun
+- else mkProc(eqFun, outerFunLevel, nTypeVars, "eq-" ^ typeName ^ "(1)")
+- in
+- generatedFuns := !generatedFuns @ [mkDec(addr, resFun)];
+- fn {level=l, myAddr} => mkLoad(addr, l-baseLevel)
+- end
+-
+- fun equalityForConstruction(constr, args, vConstrs): resfun =
+- (* Generate an equality function for a datatype construction. *)
+- let
+- (* See if we are currently making this function or
+- have already made it. If this is recursive we may
+- be able to optimise it. *)
+- val id = tcIdentifier constr
+- val constrName = tcName constr
+-
+- fun searchList [] = NONE
+- | searchList ((addr, t) :: rest) =
+- if sameTypeId(t, id) then SOME addr else searchList rest
+- val alreadyAddr = searchList (!datatypeList)
+- (* Get the equality functions for the argument types.
+- These want to be functions taking two arguments.
+- This applies only to polytypes. *)
+- fun getArg (lA as {level, myAddr}) ty : codetree =
+- let
+- val eqFun = makeEq(ty, MakeFun, findTyVars)
+- in
+- case eqFun of
+- PairArg f =>
+- (* Have to make a function which takes two arguments. *)
+- mkInlproc(
+- mkEval(f{level=level+1, myAddr=myAddr}, [mkTuple[arg1, arg2]], true),
+- level+1, 2, "eq-"^constrName^"(...)")
+- | TwoArgs f => f lA
+- end
+- (* If we are compiling a recursive polytype (e.g. list) and
+- we find a recursive call we can generate better code by
+- calling the inner function directly, provided the recursive
+- call involves the polymorphic type. This isn't true if we
+- have datatype 'a t = X of int t | Y of 'a where the
+- recursive call is not polymorphic. *)
+- fun sameTypeVars(TypeVar tv, TypeVar tv') = sameTv(tv, tv')
+- | sameTypeVars _ = false
+-
+- fun recursiveEq (addr, []) {level:int, myAddr: int} =
+- if addr = myAddr
+- then mkRecLoad(level-baseLevel-1)
+- else mkLoad(addr, level-baseLevel)
+-
+- | recursiveEq (addr, _) (lA as {level:int, myAddr: int}) =
+- if addr <> myAddr
+- then mkEval(mkLoad(addr, level-baseLevel),
+- map (getArg lA) args, true)
+- else if ListPair.foldl
+- (fn(a, b, t) => t andalso sameTypeVars(a,b))
+- true (args, tcTypeVars constr)
+- then mkRecLoad(level-baseLevel-2)
+- else mkEval(mkRecLoad(level-baseLevel-1),
+- map (getArg lA) args, true)
+- in
+- (* Apply the function we obtained to any type arguments. *)
+- case searchList (!datatypeList) of
+- SOME addr => TwoArgs(recursiveEq(addr, args))
+- | NONE =>
+- let
+- val eq = equalityForDatatype(constr, vConstrs)
+- in
+- case args of
+- [] => TwoArgs eq
+- | _ =>
+- TwoArgs(fn l =>
+- mkEval(eq l, map (getArg l) args, true))
+- end
+- end
+- in
+- case ty of
+- TypeVar tyVar =>
+- let
+- (* The type variable may be bound to something. *)
+- val tyVal = tvValue tyVar
+- in
+- (* If we have an unbound type variable it may either
+- be a type constructor argument or it may be a free
+- equality type variable. *)
+- if isEmpty tyVal
+- then returnFun(findTyVars tyVar, resKind)
+- else makeEq(tyVal, resKind, findTyVars)
+- end
+-
+- | TypeConstruction{value, args, ...} =>
+- let
+- val constr = pling value
+- val id = tcIdentifier constr
+- (* See if we have a special version of equality for this type.
+- N.B. The only special functions we have for polytypes are
+- for 'a ref and 'a array. In these cases the function does
+- pointer equality and is applied directly. We must not use
+- the normal approach of combining the equality function for
+- the polytype with that for the argument because in this
+- case there may not be an equality function for the argument.
+- e.g. we can use equality on (int->int) ref. *)
+- val special = getOverload("=", constr, fn () => CodeNil);
+- in
+- if not (isCodeNil special) (* There's an overloading. *)
+- then returnFun(PairArg(fn _ => special), resKind)
+- else (* Not there *)
+- if sameTypeId (id, tcIdentifier unitType)
+- then (* unit - always true for equality. *)
+- returnCode(fn _ => CodeTrue, resKind)
+- else case tcConstructors constr of
+- [] => (* Not a datatype. *)
+- if not (isEmpty (tcEquivalent constr)) (* May be an alias *)
+- then makeEq (makeEquivalent (constr, args), resKind, findTyVars)
+- else (* An opaque eqtype - probably a functor argument. N.B. since
+- we're returning the structure equality function we mustn't
+- apply it to the equality function for the arguments. *)
+- returnFun(default, resKind)
+- | Value{access=Formal _, ...} :: _ =>
+- (* If the datatype constructor is a parameter to a functor
+- the value constructors will be in parameter structure.
+- It's too complicated to find out where the structure is
+- so we just use structure equality. *)
+- returnFun(default, resKind)
+- | vConstrs => (* Datatype. *)
+- returnFun(
+- equalityForConstruction(constr, args, vConstrs), resKind)
+- end
+-
+- | LabelledType {recList=[{typeof=singleton, ...}], ...} =>
+- (* Unary tuples are optimised - no indirection. *)
+- makeEq(singleton, resKind, findTyVars)
+-
+- | LabelledType {recList, ...} =>
+- (* Combine the entries.
+- fun eq(a,b) = #1 a = #1 b andalso #2 a = #2 b ... *)
+- let
+- fun eqTuple(arg1, arg2, lA) =
+- let
+- fun combineEntries ([], n) = CodeTrue
+- | combineEntries ({typeof, name=_}::t, n) =
+- mkCand
+- (applyEq(typeof, fn l => mkInd(n, arg1 l),
+- fn l => mkInd(n, arg2 l),
+- lA, findTyVars),
+- combineEntries (t, n+1))
+- in
+- combineEntries(recList, 0)
+- end
+- in
+- returnCode(eqTuple, resKind)
+- end
+-
+- | _ => (* It is actually possible to get an equality function
+- on functions in ML97 as a result of sharing constraints
+- in a functor. The signature would not be matchable by
+- a real structure so the functor could never be applied.
+- Nevertheless the functor must compile so we just put
+- in structure equality here. *)
+- returnFun(default, resKind)
+- end
+-
+- (* Make an equality function and apply it to the arguments. *)
+- and applyEq(ty, arg1, arg2, lA, findTyVars): codetree =
+- case makeEq(ty, ApplyFun(arg1, arg2), findTyVars) of
+- PairArg c => c lA
+- | TwoArgs _ => raise InternalError "applyEq: wrong result"
+-
+- (* The instance type is a function so we have to get the first
+- argument. *)
+- val argType = firstArg instance
+- (* Get the final equality function and generate any which are needed
+- as a side effect. *)
+- val resultCode = makeEq(argType, MakeFun, fn _ => default)
+- in
+- (* The final result function must take a single argument. If we have
+- generated a function the result must be one which takes two arguments.
+- If we have not generated it it must have come from somewhere else so
+- it must take a pair. *)
+- case resultCode of
+- PairArg c => c {level=baseLevel,myAddr=0}
+- | TwoArgs c =>
+- let
+- (* Must call c BEFORE we dereference generatedFuns because
+- the call may generate new functions. *)
+- val code = c {level=baseLevel,myAddr=0}
+- val funs = ! generatedFuns
+- val wrappedFuns =
+- case funs of
+- [singleton] => singleton
+- | funs => mkMutualDecs funs
+- in
+- (* We need to wrap this up in a new inline function for two reasons.
+- One is that it needs to take a single pair argument, the other is
+- that we have allocated the addresses from 1 and we may get conflicts
+- with addresses in the surrounding scope. *)
+- mkInlproc(CODETREE.mkEnv[wrappedFuns,
+- mkEval(code, [mkInd(0, arg1), mkInd(1, arg1)], true)],
+- baseLevel, 1, "equality")
+- end
+- end
+-
+-
+ (*****************************************************************************)
+ (* datatype access functions *)
+ (*****************************************************************************)
+
+- (* Get the appropriate instance of an overloaded function. If the
+- overloading has not resolved to a single type it finds the preferred
+- type if possible (i.e. int for most overloadings, but possibly real,
+- word, string or char for conversion functions.) *)
+- fun getOverloadInstance(name, instance, isConv, lex, lineno): codetree*string =
+- let
+- val constr = typeConstrFromOverload(instance, isConv)
+- (* If there is no matching type produce a message. That should only
+- happen if we are running in ML90 mode and the overloading has not
+- reduced to a single type. *)
+- fun notFound () =
+- if name = "=" (* Special case *)
+- then mkConst (toMachineWord structureEq)
+- else
+- let
+- val ops = getOverloads name
+- (* Construct a list of the current overloadings. *)
+- fun makeOverloadList [] = ""
+- | makeOverloadList [(last, _)] = tcName last
+- | makeOverloadList ((h, _)::l) =
+- tcName h ^ "/" ^ makeOverloadList l
+- val overloads = makeOverloadList ops
+- in
+- overloadError (instance, name, overloads, lex, lineno);
+- CodeNil
+- end
+-
+- in
+- (getOverload(name, constr, notFound), tcName constr)
+- end
++ (* Get the appropriate instance of an overloaded function. If the
++ overloading has not resolved to a single type it finds the preferred
++ type if possible (i.e. int for most overloadings, but possibly real,
++ word, string or char for conversion functions.) *)
++ fun getOverloadInstance(name, instance, isConv): codetree*string =
++ let
++ val constr = typeConstrFromOverload(instance, isConv)
++ in
++ (getOverload(name, constr, fn _ => raise InternalError "getOverloadInstance: Missing"), tcName constr)
++ end
++
++ (* This is only used in addPrettyPrint and install_pp. There's no point in
++ producing a lot of detailed information. *)
++ fun checkPPType (instanceType, matchType, fnName, lex, location, moreInfo) =
++ case unifyTypes (instanceType, matchType) of
++ NONE => ()
++ | SOME error =>
++ let
++ open DEBUG
++ val parameters = LEX.debugParams lex
++ val errorDepth = getParameter errorDepthTag parameters
++ in
++ reportError lex
++ {
++ location = location,
++ hard = true,
++ message =
++ PrettyBlock(0, true, [],
++ [
++ PrettyString ("Argument for " ^ fnName),
++ PrettyBreak (1, 3),
++ PrettyBlock(0, false, [],
++ [
++ PrettyString "Required type:",
++ PrettyBreak (1, 0),
++ display (matchType, errorDepth, emptyTypeEnv)
++ ]),
++ PrettyBreak (1, 3),
++ PrettyBlock(0, false, [],
++ [
++ PrettyString "Argument type:",
++ PrettyBreak (1, 0),
++ display (instanceType, errorDepth, emptyTypeEnv)
++ ]),
++ PrettyBreak (1, 3),
++ unifyTypesErrorReport(lex, emptyTypeEnv, emptyTypeEnv, "unify") error
++ ]),
++ context = SOME (moreInfo ())
++ }
++ end;
+
+ (* Code-generate an identifier matched to a value. N.B. If the value is a
+ constructor it returns the pair or triple representing the functions on the
+- constructor. *)
++ constructor. *)
+ fun codeVal (Value{access = Global code, ...}, _, _, _, _) = code
+
+ | codeVal (Value{access = Local{addr=ref locAddr, level=ref locLevel}, ...}, level, _, _, _) =
+@@ -2507,251 +1418,361 @@
+ (* Select from a structure. *)
+ mkInd (addr, codeStruct (base, level))
+
+- | codeVal (Value{access = Formal _, ...}, level, _, _, _) =
+- raise InternalError "codeVal - Formal"
++ | codeVal (Value{access = Formal _, ...}, _, _, _, _) =
++ raise InternalError "codeVal - Formal"
+
+ | codeVal (Value{access = Overloaded Print, ...}, level, instance, lex, _) =
+ let
+- (* "instance" should be 'a -> 'a. We need to get the 'a. *)
+- val argType = if not (isFunctionType instance) then badType
+- else ffArg (typesFunctionType instance);
+- open DEBUG
+- (* The parameter is the reference used to control the print depth
+- when the value is actually printed. *)
+- val printDepthFun = getParameter printDepthFunTag (LEX.debugParams lex)
+- and printString = getParameter printStringTag (LEX.debugParams lex)
+-
+- val printSpace =
+- case List.find (Universal.tagIs printSpaceTag) (LEX.debugParams lex) of
+- SOME a => Universal.tagProject printSpaceTag a
+- | NONE => nullEnvironment
+-
+- fun printProc value =
+- (
+- printStruct (value, argType, printDepthFun(),
+- prettyPrint (77, printString), printSpace);
+- value
+- );
+- (* Coerce the procedure so that it can be put into the code. *)
+- in
+- mkConst (toMachineWord printProc)
+- end
++ (* "instance" should be 'a -> 'a. We need to get the 'a. *)
++ val argType = case getFnArgType instance of NONE => badType | SOME t => t;
++ open DEBUG
++ (* The parameter is the reference used to control the print depth
++ when the value is actually printed. *)
++ val printDepthFun = getParameter printDepthFunTag (LEX.debugParams lex)
++ and prettyOut = getPrintOutput (LEX.debugParams lex)
++ in
++ (* Construct a function that gets the print code, prints it out and returns
++ its argument. *)
++ mkProc(
++ CODETREE.mkEnv
++ [
++ mkEval(
++ mkConst(toMachineWord prettyOut),
++ [
++ mkEval(
++ printerForType(argType, level+1),
++ [
++ mkTuple[arg1,
++ mkEval(mkConst(toMachineWord printDepthFun), [CodeZero], false)]
++ ],
++ false)
++ ],
++ false),
++ arg1 (* Returns its argument. *)
++ ],
++ level, 1, "print()")
++ end
+
+- | codeVal (Value{access = Overloaded PrintSpace, ...}, level, instance, _, _) =
++ | codeVal (Value{access = Overloaded MakeString, ...}, level, instance, _, _) =
+ let
+- (* "instance" should be 'a * namespace * printer * int -> 'a. We need to get the 'a. *)
+- val argType =
+- case instance of
+- FunctionType{arg= LabelledType { recList = {typeof, ...} ::_, ...}, ...} =>
+- typeof
+- | _ => badType
+-
+- fun printProc (value, namespace, printer, depth): unit =
+- (
+- printStruct (value, argType, depth,
+- prettyPrint (77, printer), namespace)
+- )
++ (* "instance" should be 'a -> string. We need to get the 'a. *)
++ val argType = case getFnArgType instance of NONE => badType | SOME t => t;
+ in
+- mkConst (toMachineWord printProc)
+- end
++ (* Construct a function that gets the print code and prints it out using "uglyPrint". *)
++ mkProc(
++ mkEval(
++ mkConst(toMachineWord uglyPrint),
++ [
++ mkEval(
++ printerForType(argType, level+1),
++ [
++ mkTuple[arg1, mkConst(toMachineWord 10000)]
++ ],
++ false)
++ ],
++ false),
++ level, 1, "makestring()")
++ end
+
+- | codeVal (Value{access = Overloaded MakeString, ...}, level, instance, lex, _) =
+- let
+- (* "instance" should be 'a -> string. We need to get the 'a. *)
++ | codeVal (Value{access = Overloaded GetPretty, ...}, level, instance, _, _) =
++ let (* Get the pretty code for the specified argument. *)
++ (* "instance" should be 'a * int -> pretty. We need to get the 'a. *)
+ val argType =
+- if not (isFunctionType instance)
+- then badType
+- else ffArg (typesFunctionType instance);
+-
+- val printSpace =
+- case List.find (Universal.tagIs printSpaceTag) (LEX.debugParams lex) of
+- SOME a => Universal.tagProject printSpaceTag a
+- | NONE => nullEnvironment
+-
+- fun makeString value =
+- let
+- val result = ref ""; (* Accumulate results in this *)
+- val pp = uglyPrint (fn s => result := !result ^ s);
+- val U : unit =
+- printStruct (value, argType, 10000, pp, printSpace);
+- in
+- ! result
+- end;
++ case getFnArgType instance of
++ SOME(LabelledType{recList=({typeof, ...} :: _), ...}) => typeof
++ | _ => badType
+ in
+- mkConst (toMachineWord makeString)
++ printerForType(argType, level)
+ end
+
+- | codeVal (Value{access = Overloaded MakeStringSpace, ...}, level, instance, lex, _) =
++ | codeVal (Value{access = Overloaded AddPretty, ...}, level, instance, lex, loc) =
+ let
+- (* "instance" should be 'a * namespace -> string. We need to get the 'a. *)
+- val argType =
+- case instance of
+- FunctionType{arg= LabelledType { recList = {typeof, ...} ::_, ...}, ...} =>
+- typeof
+- | _ => badType
++ (* "instance" should be (int-> 'a -> 'b -> pretty) -> unit.
++ We need to get the 'a and 'b. This function installs a
++ pretty printer against the type which matches 'b.
++ The type 'a is related to type of 'b as follows:
++ If 'b is a monotype t then 'a is ignored.
++ If 'b is a unary type constructor 'c t then 'a must have
++ type 'c * int -> pretty.
++ If 'b is a binary or higher type constructor e.g. ('c, 'd, 'e) t
++ then 'a must be a tuple of functions of the form
++ ('c * int -> pretty, 'd * int -> pretty, 'e * int -> pretty).
++ When the installed function is called it will be passed the
++ appropriate argument functions which it can call to print the
++ argument types. *)
++ val argPrints = mkTypeVar (generalisable, false, false);
++ val installType = mkTypeVar (generalisable, false, false);
++ val pretty = mkTypeVar (generalisable, false, false);
++ (* Build a pattern type and unify it to get the type variables.
++ Unification should not fail here because type checking has already
++ been done by the time we get here. *)
++ val addPPType =
++ mkFunctionType(
++ mkFunctionType (TYPESTRUCT.intType,
++ mkFunctionType(argPrints, mkFunctionType(installType, pretty))),
++ TYPESTRUCT.unitType);
++ val () = checkPPType(instance, addPPType, "addPrettyPrinter", lex, loc, fn () => PrettyString "");
+
+- fun printProc (value, namespace, printer) =
++ (* Find the last type constructor in the chain. We have to install
++ this against the last in the chain because type constructors in
++ different modules may be at different points in the chain. *)
++ (* This does mean that it's not possible to install a
++ pretty printer for a type constructor rather than a datatype. *)
++ fun followTypes (TypeConstruction{value, args, ...}) =
+ let
+- val result = ref ""; (* Accumulate results in this *)
+- val pp = uglyPrint (fn s => result := !result ^ s);
+- val () = printStruct (value, argType, 10000, pp, namespace);
++ val constr = pling value
+ in
+- !result
++ if not (tcIsAbbreviation constr)
++ then SOME(tcIdentifier constr, constr, List.length args)
++ else followTypes (makeEquivalent (constr, args))
+ end
++ | followTypes (TypeVar tv) =
++ (
++ case tvValue tv of
++ EmptyType => NONE (* Unbound type variable *)
++ | t => followTypes t
++ )
++ | followTypes _ = NONE;
++
++ val constrId = followTypes installType
++
++ val () =
++ case constrId of
++ NONE => ()
++ | SOME (_, constr, arity) =>
++ let
++ (* Check that the function tuple matches the arguments of the type
++ we're installing for. *)
++ (* Each entry should be a function of type 'a * int -> pretty *)
++ fun mkFn arg = mkFunctionType(mkProductType[arg, TYPESTRUCT.intType], pretty)
++ (* Create non-unifiable type vars to ensure this is properly polymorphic. *)
++ val typeVars = List.tabulate(arity, fn _ => mkTypeVar (0, false, true))
++ val tupleType =
++ case typeVars of
++ [] => (* No arg so we can have anything here. *)
++ mkTypeVar (generalisable, false, false)
++ | [arg] => mkFn arg (* Just a single function. *)
++ | args => mkProductType(List.map mkFn args)
++ val addPPType = mkFunctionType(argPrints, mkFunctionType(installType, pretty))
++ val testType = mkFunctionType(tupleType,
++ mkFunctionType(
++ mkTypeConstruction(tcName constr, constr, typeVars, [DeclaredAt loc]),
++ pretty))
++ in
++ checkPPType(addPPType, testType, "addPrettyPrint", lex, loc,
++ fn () =>
++ PrettyString "addPrettyPrint element functions must have type 'a * int -> pretty")
++ end;
++
++ (* Only report the error when the function is run. Because addPrettyPrint is
++ contained in the PolyML structure we may compile a reference to a polymorphic
++ version of this for the structure record. It's replaced in the final structure
++ by this version. *)
+ in
+- mkConst (toMachineWord printProc)
++ case constrId of
++ SOME (typeId, _, _) =>
++ (* Generate a function that will set the "print" ref for the type to
++ the argument function. *)
++ mkProc(
++ mkEval(
++ mkConst (ioOp POLY_SYS_assign_word),
++ [mkInd(1, codeAccess(idAccess typeId, level+1)), CodeZero, arg1],
++ false), 1, 1, "addPP")
++ (*mkConst (toMachineWord (fn _ => ()))*)
++ | NONE =>
++ mkConst (toMachineWord
++ (fn _ => raise Fail "addPrettyPrint: The argument type was not a simple type construction"))
+ end
+
+- | codeVal (Value{access = Overloaded InstallPP, ...}, level, instance, _, _) =
+- let
++ | codeVal (Value{access = Overloaded InstallPP, ...}, _, instance, lex, loc) =
++ let
++ (* This is the old function to install a pretty printer. It has
++ been retained for backwards compatibility.
++ Since it will eventually be removed there's not much point in
++ avoiding duplication with the code for AddPretty. *)
+ (* "instance" should be ((,,,) -> int-> 'a -> 'b -> unit) -> unit.
+ We need to get the 'a and 'b. This function installs a
+- pretty printer against the type which matches 'b.
+- The type 'a is related to type of 'b as follows:
+- If 'b is a monotype t then 'a is ignored.
+- If 'b is a unary type constructor 'c t then 'a must have
+- type 'c * int -> unit.
+- If 'b is a binary or higher type constructor e.g. ('c, 'd, 'e) t
+- then 'a must be a tuple of functions of the form
+- ('c * int -> unit, 'd * int -> unit, 'e * int -> unit).
+- When the installed function is called it will be passed the
+- appropriate argument functions which it can call to print the
+- argument types. *)
+- fun rmvars (t as TypeVar tv) =
+- (
+- case tvValue tv of EmptyType => t (* Unbound type variable - return it*)
+- | t' => rmvars t'
+- )
+- | rmvars t = t;
+-
+- val (installType, argPrints) =
+- case instance of
+- FunctionType{arg, ...} => (* arg should be (,,,)-> int -> 'a->..*)
+- (
+- case arg of
+- FunctionType{result, ...} => (* result should be int->'a->'b->unit*)
+- (
+- case result of
+- FunctionType{result, ...} => (* result should be 'a->'b->unit*)
+- (
+- case result of
+- FunctionType{arg=aType, result} =>
+- (* arg should be 'a, result should be 'b->unit.*)
+- (
+- case result of
+- FunctionType{arg=bType, ...} => (* arg should be 'b *)
+- (rmvars bType, rmvars aType)
+- | _ => (badType, badType)
+- )
+- | _ => (badType, badType)
+- )
+- | _ => (badType, badType)
+- )
+- | _ => (badType, badType)
+- )
+- | _ => (badType, badType);
+-
+- (* This is the type of the pretty-printer as seen by the user *)
+- type pp =
+- (* addString *) (string -> unit) *
+- (* beginBlock *) (int * bool -> unit) *
+- (* break *) (int * int -> unit) *
+- (* endBlock *) (unit -> unit);
++ pretty printer against the type which matches 'b.
++ The type 'a is related to type of 'b as follows:
++ If 'b is a monotype t then 'a is ignored.
++ If 'b is a unary type constructor 'c t then 'a must have
++ type 'c * int -> unit.
++ If 'b is a binary or higher type constructor e.g. ('c, 'd, 'e) t
++ then 'a must be a tuple of functions of the form
++ ('c * int -> unit, 'd * int -> unit, 'e * int -> unit).
++ When the installed function is called it will be passed the
++ appropriate argument functions which it can call to print the
++ argument types. *)
++ val argPrints = mkTypeVar (generalisable, false, false);
++ val installType = mkTypeVar (generalisable, false, false);
++ (* Build a pattern type and unify it to get the type variables.
++ Unification should not fail here because type checking has already
++ been done by the time we get here. *)
++ (* The first type variable matches the set of pretty-printer functions
++ we pass in and isn't needed for type info. *)
++ val installPPType =
++ mkFunctionType(
++ mkFunctionType(mkTypeVar (generalisable, false, false),
++ mkFunctionType (TYPESTRUCT.intType,
++ mkFunctionType(argPrints,
++ mkFunctionType(installType, TYPESTRUCT.unitType)))),
++ TYPESTRUCT.unitType);
++ val () = checkPPType(instance, installPPType, "install_pp", lex, loc, fn () => PrettyString "");
+
+- fun installPp (pprint:pp -> int -> machineWord -> machineWord -> unit) =
+- let (* Find the last type constructor in the chain. We have to install
++ (* Find the last type constructor in the chain. We have to install
+ this against the last in the chain because type constructors in
+ different modules may be at different points in the chain. *)
+- (* This does mean that it's not possible to install a
+- pretty printer for a type constructor rather than a datatype. *)
+- fun followTypes (TypeConstruction{value, args, ...}) : typeId =
+- let
+- val constr = pling value
+- in
+- if isEmpty (tcEquivalent constr)
+- then let
+- val typeId : typeId = tcIdentifier constr;
+-
+- (* Check that the argument is a function from the type
+- variable to unit. *)
+- fun checkFun(tvar: types, FunctionType{arg, result}) =
+- (
+- case rmvars arg of
+- LabelledType{recList=[{name="1", typeof=arg},
+- {name="2", typeof=depthType}],
+- frozen=true, ...} =>
+- if sameTypeVar(rmvars tvar, rmvars arg)
+- then
+- (
+- case rmvars depthType of
+- TypeConstruction{value, args=[], ...} =>
+- if sameTypeId (tcIdentifier(pling value),
+- tcIdentifier intType)
+- then ()
+- else raise Fail "Argument printer must have type 'a*int->unit (second arg not int)"
+- | _ => raise Fail "Argument printer must have type 'a*int->unit (second arg not type int)"
+- )
+- else raise Fail "Argument printer must have type 'a*int->unit (mismatched 'a)"
+- | _ =>
+- raise Fail "Argument printer must have type 'a*int->unit (not pair)"
+- )
+- | checkFun(tvar: types, _) =
+- raise Fail "Argument printer must have type 'a*int->unit (not function)"
+-
+- fun checkFuns([], []) = ()
+- | checkFuns(tvar::tRest, {name, typeof}::argRest) =
+- (checkFun(tvar, typeof); checkFuns(tRest, argRest))
+- | checkFuns _ =
+- raise Fail "Tuple size does not match type"
+-
+- in
+- (* Check that the arity of the type constructor matches
+- the arity of the tuple. *)
+- case args of
+- [] => (* Simple constructor *)
+- () (* Ignore this for the moment. *)
+- | [t] => checkFun(t, argPrints)
+- | tlist =>
+- if not (isProductType argPrints)
+- then raise Fail "Argument must be a tuple"
+- else (
+- case argPrints of
+- LabelledType{recList, ...} => checkFuns(tlist, recList)
+- | _ => ()
+- );
+- (* Check that it's a top-level datatype (NOT in a functor) *)
+- if not (isFreeId typeId)
+- then raise Fail "Invalid type (not free at top-level)"
+- else ();
+- typeId
+- end
+- else followTypes (makeEquivalent (constr, args))
+- end
+- | followTypes _ =
+- raise Fail "Invalid type (not a type construction)";
+-
+- fun pproc (pretty:prettyPrinter) : int -> machineWord -> machineWord -> unit =
+- let
+- val addString = ppAddString pretty;
+- val beginBlock = ppBeginBlock pretty;
+- val break = ppBreak pretty;
+- val endBlock = ppEndBlock pretty;
+- in
+- pprint (addString, beginBlock, break, endBlock)
++ (* This does mean that it's not possible to install a
++ pretty printer for a type constructor rather than a datatype. *)
++ fun followTypes (TypeConstruction{value, args, ...}) =
++ let
++ val constr = pling value
++ in
++ if not (tcIsAbbreviation constr)
++ then SOME(tcIdentifier constr, constr, List.length args)
++ else followTypes (makeEquivalent (constr, args))
+ end
+- in
+- addPp (followTypes installType, pproc)
+- end (* installPp *);
+-
+- in
+- mkConst (toMachineWord installPp)
+- end
++ | followTypes (TypeVar tv) =
++ (
++ case tvValue tv of
++ EmptyType => NONE (* Unbound type variable *)
++ | t => followTypes t
++ )
++ | followTypes _ = NONE;
++
++ val constrId = followTypes installType
++
++ val () =
++ case constrId of
++ NONE => ()
++ | SOME (_, constr, arity) =>
++ let
++ (* Check that the function tuple matches the arguments of the type
++ we're installing for. *)
++ (* Each entry should be a function of type 'a * int -> unit *)
++ fun mkFn arg = mkFunctionType(mkProductType[arg, TYPESTRUCT.intType], TYPESTRUCT.unitType)
++ (* Create non-unifiable type vars to ensure this is properly polymorphic. *)
++ val typeVars = List.tabulate(arity, fn _ => mkTypeVar (0, false, true))
++ val tupleType =
++ case typeVars of
++ [] => (* No arg so we can have anything here. *)
++ mkTypeVar (generalisable, false, false)
++ | [arg] => mkFn arg (* Just a single function. *)
++ | args => mkProductType(List.map mkFn args)
++ val installPPType =
++ mkFunctionType(argPrints, mkFunctionType(installType, TYPESTRUCT.unitType))
++ val testType =
++ mkFunctionType(tupleType,
++ mkFunctionType(
++ mkTypeConstruction(tcName constr, constr, typeVars, [DeclaredAt loc]),
++ TYPESTRUCT.unitType))
++ in
++ checkPPType(installPPType, testType, "install_pp", lex, loc,
++ fn () =>
++ PrettyString "install_pp element functions must have type 'a * int -> unit")
++ end;
++
++ (* This is the type of the pretty-printer as seen by the user *)
++ type pp =
++ (* addString *) (string -> unit) *
++ (* beginBlock *) (int * bool -> unit) *
++ (* break *) (int * int -> unit) *
++ (* endBlock *) (unit -> unit);
++
++ fun installPp (pprint:pp -> int -> machineWord -> machineWord -> unit) =
++ case constrId of
++ NONE => raise Fail "install_pp: The argument type was not a simple type construction"
++ | SOME (typeToInstallFor, _, tupleWidth) =>
++ let
++ (* Convert the old imperative form into the new pretty datatype. *)
++ fun createPretty depth (elemFns: machineWord) (valToPrint: machineWord): pretty =
++ let
++ (* Result stack. This contains open Begins and also accumulates the result. *)
++ val resultStack = ref []
++ (* Add an entry to the top block in the stack. *)
++ fun addEntry p =
++ case ! resultStack of
++ [] => (* Nothing there so far. *)
++ resultStack := [p]
++ | PrettyBlock(i, b, c, l) :: tail =>
++ (* Add to current block. *)
++ resultStack := PrettyBlock(i, b, c, l @ [p]) :: tail
++ | _ => (* Something there but not a Begin. *)
++ raise Fail "Missing Begin"
++ fun addString s =
++ addEntry(PrettyString s)
++ and beginBlock(i: int, b: bool) =
++ addEntry(PrettyBlock(i, b, [], []))
++ and break (i: int, j: int) : unit =
++ addEntry(PrettyBreak(i, j))
++ and endBlock () =
++ case ! resultStack of
++ [] => raise Fail "End found with no Begin"
++ | hd :: tl =>
++ (* Pop the current block from the stack and
++ add it as an entry to the immediately containing block. *)
++ (
++ resultStack := tl;
++ addEntry hd
++ )
++
++ val processElement: machineWord =
++ (* This is the single function or tuple of functions to process
++ the elements when this is a polytype. e.g. for "int" if this
++ is "int list". *)
++ case tupleWidth of
++ 0 => toMachineWord (* Not used for monotypes. *)
++ (fn _ => raise Fail "Monotype has no type argument")
++ | 1 => toMachineWord (* Single argument polytypes e.g. list *)
++ (fn (v, depth) => addEntry(RunCall.unsafeCast elemFns (v, depth)))
++ | n => (* Polytypes of more than one type e.g. ('a, 'b) pair. *)
++ let (* We have to construct a tuple of functions each of which calls
++ the corresponding function in the tuple that is passed in. *)
++ fun getElem n (v, depth) =
++ let
++ val prettyFn =
++ RunCall.unsafeCast(loadWord(toAddress elemFns, toShort n))
++ in
++ addEntry(prettyFn(v, depth))
++ end
++ (* As with the print code in printConstruction we use CodeTree
++ to create the tuple. *)
++ val fns = List.tabulate (n, fn n => mkConst(toMachineWord(getElem n)))
++ in
++ evalue (mkTuple fns)
++ end
++ in
++ pprint (addString, beginBlock, break, endBlock) depth processElement valToPrint;
++ case ! resultStack of
++ [] => PrettyBlock(0, false, [], [])
++ | [one] => one
++ | _ => raise Fail "Incorrect nesting of begin...end blocks"
++ end
++ in
++ case idAccess typeToInstallFor of
++ Global code =>
++ unsafeCast(evalue(mkInd(1, code))) := createPretty
++ | _ => () (* Do nothing silently at the moment. *)
++ end (* installPp *)
++
++ in
++ mkConst (toMachineWord installPp)
++ end
++
++ | codeVal (Value{access = Overloaded GetLocation, ...}, _, _, _, _) =
++ (* This can't be used a value: It must be called immediately. *)
++ let
++ fun getLoc() =
++ raise Fail "The special function PolyML.sourceLocation cannot be used as a value"
++ in
++ mkConst (toMachineWord getLoc)
++ end
+
+ | codeVal (value as Value{access = Overloaded _, ...}, level, instance, lex, lineno) =
+ (* AddOverload, Equal, NotEqual, TypeDep *)
+ mkProc
+- (applyFunction (value, arg1, level, instance, lex, lineno),
+- 1, 1, "")
++ (applyFunction (value, arg1, level+1, instance, lex, lineno),
++ level, 1, "")
+ (* codeVal *)
+
+ (* Some of these have a more efficient way of calling them as functions. *)
+@@ -2760,156 +1781,159 @@
+ (* If we are applying it as a function we cannot be after the
+ exception id, we must be constructing an exception packet. *)
+ (* Get the exception id, put it in the packet with the exception name
+- and the argument. *)
++ the argument and, currently, an empty location as the exception location. *)
+ val exIden = codeVal (value, level, instance, lex, lineno);
+ in
+- mkTuple (exIden :: mkStr (valName value) :: [argument])
++ mkTuple (exIden :: mkStr (valName value) :: argument :: [mkConst(toMachineWord NoLocation)])
+ end
+
+ | applyFunction(value as Value{class=Constructor _, ...},
+- argument, level, instance, lex, lineno) =
+- let
+- (* If this is a value constructor we need to get the construction
+- function and use that. *)
++ argument, level, instance, lex, lineno) =
++ let
++ (* If this is a value constructor we need to get the construction
++ function and use that. *)
+ val constrTriple = codeVal (value, level, instance, lex, lineno);
+- in
+- (* Don't apply this "early". It might be the ref constructor and that
+- must not be applied until run-time. The optimiser should take care
+- of any other cases. *)
+- mkEval (mkInd(1, constrTriple), [argument], false)
+- end
++ in
++ (* Don't apply this "early". It might be the ref constructor and that
++ must not be applied until run-time. The optimiser should take care
++ of any other cases. *)
++ mkEval (mkInd(1, constrTriple), [argument], false)
++ end
+
+ | applyFunction (value as Value{access = Overloaded oper, name = valName, ...},
+- argument, level, instance, lex, lineno) =
++ argument, level, instance, lex, lineno) =
+ (
+- case oper of
+- Equal =>
+- (* See if we have a special implementation for equality on
+- this type. If not we have to fall back to the default
+- structure equality. *)
+- (* Note: the overloadings will normally be inline functions
+- which will unwrap the argument tuple and so elide it away.
+- structureEq, though, is passed here as a pointer to
+- the code so no such optimisation is possible and we will
+- always make a tuple which will then be unwrapped inside
+- structureEq. Two solutions are possible: we could build
+- structureEq into the RTS in which case it would take an
+- argument pair (usually in registers) or we could write it
+- in the prelude and set it as an overload with some special
+- type so that getOverload would return it as the default. *)
+- let
+- val code = genEqualityFunction(instance, level)
+- in
+- mkEval (code, [argument], true) (* evaluate early *)
+- end
+-
+- | NotEqual =>
+- let
+- (* Use the "=" function to provide inequality as well as
+- equality. *)
+- val code = genEqualityFunction(instance, level)
+- val isEqual =
+- mkEval (code, [argument], true) (* evaluate early *)
+- in
+- mkNot isEqual
+- end
++ case oper of
++ Equal =>
++ (* See if we have a special implementation for equality on
++ this type. If not we have to fall back to the default
++ structure equality. *)
++ (* Note: the overloadings will normally be inline functions
++ which will unwrap the argument tuple and so elide it away.
++ structureEq, though, is passed here as a pointer to
++ the code so no such optimisation is possible and we will
++ always make a tuple which will then be unwrapped inside
++ structureEq. Two solutions are possible: we could build
++ structureEq into the RTS in which case it would take an
++ argument pair (usually in registers) or we could write it
++ in the prelude and set it as an overload with some special
++ type so that getOverload would return it as the default. *)
++ let
++ (* The instance type is a function so we have to get the first argument. *)
++ val code = equalityForType(firstArg instance, level)
++ in
++ mkEval (code, [argument], true) (* evaluate early *)
++ end
++
++ | NotEqual =>
++ let
++ (* Use the "=" function to provide inequality as well as equality. *)
++ val code = equalityForType(firstArg instance, level)
++ val isEqual =
++ mkEval (code, [argument], true) (* evaluate early *)
++ in
++ mkNot isEqual
++ end
+
+ | TypeDep =>
+- let
+- val (code, _) =
+- getOverloadInstance(valName, instance, false, lex, lineno)
+- in
+- mkEval (code, [argument], true) (* evaluate early *)
+- end
+-
+- | AddOverload =>
+- (* AddOverload is only intended for use by writers of library modules.
+- It only does limited checking and should be regarded as "unsafe". *)
+- let
+- (* instance should be ('a->'b) -> string -> unit. For overloadings
+- on most functions (e.g. abs and +) we are looking for the 'a, which
+- may be a pair, but in the case of conversion functions we want the 'b. *)
+- (* rmvars removes type variables put on by unification. *)
+- fun rmvars (TypeVar tv) = rmvars(tvValue tv)
+- | rmvars t = t
+-
+- fun followTypes(TypeConstruction{value, args, ...}):typeConstrs =
+- let
+- val constr = pling value
+- in
+- if isEmpty (tcEquivalent constr)
+- then constr
++ let
++ val (code, _) = getOverloadInstance(valName, instance, false)
++ in
++ mkEval (code, [argument], true) (* evaluate early *)
++ end
++
++ | AddOverload =>
++ (* AddOverload is only intended for use by writers of library modules.
++ It only does limited checking and should be regarded as "unsafe". *)
++ let
++ (* instance should be ('a->'b) -> string -> unit. For overloadings
++ on most functions (e.g. abs and +) we are looking for the 'a, which
++ may be a pair, but in the case of conversion functions we want the 'b. *)
++ (* rmvars removes type variables put on by unification. *)
++ fun rmvars (TypeVar tv) = rmvars(tvValue tv)
++ | rmvars t = t
++
++ fun followTypes(TypeConstruction{value, args, ...}):typeConstrs =
++ let
++ val constr = pling value
++ in
++ if not (tcIsAbbreviation constr)
++ then if not (isFreeId(tcIdentifier constr))
++ then raise Fail "Cannot install an overload within a structure or functor"
++ else constr
+ else followTypes (makeEquivalent (constr, args))
+ end
+- | followTypes t =
+- raise Fail "Invalid type (not a type construction)";
++ | followTypes _ =
++ raise Fail "Invalid type (not a type construction) (addOverload)"
+
+- (* In normal use the instance type would be a function and
+- everything would be fine. It is possible though that we
+- might have something of the form val a = addOverload in
+- which case we want to leave the error until runtime. This
+- particular case seems to happen as a result of open PolyML
+- when PolyML contains addOverload. *)
+- val (argType, resultType) =
+- case instance of
+- FunctionType{arg,...} =>
+- (
+- case arg of
+- (* We could do some checking of the type of the
+- function such as checking that we either have
+- something of the form t->t, t*t->t or t*t->bool
+- or string->t in the case of conversion functions.
+- It's probably not worth it since adding overloads
+- is only intended to be done by writers of libraries. *)
+- FunctionType{arg, result} =>
+- (
+- case (rmvars arg) of
+- LabelledType{recList=[{typeof, ...}, _], ...} =>
+- (rmvars typeof, rmvars result)
+- | t => (rmvars t, rmvars result)
+- )
+- | _ => (badType, badType)
+- )
+- | _ => (badType, badType)
+-
+- fun addOverloading (argCode: codetree) (name: string) =
+- let
+- val typeToUse =
+- if size name > 4 andalso
+- String.substring(name, 0, 4) = "conv"
+- (* For conversion functions it's the result
+- type we're interested in. For everything
+- else it's the argument type. *)
+- then resultType
+- else argType
+- val tcons = followTypes typeToUse
+- in
+- addOverload(name, tcons, argCode)
+- end
+-
+- (* This function is used if we can't get the codetree at
+- compile time. *)
+- fun addOverloadGeneral (arg: machineWord) =
+- addOverloading(mkConst arg)
+- in
+- (* This is messy but necessary for efficiency. If we simply treat
+- addOverload as a function we would be able to pick up the
+- additional overloading as a pointer to a function. Most overloads
+- are small functions or wrapped calls to RTS functions and so
+- we need to get the inline code for them. *)
+- (
+- (* evalue raises an exception if "argument" is not a constant,
+- or more usefully, a global value containing a constant and
+- possibly a piece of codetree to inline. *)
+- evalue(argument);
+- mkConst (toMachineWord (addOverloading argument))
+- )
+- handle SML90.Interrupt => raise SML90.Interrupt
+- | _ =>
+- mkEval (mkConst (toMachineWord addOverloadGeneral), [argument], false)
+- end
++ (* In normal use the instance type would be a function and
++ everything would be fine. It is possible though that we
++ might have something of the form val a = addOverload in
++ which case we want to leave the error until runtime. This
++ particular case seems to happen as a result of open PolyML
++ when PolyML contains addOverload. *)
++ val (argType, resultType) =
++ case rmvars instance of
++ FunctionType{arg,...} =>
++ (
++ case arg of
++ (* We could do some checking of the type of the
++ function such as checking that we either have
++ something of the form t->t, t*t->t or t*t->bool
++ or string->t in the case of conversion functions.
++ It's probably not worth it since adding overloads
++ is only intended to be done by writers of libraries. *)
++ FunctionType{arg, result} =>
++ (
++ case (rmvars arg) of
++ LabelledType{recList=[{typeof, ...}, _], ...} =>
++ (rmvars typeof, rmvars result)
++ | t => (rmvars t, rmvars result)
++ )
++ | _ => (badType, badType)
++ )
++ | _ => (badType, badType)
++
++ fun addOverloading (argCode: codetree) (name: string) =
++ let
++ val typeToUse =
++ if size name > 4 andalso
++ String.substring(name, 0, 4) = "conv"
++ (* For conversion functions it's the result
++ type we're interested in. For everything
++ else it's the argument type. *)
++ then resultType
++ else argType
++ val tcons = followTypes typeToUse
++ in
++ addOverload(name, tcons, argCode)
++ end
++
++ (* This function is used if we can't get the codetree at
++ compile time. *)
++ fun addOverloadGeneral (arg: machineWord) =
++ addOverloading(mkConst arg)
++ in
++ (* This is messy but necessary for efficiency. If we simply treat
++ addOverload as a function we would be able to pick up the
++ additional overloading as a pointer to a function. Most overloads
++ are small functions or wrapped calls to RTS functions and so
++ we need to get the inline code for them. *)
++ (
++ (* evalue raises an exception if "argument" is not a constant,
++ or more usefully, a global value containing a constant and
++ possibly a piece of codetree to inline. *)
++ evalue(argument);
++ mkConst (toMachineWord (addOverloading argument))
++ )
++ handle SML90.Interrupt => raise SML90.Interrupt
++ | _ =>
++ mkEval (mkConst (toMachineWord addOverloadGeneral), [argument], false)
++ end
+
+- | _ => (* Print, MakeString, InstallPP *)
++ | GetLocation => (* Return the current location. *) mkConst(toMachineWord lineno)
++
++ | _ => (* Print, MakeString, InstallPP *)
+ (* Just call as functions. *) (* not early *)
+ mkEval (codeVal (value, level, instance, lex, lineno), [argument], false)
+
+@@ -2925,54 +1949,55 @@
+ an exception packet now, otherwise generate a function to construct
+ an exception packet. *)
+ fun codeExFunction (value, level, instance, lex, lineno) =
+- if isEmpty (valTypeOf value) (* N.B. Not "instance" *)
+- then applyFunction (value, CodeZero, level, instance, lex, lineno)
+- else mkProc
+- (applyFunction (value, arg1, level + 1, instance, lex, lineno),
+- 1, 1, ""); (* shouldn't this function be in-lined??? SPF 20/10/94 *)
+-
+- (* Operations to compile code from the representation of a constructor. *)
+- (* Code to test whether a value matches a constructor. *)
+- fun makeGuard (value as Value{class=Constructor _, ...}, testing, level) =
+- mkEval(mkInd(0, codeVal (value, level, emptyType, nullLex, 0)),
+- [testing], true)
++ case getFnArgType(valTypeOf value) of (* N.B. Not "instance" *)
++ NONE => applyFunction (value, CodeZero, level, instance, lex, lineno)
++ | SOME _ =>
++ mkProc
++ (applyFunction (value, arg1, level + 1, instance, lex, lineno),
++ 1, 1, ""); (* shouldn't this function be in-lined??? SPF 20/10/94 *)
++
++ (* Operations to compile code from the representation of a constructor. *)
++ (* Code to test whether a value matches a constructor. *)
++ fun makeGuard (value as Value{class=Constructor _, ...}, testing, level) =
++ mkEval(mkInd(0, codeVal (value, level, emptyType, nullLex, location nullLex)),
++ [testing], true)
+
+- | makeGuard (value as Value{class=Exception, ...}, testing, level) =
++ | makeGuard (value as Value{class=Exception, ...}, testing, level) =
+ (* Should only be an exception. Get the value of the exception identifier
+ and compare with the identifier in the exception packet. *)
+ mkTestptreq
+ (mkInd (0, testing),
+- codeVal (value, level, emptyType, nullLex, 0))
++ codeVal (value, level, emptyType, nullLex, location nullLex))
+
+- | makeGuard _ = raise InternalError "makeGuard"
++ | makeGuard _ = raise InternalError "makeGuard"
+
+- (* Code to invert a constructor. i.e. return the value originally
++ (* Code to invert a constructor. i.e. return the value originally
+ used as the argument. *)
+- fun makeInverse(value as Value{class=Constructor{nullary=false}, ...}, arg, level): codetree =
+- mkEval(mkInd(2, codeVal (value, level, emptyType, nullLex, 0)),
+- [arg], false) (* NOT "early" - this may be the "ref" constructor. *)
+-
+- | makeInverse(value as Value{class=Constructor{nullary=true}, ...}, arg, level): codetree =
+- (* makeInverse is called even on nullary constructors. Return zero to keep the
+- optimiser happy. *) CodeZero
++ fun makeInverse(value as Value{class=Constructor{nullary=false, ...}, ...}, arg, level): codetree =
++ mkEval(mkInd(2, codeVal (value, level, emptyType, nullLex, location nullLex)),
++ [arg], false) (* NOT "early" - this may be the "ref" constructor. *)
++
++ | makeInverse(Value{class=Constructor{nullary=true, ...}, ...}, _, _): codetree =
++ (* makeInverse is called even on nullary constructors. Return zero to keep the
++ optimiser happy. *) CodeZero
+
+- | makeInverse (value as Value{class=Exception, ...}, arg, level) =
++ | makeInverse (Value{class=Exception, ...}, arg, _) =
+ (* Exceptions. - Get the parameter from third word *) mkInd (2,arg)
+
+- | makeInverse _ = raise InternalError "makeInverse"
++ | makeInverse _ = raise InternalError "makeInverse"
+
+ (* Get the current overload set for the function and return a new
+ instance of the type containing the overload set. *)
+ fun overloadType(Value{typeOf, access = Overloaded TypeDep, name, ...}, isConv) =
+- let
+- fun getTypes [] = []
+- | getTypes ((t, _) :: l) = t :: getTypes l
+-
+- in
+- generaliseOverload(typeOf, getTypes(getOverloads name), isConv)
+- end
++ let
++ fun getTypes [] = []
++ | getTypes ((t, _) :: l) = t :: getTypes l
++
++ in
++ generaliseOverload(typeOf, getTypes(getOverloads name), isConv)
++ end
+
+- | overloadType(Value{typeOf, ...}, isConv) = generalise(typeOf, true)
++ | overloadType(Value{typeOf, ...}, _) = generalise typeOf
+
+ (* True if the arguments are definitely the same exception. Used in the
+ match compiler to see if we can merge adjacent exception patterns.
+@@ -2980,17 +2005,37 @@
+ same (short) name means that the exceptions are the same, we have to
+ look at the address. *)
+ fun isTheSameException(Value{access = Global aCode, ...},
+- Value{access = Global bCode, ...}) : bool =
+- wordEq(evalue aCode, evalue bCode)
++ Value{access = Global bCode, ...}) : bool =
++ wordEq(evalue aCode, evalue bCode)
+
+ | isTheSameException(Value{access = Local{addr=ref aAddr, level=ref aLevel}, ...},
+- Value{access = Local{addr=ref bAddr, level=ref bLevel}, ...}) : bool =
++ Value{access = Local{addr=ref bAddr, level=ref bLevel}, ...}) : bool =
+ (* I don't like this. It assumes that the address and level have
+ already been set. *)
+- aAddr = bAddr andalso aLevel = bLevel
++ aAddr = bAddr andalso aLevel = bLevel
+
+ | isTheSameException _ = false (* Forget about "selected" for the moment. *)
+
++ (* Types that can be shared. *)
++ structure Sharing =
++ struct
++ type machineWord = machineWord
++ type lexan = lexan
++ type codetree = codetree
++ type types = types
++ type values = values
++ type structVals = structVals
++ type functors = functors
++ type valAccess = valAccess
++ type typeConstrs = typeConstrs
++ type signatures = signatures
++ type fixStatus = fixStatus
++ type univTable = univTable
++ type pretty = pretty
++ type locationProp = locationProp
++ type typeId = typeId
++ type typeVarForm = typeVarForm
++ end
+
+ end (* body of VALUEOPS *);
+
+diff -u -r mlsource/MLCompiler/ValueOps.ML mlsource/MLCompiler/ValueOps.ML
+--- mlsource/MLCompiler/ValueOps.ML 2008-03-25 12:14:19.000000000 +0100
++++ mlsource/MLCompiler/ValueOps.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -1,5 +1,5 @@
+ (*
+- Copyright (c) 2000
++ Copyright (c) 2000, 2009
+ Cambridge University Technical Services Limited
+
+ This library is free software; you can redistribute it and/or
+@@ -28,7 +28,9 @@
+ structure DEBUG = Debug
+ structure ADDRESS = Address
+ structure MISC = Misc
+- structure PRETTYPRINTER = PrettyPrinter
++ structure PRETTY = Pretty
+ structure UNIVERSAL = Universal
+ structure UTILITIES = Utilities
++ structure COPIER = CopierStruct
++ structure TYPEIDCODE = TypeIDCodeStruct
+ ) ;
+diff -u -r mlsource/MLCompiler/ml_bind.ML mlsource/MLCompiler/ml_bind.ML
+--- mlsource/MLCompiler/ml_bind.ML 2008-04-21 13:36:11.000000000 +0200
++++ mlsource/MLCompiler/ml_bind.ML 2009-09-15 08:56:46.000000000 +0200
+@@ -33,5 +33,7 @@
+
+ (* This is exported when building the normal distribution. *)
+ val shell = mainShell
++
++ val useString = Make.useStringIntoEnv globalTable;
+ end;
+ end;
+Only in mlsource/extra/CInterface: CALL_WITH_CONV.530.ML
+diff -u -r mlsource/extra/CInterface/CALL_WITH_CONV.ML mlsource/extra/CInterface/CALL_WITH_CONV.ML
+--- mlsource/extra/CInterface/CALL_WITH_CONV.ML 2005-09-17 18:40:16.000000000 +0200
++++ mlsource/extra/CInterface/CALL_WITH_CONV.ML 2009-09-15 08:56:47.000000000 +0200
+@@ -62,8 +62,8 @@
+ infix @
+ infix @@
+
+-fun (x @ Conversion(_,to,_)) = In (to x)
+-fun (Conversion(from,_,choice) @@ pap) =
++fun x @ (Conversion(_,to,_)) = In (to x)
++fun (Conversion(from,_,choice)) @@ pap =
+ case (pap choice) of
+ (union,[]) => from union
+ | _ => never "@@"
+diff -u -r mlsource/extra/CInterface/CInterfaceSig.ML mlsource/extra/CInterface/CInterfaceSig.ML
+--- mlsource/extra/CInterface/CInterfaceSig.ML 2006-09-26 15:38:32.000000000 +0200
++++ mlsource/extra/CInterface/CInterfaceSig.ML 2009-09-15 08:56:47.000000000 +0200
+@@ -95,6 +95,8 @@
+ val load_lib : string -> dylib
+ val load_sym : dylib -> string -> sym
+ val get_sym : string -> string -> sym
++
++ val setFinal : sym -> vol -> unit
+
+ val set_libPath : dylib -> string -> unit
+ val get_libPath : dylib -> string
+Only in mlsource/extra/CInterface: CTYPE_SAVE_SIZEOF.530.ML
+diff -u -r mlsource/extra/CInterface/Ctype/CTYPE.ML mlsource/extra/CInterface/Ctype/CTYPE.ML
+--- mlsource/extra/CInterface/Ctype/CTYPE.ML 2005-09-17 18:40:17.000000000 +0200
++++ mlsource/extra/CInterface/Ctype/CTYPE.ML 2009-09-15 08:56:47.000000000 +0200
+@@ -107,7 +107,7 @@
+ | makeRaw Cuint = Dispatch.Cuint
+ | makeRaw (Cpointer _) = Dispatch.Cpointer
+ | makeRaw (Cfunction _) = Dispatch.Cpointer (*Always the same as a pointer?*)
+- | makeRaw (t as Cstruct ts) = Dispatch.Cstruct (sizeof t)
++ | makeRaw (t as Cstruct _) = Dispatch.Cstruct (sizeof t)
+ | makeRaw Cvoid = Dispatch.Cint (*hack*)
+
+
+Only in mlsource/extra/CInterface: Dispatch.530.ML
+diff -u -r mlsource/extra/CInterface/Dispatch.ML mlsource/extra/CInterface/Dispatch.ML
+--- mlsource/extra/CInterface/Dispatch.ML 2008-03-18 09:30:51.000000000 +0100
++++ mlsource/extra/CInterface/Dispatch.ML 2009-09-15 08:56:47.000000000 +0200
+@@ -337,5 +337,7 @@
+
+ val toCfunction = next(three);(* Added DCJM 7/4/04 *)
+ val toPascalfunction = next(three);(* Added DCJM 7/4/04 *)
++
++ val setFinal = next(two); (* Added DCJM 2/8/09. *)
+
+ end (* struct *)
+diff -u -r mlsource/extra/CInterface/DispatchSig.ML mlsource/extra/CInterface/DispatchSig.ML
+--- mlsource/extra/CInterface/DispatchSig.ML 2006-09-26 15:38:32.000000000 +0200
++++ mlsource/extra/CInterface/DispatchSig.ML 2009-09-15 08:56:47.000000000 +0200
+@@ -79,5 +79,7 @@
+
+ val toCfunction : RawCtype list -> RawCtype -> (rawvol list -> rawvol) -> rawvol
+ val toPascalfunction : RawCtype list -> RawCtype -> (rawvol list -> rawvol) -> rawvol
++
++ val setFinal : rawvol -> rawvol -> unit
+
+ end;
+diff -u -r mlsource/extra/CInterface/Examples/Foreign.def mlsource/extra/CInterface/Examples/Foreign.def
+--- mlsource/extra/CInterface/Examples/Foreign.def 2007-12-30 17:58:25.000000000 +0100
++++ mlsource/extra/CInterface/Examples/Foreign.def 2009-09-15 08:56:47.000000000 +0200
+@@ -10,3 +10,5 @@
+ MakeCallback
+ MakeCallback2
+ MakeCallback3
++ AllocateIt
++ FreeIt
+diff -u -r mlsource/extra/CInterface/Examples/ForeignTest.c mlsource/extra/CInterface/Examples/ForeignTest.c
+--- mlsource/extra/CInterface/Examples/ForeignTest.c 2007-12-30 17:52:41.000000000 +0100
++++ mlsource/extra/CInterface/Examples/ForeignTest.c 2009-09-15 08:56:47.000000000 +0200
+@@ -1,7 +1,7 @@
+ /* Example code for a C-library accessible from ML
+ using the CInterface structure.
+
+- Copyright David C.J. Matthews 1999
++ Copyright David C.J. Matthews 1999, 2009
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+@@ -24,6 +24,7 @@
+ */
+ #include <stdlib.h>
+ #include <string.h>
++#include <stdio.h>
+
+ /* Return a string duplicated n Times. */
+ char *DupNString(int n, char *str)
+@@ -83,3 +84,19 @@
+ mlcall(i+1);
+ }
+
++/* Test for finalisation. */
++void *AllocateIt()
++{
++ void *p = malloc(1);
++ printf("Allocated object at %p\n", p);
++ fflush(stdout);
++ return p;
++}
++
++void FreeIt(void *p)
++{
++ printf("Freed object at %p\n", p);
++ fflush(stdout);
++ free(p);
++}
++
+diff -u -r mlsource/extra/CInterface/Examples/ForeignTest.sml mlsource/extra/CInterface/Examples/ForeignTest.sml
+--- mlsource/extra/CInterface/Examples/ForeignTest.sml 2007-12-30 17:52:41.000000000 +0100
++++ mlsource/extra/CInterface/Examples/ForeignTest.sml 2009-09-15 08:56:47.000000000 +0200
+@@ -1,7 +1,7 @@
+ (* Example code for a C-library accessible from ML
+ using the CInterface structure.
+
+- Copyright David C.J. Matthews 1999-2006
++ Copyright David C.J. Matthews 1999-2009
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+@@ -125,3 +125,17 @@
+ val doit = call2(load_sym mylib "MakeCallback3") (FUNCTION1 INT VOID, INT) VOID;
+ doit(fn i => print(Int.toString i), 2);
+
++(* Test for finalisation. *)
++val allocateIt = call0 (load_sym mylib "AllocateIt") () POINTER;
++val v1 = allocateIt();
++val v2 = allocateIt ();
++val final = load_sym mylib "FreeIt";
++setFinal final v1;
++setFinal final v2;
++
++(* Activating the finalisers requires a full GC. *)
++val v1 = 0; (* The v1 object is no longer reachable. *)
++PolyML.fullGC();
++val v2 = 0; (* The v2 object is no longer reachable. *)
++PolyML.fullGC();
++
+diff -u -r mlsource/extra/CInterface/ForeignException.ML mlsource/extra/CInterface/ForeignException.ML
+--- mlsource/extra/CInterface/ForeignException.ML 2005-09-17 18:40:16.000000000 +0200
++++ mlsource/extra/CInterface/ForeignException.ML 2009-09-15 08:56:47.000000000 +0200
+@@ -19,17 +19,5 @@
+
+ structure ForeignException : ForeignExceptionSig =
+ struct
+- local
+- structure Type =
+- struct
+- type ex_type = string;
+- val ex_iden = 23;
+- end;
+-
+- structure E: sig exception ex of string end =
+- RunCall.Run_exception1(Type);
+- in
+- exception Foreign = E.ex;
+- end;
+-
++ exception Foreign = PolyML.Foreign
+ end;
+Only in mlsource/extra/CInterface: LowerLevel.530.ML
+diff -u -r mlsource/extra/CInterface/LowerLevel.ML mlsource/extra/CInterface/LowerLevel.ML
+--- mlsource/extra/CInterface/LowerLevel.ML 2006-09-26 15:38:32.000000000 +0200
++++ mlsource/extra/CInterface/LowerLevel.ML 2009-09-15 08:56:47.000000000 +0200
+@@ -161,6 +161,10 @@
+ ******)
+ withSym sym (fn symVol =>
+ Volatile.call_sym_and_convert symVol args retType);
++
++ (* Set a finalizer for a vol. *)
++ fun setFinal sym vol =
++ withSym sym (fn symVol => Volatile.setFinal symVol vol)
+
+
+ fun volOfSym sym =
+diff -u -r mlsource/extra/CInterface/LowerLevelSig.ML mlsource/extra/CInterface/LowerLevelSig.ML
+--- mlsource/extra/CInterface/LowerLevelSig.ML 2005-09-17 18:40:16.000000000 +0200
++++ mlsource/extra/CInterface/LowerLevelSig.ML 2009-09-15 08:56:47.000000000 +0200
+@@ -73,6 +73,8 @@
+ val load_lib : string -> dylib
+ val load_sym : dylib -> string -> sym
+ val get_sym : string -> string -> sym
++
++ val setFinal : sym -> vol -> unit
+
+ val set_libPath : dylib -> string -> unit
+ val get_libPath : dylib -> string
+diff -u -r mlsource/extra/CInterface/STRUCT_CONVERSIONALS.ML mlsource/extra/CInterface/STRUCT_CONVERSIONALS.ML
+--- mlsource/extra/CInterface/STRUCT_CONVERSIONALS.ML 2006-09-26 15:38:32.000000000 +0200
++++ mlsource/extra/CInterface/STRUCT_CONVERSIONALS.ML 2009-09-15 08:56:47.000000000 +0200
+@@ -232,7 +232,7 @@
+ fun FUNCTION0 () (cr: 'a Conversion) =
+ let
+ val (_, tor, ctyper) = breakConversion cr (* Convert the result type. *)
+- fun from v = raise Foreign "Conversion from C function to ML function is not implemented"
++ fun from _ = raise Foreign "Conversion from C function to ML function is not implemented"
+ (* Construct a wrapper function. The argument is ignored and the result is converted into a vol.*)
+ fun convF f _ = tor(f())
+ fun to (f: unit->'a) : vol = toCfunction [] ctyper (convF f)
+@@ -243,7 +243,7 @@
+ fun PASCALFUNCTION0 () cr =
+ let
+ val (_, tor, ctyper) = breakConversion cr (* Convert the result type. *)
+- fun from v = raise Foreign "Conversion from C function to ML function is not implemented"
++ fun from _ = raise Foreign "Conversion from C function to ML function is not implemented"
+ fun convF f _ = tor(f())
+ fun to f = toPascalfunction [] ctyper (convF f)
+ in
+@@ -254,7 +254,7 @@
+ let
+ val (from1,_,ctype1) = breakConversion c1
+ val (_,tor,ctyper) = breakConversion cr
+- fun from v = raise Foreign "Conversion from C function to ML function is not implemented"
++ fun from _ = raise Foreign "Conversion from C function to ML function is not implemented"
+ (* The wrapper function. We need a single argument. *)
+ fun convF f [a] = tor(f(from1 a))
+ | convF _ _ = raise Union.Never "arg mismatch"
+@@ -267,7 +267,7 @@
+ let
+ val (from1,_,ctype1) = breakConversion c1
+ val (_,tor,ctyper) = breakConversion cr
+- fun from v = raise Foreign "Conversion from C function to ML function is not implemented"
++ fun from _ = raise Foreign "Conversion from C function to ML function is not implemented"
+ fun convF f [a] = tor(f(from1 a))
+ | convF _ _ = raise Union.Never "arg mismatch"
+ fun to f : vol = toPascalfunction [ctype1] ctyper (convF f)
+@@ -280,7 +280,7 @@
+ val (from1,_,ctype1) = breakConversion c1
+ val (from2,_,ctype2) = breakConversion c2
+ val (_,tor,ctyper) = breakConversion cr
+- fun from v = raise Foreign "Conversion from C function to ML function is not implemented"
++ fun from _ = raise Foreign "Conversion from C function to ML function is not implemented"
+ fun convF f [a,b] = tor(f(from1 a, from2 b))
+ | convF _ _ = raise Union.Never "arg mismatch"
+ fun to f = toCfunction [ctype1, ctype2] ctyper (convF f)
+@@ -293,7 +293,7 @@
+ val (from1,_,ctype1) = breakConversion c1
+ val (from2,_,ctype2) = breakConversion c2
+ val (_,tor,ctyper) = breakConversion cr
+- fun from v = raise Foreign "Conversion from C function to ML function is not implemented"
++ fun from _ = raise Foreign "Conversion from C function to ML function is not implemented"
+ fun convF f [a,b] = tor(f(from1 a, from2 b))
+ | convF _ _ = raise Union.Never "arg mismatch"
+ fun to f = toPascalfunction [ctype1, ctype2] ctyper (convF f)
+@@ -303,11 +303,11 @@
+
+ fun FUNCTION3 (c1, c2, c3) cr =
+ let
+- val (from1,to1,ctype1) = breakConversion c1
+- val (from2,to2,ctype2) = breakConversion c2
+- val (from3,to3,ctype3) = breakConversion c3
+- val (fromr,tor,ctyper) = breakConversion cr
+- fun from v = raise Foreign "Conversion from C function to ML function is not implemented"
++ val (from1,_,ctype1) = breakConversion c1
++ val (from2,_,ctype2) = breakConversion c2
++ val (from3,_,ctype3) = breakConversion c3
++ val (_,tor,ctyper) = breakConversion cr
++ fun from _ = raise Foreign "Conversion from C function to ML function is not implemented"
+ fun convF f [a,b,c] = tor(f(from1 a, from2 b, from3 c))
+ | convF _ _ = raise Union.Never "arg mismatch"
+ fun to f = toCfunction [ctype1, ctype2, ctype3] ctyper (convF f)
+@@ -317,11 +317,11 @@
+
+ fun PASCALFUNCTION3 (c1, c2, c3) cr =
+ let
+- val (from1,to1,ctype1) = breakConversion c1
+- val (from2,to2,ctype2) = breakConversion c2
+- val (from3,to3,ctype3) = breakConversion c3
+- val (fromr,tor,ctyper) = breakConversion cr
+- fun from v = raise Foreign "Conversion from C function to ML function is not implemented"
++ val (from1,_,ctype1) = breakConversion c1
++ val (from2,_,ctype2) = breakConversion c2
++ val (from3,_,ctype3) = breakConversion c3
++ val (_,tor,ctyper) = breakConversion cr
++ fun from _ = raise Foreign "Conversion from C function to ML function is not implemented"
+ fun convF f [a,b,c] = tor(f(from1 a, from2 b, from3 c))
+ | convF _ _ = raise Union.Never "arg mismatch"
+ fun to f = toPascalfunction [ctype1, ctype2, ctype3] ctyper (convF f)
+@@ -331,12 +331,12 @@
+
+ fun FUNCTION4 (c1, c2, c3, c4) cr =
+ let
+- val (from1,to1,ctype1) = breakConversion c1
+- val (from2,to2,ctype2) = breakConversion c2
+- val (from3,to3,ctype3) = breakConversion c3
+- val (from4,to4,ctype4) = breakConversion c4
+- val (fromr,tor,ctyper) = breakConversion cr
+- fun from v = raise Foreign "Conversion from C function to ML function is not implemented"
++ val (from1,_,ctype1) = breakConversion c1
++ val (from2,_,ctype2) = breakConversion c2
++ val (from3,_,ctype3) = breakConversion c3
++ val (from4,_,ctype4) = breakConversion c4
++ val (_,tor,ctyper) = breakConversion cr
++ fun from _ = raise Foreign "Conversion from C function to ML function is not implemented"
+ fun convF f [a,b,c,d] = tor(f(from1 a, from2 b, from3 c, from4 d))
+ | convF _ _ = raise Union.Never "arg mismatch"
+ fun to f = toCfunction [ctype1, ctype2, ctype3, ctype4] ctyper (convF f)
+@@ -346,12 +346,12 @@
+
+ fun PASCALFUNCTION4 (c1, c2, c3, c4) cr =
+ let
+- val (from1,to1,ctype1) = breakConversion c1
+- val (from2,to2,ctype2) = breakConversion c2
+- val (from3,to3,ctype3) = breakConversion c3
+- val (from4,to4,ctype4) = breakConversion c4
+- val (fromr,tor,ctyper) = breakConversion cr
+- fun from v = raise Foreign "Conversion from C function to ML function is not implemented"
++ val (from1,_,ctype1) = breakConversion c1
++ val (from2,_,ctype2) = breakConversion c2
++ val (from3,_,ctype3) = breakConversion c3
++ val (from4,_,ctype4) = breakConversion c4
++ val (_,tor,ctyper) = breakConversion cr
++ fun from _ = raise Foreign "Conversion from C function to ML function is not implemented"
+ fun convF f [a,b,c,d] = tor(f(from1 a, from2 b, from3 c, from4 d))
+ | convF _ _ = raise Union.Never "arg mismatch"
+ fun to f = toPascalfunction [ctype1, ctype2, ctype3, ctype4] ctyper (convF f)
+diff -u -r mlsource/extra/CInterface/Struct/STRUCT.ML mlsource/extra/CInterface/Struct/STRUCT.ML
+--- mlsource/extra/CInterface/Struct/STRUCT.ML 2005-09-17 18:40:17.000000000 +0200
++++ mlsource/extra/CInterface/Struct/STRUCT.ML 2009-09-15 08:56:47.000000000 +0200
+@@ -32,7 +32,7 @@
+ open Ctype
+
+ local
+-fun offsets acc [] = []
++fun offsets _ [] = []
+ | offsets acc (t::ts) = let val pos = align acc t
+ in pos :: offsets (pos + sizeof t) ts
+ end
+Only in mlsource/extra/CInterface: VOLS_THAT_HOLD_REFS.530.ML
+diff -u -r mlsource/extra/CInterface/VOLS_THAT_HOLD_REFS.ML mlsource/extra/CInterface/VOLS_THAT_HOLD_REFS.ML
+--- mlsource/extra/CInterface/VOLS_THAT_HOLD_REFS.ML 2005-09-17 18:40:17.000000000 +0200
++++ mlsource/extra/CInterface/VOLS_THAT_HOLD_REFS.ML 2009-09-15 08:56:47.000000000 +0200
+@@ -296,4 +296,6 @@
+ end
+
+
++fun setFinal f v = Underlying.setFinal (thevol f) (thevol v)
++
+ end (* struct *)
+Only in mlsource/extra/CInterface/Volatile: Volatile.530.ML
+diff -u -r mlsource/extra/CInterface/VolatileSig.ML mlsource/extra/CInterface/VolatileSig.ML
+--- mlsource/extra/CInterface/VolatileSig.ML 2005-09-17 18:40:17.000000000 +0200
++++ mlsource/extra/CInterface/VolatileSig.ML 2009-09-15 08:56:47.000000000 +0200
+@@ -66,4 +66,6 @@
+
+ val toCfunction : Ctype.Ctype list -> Ctype.Ctype -> (vol list -> vol) -> vol
+ val toPascalfunction : Ctype.Ctype list -> Ctype.Ctype -> (vol list -> vol) -> vol
++
++ val setFinal : vol -> vol -> unit
+ end;
+diff -u -r mlsource/extra/Win/Base.sml mlsource/extra/Win/Base.sml
+--- mlsource/extra/Win/Base.sml 2007-09-27 17:24:16.000000000 +0200
++++ mlsource/extra/Win/Base.sml 2009-09-15 08:56:47.000000000 +0200
+@@ -21,7 +21,9 @@
+ structure Base =
+ struct
+ local
+-open CInterface
++ open CInterface
++ val System_isShort : vol -> bool =
++ RunCall.run_call1 RuntimeCalls.POLY_SYS_is_short
+ in
+
+ fun absConversion {abs,rep} C =
+@@ -303,7 +305,7 @@
+ let
+ val v' = fromCint v
+ in
+- if Address.isShort v then ClassAtom v' else NamedClass(fromCstring v)
++ if System_isShort v then ClassAtom v' else NamedClass(fromCstring v)
+ end
+ in
+ val CLASS = mkConversion vol2Class class2Vol voidStar
+@@ -371,7 +373,7 @@
+ let
+ val v' = fromCint v
+ in
+- if Address.isShort v then IdAsInt v' else IdAsString(fromCstring v)
++ if System_isShort v then IdAsInt v' else IdAsString(fromCstring v)
+ end
+ in
+ val RESID = mkConversion vol2Resid resid2Vol voidStar;
+diff -u -r mlsource/extra/Win/Color.sml mlsource/extra/Win/Color.sml
+--- mlsource/extra/Win/Color.sml 2005-09-17 18:40:19.000000000 +0200
++++ mlsource/extra/Win/Color.sml 2009-09-15 08:56:47.000000000 +0200
+@@ -191,14 +191,15 @@
+ (* Install a pretty printer for COLORREF. *)
+ local
+ open Color
+- fun printColorRef (put, beg, brk, nd) _ _ x =
++ fun printColorRef _ _ x =
+ let
+ val {red, green, blue} = toRGB x
+ in
+- put(concat["RGB{red=", Int.toString red,
++ PolyML.PrettyString
++ (concat["RGB{red=", Int.toString red,
+ ",green=", Int.toString green,
+- ",blue=", Int.toString blue, "}"])
++ ",blue=", Int.toString blue, "}"], [])
+ end
+ in
+- val _ = PolyML.install_pp printColorRef
++ val _ = PolyML.addPrettyPrinter printColorRef
+ end;
+diff -u -r mlsource/extra/Win/Examples/mlEdit.sml mlsource/extra/Win/Examples/mlEdit.sml
+--- mlsource/extra/Win/Examples/mlEdit.sml 2007-09-27 17:40:26.000000000 +0200
++++ mlsource/extra/Win/Examples/mlEdit.sml 2009-09-15 08:56:47.000000000 +0200
+@@ -1,628 +1,628 @@
+ (*
+- Copyright (c) 2001-7
+- David C.J. Matthews
++ Copyright (c) 2001-7
++ David C.J. Matthews
+
+- This library is free software; you can redistribute it and/or
+- modify it under the terms of the GNU Lesser General Public
+- License as published by the Free Software Foundation; either
+- version 2.1 of the License, or (at your option) any later version.
+-
+- This library is distributed in the hope that it will be useful,
+- but WITHOUT ANY WARRANTY; without even the implied warranty of
+- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+- Lesser General Public License for more details.
+-
+- You should have received a copy of the GNU Lesser General Public
+- License along with this library; if not, write to the Free Software
+- Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
++ This library is free software; you can redistribute it and/or
++ modify it under the terms of the GNU Lesser General Public
++ License as published by the Free Software Foundation; either
++ version 2.1 of the License, or (at your option) any later version.
++
++ This library is distributed in the hope that it will be useful,
++ but WITHOUT ANY WARRANTY; without even the implied warranty of
++ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
++ Lesser General Public License for more details.
++
++ You should have received a copy of the GNU Lesser General Public
++ License along with this library; if not, write to the Free Software
++ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+ *)
+ (* Example text editor. *)
+ fun mlEdit () =
+ let
+- open Window Message Menu Edit Class Dialog CommonDialog MessageBox Caret
+- open DeviceContext Font Printing Transform Painting Color
+- open Keyboard
+-
+- (* Define values to be delivered when the menu items are selected.
+- The Id is delivered as part of a WM_COMMAND message. *)
+- val menuOpen = 1
+- and menuQuit = 2
+- and menuSave = 3
+- and menuSaveAs = 4
+- and menuCut = 5
+- and menuCopy = 6
+- and menuPaste = 7
+- and menuFind = 8
+- and menuPageSetup = 9
+- and menuPrint = 10
+- and menuAbout = 11
+-
+- val app = Globals.ApplicationInstance()
+-
+- (* Borrow the Poly icon from the application program. It happens to
+- be icon id 102. If this doesn't work return NULL. *)
+- val polyIcon =
+- Icon.LoadIcon(app, Resource.MAKEINTRESOURCE 102) handle _ => Globals.hNull;
+-
+- local
+- (* Create sub-menus. *)
+- val fileMenu =
+- let
+- val fileMenu = CreateMenu();
+- in
+- AppendMenu(fileMenu, [], MenuId menuOpen, MFT_STRING "&Open");
+- AppendMenu(fileMenu, [], MenuId menuSave, MFT_STRING "&Save");
+- AppendMenu(fileMenu, [], MenuId menuSaveAs, MFT_STRING "Save &As...");
+- AppendMenu(fileMenu, [], MenuId 0, MFT_SEPARATOR);
+- AppendMenu(fileMenu, [], MenuId menuPageSetup, MFT_STRING "Page Set&up...");
+- AppendMenu(fileMenu, [], MenuId menuPrint, MFT_STRING "P&rint...");
+- AppendMenu(fileMenu, [], MenuId 0, MFT_SEPARATOR);
+- AppendMenu(fileMenu, [], MenuId menuQuit, MFT_STRING "&Quit");
+- fileMenu
+- end;
+-
+- val editMenu =
+- let
+- val editMenu = CreateMenu();
+- in
+- AppendMenu(editMenu, [], MenuId menuCut, MFT_STRING "Cu&t");
+- AppendMenu(editMenu, [], MenuId menuCopy, MFT_STRING "&Copy");
+- AppendMenu(editMenu, [], MenuId menuPaste, MFT_STRING "&Paste");
+- AppendMenu(editMenu, [], MenuId menuFind, MFT_STRING "&Find");
+- editMenu
+- end;
+-
+- val helpMenu =
+- let
+- val helpMenu = CreateMenu()
+- in
+- AppendMenu(helpMenu, [], MenuId menuAbout, MFT_STRING "&About mlEdit...");
+- helpMenu
+- end
+-
+- in
+- (* Create the main menu and append the sub-menus. *)
+- val menu = CreateMenu();
+- val _ = AppendMenu(menu, [], MenuHandle fileMenu, MFT_STRING "&File");
+- val _ = AppendMenu(menu, [], MenuHandle editMenu, MFT_STRING "&Edit")
+- val _ = AppendMenu(menu, [], MenuHandle helpMenu, MFT_STRING "&Help")
+- end;
+-
+- (* The "state" of the editor. *)
+- type state = {
+- edit: HWND, (* Handle to the edit window. *)
+- devMode: DEVMODE option, devNames: DEVNAMES option, (* Printer settings *)
+- fileName: string
+- }
+-
+- fun wndProc(hw: HWND, msg: Message, NONE): LRESULT * state option =
+- (
+- case msg of
+- WM_CREATE _ => (* Create an edit window and return it as the state. *)
+- let
+- val edit =
+- CreateWindow{class = Class.Edit, name = "",
+- (* The style does not include horizontal scrolling. That causes us to use word-wrapping. *)
+- style = Edit.Style.flags[Edit.Style.WS_CHILD, Edit.Style.WS_VISIBLE, Edit.Style.WS_VSCROLL,
+- (*Edit.Style.WS_HSCROLL, *)Edit.Style.ES_LEFT, Edit.Style.ES_MULTILINE,
+- Edit.Style.ES_AUTOVSCROLL(*, Edit.Style.ES_AUTOHSCROLL*)],
+- x = 0, y = 0, height = 0, width = 0, relation = ChildWindow{parent=hw, id=99},
+- instance = Globals.ApplicationInstance(), init = ()}
+-
+- (* Create a 10 point Courier font. *)
+- val hDC = GetDC edit;
+- val height = ~10 * GetDeviceCaps(hDC, LOGPIXELSY) div 72;
+- val _ = ReleaseDC(edit, hDC);
+- val hFont = CreateFont{height=height, width=0, escapement=0, orientation=0,
+- weight=FW_DONTCARE, italic=false, underline=false, strikeOut=false,
+- charSet=ANSI_CHARSET, outputPrecision=OUT_DEFAULT_PRECIS,
+- clipPrecision=CLIP_DEFAULT_PRECIS, quality=DEFAULT_QUALITY,
+- pitch=FIXED_PITCH, family=FF_MODERN, faceName="Courier"}
+- in
+- SendMessage(edit, WM_SETFONT{font=hFont, redrawflag=false});
+- (LRESINT 0, SOME{edit=edit, devMode=NONE, devNames = NONE, fileName=""})
+- end
+-
+- | _ => (DefWindowProc(hw, msg), NONE)
+- )
+-
+- | wndProc(hw: HWND,
+- msg: Message,
+- state: state option as SOME{edit, devMode, devNames, fileName, ...}) =
+- case msg of
+- WM_SETFOCUS _ =>
+- (* If we get a focus request we set the focus to the edit window. *)
+- (SetFocus(SOME edit); (DefWindowProc(hw, msg), state))
+-
+- | WM_SIZE{height, width, ...} =>
+- (* If we get a size change we set the size of the edit window. *)
+- (MoveWindow{hWnd=edit, x=0, y=0, height=height, width=width, repaint=true}; (DefWindowProc(hw, msg), state))
+-
+- | WM_NCDESTROY =>
+- (* When the window is closed we send a QUIT message which exits from the application loop. *)
+- (PostQuitMessage 0; (DefWindowProc(hw, msg), state))
+-
+- | WM_CLOSE =>
+- (* User has pressed the Close box. If it's ok to close we could call
+- DestroyWindow ourselves. Just as an example we return NONE which
+- passes it to the default window procedure and does it for us. *)
+- (if checkForSave(hw, edit, fileName) then DefWindowProc(hw, msg) else LRESINT 0, state)
+-
+- | WM_COMMAND{notifyCode = 0, wId, control} =>
+- (* Menu selections arrive here. *)
+-
+- if wId = menuQuit
+- then
+- (
+- if checkForSave(hw, edit, fileName) then DestroyWindow hw else ();
+- (LRESINT 0, state)
+- )
+-
+- else if wId = menuOpen
+- then
+- let
+- val on = {
+- owner = SOME hw,
+- template = TemplateDefault,
+- filter =
+- [("Text Files (*.txt)", "*.txt"),
+- ("ML Files (*.sml)", "*.sml"),
+- ("All Files (*.*)", "*.*")],
+- customFilter = NONE,
+- filterIndex = 1,
+- file = "",
+- maxFile = 1000,
+- fileTitle = "",
+- initialDir = NONE,
+- title = NONE,
+- flags = OpenFileFlags.flags[OpenFileFlags.OFN_HIDEREADONLY],
+- defExt = NONE
+- }
+- in
+- case GetOpenFileName on of
+- NONE => (LRESINT 0, state)
+- | SOME {file, ...} =>
+- (* If it's been modified we need to ask before overwriting. *)
+- if checkForSave(hw, edit, fileName)
+- then
+- (let
+- val f = TextIO.openIn file
+- (* Text input will convert CRNL to \n. We need to
+- reverse the process. *)
+- fun nlToCrnl s =
+- String.translate(fn #"\n" => "\r\n" | c => String.str c) s
+- in
+- (* Should we save any existing file? *)
+- SetWindowText(edit, nlToCrnl(TextIO.inputAll f));
+- TextIO.closeIn f;
+- SendMessage(edit, EM_SETMODIFY{modified=false});
+- (LRESINT 0, SOME{edit=edit, devMode=devMode, devNames=devNames,
+- fileName=file})
+- end) handle exn =>
+- (MessageBox(SOME hw,
+- concat["Unable to open - ", file, "\n"(*, exnMessage exn*)],
+- "Open failure", MessageBoxStyle.MB_OK);
+- (LRESINT 0, state))
+- else (LRESINT 0, state)
+- end
+-
+- else if wId = menuSave andalso fileName <> ""
+- then (* Save to the original file name if there is one. *)
+- (
+- saveDocument(hw, fileName, edit);
+- (LRESINT 0, state)
+- )
+-
+- else if wId = menuSaveAs orelse wId = menuSave (* andalso fileName = "" *)
+- then
+- (
+- case saveAsDocument(hw, edit) of
+- NONE => (LRESINT 0, state)
+- | SOME newName =>
+- (LRESINT 0, (* Use the selected file name. *)
+- SOME{edit=edit, devMode=devMode, devNames=devNames,
+- fileName=newName})
+- )
+-
+- else if wId = menuFind
+- then
+- let
+- open FindReplaceFlags
+- (* Create a "Find" dialogue. *)
+- val find =
+- FindText{owner = hw, template = TemplateDefault,
+- flags=flags[FR_DOWN, FR_HIDEWHOLEWORD],
+- findWhat="", replaceWith="", bufferSize = 100}
+- in
+- ShowWindow(find, SW_SHOW);
+- (LRESINT 0, state)
+- end
+-
+- (* Cut, Copy and Paste are all handled by the Edit window. *)
+- else if wId = menuCut
+- then (SendMessage(edit, WM_CUT); (LRESINT 0, state))
+- else if wId = menuCopy
+- then (SendMessage(edit, WM_COPY); (LRESINT 0, state))
+- else if wId = menuPaste
+- then (SendMessage(edit, WM_PASTE); (LRESINT 0, state))
+-
+- else if wId = menuPageSetup
+- then
+- (
+- (* Put up the dialogue and change the settings if necessary. *)
+- case PageSetupDlg {owner=SOME hw, devMode=devMode, devNames=devNames,
+- flags=PageSetupFlags.flags[], paperSize={x=0,y=0},
+- minMargin={top=0,bottom=0,left=0,right=0},
+- margin={top=0,bottom=0,left=0,right=0}} of
+- NONE => (LRESINT 0, state)
+- | SOME {devMode, devNames, ...} =>
+- (LRESINT 0, SOME{edit=edit, devMode=devMode, devNames=devNames,
+- fileName=fileName})
+- )
+-
+- else if wId = menuPrint (* "Print" menu item. *)
+- then
+- let
+- (* Put up the dialogue box to get the settings. *)
+- val printSettings =
+- PrintDlg {owner=SOME hw, devMode=devMode, devNames=devNames,
+- context=NONE,
+- flags=PrintDlgFlags.flags[PrintDlgFlags.PD_RETURNDC],
+- fromPage=1, toPage= ~1, minPage=1, maxPage= ~1, copies=1};
+- in
+- case printSettings of
+- SOME {devMode, devNames, context = SOME hdc, flags, fromPage, toPage, ...} =>
+- (let
+- (* If the "Selection" button has been pressed we only print the
+- selection. *)
+- val printWhat =
+- if PrintDlgFlags.anySet(flags, PrintDlgFlags.PD_SELECTION)
+- then
+- let
+- val from = ref 0 and to = ref 0
+- val _ = SendMessage(edit, EM_GETSEL{startPos = from, endPos = to})
+- val text = GetWindowText edit
+- in
+- if !from < 0 orelse !from > size text orelse
+- !to < 0 orelse !from > size text
+- then ""
+- else String.substring(text, !from, !to - !from)
+- end
+- else (* "All" button pressed or "Pages" pressed. *)
+- GetWindowText edit;
+- val textLength = size printWhat
+-
+- (* Tell the spooler to start the document. *)
+- val jobID = StartDoc(hdc, {docName=fileName, output=NONE, dType=NONE})
+-
+- (* Find out how big a character is. From this we can work out
+- how many characters fit on a line and how many lines on a
+- page. Since we're using a fixed width font this is fairly
+- easy. *)
+- val _ = SetMapMode(hdc, MM_TEXT)
+- val white = RGB{red=255, blue=255, green=255}
+- val black = RGB{red=0, blue=0, green = 0}
+- val pageWidth = GetDeviceCaps(hdc, HORZRES)
+- and pageHeight = GetDeviceCaps(hdc, VERTRES)
+-
+- (* Create the same font as we're using on the screen. Since this is
+- a fixed width font it makes calculating the number of characters
+- fairly easy. *)
+- val charHeight = ~10 * GetDeviceCaps(hdc, LOGPIXELSY) div 72;
+- val hFont = CreateFont{height=charHeight, width=0, escapement=0, orientation=0,
+- weight=FW_DONTCARE, italic=false, underline=false, strikeOut=false,
+- charSet=ANSI_CHARSET, outputPrecision=OUT_DEFAULT_PRECIS,
+- clipPrecision=CLIP_DEFAULT_PRECIS, quality=DEFAULT_QUALITY,
+- pitch=FIXED_PITCH, family=FF_MODERN, faceName="Courier"}
+- val oldFont = SelectObject(hdc, hFont); (* Use this font. *)
+-
+- val textMetric = GetTextMetrics hdc;
+-
+- fun printPage pno index =
+- let
+- (* If we are printing a range of pages we need to check whether
+- we are in the range. *)
+- val printThisPage =
+- if PrintDlgFlags.anySet(flags, PrintDlgFlags.PD_PAGENUMS)
+- then pno >= fromPage andalso (pno <= toPage orelse toPage < 0)
+- else true
+- val pageRect = {top=0, left=0, bottom=pageHeight, right=pageWidth}
+- (* Calculate the number of lines and columns. *)
+- val nLines = pageHeight div #height textMetric;
+- val nCols = pageWidth div #maxCharWidth textMetric
+-
+- (* Output the lines to fill the page. *)
+- fun outputLines lineNo p =
+- if lineNo >= nLines
+- then p (* Return last pointer. *)
+- else
+- let
+- (* Find the point to split the line. We stop at the end of
+- the text, a line break, the last word break on the line
+- or the maximum number of characters. *)
+- fun findEnd lastBreak i =
+- if i >= textLength then (textLength, textLength)
+- else if i-p > nCols
+- then
+- (
+- case lastBreak of
+- NONE => (* No breaks on the line - break just before here. *)
+- (i-1, i-1)
+- | SOME b => b (* Break at the last break. *)
+- )
+- else if i < textLength - 1 andalso
+- String.sub(printWhat, i) = #"\r" andalso
+- String.sub(printWhat, i+1) = #"\n"
+- then (* End of line - stop here. *)
+- (i, i+2)
+- else if Char.isSpace(String.sub(printWhat, i))
+- then (* Remember this. *)
+- findEnd (SOME(i, i+1)) (i+1)
+- (* Actually tabs need to be handled more carefully. *)
+- else findEnd lastBreak (i+1)
+-
+- val (endLine, nextLine) = findEnd NONE p
+- val thisLine =
+- if p >= textLength
+- then ""
+- else String.substring(printWhat, p, endLine-p)
+- in
+- if printThisPage
+- then
+- (
+- TabbedTextOut(hdc, {x=0, y= lineNo * #height textMetric},
+- thisLine, [], 0);
+- ()
+- )
+- else ();
+- outputLines (lineNo+1) nextLine
+- end
+- val nextPage =
+- if printThisPage
+- then
+- let
+- val _ = StartPage hdc;
+- (* Fill the page with white. *)
+- val _ = SetBkColor(hdc, white);
+- val _ = SetTextColor(hdc, black);
+- val _ = ExtTextOut(hdc, {x=0, y=0}, [ETO_OPAQUE], SOME pageRect, "", []);
+- (* Print the text. *)
+- val next = outputLines 0 index
+- in
+- EndPage hdc;
+- next
+- end
+- else (* Format the page but don't print it. *) outputLines 0 index
+- in
+- if nextPage >= size printWhat
+- then ()
+- else printPage (pno+1) nextPage
+- end
+-
+- val _: unit = printPage 1 0
+- in
+- EndDoc hdc;
+- (* Restore the original font and delete the new one. *)
+- SelectObject(hdc, oldFont);
+- DeleteObject(hFont);
+- DeleteDC hdc; (* Now delete the device context. *)
+- (LRESINT 0, SOME{edit=edit, devMode=devMode, devNames=devNames,
+- fileName=fileName})
+- end
+- (* If any of the functions failed simply delete the device
+- context and return the original state. *)
+- handle (exn as OS.SysErr _) => (
+- print (exnName exn); AbortDoc hdc; DeleteDC hdc; (LRESINT 0, state)))
+- | _ => (LRESINT 0, state)
+- end
+-
+- else if wId = menuAbout
+- then (aboutmlEdit hw; (LRESINT 0, state))
+-
+- else (DefWindowProc(hw, msg), state)
+-
+- | FINDMSGSTRING{flags, findWhat, ...} =>
+- if FindReplaceFlags.anySet(flags, FindReplaceFlags.FR_DIALOGTERM)
+- then (* The "find" box is going away. *)
+- (
+- SetFocus(SOME edit);
+- (LRESINT 0, state)
+- )
+- else if FindReplaceFlags.anySet(flags, FindReplaceFlags.FR_FINDNEXT)
+- then (* The Find Next button has been pressed. *)
+- let
+- (* Get the whole of the text - not very efficient. *)
+- val text = GetWindowText edit
+- val startPos = ref 0 and endPos = ref 0
+- (* Get the starting position. *)
+- val _ = SendMessage(edit, EM_GETSEL{startPos=startPos, endPos=endPos})
+-
+- val isDown = FindReplaceFlags.anySet(flags, FindReplaceFlags.FR_DOWN)
+- (* Get the starting position for the search. *)
+- val startPos = if isDown then !endPos else !startPos - 1
+-
+- val findLen = size findWhat
+- (* Get the options. *)
+- local
+- val toLower = String.map Char.toLower
+- in
+- val doMatch: string * string -> bool =
+- if FindReplaceFlags.anySet(flags, FindReplaceFlags.FR_MATCHCASE)
+- then op =
+- else fn (s1, s2) => toLower s1 = toLower s2
+- end
+-
+- fun doFind p =
+- let
+- val isMatch =
+- p >= 0 andalso size text - p >= size findWhat andalso
+- doMatch(String.substring(text, p, findLen), findWhat)
+- in
+- if isMatch then p
+- else if isDown
+- then if p = size text then p (* Finish *) else doFind(p+1)
+- else (* Find up *) if p = 0 then ~1 (* Finish *) else doFind(p-1)
+- end
+- val foundAt = doFind startPos
+- in
+- if foundAt >= 0 andalso foundAt + findLen < size text
+- then
+- (
+- SendMessage(edit, EM_SETSEL{startPos=foundAt, endPos=foundAt + findLen});
+- SendMessage(edit, EM_SCROLLCARET);
+- ()
+- )
+- else MessageBeep(MessageBoxStyle.fromWord 0wxFFFFFFFF);
+- (LRESINT 0, state)
+- end
+- else (DefWindowProc(hw, msg), state)
+-
+- | _ => (DefWindowProc(hw, msg), state)
+-
+- (* If this document has been modified we want to ask before quitting or
+- opening a new document. *)
+- and checkForSave(hw, edit, fileName) =
+- case SendMessage(edit, EM_GETMODIFY) of
+- LRESINT 0 => true (* Unmodified - continue. *)
+- | _ =>
+- let
+- val res =
+- MessageBox(SOME hw, "Save document?", "Confirm",
+- MessageBoxStyle.MB_YESNOCANCEL)
+- in
+- if res = IDYES
+- then if fileName = ""
+- then saveAsDocument(hw, edit) <> NONE
+- else saveDocument(hw, fileName, edit)
+- else if res = IDNO
+- then true (* Continue anyway. *)
+- else false (* Cancel - don't exit or open. *)
+- end
+-
+- and saveDocument(hw, fileName, edit) =
+- (* Write the document to the given file name. *)
+- let
+- (* Write the file as binary. That way we don't need to
+- convert CRNL to NL before writing. *)
+- val f = BinIO.openOut fileName
+- val s = GetWindowText edit
+- in
+- BinIO.output(f, Byte.stringToBytes s);
+- BinIO.closeOut f;
+- (* Document is now unmodified. *)
+- SendMessage(edit, EM_SETMODIFY{modified=false});
+- true (* Succeeded. *)
+- end handle exn =>
+- (MessageBox(SOME hw,
+- concat["Unable to save to - ", fileName, "\n"(*, exnMessage exn*)],
+- "Open failure", MessageBoxStyle.MB_OK);
+- false)
+-
+- and saveAsDocument(hw, edit) =
+- (* Ask for the file name before trying to save. *)
+- let
+- val on = {
+- owner = SOME hw,
+- template = TemplateDefault,
+- filter =
+- [("Text Files (*.txt)", "*.txt"),
+- ("ML Files (*.sml)", "*.sml"),
+- ("All Files (*.*)", "*.*")],
+- customFilter = NONE,
+- filterIndex = 1,
+- file = "",
+- maxFile = 1000,
+- fileTitle = "",
+- initialDir = NONE,
+- title = NONE,
+- flags = OpenFileFlags.flags[],
+- defExt = NONE
+- }
+- in
+- case GetSaveFileName on of
+- NONE => NONE
+- | SOME {file, filterIndex, fileTitle, ...} =>
+- let
+- (* If the user typed a file name without an extension use
+- the extension from the appropriate filter. *)
+- val suffix =
+- case filterIndex of
+- 1 => ".txt"
+- | 2 => ".sml"
+- | _ => ""
+- val fileName =
+- if Char.contains fileTitle #"."
+- then file else file ^ suffix
+- in
+- if saveDocument(hw, fileName, edit)
+- then SOME file (* Return the selected name. *)
+- else NONE
+- end
+- end
+-
+- and aboutmlEdit hw =
+- (* Called when the user selects "About..." from the help menu. *)
+- let
+- (* Dialogue template containing three items: an OK button, a static picture and
+- a piece of text. *)
+- val pictureId = 1000 (* Could use any number here. *)
+- open Static.Style
+- val template =
+- {x = 0, y = 0, cx = 210, cy = 94, font = SOME (8, "MS Sans Serif"), menu = NONE,
+- class = NONE,title = "About mlEdit", extendedStyle = 0,
+- style = flags[WS_POPUP, WS_CAPTION],
+- items =
+- [{x = 73, y = 62, cx = 50, cy = 14, id = 1,
+- class = DLG_BUTTON (flags[WS_CHILD, WS_VISIBLE, WS_TABSTOP]),
+- title = DLG_TITLESTRING "OK", creationData = NONE, extendedStyle = 0},
+- {x = 7, y = 7, cx = 32, cy = 32, id = pictureId,
+- class = DLG_STATIC (flags[WS_CHILD, WS_VISIBLE, SS_ICON]),
+- title = DLG_TITLESTRING "", creationData = NONE, extendedStyle = 0},
+- {x = 15, y = 39, cx = 180, cy = 21, id = 65535,
+- class = DLG_STATIC (flags[WS_CHILD, WS_VISIBLE, WS_GROUP]),
+- title =
+- DLG_TITLESTRING
+- "mlEdit - An example of Windows programming in Poly/ML\
+- \\nCopyright David C.J. Matthews 2001-7",
+- creationData = NONE, extendedStyle = 0}] }
+-
+- (* Dialogue procedure. *)
+- fun dlgProc(dial, WM_INITDIALOG _, ()) =
+- (
+- (* Send a message to the picture control to set it to this icon. *)
+- SendMessage(GetDlgItem(dial, pictureId), STM_SETICON{icon=polyIcon});
+- (LRESINT 1, ())
+- )
+-
+- | dlgProc(dial, WM_COMMAND{notifyCode = 0, wId=1 (* OK button *), ...}, ()) =
+- (* When the OK button is pressed we end the dialogue. *)
+- (EndDialog(dial, 1); (LRESINT 1, ()) )
+-
+- | dlgProc _ = (LRESINT 0, ())
+-
+- in
+- DialogBoxIndirect(app, template, hw, dlgProc, ());
+- ()
+- end
+-
+- val className = "mlEditWindowClass"
+- (* Register a class for the top-level window. Use the Poly icon from the application. *)
+- val myWindowClass = RegisterClassEx{style = Class.Style.flags[],
+- wndProc = wndProc, hInstance = app,
+- hIcon = SOME polyIcon, hCursor = NONE, hbrBackGround = NONE, menuName = NONE,
+- className = className, hIconSm = NONE};
+-
+-
+- val w = CreateWindow{class = myWindowClass, name = "mlEdit", style = Window.Style.WS_OVERLAPPEDWINDOW,
+- x = CW_USEDEFAULT, y = CW_USEDEFAULT, height = CW_USEDEFAULT, width = CW_USEDEFAULT,
+- relation = PopupWindow menu,
+- instance = app, init = NONE};
++ open Window Message Menu Edit Class Dialog CommonDialog MessageBox Caret
++ open DeviceContext Font Printing Transform Painting Color
++ open Keyboard
++
++ (* Define values to be delivered when the menu items are selected.
++ The Id is delivered as part of a WM_COMMAND message. *)
++ val menuOpen = 1
++ and menuQuit = 2
++ and menuSave = 3
++ and menuSaveAs = 4
++ and menuCut = 5
++ and menuCopy = 6
++ and menuPaste = 7
++ and menuFind = 8
++ and menuPageSetup = 9
++ and menuPrint = 10
++ and menuAbout = 11
++
++ val app = Globals.ApplicationInstance()
++
++ (* Borrow the Poly icon from the application program. It happens to
++ be icon id 102. If this doesn't work return NULL. *)
++ val polyIcon =
++ Icon.LoadIcon(app, Resource.MAKEINTRESOURCE 102) handle _ => Globals.hNull;
++
++ local
++ (* Create sub-menus. *)
++ val fileMenu =
++ let
++ val fileMenu = CreateMenu();
++ in
++ AppendMenu(fileMenu, [], MenuId menuOpen, MFT_STRING "&Open");
++ AppendMenu(fileMenu, [], MenuId menuSave, MFT_STRING "&Save");
++ AppendMenu(fileMenu, [], MenuId menuSaveAs, MFT_STRING "Save &As...");
++ AppendMenu(fileMenu, [], MenuId 0, MFT_SEPARATOR);
++ AppendMenu(fileMenu, [], MenuId menuPageSetup, MFT_STRING "Page Set&up...");
++ AppendMenu(fileMenu, [], MenuId menuPrint, MFT_STRING "P&rint...");
++ AppendMenu(fileMenu, [], MenuId 0, MFT_SEPARATOR);
++ AppendMenu(fileMenu, [], MenuId menuQuit, MFT_STRING "&Quit");
++ fileMenu
++ end;
++
++ val editMenu =
++ let
++ val editMenu = CreateMenu();
++ in
++ AppendMenu(editMenu, [], MenuId menuCut, MFT_STRING "Cu&t");
++ AppendMenu(editMenu, [], MenuId menuCopy, MFT_STRING "&Copy");
++ AppendMenu(editMenu, [], MenuId menuPaste, MFT_STRING "&Paste");
++ AppendMenu(editMenu, [], MenuId menuFind, MFT_STRING "&Find");
++ editMenu
++ end;
++
++ val helpMenu =
++ let
++ val helpMenu = CreateMenu()
++ in
++ AppendMenu(helpMenu, [], MenuId menuAbout, MFT_STRING "&About mlEdit...");
++ helpMenu
++ end
++
++ in
++ (* Create the main menu and append the sub-menus. *)
++ val menu = CreateMenu();
++ val _ = AppendMenu(menu, [], MenuHandle fileMenu, MFT_STRING "&File");
++ val _ = AppendMenu(menu, [], MenuHandle editMenu, MFT_STRING "&Edit")
++ val _ = AppendMenu(menu, [], MenuHandle helpMenu, MFT_STRING "&Help")
++ end;
++
++ (* The "state" of the editor. *)
++ type state = {
++ edit: HWND, (* Handle to the edit window. *)
++ devMode: DEVMODE option, devNames: DEVNAMES option, (* Printer settings *)
++ fileName: string
++ }
++
++ fun wndProc(hw: HWND, msg: Message, NONE): LRESULT * state option =
++ (
++ case msg of
++ WM_CREATE _ => (* Create an edit window and return it as the state. *)
++ let
++ val edit =
++ CreateWindow{class = Class.Edit, name = "",
++ (* The style does not include horizontal scrolling. That causes us to use word-wrapping. *)
++ style = Edit.Style.flags[Edit.Style.WS_CHILD, Edit.Style.WS_VISIBLE, Edit.Style.WS_VSCROLL,
++ (*Edit.Style.WS_HSCROLL, *)Edit.Style.ES_LEFT, Edit.Style.ES_MULTILINE,
++ Edit.Style.ES_AUTOVSCROLL(*, Edit.Style.ES_AUTOHSCROLL*)],
++ x = 0, y = 0, height = 0, width = 0, relation = ChildWindow{parent=hw, id=99},
++ instance = Globals.ApplicationInstance(), init = ()}
++
++ (* Create a 10 point Courier font. *)
++ val hDC = GetDC edit;
++ val height = ~10 * GetDeviceCaps(hDC, LOGPIXELSY) div 72;
++ val _ = ReleaseDC(edit, hDC);
++ val hFont = CreateFont{height=height, width=0, escapement=0, orientation=0,
++ weight=FW_DONTCARE, italic=false, underline=false, strikeOut=false,
++ charSet=ANSI_CHARSET, outputPrecision=OUT_DEFAULT_PRECIS,
++ clipPrecision=CLIP_DEFAULT_PRECIS, quality=DEFAULT_QUALITY,
++ pitch=FIXED_PITCH, family=FF_MODERN, faceName="Courier"}
++ in
++ SendMessage(edit, WM_SETFONT{font=hFont, redrawflag=false});
++ (LRESINT 0, SOME{edit=edit, devMode=NONE, devNames = NONE, fileName=""})
++ end
++
++ | _ => (DefWindowProc(hw, msg), NONE)
++ )
++
++ | wndProc(hw: HWND,
++ msg: Message,
++ state: state option as SOME{edit, devMode, devNames, fileName, ...}) =
++ case msg of
++ WM_SETFOCUS _ =>
++ (* If we get a focus request we set the focus to the edit window. *)
++ (SetFocus(SOME edit); (DefWindowProc(hw, msg), state))
++
++ | WM_SIZE{height, width, ...} =>
++ (* If we get a size change we set the size of the edit window. *)
++ (MoveWindow{hWnd=edit, x=0, y=0, height=height, width=width, repaint=true}; (DefWindowProc(hw, msg), state))
++
++ | WM_NCDESTROY =>
++ (* When the window is closed we send a QUIT message which exits from the application loop. *)
++ (PostQuitMessage 0; (DefWindowProc(hw, msg), state))
++
++ | WM_CLOSE =>
++ (* User has pressed the Close box. If it's ok to close we could call
++ DestroyWindow ourselves. Just as an example we return NONE which
++ passes it to the default window procedure and does it for us. *)
++ (if checkForSave(hw, edit, fileName) then DefWindowProc(hw, msg) else LRESINT 0, state)
++
++ | WM_COMMAND{notifyCode = 0, wId, control} =>
++ (* Menu selections arrive here. *)
++
++ if wId = menuQuit
++ then
++ (
++ if checkForSave(hw, edit, fileName) then DestroyWindow hw else ();
++ (LRESINT 0, state)
++ )
++
++ else if wId = menuOpen
++ then
++ let
++ val on = {
++ owner = SOME hw,
++ template = TemplateDefault,
++ filter =
++ [("Text Files (*.txt)", "*.txt"),
++ ("ML Files (*.sml)", "*.sml"),
++ ("All Files (*.*)", "*.*")],
++ customFilter = NONE,
++ filterIndex = 1,
++ file = "",
++ maxFile = 1000,
++ fileTitle = "",
++ initialDir = NONE,
++ title = NONE,
++ flags = OpenFileFlags.flags[OpenFileFlags.OFN_HIDEREADONLY],
++ defExt = NONE
++ }
++ in
++ case GetOpenFileName on of
++ NONE => (LRESINT 0, state)
++ | SOME {file, ...} =>
++ (* If it's been modified we need to ask before overwriting. *)
++ if checkForSave(hw, edit, fileName)
++ then
++ (let
++ val f = TextIO.openIn file
++ (* Text input will convert CRNL to \n. We need to
++ reverse the process. *)
++ fun nlToCrnl s =
++ String.translate(fn #"\n" => "\r\n" | c => String.str c) s
++ in
++ (* Should we save any existing file? *)
++ SetWindowText(edit, nlToCrnl(TextIO.inputAll f));
++ TextIO.closeIn f;
++ SendMessage(edit, EM_SETMODIFY{modified=false});
++ (LRESINT 0, SOME{edit=edit, devMode=devMode, devNames=devNames,
++ fileName=file})
++ end) handle exn =>
++ (MessageBox(SOME hw,
++ concat["Unable to open - ", file, "\n"(*, exnMessage exn*)],
++ "Open failure", MessageBoxStyle.MB_OK);
++ (LRESINT 0, state))
++ else (LRESINT 0, state)
++ end
++
++ else if wId = menuSave andalso fileName <> ""
++ then (* Save to the original file name if there is one. *)
++ (
++ saveDocument(hw, fileName, edit);
++ (LRESINT 0, state)
++ )
++
++ else if wId = menuSaveAs orelse wId = menuSave (* andalso fileName = "" *)
++ then
++ (
++ case saveAsDocument(hw, edit) of
++ NONE => (LRESINT 0, state)
++ | SOME newName =>
++ (LRESINT 0, (* Use the selected file name. *)
++ SOME{edit=edit, devMode=devMode, devNames=devNames,
++ fileName=newName})
++ )
++
++ else if wId = menuFind
++ then
++ let
++ open FindReplaceFlags
++ (* Create a "Find" dialogue. *)
++ val find =
++ FindText{owner = hw, template = TemplateDefault,
++ flags=flags[FR_DOWN, FR_HIDEWHOLEWORD],
++ findWhat="", replaceWith="", bufferSize = 100}
++ in
++ ShowWindow(find, SW_SHOW);
++ (LRESINT 0, state)
++ end
++
++ (* Cut, Copy and Paste are all handled by the Edit window. *)
++ else if wId = menuCut
++ then (SendMessage(edit, WM_CUT); (LRESINT 0, state))
++ else if wId = menuCopy
++ then (SendMessage(edit, WM_COPY); (LRESINT 0, state))
++ else if wId = menuPaste
++ then (SendMessage(edit, WM_PASTE); (LRESINT 0, state))
++
++ else if wId = menuPageSetup
++ then
++ (
++ (* Put up the dialogue and change the settings if necessary. *)
++ case PageSetupDlg {owner=SOME hw, devMode=devMode, devNames=devNames,
++ flags=PageSetupFlags.flags[], paperSize={x=0,y=0},
++ minMargin={top=0,bottom=0,left=0,right=0},
++ margin={top=0,bottom=0,left=0,right=0}} of
++ NONE => (LRESINT 0, state)
++ | SOME {devMode, devNames, ...} =>
++ (LRESINT 0, SOME{edit=edit, devMode=devMode, devNames=devNames,
++ fileName=fileName})
++ )
++
++ else if wId = menuPrint (* "Print" menu item. *)
++ then
++ let
++ (* Put up the dialogue box to get the settings. *)
++ val printSettings =
++ PrintDlg {owner=SOME hw, devMode=devMode, devNames=devNames,
++ context=NONE,
++ flags=PrintDlgFlags.flags[PrintDlgFlags.PD_RETURNDC],
++ fromPage=1, toPage= ~1, minPage=1, maxPage= ~1, copies=1};
++ in
++ case printSettings of
++ SOME {devMode, devNames, context = SOME hdc, flags, fromPage, toPage, ...} =>
++ (let
++ (* If the "Selection" button has been pressed we only print the
++ selection. *)
++ val printWhat =
++ if PrintDlgFlags.anySet(flags, PrintDlgFlags.PD_SELECTION)
++ then
++ let
++ val from = ref 0 and to = ref 0
++ val _ = SendMessage(edit, EM_GETSEL{startPos = from, endPos = to})
++ val text = GetWindowText edit
++ in
++ if !from < 0 orelse !from > size text orelse
++ !to < 0 orelse !from > size text
++ then ""
++ else String.substring(text, !from, !to - !from)
++ end
++ else (* "All" button pressed or "Pages" pressed. *)
++ GetWindowText edit;
++ val textLength = size printWhat
++
++ (* Tell the spooler to start the document. *)
++ val jobID = StartDoc(hdc, {docName=fileName, output=NONE, dType=NONE})
++
++ (* Find out how big a character is. From this we can work out
++ how many characters fit on a line and how many lines on a
++ page. Since we're using a fixed width font this is fairly
++ easy. *)
++ val _ = SetMapMode(hdc, MM_TEXT)
++ val white = RGB{red=255, blue=255, green=255}
++ val black = RGB{red=0, blue=0, green = 0}
++ val pageWidth = GetDeviceCaps(hdc, HORZRES)
++ and pageHeight = GetDeviceCaps(hdc, VERTRES)
++
++ (* Create the same font as we're using on the screen. Since this is
++ a fixed width font it makes calculating the number of characters
++ fairly easy. *)
++ val charHeight = ~10 * GetDeviceCaps(hdc, LOGPIXELSY) div 72;
++ val hFont = CreateFont{height=charHeight, width=0, escapement=0, orientation=0,
++ weight=FW_DONTCARE, italic=false, underline=false, strikeOut=false,
++ charSet=ANSI_CHARSET, outputPrecision=OUT_DEFAULT_PRECIS,
++ clipPrecision=CLIP_DEFAULT_PRECIS, quality=DEFAULT_QUALITY,
++ pitch=FIXED_PITCH, family=FF_MODERN, faceName="Courier"}
++ val oldFont = SelectObject(hdc, hFont); (* Use this font. *)
++
++ val textMetric = GetTextMetrics hdc;
++
++ fun printPage pno index =
++ let
++ (* If we are printing a range of pages we need to check whether
++ we are in the range. *)
++ val printThisPage =
++ if PrintDlgFlags.anySet(flags, PrintDlgFlags.PD_PAGENUMS)
++ then pno >= fromPage andalso (pno <= toPage orelse toPage < 0)
++ else true
++ val pageRect = {top=0, left=0, bottom=pageHeight, right=pageWidth}
++ (* Calculate the number of lines and columns. *)
++ val nLines = pageHeight div #height textMetric;
++ val nCols = pageWidth div #maxCharWidth textMetric
++
++ (* Output the lines to fill the page. *)
++ fun outputLines lineNo p =
++ if lineNo >= nLines
++ then p (* Return last pointer. *)
++ else
++ let
++ (* Find the point to split the line. We stop at the end of
++ the text, a line break, the last word break on the line
++ or the maximum number of characters. *)
++ fun findEnd lastBreak i =
++ if i >= textLength then (textLength, textLength)
++ else if i-p > nCols
++ then
++ (
++ case lastBreak of
++ NONE => (* No breaks on the line - break just before here. *)
++ (i-1, i-1)
++ | SOME b => b (* Break at the last break. *)
++ )
++ else if i < textLength - 1 andalso
++ String.sub(printWhat, i) = #"\r" andalso
++ String.sub(printWhat, i+1) = #"\n"
++ then (* End of line - stop here. *)
++ (i, i+2)
++ else if Char.isSpace(String.sub(printWhat, i))
++ then (* Remember this. *)
++ findEnd (SOME(i, i+1)) (i+1)
++ (* Actually tabs need to be handled more carefully. *)
++ else findEnd lastBreak (i+1)
++
++ val (endLine, nextLine) = findEnd NONE p
++ val thisLine =
++ if p >= textLength
++ then ""
++ else String.substring(printWhat, p, endLine-p)
++ in
++ if printThisPage
++ then
++ (
++ TabbedTextOut(hdc, {x=0, y= lineNo * #height textMetric},
++ thisLine, [], 0);
++ ()
++ )
++ else ();
++ outputLines (lineNo+1) nextLine
++ end
++ val nextPage =
++ if printThisPage
++ then
++ let
++ val _ = StartPage hdc;
++ (* Fill the page with white. *)
++ val _ = SetBkColor(hdc, white);
++ val _ = SetTextColor(hdc, black);
++ val _ = ExtTextOut(hdc, {x=0, y=0}, [ETO_OPAQUE], SOME pageRect, "", []);
++ (* Print the text. *)
++ val next = outputLines 0 index
++ in
++ EndPage hdc;
++ next
++ end
++ else (* Format the page but don't print it. *) outputLines 0 index
++ in
++ if nextPage >= size printWhat
++ then ()
++ else printPage (pno+1) nextPage
++ end
++
++ val _: unit = printPage 1 0
++ in
++ EndDoc hdc;
++ (* Restore the original font and delete the new one. *)
++ SelectObject(hdc, oldFont);
++ DeleteObject(hFont);
++ DeleteDC hdc; (* Now delete the device context. *)
++ (LRESINT 0, SOME{edit=edit, devMode=devMode, devNames=devNames,
++ fileName=fileName})
++ end
++ (* If any of the functions failed simply delete the device
++ context and return the original state. *)
++ handle (exn as OS.SysErr _) => (
++ print (exnName exn); AbortDoc hdc; DeleteDC hdc; (LRESINT 0, state)))
++ | _ => (LRESINT 0, state)
++ end
++
++ else if wId = menuAbout
++ then (aboutmlEdit hw; (LRESINT 0, state))
++
++ else (DefWindowProc(hw, msg), state)
++
++ | FINDMSGSTRING{flags, findWhat, ...} =>
++ if FindReplaceFlags.anySet(flags, FindReplaceFlags.FR_DIALOGTERM)
++ then (* The "find" box is going away. *)
++ (
++ SetFocus(SOME edit);
++ (LRESINT 0, state)
++ )
++ else if FindReplaceFlags.anySet(flags, FindReplaceFlags.FR_FINDNEXT)
++ then (* The Find Next button has been pressed. *)
++ let
++ (* Get the whole of the text - not very efficient. *)
++ val text = GetWindowText edit
++ val startPos = ref 0 and endPos = ref 0
++ (* Get the starting position. *)
++ val _ = SendMessage(edit, EM_GETSEL{startPos=startPos, endPos=endPos})
++
++ val isDown = FindReplaceFlags.anySet(flags, FindReplaceFlags.FR_DOWN)
++ (* Get the starting position for the search. *)
++ val startPos = if isDown then !endPos else !startPos - 1
++
++ val findLen = size findWhat
++ (* Get the options. *)
++ local
++ val toLower = String.map Char.toLower
++ in
++ val doMatch: string * string -> bool =
++ if FindReplaceFlags.anySet(flags, FindReplaceFlags.FR_MATCHCASE)
++ then op =
++ else fn (s1, s2) => toLower s1 = toLower s2
++ end
++
++ fun doFind p =
++ let
++ val isMatch =
++ p >= 0 andalso size text - p >= size findWhat andalso
++ doMatch(String.substring(text, p, findLen), findWhat)
++ in
++ if isMatch then p
++ else if isDown
++ then if p = size text then p (* Finish *) else doFind(p+1)
++ else (* Find up *) if p = 0 then ~1 (* Finish *) else doFind(p-1)
++ end
++ val foundAt = doFind startPos
++ in
++ if foundAt >= 0 andalso foundAt + findLen < size text
++ then
++ (
++ SendMessage(edit, EM_SETSEL{startPos=foundAt, endPos=foundAt + findLen});
++ SendMessage(edit, EM_SCROLLCARET);
++ ()
++ )
++ else MessageBeep(MessageBoxStyle.fromWord 0wxFFFFFFFF);
++ (LRESINT 0, state)
++ end
++ else (DefWindowProc(hw, msg), state)
++
++ | _ => (DefWindowProc(hw, msg), state)
++
++ (* If this document has been modified we want to ask before quitting or
++ opening a new document. *)
++ and checkForSave(hw, edit, fileName) =
++ case SendMessage(edit, EM_GETMODIFY) of
++ LRESINT 0 => true (* Unmodified - continue. *)
++ | _ =>
++ let
++ val res =
++ MessageBox(SOME hw, "Save document?", "Confirm",
++ MessageBoxStyle.MB_YESNOCANCEL)
++ in
++ if res = IDYES
++ then if fileName = ""
++ then saveAsDocument(hw, edit) <> NONE
++ else saveDocument(hw, fileName, edit)
++ else if res = IDNO
++ then true (* Continue anyway. *)
++ else false (* Cancel - don't exit or open. *)
++ end
++
++ and saveDocument(hw, fileName, edit) =
++ (* Write the document to the given file name. *)
++ let
++ (* Write the file as binary. That way we don't need to
++ convert CRNL to NL before writing. *)
++ val f = BinIO.openOut fileName
++ val s = GetWindowText edit
++ in
++ BinIO.output(f, Byte.stringToBytes s);
++ BinIO.closeOut f;
++ (* Document is now unmodified. *)
++ SendMessage(edit, EM_SETMODIFY{modified=false});
++ true (* Succeeded. *)
++ end handle exn =>
++ (MessageBox(SOME hw,
++ concat["Unable to save to - ", fileName, "\n"(*, exnMessage exn*)],
++ "Open failure", MessageBoxStyle.MB_OK);
++ false)
++
++ and saveAsDocument(hw, edit) =
++ (* Ask for the file name before trying to save. *)
++ let
++ val on = {
++ owner = SOME hw,
++ template = TemplateDefault,
++ filter =
++ [("Text Files (*.txt)", "*.txt"),
++ ("ML Files (*.sml)", "*.sml"),
++ ("All Files (*.*)", "*.*")],
++ customFilter = NONE,
++ filterIndex = 1,
++ file = "",
++ maxFile = 1000,
++ fileTitle = "",
++ initialDir = NONE,
++ title = NONE,
++ flags = OpenFileFlags.flags[],
++ defExt = NONE
++ }
++ in
++ case GetSaveFileName on of
++ NONE => NONE
++ | SOME {file, filterIndex, fileTitle, ...} =>
++ let
++ (* If the user typed a file name without an extension use
++ the extension from the appropriate filter. *)
++ val suffix =
++ case filterIndex of
++ 1 => ".txt"
++ | 2 => ".sml"
++ | _ => ""
++ val fileName =
++ if Char.contains fileTitle #"."
++ then file else file ^ suffix
++ in
++ if saveDocument(hw, fileName, edit)
++ then SOME file (* Return the selected name. *)
++ else NONE
++ end
++ end
++
++ and aboutmlEdit hw =
++ (* Called when the user selects "About..." from the help menu. *)
++ let
++ (* Dialogue template containing three items: an OK button, a static picture and
++ a piece of text. *)
++ val pictureId = 1000 (* Could use any number here. *)
++ open Static.Style
++ val template =
++ {x = 0, y = 0, cx = 210, cy = 94, font = SOME (8, "MS Sans Serif"), menu = NONE,
++ class = NONE,title = "About mlEdit", extendedStyle = 0,
++ style = flags[WS_POPUP, WS_CAPTION],
++ items =
++ [{x = 73, y = 62, cx = 50, cy = 14, id = 1,
++ class = DLG_BUTTON (flags[WS_CHILD, WS_VISIBLE, WS_TABSTOP]),
++ title = DLG_TITLESTRING "OK", creationData = NONE, extendedStyle = 0},
++ {x = 7, y = 7, cx = 32, cy = 32, id = pictureId,
++ class = DLG_STATIC (flags[WS_CHILD, WS_VISIBLE, SS_ICON]),
++ title = DLG_TITLESTRING "", creationData = NONE, extendedStyle = 0},
++ {x = 15, y = 39, cx = 180, cy = 21, id = 65535,
++ class = DLG_STATIC (flags[WS_CHILD, WS_VISIBLE, WS_GROUP]),
++ title =
++ DLG_TITLESTRING
++ "mlEdit - An example of Windows programming in Poly/ML\
++ \\nCopyright David C.J. Matthews 2001-7",
++ creationData = NONE, extendedStyle = 0}] }
++
++ (* Dialogue procedure. *)
++ fun dlgProc(dial, WM_INITDIALOG _, ()) =
++ (
++ (* Send a message to the picture control to set it to this icon. *)
++ SendMessage(GetDlgItem(dial, pictureId), STM_SETICON{icon=polyIcon});
++ (LRESINT 1, ())
++ )
++
++ | dlgProc(dial, WM_COMMAND{notifyCode = 0, wId=1 (* OK button *), ...}, ()) =
++ (* When the OK button is pressed we end the dialogue. *)
++ (EndDialog(dial, 1); (LRESINT 1, ()) )
++
++ | dlgProc _ = (LRESINT 0, ())
++
++ in
++ DialogBoxIndirect(app, template, hw, dlgProc, ());
++ ()
++ end
++
++ val className = "mlEditWindowClass"
++ (* Register a class for the top-level window. Use the Poly icon from the application. *)
++ val myWindowClass = RegisterClassEx{style = Class.Style.flags[],
++ wndProc = wndProc, hInstance = app,
++ hIcon = SOME polyIcon, hCursor = NONE, hbrBackGround = NONE, menuName = NONE,
++ className = className, hIconSm = NONE};
++
++
++ val w = CreateWindow{class = myWindowClass, name = "mlEdit", style = Window.Style.WS_OVERLAPPEDWINDOW,
++ x = CW_USEDEFAULT, y = CW_USEDEFAULT, height = CW_USEDEFAULT, width = CW_USEDEFAULT,
++ relation = PopupWindow menu,
++ instance = app, init = NONE};
+ in
+- ShowWindow(w, SW_SHOW);
+- SetForegroundWindow w;
+-
+- RunApplication();
+- (* Must unregister the class before returning otherwise RegisterClass will
+- fail if we call mlEdit again. *)
+- UnregisterClass(className, app)
++ ShowWindow(w, SW_SHOW);
++ SetForegroundWindow w;
++
++ RunApplication();
++ (* Must unregister the class before returning otherwise RegisterClass will
++ fail if we call mlEdit again. *)
++ UnregisterClass(className, app)
+ end;
+diff -u -r mlsource/extra/Win/FlagPrint.sml mlsource/extra/Win/FlagPrint.sml
+--- mlsource/extra/Win/FlagPrint.sml 2005-09-17 18:40:20.000000000 +0200
++++ mlsource/extra/Win/FlagPrint.sml 2009-09-15 08:56:47.000000000 +0200
+@@ -28,24 +28,26 @@
+ if BITS.allSet(w, f) then s :: accumulateFlags(BITS.clear(w, f)) t
+ else accumulateFlags f t
+
+- fun printFlags(put, beg, brk, nd) depth _ x =
++ fun printFlags depth _ x =
+ (* This is just the code to print a list. *)
+ let
++ open PolyML
+ val stringFlags = accumulateFlags x flagTable
+- fun plist [] depth = ()
+- | plist _ 0 = put "..."
+- | plist [h] depth = put h
+- | plist (h::t) depth =
+- ( put (h^",");
+- brk (1, 0);
+- plist t (depth - 1)
+- )
++ fun plist [] depth = []
++ | plist _ 0 = [PrettyString("...", [])]
++ | plist [h] depth = [PrettyString(h, [])]
++ | plist (h::t) depth =
++ PrettyString(h ^ ",", []) ::
++ PrettyBreak (1, 0) ::
++ plist t (depth - 1)
+ in
+- beg (3, false);
+- put "[";
+- if depth <= 0 then put "..." else plist stringFlags depth;
+- put "]";
+- nd ()
++ PrettyBlock (3, false,
++ PrettyString("[", []) ::
++ ((if depth <= 0 then [PrettyString("...", [])]
++ else plist stringFlags depth) @
++ [PrettyString("]", [])]
++ )
++ )
+ end
+ in
+ printFlags
+diff -u -r mlsource/extra/Win/Window.sml mlsource/extra/Win/Window.sml
+--- mlsource/extra/Win/Window.sml 2007-09-27 17:39:46.000000000 +0200
++++ mlsource/extra/Win/Window.sml 2009-09-15 08:56:47.000000000 +0200
+@@ -555,5 +555,5 @@
+
+ structure FlagP = FlagPrint(structure BITS = Window.Style)
+ in
+- val _ = PolyML.install_pp (FlagP.createFlagPrinter flagTable)
++ val _ = PolyML.addPrettyPrinter (FlagP.createFlagPrinter flagTable)
+ end;
+diff -u -r mlsource/extra/XWindows/XCall.ML mlsource/extra/XWindows/XCall.ML
+--- mlsource/extra/XWindows/XCall.ML 2008-04-21 15:43:54.000000000 +0200
++++ mlsource/extra/XWindows/XCall.ML 2009-09-15 08:56:47.000000000 +0200
+@@ -19,17 +19,7 @@
+
+ structure XCall =
+ struct
+- local
+- structure Type =
+- struct
+- type ex_type = string;
+- val ex_iden = 10;
+- end;
+-
+- structure E: sig exception ex of string end = RunCall.Run_exception1(Type);
+- in
+- exception XWindows = E.ex;
+- end;
++ exception XWindows = PolyML.XWindows;
+
+ fun xcall n = RunCall.run_call1 RuntimeCalls.POLY_SYS_XWindows n
+
+diff -u -r mlsource/extra/XWindows/ml_bind.ML mlsource/extra/XWindows/ml_bind.ML
+--- mlsource/extra/XWindows/ml_bind.ML 2008-03-28 11:53:27.000000000 +0100
++++ mlsource/extra/XWindows/ml_bind.ML 2009-09-15 08:56:47.000000000 +0200
+@@ -2440,12 +2440,12 @@
+ let
+ open XWindows;
+
+- fun printRect ( addString,beginBracket,space,endBracket ) _ _ (r:XRectangle) =
++ fun printRect _ _ (r:XRectangle) =
+ let
+ val R = DestructRect r;
+ in
+- addString ("Rect " ^ PolyML.makestring R)
++ PolyML.PrettyString ("Rect " ^ PolyML.makestring R)
+ end;
+ in
+- PolyML.install_pp printRect
++ PolyML.addPrettyPrinter printRect
+ end;
+diff -u -r poly.1 poly.1
+--- poly.1 2007-11-20 20:34:24.000000000 +0100
++++ poly.1 2009-09-15 08:56:48.000000000 +0200
+@@ -1,4 +1,4 @@
+-.TH POLY 1 "Poly/ML Version 5.1 2007"
++.TH POLY 1 "Poly/ML Version 5.3 2009"
+ .SH NAME
+ poly \- the Poly/ML Standard ML implementation
+ .SH SYNOPSIS
+@@ -38,5 +38,5 @@
+ .fi
+ .SH SEE ALSO
+ .PP
+-.B http://www.poly.org
++.B http://www.polyml.org
+ The Poly/ML web site.
+diff -u -r polyimport.1 polyimport.1
+--- polyimport.1 2007-11-20 20:34:24.000000000 +0100
++++ polyimport.1 2009-09-15 08:56:48.000000000 +0200
+@@ -1,4 +1,4 @@
+-.TH POLY 1 "Poly/ML Version 5.1 2007"
++.TH POLY 1 "Poly/ML Version 5.3 2009"
+ .SH NAME
+ polyimport \- the Poly/ML import program
+ .SH SYNOPSIS
+@@ -30,5 +30,5 @@
+ .fi
+ .SH SEE ALSO
+ .PP
+-.B http://www.poly.org
++.B http://www.polyml.org
+ The Poly/ML web site.
+Only in src/polyml/polyml: polyml.pyp
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://lists.macosforge.org/pipermail/macports-changes/attachments/20090915/a49480de/attachment-0001.html>
More information about the macports-changes
mailing list