lib/stubs/mlton-stubs-for-smlnj/mlton.sml

   1 (* Copyright (C) 2009 Matthew Fluet.
   2  * Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  *
   5  * MLton is released under a BSD-style license.
   6  * See the file MLton-LICENSE for details.
   7  *)
   8
   9 structure MLton =
  10    struct
  11       val isMLton = false
  12       val size : 'a -> int = fn _ => ~1
  13       structure Exn =
  14          struct
  15             val history = SMLofNJ.exnHistory
  16          end
  17       structure GC =
  18          struct
  19             fun collect () = SMLofNJ.Internals.GC.doGC 8
  20             fun setMessages b = SMLofNJ.Internals.GC.messages b
  21             fun pack () = collect ()
  22          end
  23       structure Platform =
  24          struct
  25             local
  26                fun mkHost cmd =
  27                   let
  28                      fun findCmd dir =
  29                         let
  30                            val cmd = dir ^ "/bin/" ^ cmd
  31                            val upDir = OS.FileSys.realPath (dir ^ "/..")
  32                         in
  33                            if OS.FileSys.access (cmd, [OS.FileSys.A_EXEC])
  34                               then SOME cmd
  35                            else if dir <> upDir
  36                               then findCmd upDir
  37                            else NONE
  38                         end
  39                      val proc = Unix.execute (valOf (findCmd "."), [])
  40                      val ins = Unix.textInstreamOf proc
  41                      val hostString = TextIO.inputAll ins
  42                      val status = Unix.reap proc
  43                   in
  44                      String.extract
  45                      (hostString, 0, SOME (String.size hostString - 1))
  46                   end
  47             in
  48                structure Arch =
  49                   struct
  50                      type t = string
  51                      val toString = fn s => s
  52                      val host = mkHost "host-arch"
  53                   end
  54                structure OS =
  55                   struct
  56                      type t = string
  57                      val toString = fn s => s
  58                      val host = mkHost "host-os"
  59                   end
  60             end
  61          end
  62    end