[MLton-commit] r5004

Vesa Karvonen vesak at mlton.org
Thu Dec 28 16:53:54 PST 2006


Added command line switch -show {anns|path-map} and deprecated command
line switch -show-anns {false|true}.  Use -show path-map to see the
complete MLB path map as seen by the compiler.

----------------------------------------------------------------------

U   mlton/trunk/doc/changelog
U   mlton/trunk/mlton/control/control-flags.sig
U   mlton/trunk/mlton/control/control-flags.sml
U   mlton/trunk/mlton/front-end/mlb-front-end.fun
U   mlton/trunk/mlton/main/main.fun

----------------------------------------------------------------------

Modified: mlton/trunk/doc/changelog
===================================================================
--- mlton/trunk/doc/changelog	2006-12-28 22:26:34 UTC (rev 5003)
+++ mlton/trunk/doc/changelog	2006-12-29 00:53:36 UTC (rev 5004)
@@ -1,5 +1,15 @@
 Here are the changes since version 20051202.
 
+* 2006-12-29
+   - Added command line switch -show {anns|path-map} and deprecated command
+     line switch -show-anns {false|true}.  Use -show path-map to see the
+     complete MLB path map as seen by the compiler.
+
+* 2006-12-20
+   - Changed the output of command line switch -stop f to include mlb-files.
+     This is useful for generating Makefile dependencies.  The old output is
+     easy to recover if necessary (e.g. grep -v '\.mlb$').
+
 * 2006-12-8
    - Added command line switches -{,target}-{as,cc,link}-opt-quote, which
      pass their argument as a single argument to gcc (i.e., without

Modified: mlton/trunk/mlton/control/control-flags.sig
===================================================================
--- mlton/trunk/mlton/control/control-flags.sig	2006-12-28 22:26:34 UTC (rev 5003)
+++ mlton/trunk/mlton/control/control-flags.sig	2006-12-29 00:53:36 UTC (rev 5004)
@@ -195,6 +195,8 @@
       val maxFunctionSize: int ref
 
       val mlbPathMaps: string list ref
+      val mlbPathMap: unit -> {var: string,
+                               path: string} list
 
       structure Native:
          sig

Modified: mlton/trunk/mlton/control/control-flags.sml
===================================================================
--- mlton/trunk/mlton/control/control-flags.sml	2006-12-28 22:26:34 UTC (rev 5003)
+++ mlton/trunk/mlton/control/control-flags.sml	2006-12-29 00:53:36 UTC (rev 5004)
@@ -991,6 +991,49 @@
                         default = Linux,
                         toString = MLton.Platform.OS.toString}
 
+local
+   fun make (file: File.t) =
+      if not (File.canRead file) then
+         Error.bug (concat ["can't read MLB path map file: ", file])
+      else
+         List.keepAllMap
+         (File.lines file, fn line =>
+          if String.forall (line, Char.isSpace)
+             then NONE
+          else
+             case String.tokens (line, Char.isSpace) of
+                [var, path] => SOME {var = var, path = path}
+              | _ => Error.bug (concat ["strange mlb path mapping: ",
+                                        file, ":: ", line]))
+in
+   fun mlbPathMap () =
+      List.rev
+         (List.concat
+             [[{var = "LIB_MLTON_DIR",
+                path = !libDir},
+               {var = "TARGET_ARCH",
+                path = String.toLower (MLton.Platform.Arch.toString
+                                       (!targetArch))},
+               {var = "TARGET_OS",
+                path = String.toLower (MLton.Platform.OS.toString
+                                       (!targetOS))},
+               {var = "OBJPTR_REP",
+                path = "objptr-rep32.sml"},
+               {var = "HEADER_WORD",
+                path = "header-word32.sml"},
+               {var = "SEQINDEX_INT",
+                path = "seqindex-int32.sml"},
+               {var = "DEFAULT_CHAR",
+                path = concat ["default-", !defaultChar, ".sml"]},
+               {var = "DEFAULT_INT",
+                path = concat ["default-", !defaultInt, ".sml"]},
+               {var = "DEFAULT_REAL",
+                path = concat ["default-", !defaultReal, ".sml"]},
+               {var = "DEFAULT_WORD",
+                path = concat ["default-", !defaultWord, ".sml"]}],
+              List.concat (List.map (!mlbPathMaps, make))])
+end
+
 val typeCheck = control {name = "type check",
                          default = false,
                          toString = Bool.toString}

Modified: mlton/trunk/mlton/front-end/mlb-front-end.fun
===================================================================
--- mlton/trunk/mlton/front-end/mlb-front-end.fun	2006-12-28 22:26:34 UTC (rev 5003)
+++ mlton/trunk/mlton/front-end/mlb-front-end.fun	2006-12-29 00:53:36 UTC (rev 5004)
@@ -84,46 +84,8 @@
       val psi : (File.t * Ast.Basdec.t Promise.t) HashSet.t =
          HashSet.new {hash = String.hash o #1}
       local
-         fun make (file: File.t) =
-            if not (File.canRead file) then
-               Error.bug (concat ["can't read MLB path map file: ", file])
-            else
-               List.keepAllMap
-               (File.lines file, fn line =>
-                if String.forall (line, Char.isSpace)
-                   then NONE
-                else 
-                   case String.tokens (line, Char.isSpace) of
-                      [var, path] => SOME {var = var, path = path}
-                    | _ => Error.bug (concat ["strange mlb path mapping: ", 
-                                              file, ":: ", line]))
          val pathMap =
-            List.rev
-            (List.concat
-             [[{var = "LIB_MLTON_DIR", 
-                path = !Control.libDir},
-               {var = "TARGET_ARCH",
-                path = String.toLower (MLton.Platform.Arch.toString
-                                       (!Control.targetArch))},
-               {var = "TARGET_OS",
-                path = String.toLower (MLton.Platform.OS.toString
-                                       (!Control.targetOS))},
-               {var = "OBJPTR_REP",
-                path = "objptr-rep32.sml"},
-               {var = "HEADER_WORD",
-                path = "header-word32.sml"},
-               {var = "SEQINDEX_INT",
-                path = "seqindex-int32.sml"},
-               {var = "DEFAULT_CHAR",
-                path = concat ["default-", !Control.defaultChar, ".sml"]},
-               {var = "DEFAULT_INT",
-                path = concat ["default-", !Control.defaultInt, ".sml"]},
-               {var = "DEFAULT_REAL",
-                path = concat ["default-", !Control.defaultReal, ".sml"]},
-               {var = "DEFAULT_WORD",
-                path = concat ["default-", !Control.defaultWord, ".sml"]}],
-              List.concat (List.map (!Control.mlbPathMaps, make))])
-
+             Control.mlbPathMap ()
          fun peekPathMap var' =
             case List.peek (pathMap, fn {var,...} =>
                             var = var') of

Modified: mlton/trunk/mlton/main/main.fun
===================================================================
--- mlton/trunk/mlton/main/main.fun	2006-12-28 22:26:34 UTC (rev 5003)
+++ mlton/trunk/mlton/main/main.fun	2006-12-29 00:53:36 UTC (rev 5004)
@@ -47,6 +47,11 @@
        | Yes 
    end
 
+structure Show =
+   struct
+      datatype t = Anns | PathMap
+   end
+
 val gcc: string ref = ref "<unset>"
 val asOpts: {opt: string, pred: OptPred.t} list ref = ref []
 val ccOpts: {opt: string, pred: OptPred.t} list ref = ref []
@@ -65,7 +70,7 @@
 val profileSet: bool ref = ref false
 val profileTimeSet: bool ref = ref false
 val runtimeArgs: string list ref = ref ["@MLton"]
-val showAnns: bool ref = ref false
+val show: Show.t option ref = ref NONE
 val stop = ref Place.OUT
 
 val targetMap: unit -> {arch: MLton.Platform.Arch.t,
@@ -451,8 +456,20 @@
         boolRef profileStack),
        (Normal, "runtime", " <arg>", "pass arg to runtime via @MLton",
         SpaceString (fn s => List.push (runtimeArgs, s))),
-       (Expert, "show-anns", " {false|true}", "show annotations",
-        boolRef showAnns),
+       (Expert, "show", " {anns|path-map}", "print specified data and stop",
+        SpaceString
+        (fn s =>
+         show := SOME (case s of
+                          "anns" => Show.Anns
+                        | "path-map" => Show.PathMap
+                        | _ => usage (concat ["invalid -show arg: ", s])))),
+       (Expert, "show-anns", " {false|true}", "deprecated (use -show anns)",
+        Bool
+        (fn b =>
+         (if b then show := SOME Show.Anns else ()
+          ; Out.output
+            (Out.error,
+             "Warning: deprecated option: -show-anns.  Use -show anns.\n")))),
        (Normal, "show-basis", " <file>", "write out the final basis environment",
         SpaceString (fn s => showBasis := SOME s)),
        (Normal, "show-def-use", " <file>", "write def-use information",
@@ -583,11 +600,24 @@
                       | SOME c => c)
       val () = MLton.Rusage.measureGC (!verbosity <> Silent)
       val () =
-         if !showAnns then
-            (Layout.outputl (Control.Elaborate.document {expert = !expert}, 
-                             Out.standard)
+         case !show of
+            NONE => ()
+          | SOME info =>
+            (case info of
+                Show.Anns =>
+                Layout.outputl (Control.Elaborate.document {expert = !expert},
+                                Out.standard)
+              | Show.PathMap =>
+                let
+                   open Layout
+                in
+                   outputl (align
+                            (List.map (Control.mlbPathMap (),
+                                       fn {var, path, ...} =>
+                                       str (concat [var, " ", path]))),
+                            Out.standard)
+                end
              ; let open OS.Process in exit success end)
-         else ()
       val () = if !profileTimeSet
                   then (case !codegen of
                            Native => profile := ProfileTimeLabel




More information about the MLton-commit mailing list