[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