[MLton] cvs commit: -show-basis
Stephen Weeks
sweeks@mlton.org
Mon, 9 Feb 2004 09:50:37 -0800
sweeks 04/02/09 09:50:37
Modified: doc changelog
mlton/elaborate elaborate-env.fun elaborate-env.sig
mlton/main compile.fun
Log:
MAIL -show-basis
Extended -show-basis so that when used with an input program, it shows
the basis defined by the input program.
Revision Changes Path
1.101 +4 -0 mlton/doc/changelog
Index: changelog
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/changelog,v
retrieving revision 1.100
retrieving revision 1.101
diff -u -r1.100 -r1.101
--- changelog 21 Jan 2004 07:30:29 -0000 1.100
+++ changelog 9 Feb 2004 17:50:37 -0000 1.101
@@ -1,5 +1,9 @@
Here are the changes since version 20030716.
+* 2004-02-09
+ - Extended -show-basis so that when used with an input program, it
+ shows the basis defined by the input program.
+
* 2004-01-20
- Fixed a bug in IEEEReal.{fromString,scan}, which would improperly
return INF instead of ZERO for things like "0.0000e123456789012345".
1.56 +18 -8 mlton/mlton/elaborate/elaborate-env.fun
Index: elaborate-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.fun,v
retrieving revision 1.55
retrieving revision 1.56
diff -u -r1.55 -r1.56
--- elaborate-env.fun 7 Feb 2004 03:09:23 -0000 1.55
+++ elaborate-env.fun 9 Feb 2004 17:50:37 -0000 1.56
@@ -691,7 +691,7 @@
List.foreach (!topSymbols, fn s => foreach (E, s, z))
end
-fun collect (E as T r, f: {isUsed: bool} -> bool) =
+fun collect (E as T r, f: {isUsed: bool, scope: Scope.t} -> bool) =
let
val fcts = ref []
val sigs = ref []
@@ -701,9 +701,9 @@
fun doit ac vs =
case Values.! vs of
[] => ()
- | {domain, isUsed, range, ...} :: _ =>
- if f {isUsed = !isUsed}
- then List.push (ac, (domain, range))
+ | {domain, isUsed, range, scope, ...} :: _ =>
+ if f {isUsed = !isUsed, scope = scope}
+ then List.push (ac, (domain, range))
else ()
val _ =
foreachDefinedSymbol (E, {fcts = doit fcts,
@@ -724,9 +724,9 @@
vals = finish (vals, Ast.Vid.toSymbol)}
end
-fun layout (E: t): Layout.t =
+fun layout' (E: t, f): Layout.t =
let
- val {fcts, sigs, strs, types, vals} = collect (E, fn _ => true)
+ val {fcts, sigs, strs, types, vals} = collect (E, f)
open Layout
fun doit (a, layout) = align (Array.toListMap (a, layout))
in
@@ -737,6 +737,15 @@
doit (strs, Structure.layoutStrSpec)]
end
+fun layout E = layout' (E, fn _ => true)
+
+fun layoutCurrentScope (E as T {currentScope, ...}) =
+ let
+ val s = !currentScope
+ in
+ layout' (E, fn {scope, ...} => Scope.equals (s, scope))
+ end
+
fun layoutUsed (E: t): Layout.t =
let
val {fcts, sigs, strs, types, vals} = collect (E, #isUsed)
@@ -1059,7 +1068,8 @@
in
b
end
- in (a, finish)
+ in
+ (a, finish)
end
fun localModule (E as T {currentScope, fixs, strs, types, vals, ...},
@@ -1109,7 +1119,7 @@
in
(res, S)
end
-
+
fun scope (T {currentScope, fixs, strs, types, vals, ...}, th) =
let
fun doit (NameSpace.T {current, ...}) =
1.25 +10 -1 mlton/mlton/elaborate/elaborate-env.sig
Index: elaborate-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.sig,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- elaborate-env.sig 6 Feb 2004 23:55:36 -0000 1.24
+++ elaborate-env.sig 9 Feb 2004 17:50:37 -0000 1.25
@@ -136,10 +136,19 @@
* (Structure.t * string list -> Decs.t * Structure.t option)
-> FunctorClosure.t
val layout: t -> Layout.t
+ val layoutCurrentScope: t -> Layout.t
val layoutUsed: t -> Layout.t
val localCore: t * (unit -> 'a) * ('a -> 'b) -> 'b
val localModule: t * (unit -> 'a) * ('a -> 'b) -> 'b
- val localTop: t * (unit -> 'a) -> ('a * ((unit -> 'b) -> 'b))
+ (* localTop (E, f) = (a, finish)
+ * evaluates f () in a new scope. finish g can then be called later to
+ * finish the local, evaluating g () within the scope and eventually
+ * leaving only the bindings introduced by g. Thus, the whole thing is
+ * very much like the following.
+ *
+ * local f () in g () end
+ *)
+ val localTop: t * (unit -> 'a) -> 'a * ((unit -> 'b) -> 'b)
val lookupFctid: t * Ast.Fctid.t -> FunctorClosure.t
val lookupLongcon: t * Ast.Longcon.t -> CoreML.Con.t * Scheme.t
val lookupLongstrid: t * Ast.Longstrid.t -> Structure.t option
1.22 +16 -13 mlton/mlton/main/compile.fun
Index: compile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.fun,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- compile.fun 7 Feb 2004 16:45:18 -0000 1.21
+++ compile.fun 9 Feb 2004 17:50:37 -0000 1.22
@@ -316,8 +316,8 @@
dir := SOME d
fun basisLibrary ()
: {build: Decs.t,
- localTopFinish: (unit -> Decs.t * Decs.t * Decs.t) ->
- Decs.t * Decs.t * Decs.t,
+ localTopFinish: ((unit -> Decs.t * Decs.t * Decs.t)
+ -> Decs.t * Decs.t * Decs.t),
libs: {name: string,
bind: Ast.Program.t,
prefix: Ast.Program.t,
@@ -443,19 +443,22 @@
parseAndElaborateFiles (input, basisEnv, lookupConstantError)
val _ =
if !Control.showBasisUsed
- then (Elaborate.Env.scopeAll (basisEnv, parseAndElab)
- ; Layout.outputl (Elaborate.Env.layoutUsed basisEnv,
- Out.standard)
- ; Process.succeed ())
+ then (Env.scopeAll (basisEnv, parseAndElab)
+ ; Layout.outputl (Env.layoutUsed basisEnv, Out.standard)
+ ; raise Done)
else ()
- val input = parseAndElab ()
- val _ = if !Control.elaborateOnly then raise Done else ()
val _ =
if !Control.showBasis
- then (Env.setTyconNames basisEnv
- ; Layout.outputl (Env.layout basisEnv, Out.standard)
- ; Process.succeed ())
+ then
+ Env.scopeAll
+ (basisEnv, fn () =>
+ (parseAndElab ()
+ ; Env.setTyconNames basisEnv
+ ; Layout.outputl (Env.layoutCurrentScope basisEnv, Out.standard)
+ ; raise Done))
else ()
+ val input = parseAndElab ()
+ val _ = if !Control.elaborateOnly then raise Done else ()
val _ =
if not (!Control.exportHeader)
then ()
@@ -468,7 +471,7 @@
val _ = print "\n"
val _ = Ffi.declareHeaders {print = print}
in
- Process.succeed ()
+ raise Done
end
val user = Decs.toList (Decs.appends [prefix, input, suffix])
val _ = parseElabMsg ()
@@ -615,7 +618,7 @@
val _ = Control.message (Control.Detail, HashSet.stats)
in
()
- end
+ end handle Done => ()
val elaborate =
fn {input: File.t list} =>