[MLton-commit] r7123

[Matthew Fluet]

Properly set MLton.Platform.{Arch,OS}.host.
----------------------------------------------------------------------

U   mlton/trunk/lib/stubs/mlton-stubs/mlton.sml
U   mlton/trunk/lib/stubs/mlton-stubs-for-polyml/mlton.sml
U   mlton/trunk/lib/stubs/mlton-stubs-for-smlnj/mlton.sml

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

Modified: mlton/trunk/lib/stubs/mlton-stubs/mlton.sml
===================================================================
--- mlton/trunk/lib/stubs/mlton-stubs/mlton.sml	2009-06-11 03:23:24 UTC (rev 7122)
+++ mlton/trunk/lib/stubs/mlton-stubs/mlton.sml	2009-06-11 03:23:26 UTC (rev 7123)
@@ -156,8 +156,6 @@
                   datatype t = Alpha | AMD64 | ARM | HPPA | IA64 | m68k |
                                MIPS | PowerPC | PowerPC64 | S390 | Sparc | X86
 
-                  val host: t = X86
-
                   val all = [(Alpha, "Alpha"),
                              (AMD64, "AMD64"),
                              (ARM, "ARM"),
@@ -180,6 +178,11 @@
                      end
 
                   fun toString a = #2 (valOf (peek (all, fn (a', _) => a = a')))
+
+                  val host: t =
+                     case fromString (MLton.Platform.Arch.toString MLton.Platform.Arch.host) of
+                        NONE => raise Fail "MLton.Platform.Arch.host: strange arch"
+                      | SOME host => host
                end
 
             structure OS =
@@ -196,8 +199,6 @@
                    | OpenBSD
                    | Solaris
 
-                  val host: t = Linux
-
                   val all = [(AIX, "AIX"),
                              (Cygwin, "Cygwin"),
                              (Darwin, "Darwin"),
@@ -218,6 +219,11 @@
                      end
 
                   fun toString a = #2 (valOf (peek (all, fn (a', _) => a = a')))
+
+                  val host: t =
+                     case fromString (MLton.Platform.OS.toString MLton.Platform.OS.host) of
+                        NONE => raise Fail "MLton.Platform.OS.host: strange os"
+                      | SOME os => os
                end
          end
 

Modified: mlton/trunk/lib/stubs/mlton-stubs-for-polyml/mlton.sml
===================================================================
--- mlton/trunk/lib/stubs/mlton-stubs-for-polyml/mlton.sml	2009-06-11 03:23:24 UTC (rev 7122)
+++ mlton/trunk/lib/stubs/mlton-stubs-for-polyml/mlton.sml	2009-06-11 03:23:26 UTC (rev 7123)
@@ -9,7 +9,7 @@
 structure MLton =
    struct
       val isMLton = false
-      val size : 'a -> int = fn _ => ~1
+      val size : 'a -> int = PolyML.objSize
       structure Exn =
          struct
             val history : exn -> string list = fn _ => []
@@ -20,4 +20,43 @@
             fun setMessages (b : bool) = ()
             fun pack () = collect ()
          end
+      structure Platform =
+         struct
+            local
+               fun mkHost cmd =
+                  let
+                     fun findCmd dir =
+                        let
+                           val cmd = dir ^ "/bin/" ^ cmd
+                           val upDir = OS.FileSys.realPath (dir ^ "/..")
+                        in
+                           if OS.FileSys.access (cmd, [OS.FileSys.A_EXEC])
+                              then SOME cmd
+                           else if dir <> upDir
+                              then findCmd upDir
+                           else NONE
+                        end
+                     val proc = Unix.execute (valOf (findCmd "."), [])
+                     val ins = Unix.textInstreamOf proc
+                     val hostString = TextIO.inputAll ins
+                     val status = Unix.reap proc
+                  in
+                     String.extract
+                     (hostString, 0, SOME (String.size hostString - 1))
+                  end
+            in
+               structure Arch =
+                  struct
+                     type t = string
+                     val toString = fn s => s
+                     val host = mkHost "host-arch"
+                  end
+               structure OS =
+                  struct
+                     type t = string
+                     val toString = fn s => s
+                     val host = mkHost "host-os"
+                  end
+            end
+         end
    end

Modified: mlton/trunk/lib/stubs/mlton-stubs-for-smlnj/mlton.sml
===================================================================
--- mlton/trunk/lib/stubs/mlton-stubs-for-smlnj/mlton.sml	2009-06-11 03:23:24 UTC (rev 7122)
+++ mlton/trunk/lib/stubs/mlton-stubs-for-smlnj/mlton.sml	2009-06-11 03:23:26 UTC (rev 7123)
@@ -20,4 +20,43 @@
             fun setMessages b = SMLofNJ.Internals.GC.messages b
             fun pack () = collect ()
          end
+      structure Platform =
+         struct
+            local
+               fun mkHost cmd =
+                  let
+                     fun findCmd dir =
+                        let
+                           val cmd = dir ^ "/bin/" ^ cmd
+                           val upDir = OS.FileSys.realPath (dir ^ "/..")
+                        in
+                           if OS.FileSys.access (cmd, [OS.FileSys.A_EXEC])
+                              then SOME cmd
+                           else if dir <> upDir
+                              then findCmd upDir
+                           else NONE
+                        end
+                     val proc = Unix.execute (valOf (findCmd "."), [])
+                     val ins = Unix.textInstreamOf proc
+                     val hostString = TextIO.inputAll ins
+                     val status = Unix.reap proc
+                  in
+                     String.extract
+                     (hostString, 0, SOME (String.size hostString - 1))
+                  end
+            in
+               structure Arch =
+                  struct
+                     type t = string
+                     val toString = fn s => s
+                     val host = mkHost "host-arch"
+                  end
+               structure OS =
+                  struct
+                     type t = string
+                     val toString = fn s => s
+                     val host = mkHost "host-os"
+                  end
+            end
+         end
    end