[MLton-commit] r5539

Vesa Karvonen vesak at mlton.org
Wed Apr 25 06:40:21 PDT 2007


Added tempPrefix function for adding a system or user specific prefix for
temporary files.  On the MinGW platform, the prefix is obtained by calling
the Win32 API function GetTempPath (MinGW.getTempPath).  Used tempPrefix
in the library code where appropriate.  This should fix problems with
temporary file paths on MinGW.

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

U   mlton/trunk/basis-library/build/sources.mlb
U   mlton/trunk/basis-library/mlton/io.fun
U   mlton/trunk/basis-library/mlton/io.sig
U   mlton/trunk/basis-library/mlton/mlton.sml
A   mlton/trunk/basis-library/platform/mingw.sml
U   mlton/trunk/basis-library/primitive/basis-ffi.sml
U   mlton/trunk/lib/mlton/basic/dir.sml
U   mlton/trunk/lib/mlton/basic/file.sml
U   mlton/trunk/lib/mlton-stubs/io.sig
U   mlton/trunk/lib/mlton-stubs/mlton.sml
U   mlton/trunk/runtime/basis-ffi.h
U   mlton/trunk/runtime/gen/basis-ffi.def
U   mlton/trunk/runtime/gen/basis-ffi.h
U   mlton/trunk/runtime/gen/basis-ffi.sml
U   mlton/trunk/runtime/platform/mingw.c

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

Modified: mlton/trunk/basis-library/build/sources.mlb
===================================================================
--- mlton/trunk/basis-library/build/sources.mlb	2007-04-21 22:34:48 UTC (rev 5538)
+++ mlton/trunk/basis-library/build/sources.mlb	2007-04-25 13:40:19 UTC (rev 5539)
@@ -250,6 +250,7 @@
    ../posix/posix.sml
 
    ../platform/cygwin.sml
+   ../platform/mingw.sml
 
    ../io/stream-io.sig
    ../io/stream-io.fun
@@ -318,6 +319,8 @@
    ../net/unix-sock.sig
    ../net/unix-sock.sml
 
+   ../mlton/platform.sig
+   ../mlton/platform.sml
    ../mlton/array.sig
    ../mlton/cont.sig
    ../mlton/cont.sml
@@ -336,8 +339,6 @@
       ../mlton/ffi.sml
    end
    ../mlton/int-inf.sig
-   ../mlton/platform.sig
-   ../mlton/platform.sml
    ../mlton/proc-env.sig
    ../mlton/proc-env.sml
    ../mlton/profile.sig

Modified: mlton/trunk/basis-library/mlton/io.fun
===================================================================
--- mlton/trunk/basis-library/mlton/io.fun	2007-04-21 22:34:48 UTC (rev 5538)
+++ mlton/trunk/basis-library/mlton/io.fun	2007-04-25 13:40:19 UTC (rev 5539)
@@ -33,4 +33,12 @@
 
 fun mkstemp s = mkstemps {prefix = s, suffix = ""}
 
+fun tempPrefix file =
+   case MLtonPlatform.OS.host of
+      MLtonPlatform.OS.MinGW =>
+      (case MinGW.getTempPath () of
+          SOME d => d
+        | NONE => "C:\\temp\\") ^ file
+    | _ => "/tmp/" ^ file
+
 end

Modified: mlton/trunk/basis-library/mlton/io.sig
===================================================================
--- mlton/trunk/basis-library/mlton/io.sig	2007-04-21 22:34:48 UTC (rev 5538)
+++ mlton/trunk/basis-library/mlton/io.sig	2007-04-25 13:40:19 UTC (rev 5539)
@@ -26,4 +26,6 @@
       val mkstemp: string -> string * outstream
       (* mkstemps is like mkstemp, except it has both a prefix and suffix. *)
       val mkstemps: {prefix: string, suffix: string} -> string * outstream
+      (* adds a suitable system or user specific prefix (dir) for temp files *)
+      val tempPrefix : string -> string
    end

Modified: mlton/trunk/basis-library/mlton/mlton.sml
===================================================================
--- mlton/trunk/basis-library/mlton/mlton.sml	2007-04-21 22:34:48 UTC (rev 5538)
+++ mlton/trunk/basis-library/mlton/mlton.sml	2007-04-25 13:40:19 UTC (rev 5539)
@@ -108,7 +108,8 @@
 
             fun tmpName () =
                let
-                  val (f, out) = MLton.TextIO.mkstemp "/tmp/file"
+                  val (f, out) =
+                      MLton.TextIO.mkstemp (MLton.TextIO.tempPrefix "file")
                   val _ = TextIO.closeOut out
                in
                   f

Added: mlton/trunk/basis-library/platform/mingw.sml
===================================================================
--- mlton/trunk/basis-library/platform/mingw.sml	2007-04-21 22:34:48 UTC (rev 5538)
+++ mlton/trunk/basis-library/platform/mingw.sml	2007-04-25 13:40:19 UTC (rev 5539)
@@ -0,0 +1,29 @@
+(* Copyright (C) 2007 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+structure MinGW =
+   struct
+      fun getTempPath () =
+         let
+            fun lp bufSz =
+               let
+                  val buf = CharArray.arrayUninit (C_Size.toInt bufSz)
+                  val reqSz = PrimitiveFFI.MinGW.getTempPath (bufSz, buf)
+               in
+                  if 0w0 = reqSz
+                     then NONE
+                  else if C_Size.< (reqSz, bufSz)
+                     then SOME (CharArraySlice.vector
+                                (CharArraySlice.unsafeSlice
+                                 (buf, 0, SOME (C_Size.toInt reqSz))))
+                  else lp reqSz
+               end
+         in
+            (* Win32 MAX_PATH is 260, but some subsystems allow longer names *)
+            lp 0w261
+         end
+   end


Property changes on: mlton/trunk/basis-library/platform/mingw.sml
___________________________________________________________________
Name: svn:eol-style
   + native

Modified: mlton/trunk/basis-library/primitive/basis-ffi.sml
===================================================================
--- mlton/trunk/basis-library/primitive/basis-ffi.sml	2007-04-21 22:34:48 UTC (rev 5538)
+++ mlton/trunk/basis-library/primitive/basis-ffi.sml	2007-04-25 13:40:19 UTC (rev 5539)
@@ -63,6 +63,10 @@
 end
 val setRoundingMode = _import "IEEEReal_setRoundingMode" : C_Int.t -> unit;
 end
+structure MinGW = 
+struct
+val getTempPath = _import "MinGW_getTempPath" : C_Size.t * (Char8.t) array -> C_Size.t;
+end
 structure MLton = 
 struct
 val bug = _import "MLton_bug" : NullString8.t -> unit;

Modified: mlton/trunk/lib/mlton/basic/dir.sml
===================================================================
--- mlton/trunk/lib/mlton/basic/dir.sml	2007-04-21 22:34:48 UTC (rev 5538)
+++ mlton/trunk/lib/mlton/basic/dir.sml	2007-04-25 13:40:19 UTC (rev 5539)
@@ -85,7 +85,7 @@
 
 fun inTemp thunk =
    let
-      val d = concat ["/tmp/dir", Random.alphaNumString 6]
+      val d = concat [MLton.TextIO.tempPrefix "dir", Random.alphaNumString 6]
       val _ = make d
    in
       Exn.finally (fn () => inDir (d, fn _ => thunk ()),

Modified: mlton/trunk/lib/mlton/basic/file.sml
===================================================================
--- mlton/trunk/lib/mlton/basic/file.sml	2007-04-21 22:34:48 UTC (rev 5538)
+++ mlton/trunk/lib/mlton/basic/file.sml	2007-04-25 13:40:19 UTC (rev 5539)
@@ -88,6 +88,7 @@
            List.foreach (sources, fn f => outputContents (f, out)))
 
 val temp = MLton.TextIO.mkstemps
+val tempPrefix = MLton.TextIO.tempPrefix
 
 fun tempName z =
    let
@@ -99,7 +100,7 @@
 
 fun withTemp f =
    let
-      val name = tempName {prefix = "/tmp/file", suffix = ""}
+      val name = tempName {prefix = tempPrefix "file", suffix = ""}
    in
       Exn.finally (fn () => f name, fn () => remove name)
    end
@@ -116,7 +117,7 @@
    end
 
 fun withTempOut (f, g) =
-   withTempOut' ({prefix = "/tmp/file", suffix = ""}, f, g)
+   withTempOut' ({prefix = tempPrefix "file", suffix = ""}, f, g)
 
 fun withString (s, f) =
    withTempOut (fn out => Out.output (out, s), f)

Modified: mlton/trunk/lib/mlton-stubs/io.sig
===================================================================
--- mlton/trunk/lib/mlton-stubs/io.sig	2007-04-21 22:34:48 UTC (rev 5538)
+++ mlton/trunk/lib/mlton-stubs/io.sig	2007-04-25 13:40:19 UTC (rev 5539)
@@ -26,4 +26,6 @@
       val mkstemp: string -> string * outstream
       (* mkstemps is like mkstemp, except it has both a prefix and suffix. *)
       val mkstemps: {prefix: string, suffix: string} -> string * outstream
+      (* adds a suitable system or user specific prefix (dir) for temp files *)
+      val tempPrefix: string -> string
    end

Modified: mlton/trunk/lib/mlton-stubs/mlton.sml
===================================================================
--- mlton/trunk/lib/mlton-stubs/mlton.sml	2007-04-21 22:34:48 UTC (rev 5538)
+++ mlton/trunk/lib/mlton-stubs/mlton.sml	2007-04-25 13:40:19 UTC (rev 5539)
@@ -25,6 +25,7 @@
       fun newOut _ = raise Fail "newOut"
       fun outFd _ = raise Fail "outFd"
       fun setIn _ = raise Fail "setIn"
+      fun tempPrefix _ = raise Fail "tempPrefix"
    end
 
 (* This file is just a dummy provided in place of the structure that MLton
@@ -84,6 +85,7 @@
             fun newOut _ = raise Fail "newOut"
             fun outFd _ = raise Fail "outFd"
             fun setIn _ = raise Fail "setIn"
+            fun tempPrefix _ = raise Fail "tempPrefix"
          end
 
       structure CallStack =

Modified: mlton/trunk/runtime/basis-ffi.h
===================================================================
--- mlton/trunk/runtime/basis-ffi.h	2007-04-21 22:34:48 UTC (rev 5538)
+++ mlton/trunk/runtime/basis-ffi.h	2007-04-25 13:40:19 UTC (rev 5539)
@@ -44,6 +44,7 @@
 extern const C_Int_t IEEEReal_RoundingMode_FE_TOWARDZERO;
 extern const C_Int_t IEEEReal_RoundingMode_FE_UPWARD;
 void IEEEReal_setRoundingMode(C_Int_t);
+C_Size_t MinGW_getTempPath(C_Size_t,Array(Char8_t));
 __attribute__((noreturn)) void MLton_bug(NullString8_t);
 extern const C_Int_t MLton_Itimer_PROF;
 extern const C_Int_t MLton_Itimer_REAL;

Modified: mlton/trunk/runtime/gen/basis-ffi.def
===================================================================
--- mlton/trunk/runtime/gen/basis-ffi.def	2007-04-21 22:34:48 UTC (rev 5538)
+++ mlton/trunk/runtime/gen/basis-ffi.def	2007-04-25 13:40:19 UTC (rev 5539)
@@ -103,6 +103,7 @@
 MLton.Syslog.closelog = _import : unit -> unit
 MLton.Syslog.openlog = _import : NullString8.t * C_Int.t * C_Int.t -> unit
 MLton.Syslog.syslog = _import : C_Int.t * NullString8.t -> unit
+MinGW.getTempPath = _import : C_Size.t * Char8.t array -> C_Size.t
 Net.htonl = _import : Word32.t -> Word32.t
 Net.htons = _import : Word16.t -> Word16.t
 Net.ntohl = _import : Word32.t -> Word32.t

Modified: mlton/trunk/runtime/gen/basis-ffi.h
===================================================================
--- mlton/trunk/runtime/gen/basis-ffi.h	2007-04-21 22:34:48 UTC (rev 5538)
+++ mlton/trunk/runtime/gen/basis-ffi.h	2007-04-25 13:40:19 UTC (rev 5539)
@@ -44,6 +44,7 @@
 extern const C_Int_t IEEEReal_RoundingMode_FE_TOWARDZERO;
 extern const C_Int_t IEEEReal_RoundingMode_FE_UPWARD;
 void IEEEReal_setRoundingMode(C_Int_t);
+C_Size_t MinGW_getTempPath(C_Size_t,Array(Char8_t));
 __attribute__((noreturn)) void MLton_bug(NullString8_t);
 extern const C_Int_t MLton_Itimer_PROF;
 extern const C_Int_t MLton_Itimer_REAL;

Modified: mlton/trunk/runtime/gen/basis-ffi.sml
===================================================================
--- mlton/trunk/runtime/gen/basis-ffi.sml	2007-04-21 22:34:48 UTC (rev 5538)
+++ mlton/trunk/runtime/gen/basis-ffi.sml	2007-04-25 13:40:19 UTC (rev 5539)
@@ -63,6 +63,10 @@
 end
 val setRoundingMode = _import "IEEEReal_setRoundingMode" : C_Int.t -> unit;
 end
+structure MinGW = 
+struct
+val getTempPath = _import "MinGW_getTempPath" : C_Size.t * (Char8.t) array -> C_Size.t;
+end
 structure MLton = 
 struct
 val bug = _import "MLton_bug" : NullString8.t -> unit;

Modified: mlton/trunk/runtime/platform/mingw.c
===================================================================
--- mlton/trunk/runtime/platform/mingw.c	2007-04-21 22:34:48 UTC (rev 5538)
+++ mlton/trunk/runtime/platform/mingw.c	2007-04-25 13:40:19 UTC (rev 5539)
@@ -1024,3 +1024,11 @@
                 return result;
         }
 }
+
+/* ------------------------------------------------- */
+/*                        MinGW                      */
+/* ------------------------------------------------- */
+
+C_Size_t MinGW_getTempPath(C_Size_t buf_size, Array(Char8_t) buf) {
+        return GetTempPath(buf_size, buf);
+}




More information about the MLton-commit mailing list