[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} =>