[MLton-commit] r4349: preliminary support for compiler specific annotations

[Matthew Fluet]

MAIL preliminary support for compiler specific annotations

Added very simple support for compiler specific annotations.  If an
annotation contains ":", then the text preceding the ":" is meant to
denote a compiler.  For MLton, if the text preceding the ":" is equal
to "mlton", then the remaining annotation is scanned as a normal
annotation.  If the text preceding the ":" is not-equal to "mlton",
then the annotation is ignored, and no warning is issued.


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

U   mlton/trunk/mlton/control/control-flags.sig
U   mlton/trunk/mlton/control/control-flags.sml
U   mlton/trunk/mlton/elaborate/elaborate-mlbs.fun
U   mlton/trunk/mlton/main/main.fun

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

Modified: mlton/trunk/mlton/control/control-flags.sig
===================================================================
--- mlton/trunk/mlton/control/control-flags.sig	2006-02-05 15:30:17 UTC (rev 4348)
+++ mlton/trunk/mlton/control/control-flags.sig	2006-02-10 00:38:30 UTC (rev 4349)
@@ -94,7 +94,7 @@
             val name: ('args, 'st) t -> string
 
             datatype ('a, 'b) parseResult =
-               Bad | Deprecated of 'a | Good of 'b
+               Bad | Deprecated of 'a | Good of 'b | Other
 
             structure Id :
                sig

Modified: mlton/trunk/mlton/control/control-flags.sml
===================================================================
--- mlton/trunk/mlton/control/control-flags.sml	2006-02-05 15:30:17 UTC (rev 4348)
+++ mlton/trunk/mlton/control/control-flags.sml	2006-02-10 00:38:30 UTC (rev 4349)
@@ -174,7 +174,7 @@
       fun equalsId (ctrl, id') = Id.equals (id ctrl, id')
 
       datatype ('a, 'b) parseResult =
-         Bad | Deprecated of 'a | Good of 'b
+         Bad | Deprecated of 'a | Good of 'b | Other
       val deGood = 
          fn Good z => z
           | _ => Error.bug "Control.Elaborate.deGood"
@@ -532,6 +532,24 @@
          val {parseId, parseIdAndArgs} = ac
       end
 
+      local
+         fun checkPrefix (s, f) =
+            case String.fields (s, fn c => c = #":") of
+               [s] => f s
+             | [comp,s] => 
+                  let
+                     val comp = String.deleteSurroundingWhitespace comp
+                  in
+                     if String.equals (comp, "mlton")
+                        then f s
+                        else Other
+                  end
+             | _ => Bad
+      in
+         val parseId = fn s => checkPrefix (s, parseId)
+         val parseIdAndArgs = fn s => checkPrefix (s, parseIdAndArgs)
+      end
+
       val processDefault = fn s =>
          case parseIdAndArgs s of
             Bad => Bad
@@ -540,6 +558,7 @@
                (alts, Deprecated (List.map (alts, #1)), fn ((_,args),res) =>
                 if Args.processDef args then res else Bad)
           | Good (_, args) => if Args.processDef args then Good () else Bad
+          | Other => Bad
 
       val processEnabled = fn (s, b) =>
          case parseId s of
@@ -549,6 +568,7 @@
                (alts, Deprecated alts, fn (id,res) =>
                 if Id.setEnabled (id, b) then res else Bad)
           | Good id => if Id.setEnabled (id, b) then Good () else Bad
+          | Other => Bad
 
       val withDef : (unit -> 'a) -> 'a = fn f =>
          let

Modified: mlton/trunk/mlton/elaborate/elaborate-mlbs.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-mlbs.fun	2006-02-05 15:30:17 UTC (rev 4348)
+++ mlton/trunk/mlton/elaborate/elaborate-mlbs.fun	2006-02-10 00:38:30 UTC (rev 4349)
@@ -261,6 +261,7 @@
                              else elabBasdec basdec, 
                              restore)
                          end
+                    | Other => elabBasdec basdec
                 end) basdec
       val _ = withDef (fn () => elabBasdec mlb)
    in

Modified: mlton/trunk/mlton/main/main.fun
===================================================================
--- mlton/trunk/mlton/main/main.fun	2006-02-05 15:30:17 UTC (rev 4348)
+++ mlton/trunk/mlton/main/main.fun	2006-02-10 00:38:30 UTC (rev 4349)
@@ -125,6 +125,8 @@
                 concat ["Warning: ", "deprecated annotation: ", s, ".  Use ",
                         List.toString Control.Elaborate.Id.name ids, ".\n"])
           | Control.Elaborate.Good () => ()
+          | Control.Elaborate.Other =>
+               usage (concat ["invalid -", flag, " flag: ", s])
       open Control Popt
       fun push r = SpaceString (fn s => List.push (r, s))
       datatype z = datatype MLton.Platform.Arch.t