[MLton] Windows ports and paths
Wesley W. Terpstra
wesley@terpstra.ca
Sat, 30 Apr 2005 22:41:31 +0200
--jI8keyz6grp/JLjh
Content-Type: text/plain; charset=us-ascii
Content-Disposition: inline
So, I tried rebuilding cygwin today and found that the C99 support there is
a bit broken. For whatever reason, several functions and structures get
turned off when compiled with -std=c99. An easy fix is to use -std=gnu99
instead. That's still C99, but with the GNU functions also.
A patch, fix-cygwin.patch is attached (it also fixes a buggy mingw setenv).
A remaining problem is that fenv.h appears to be missing!
However, mingw has it, so I used mingw's implementation for building.
Next, I decided to try to get the compiler to build under mingw.
Mingw is preferable to cygwin in every way, afaics. It doesn't need any
external DLLs and works from cygwin, msys, and command.com. If MLton can
be made to work reliably under mingw, a cygwin release becomes superfluous.
As has been brought up before, the primary problem was that OS.Path does
not support Windows paths. I have prepared two patches which correct this.
The big problem I had is the question about what isAbs should return for
"\". To me, an absolute path is one which is not disturbed by chdir().
The path "\" fails this test. Therefore, "E:\" isAbs but not "\".
Unfortunately, then the problem becomes, how do "\foo" and "foo" differ?
The arcs ["", "foo"] and ["foo"] make sense to me, but are rejected by the
standard's wording in toString.
To resolve this issue I wrote two patches both of which seem to work.
The first, slash_not_absolute.patch lets ["", "foo"] be allowed under
windows. The second, slash_is_absolute.patch considers "\" to be absolute
and "E:\" simply the same as "\" with a volume.
Which is best, I leave up to you guys. My personal opinion is that "\" is
NOT absolute, but the patch for this is more invasive, and probably has a
few boundary condition bugs I haven't found yet.
One important detail is that under cygwin, "/" differs from "\".
"/" points to a pseudo-UNIX filesystem that cygwin provides.
"\" points to the root directory of the current drive (as you'd expect).
Both patches deal with this by considering "/foo\bar\baz" to be on a special
disk labeled "/". This, and the use of "\" in toString causes a whole whack
of regressions in unixPath.sml, but I think the new output is correct.
I did a double-check of the patch under linux, and there is a small
regression in unixPath.sml, but I think the old behaviour was wrong:
joinDirFile {dir = "/c/a/b", file = ""} should be "/c/a/b" afaics.
-- the new concat was taken directly from the standard...
Anyways, after the path work, I built my mingw MLton and watched in horror
as it failed the second stage bootstrap. =)
The remaining problem is that MLton secretly builds an internal mlb given
the passed filename. Not a good idea!
Why? Because "mlton c:/test.sml" doesn't compile. The ":" is not allowed by
the grammar for .mlbs. Also mlton "foo a.sml" doesn't work even in unix.
What's wrong with having a space in a filename?
This matters because under msys (mingw's shell), path names are remapped to
fully qualified paths before the command gets run. This makes my mingw MLton
break. I suppose allowing a ':' in the MLB paths would fix it for now, but
paths with spaces in them are pretty common in windows. "My Documents",
"Program Files", ...
--
Wesley W. Terpstra <wesley@terpstra.ca>
--jI8keyz6grp/JLjh
Content-Type: text/plain; charset=us-ascii
Content-Disposition: attachment; filename="fix-cygwin.patch"
Index: bytecode/Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/bytecode/Makefile,v
retrieving revision 1.12
diff -u -r1.12 Makefile
--- bytecode/Makefile 22 Dec 2004 05:11:24 -0000 1.12
+++ bytecode/Makefile 30 Apr 2005 13:58:20 -0000
@@ -1,6 +1,6 @@
all: interpret.o interpret-gdb.o print-opcodes
-CC = gcc -std=c99
+CC = gcc -std=gnu99
CFLAGS = -fomit-frame-pointer -I../runtime -I../include -Wall
interpret.o: interpret.c interpret.h opcode.h
Index: runtime/Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Makefile,v
retrieving revision 1.96
diff -u -r1.96 Makefile
--- runtime/Makefile 22 Apr 2005 12:47:37 -0000 1.96
+++ runtime/Makefile 30 Apr 2005 13:58:22 -0000
@@ -15,7 +15,7 @@
FLAGS = -fomit-frame-pointer
ifeq ($(TARGET_ARCH), x86)
-FLAGS += -mcpu=pentiumpro
+FLAGS += -march=pentiumpro
ifeq ($(GCC_VERSION), 3)
FLAGS += -falign-loops=2 -falign-jumps=2 -falign-functions=5
else
@@ -38,7 +38,7 @@
FLAGS += -b $(TARGET)
endif
-CC = gcc -std=c99
+CC = gcc -std=gnu99
CFLAGS = -O2 -Wall -I. -Iplatform -D_FILE_OFFSET_BITS=64 $(FLAGS)
DEBUGFLAGS = $(CFLAGS) -gstabs+ -g2
Index: runtime/platform/mingw.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/platform/mingw.c,v
retrieving revision 1.15
diff -u -r1.15 mingw.c
--- runtime/platform/mingw.c 27 Feb 2005 02:12:52 -0000 1.15
+++ runtime/platform/mingw.c 30 Apr 2005 13:58:23 -0000
@@ -325,11 +325,16 @@
/* We could use _putenv, but then we'd need a temporary buffer for
* use to concat name=value.
*/
- if (overwrite or not (getenv (name)))
- unless (SetEnvironmentVariable (name, value)) {
- errno = ENOMEM; /* this happens often in Windows.. */
- return -1;
- }
+ if (not overwrite and getenv (name)) {
+ errno = EEXIST;
+ return -1; /* previous mingw setenv was buggy and returned 0 */
+ }
+
+ if (SetEnvironmentVariable (name, value)) {
+ errno = ENOMEM; /* this happens often in Windows.. */
+ return -1;
+ }
+
return 0;
}
Index: main/main.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.fun,v
retrieving revision 1.86
diff -u -r1.86 main.fun
--- main/main.fun 23 Mar 2005 23:58:28 -0000 1.86
+++ main/main.fun 30 Apr 2005 18:53:36 -0000
@@ -770,7 +770,7 @@
(gcc,
List.concat
[targetOpts,
- ["-std=c99"],
+ ["-std=gnu99"],
["-o", output],
if !debug then gccDebug else [],
inputs,
@@ -826,7 +826,7 @@
then debugSwitches @ switches
else switches
val switches =
- targetOpts @ ("-std=c99" :: "-c" :: switches)
+ targetOpts @ ("-std=gnu99" :: "-c" :: switches)
val output =
if stop = Place.O orelse !keepO
then
--jI8keyz6grp/JLjh
Content-Type: text/plain; charset=us-ascii
Content-Disposition: attachment; filename="slash_is_absolute.patch"
Index: path.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/path.sml,v
retrieving revision 1.11
diff -u -r1.11 path.sml
--- path.sml 4 Feb 2005 14:30:29 -0000 1.11
+++ path.sml 30 Apr 2005 14:51:32 -0000
@@ -22,40 +22,100 @@
infix 9 sub
val op sub = String.sub
val substring = String.extract
-(*KILL 26/02/1998 01:09. tho.:
- val substring = fn x => ""
-*)
-
- val slash = "/"
- val volslash = "/"
- fun isslash c = c = #"/"
- fun validVol s = s = ""
- fun iscolon c = c = #":"
-
- val isMinGW = let open Primitive.MLton.Platform.OS in host = MinGW end
-
- fun splitabsvolrest s =
- if isMinGW
- then
- (* Handle the "C:\" case *)
- if size s >= 3 andalso iscolon (s sub 1)
- then (true, "", substring(s, 3, NONE))
- else (false, "", s)
- else
- if size s >= 1 andalso isslash (s sub 0) then
- (true, "", substring(s, 1, NONE))
- else
- (false, "", s);
-
- in
+ (* Testing commands in both cygwin and mingw reveal that BOTH treat
+ * paths exactly the same, and they also match newer windows console
+ * commands (for example command.com and cmd.exe).
+ *
+ * There is one exception: both cygwin and mingw treat /foo\bar
+ * differently from \foo\bar; there is a special root for '/'.
+ * This is so that cygwin and msys can fake a Unix directory tree.
+ *
+ * Normal windows commands do not do this. Both msys and cygwin do it
+ * differently. The msys(mingw) approach is for the shell(bash) to
+ * translate the path before calling the command, eg: foo /usr will
+ * run foo with arguement "c:/msys/1.0/". Under cygwin, the path is
+ * passed through as stated and the program has to deal with it. Thus,
+ * for mingw we can (and should) ignore the issue and thus the mlton
+ * compiled application is identical to a windows app. However, under
+ * cygwin, we need to track /* as a special volume.
+ *)
+ val isWindows =
+ let
+ open Primitive.MLton.Platform.OS
+ in
+ host = MinGW orelse host = Cygwin
+ end
+
+ val volumeHack =
+ let
+ open Primitive.MLton.Platform.OS
+ in
+ host = Cygwin
+ end
+
+ (* the path seperator used in canonical paths *)
+ val slash = if isWindows then "\\" else "/"
+
+ (* newer windows commands treat both / and \ as path seperators
+ * try echo sdfsdf > foo/bar under windows command.com -- it works
+ *
+ * Sadly this means that toString o fromString is not the identity
+ * b/c foo/bar -> foo\bar. However, there's nothing else one can do!
+ * This diverges from the standard.
+ *)
+ val isslash =
+ if isWindows
+ then fn c => (c = #"/" orelse c = #"\\")
+ else fn c => (c = #"/")
+
+ (* characters disallowed in paths *)
+ val isbad =
+ if isWindows
+ then fn c => (c = #"\000" orelse c = #":")
+ else fn c => (c = #"\000")
+
+ fun iscolon c = c = #":"
+
+ fun splitabsvolrest s =
+ let
+ val (vol, rest) =
+ if isWindows andalso size s >= 2 andalso iscolon (s sub 1)
+ then (substring (s, 0, SOME 2), substring (s, 2, NONE))
+ else ("", s)
+ in
+ if size rest >= 1 andalso isslash (rest sub 0) then
+ if volumeHack andalso vol = "" andalso (rest sub 0) = #"/" then
+ (true, "/", substring(rest, 1, NONE))
+ else
+ (true, vol, substring(rest, 1, NONE))
+ else
+ (false, vol, rest)
+ end
+
+ (* I disagree with the standard; under windows "" is a valid volume even
+ * when the path is absolute. Proof: dir \ works
+ * Under cygwin, the special volume "/" denotes the cygwin pseudo-root
+ *)
+ fun isValidVolume v =
+ v = "" orelse (isWindows andalso size v = 2 andalso
+ Char.isAlpha (v sub 0) andalso iscolon (v sub 1))
+ orelse (volumeHack andalso v = "/")
+
+ fun volumeEqual (v1, v2) =
+ (isValidVolume v1) andalso (isValidVolume v2) andalso
+ Char.toUpper (v1 sub 0) = Char.toUpper (v2 sub 0)
+ in
+
val parentArc = ".."
val currentArc = "."
-
+
+ fun validVolume {isAbs = _, vol = v} = isValidVolume v
+ fun getVolume p = #2 (splitabsvolrest p)
fun isAbsolute p = #1 (splitabsvolrest p)
-
- fun isRelative p = not (isAbsolute p);
-
+ fun isRelative p = not (isAbsolute p)
+
+ (* the returned volume might not be valid (eg: "4:")... ok i guess *)
fun fromString p =
let
val (isAbs, v, rest) = splitabsvolrest p
@@ -67,64 +127,44 @@
vol = v}
end
- fun toArcOpt s =
- case fromString s of
- {arcs = [a], isAbs = false, vol = ""} => SOME a
- | _ => NONE
-
- fun isArc s = s = "" orelse isSome (toArcOpt s)
-
- fun getVolume p = #2 (splitabsvolrest p)
-
- fun validVolume {isAbs = _, vol} = validVol vol
-
+ (* MLton previously rejected "foo/bar" as an arc.
+ * Reading the standard shows that this is NOT a problem.
+ * What is more of a problem would be having a null in a filename!
+ * Under windows, a ":" may also not be in a filename.
+ *
+ * See toString: "provided no exception is raised and none of the strings
+ * in arcs contains an embedded arc separator character" -- this means
+ * that containing an embedded arc separator character does NOT raise an
+ * exception.
+ *)
+ fun isArc s = List.length (String.fields isbad s) = 1
+
fun toString {arcs, isAbs, vol} =
if not (validVolume {isAbs = isAbs, vol = vol})
then raise Path
+ else if not isAbs andalso (case arcs of ("" :: _) => true | _ => false)
+ then raise Path
else if List.exists (not o isArc) arcs
then raise InvalidArc
- else
- let
- fun h ([], res) = res
- | h (a :: ar, res) = h (ar, a :: slash :: res)
- in
- if isAbs
- then
- (case arcs of
- [] => vol ^ volslash
- | a1 :: arest =>
- String.concat
- (List.rev (h (arest, [a1, volslash, vol]))))
- else
- case arcs of
- [] => vol
- | a1 :: arest =>
- if a1 = ""
- then raise Path
- else String.concat (vol :: List.rev (h (arest, [a1])))
- end
+ else
+ vol ^
+ (if isAbs andalso (not volumeHack orelse vol <> "/") then slash else "") ^
+ String.concatWith slash arcs
fun concat (p1, p2) =
- let fun stripslash path =
- if isslash (path sub (size path - 1)) then
- substring(path, 0, SOME(size path - 1))
- else path
- in
- if isAbsolute p2 then raise Path
- else
- let
- val (isAbs, v, path) = splitabsvolrest p1
- in
- if isAbs
- then if path = ""
- then v ^ volslash ^ p2
- else String.concat [v, volslash, stripslash path,
- slash, p2]
- else if v = "" andalso path = ""
- then p2
- else String.concat [v, stripslash path, slash, p2]
- end
- end
+ let
+ fun cutEmptyTail l =
+ List.rev (case List.rev l of ("" :: r) => r | l => l)
+ in
+ case (fromString p1, fromString p2) of
+ (_, {isAbs=true, ...}) => raise Path
+ | ({isAbs, vol=v1, arcs=a1}, {vol=v2, arcs=a2, ...}) =>
+ if (v2 = "") orelse volumeEqual (v1, v2)
+ then toString { isAbs=isAbs, vol=v1,
+ arcs=cutEmptyTail a1 @ a2 }
+ else
+ raise Path
+ end
fun getParent p =
let open List
@@ -145,7 +185,7 @@
case getpar arcs of
[] =>
if isAbs then toString {isAbs=true, vol=vol, arcs=[""]}
- else currentArc
+ else toString {isAbs=false, vol=vol, arcs=[currentArc]}
| arcs => toString {isAbs=isAbs, vol=vol, arcs=arcs}
end
@@ -191,16 +231,17 @@
if a11=a21 then h a1r a2r
else parentize a2 @ (if arcs1 = [""] then [] else a1)
in
- if vol1 <> vol2 then raise Path
- else toString {isAbs=false, vol="", arcs=h arcs1 arcs2}
+ if vol1 <> "" andalso not (volumeEqual (vol1, vol2))
+ then raise Path
+ else toString {isAbs=false, vol=vol2, arcs=h arcs1 arcs2}
end
fun mkAbsolute {path = p1, relativeTo = p2} =
if isRelative p2 then raise Path
else if isAbsolute p1 then p1
- else mkCanonical(concat(p2, p1));
+ else mkCanonical(concat(p2, p1))
- fun isCanonical p = mkCanonical p = p;
+ fun isCanonical p = mkCanonical p = p
fun joinDirFile {dir, file} =
if isArc file then concat (dir, file) else raise InvalidArc
@@ -218,8 +259,8 @@
end
- fun dir s = #dir (splitDirFile s);
- fun file s = #file(splitDirFile s);
+ fun dir s = #dir (splitDirFile s)
+ fun file s = #file (splitDirFile s)
fun joinBaseExt {base, ext} =
case ext of
@@ -251,11 +292,21 @@
case fromString path of
{isAbs = true, arcs= [a], ...} => a = ""
| _ => false
- end
- (* Since MLton only runs on Unix, there is nothing to do for these.*)
- fun fromUnixPath s = s
- fun toUnixPath s = s
+ fun fromUnixPath s =
+ if not isWindows then s else
+ if not (isArc s) then raise InvalidArc else
+ String.translate (fn c => if c = #"/" then slash else Char.toString c) s
+
+ fun toUnixPath s =
+ if not isWindows then s else
+ let
+ val {arcs, isAbs, vol} = fromString s
+ in
+ if vol <> "" andalso (not volumeHack orelse vol <> "/")
+ then raise Path
+ else (if isAbs then "/" else "") ^ String.concatWith "/" arcs
+ end
+
+ end
end (*structure Path*)
-
-
--jI8keyz6grp/JLjh
Content-Type: text/plain; charset=us-ascii
Content-Disposition: attachment; filename="slash_not_absolute.patch"
Index: path.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/path.sml,v
retrieving revision 1.11
diff -u -r1.11 path.sml
--- path.sml 4 Feb 2005 14:30:29 -0000 1.11
+++ path.sml 30 Apr 2005 18:51:56 -0000
@@ -22,165 +22,235 @@
infix 9 sub
val op sub = String.sub
val substring = String.extract
-(*KILL 26/02/1998 01:09. tho.:
- val substring = fn x => ""
-*)
-
- val slash = "/"
- val volslash = "/"
- fun isslash c = c = #"/"
- fun validVol s = s = ""
- fun iscolon c = c = #":"
-
- val isMinGW = let open Primitive.MLton.Platform.OS in host = MinGW end
-
- fun splitabsvolrest s =
- if isMinGW
- then
- (* Handle the "C:\" case *)
- if size s >= 3 andalso iscolon (s sub 1)
- then (true, "", substring(s, 3, NONE))
- else (false, "", s)
- else
- if size s >= 1 andalso isslash (s sub 0) then
- (true, "", substring(s, 1, NONE))
- else
- (false, "", s);
-
- in
+ (* Testing commands in both cygwin and mingw reveal that BOTH treat
+ * paths exactly the same, and they also match newer windows console
+ * commands (for example command.com and cmd.exe).
+ *
+ * There is one exception: both cygwin and mingw treat /foo\bar
+ * differently from \foo\bar; there is a special root for '/'.
+ * This is so that cygwin and msys can fake a Unix directory tree.
+ *
+ * Normal windows commands do not do this. Both msys and cygwin do it
+ * differently. The msys(mingw) approach is for the shell(bash) to
+ * translate the path before calling the command, eg: foo /usr will
+ * run foo with arguement "c:/msys/1.0/". Under cygwin, the path is
+ * passed through as stated and the program has to deal with it. Thus,
+ * for mingw we can (and should) ignore the issue and thus the mlton
+ * compiled application is identical to a windows app. However, under
+ * cygwin, we need to track /* as a special volume.
+ *)
+ val isWindows =
+ let
+ open Primitive.MLton.Platform.OS
+ in
+ host = MinGW orelse host = Cygwin
+ end
+
+ val volumeHack =
+ let
+ open Primitive.MLton.Platform.OS
+ in
+ host = Cygwin
+ end
+
+ (* the path seperator used in canonical paths *)
+ val slash = if isWindows then "\\" else "/"
+
+ (* newer windows commands treat both / and \ as path seperators
+ * try echo sdfsdf > foo/bar under windows command.com -- it works
+ *
+ * Sadly this means that toString o fromString is not the identity
+ * b/c foo/bar -> foo\bar. However, there's nothing else one can do!
+ * This diverges from the standard.
+ *)
+ fun isslash c = c = #"/" orelse (isWindows andalso c = #"\\")
+ fun iscolon c = c = #":"
+
+ (* characters disallowed in paths *)
+ fun isbad c = c = #"\000" orelse (isWindows andalso iscolon c)
+
+ (* Under cygwin, the special volume "/" denotes the cygwin pseudo-root
+ *)
+ fun isVolumeName v =
+ (isWindows andalso size v = 2 andalso
+ Char.isAlpha (v sub 0) andalso iscolon (v sub 1))
+ orelse
+ (volumeHack andalso v = "/")
+
+ fun volumeMatch (root, relative) =
+ relative = "" orelse
+ (isVolumeName root) andalso (isVolumeName relative) andalso
+ Char.toUpper (root sub 0) = Char.toUpper (relative sub 0)
+ in
+
val parentArc = ".."
val currentArc = "."
-
- fun isAbsolute p = #1 (splitabsvolrest p)
-
- fun isRelative p = not (isAbsolute p);
-
- fun fromString p =
+
+ (* Ahh joy. The SML basis library standard and Windows paths.
+ *
+ * The big problem with windows paths is "\foo""
+ * - It's not absolute, since chdir("A:\") may switch from "C:", thus
+ * changing the meaning of "\foo".
+ * - However, it's different from (and 'more absolute' than) "foo"
+ *
+ * Somehow, we need to distinguish "\foo" and "foo" without using isAbs
+ * like is done for Unix paths. Trying to keep the leading "\" in the
+ * arc leads to a mess of interactions later, so I don't do this.
+ * It seems to make the most sense to just allow a leading "" for
+ * non-absolute paths under windows. This has implications only in
+ * the implementation of mkCanonical, concat, and isRoot.
+ *
+ * I propose for Windows:
+ * "E:foo" => { isAbs=false, vol="E:", arcs=["foo"] }
+ * "E:\foo" => { isAbs=true, vol="E:", arcs=["foo"] }
+ * "\foo" => { isAbs=false, vol="", arcs=["", "foo"] }
+ * "foo" => { isAbs=false, vol="", arcs=["foo"] }
+ * "/foo" => { isAbs=true, vol="/", arcs=["foo"] } (cygwin volumeHack)
+ *
+ * For UNIX:
+ * "foo" => { isAbs=false, vol="", arcs=["foo"] }
+ * "/foo" => { isAbs=true, vol="", arcs=["foo"] }
+ *)
+ fun validVolume {isAbs, vol} =
+ if isWindows
+ then isVolumeName vol orelse (not isAbs andalso vol = "")
+ else vol = ""
+
+ fun fromString s =
let
- val (isAbs, v, rest) = splitabsvolrest p
+ val (vol, rest) = (* 4:foo has a volume of "4:" even tho invalid *)
+ if isWindows andalso size s >= 2 andalso iscolon (s sub 1)
+ then (substring (s, 0, SOME 2), substring (s, 2, NONE))
+ else
+ if volumeHack andalso size s >= 1 andalso (s sub 0) = #"/"
+ then ("/", s)
+ else ("", s)
+
+ val (isAbs, arcs) =
+ case (String.fields isslash rest) of
+ "" :: [] => (false, [])
+ | "" :: r =>
+ if isWindows andalso vol = ""
+ then (false, "" :: r)
+ else (true, r)
+ | r => (false, r)
in
- if not isAbs andalso rest = ""
- then {isAbs = false, vol = v, arcs = []}
- else {arcs = String.fields isslash rest,
- isAbs = isAbs,
- vol = v}
+ {isAbs=isAbs, vol=vol, arcs=arcs}
end
-
- fun toArcOpt s =
- case fromString s of
- {arcs = [a], isAbs = false, vol = ""} => SOME a
- | _ => NONE
-
- fun isArc s = s = "" orelse isSome (toArcOpt s)
-
- fun getVolume p = #2 (splitabsvolrest p)
-
- fun validVolume {isAbs = _, vol} = validVol vol
-
+
+ val getVolume = #vol o fromString
+ val isAbsolute = #isAbs o fromString
+ val isRelative = not o isAbsolute
+
+ (* MLton previously rejected "foo/bar" as an arc.
+ * Reading the standard shows that this is NOT a problem.
+ * What is more of a problem would be having a null in a filename!
+ * Under windows, a ":" may also not be in a filename.
+ *
+ * See toString: "provided no exception is raised and none of the strings
+ * in arcs contains an embedded arc separator character" -- this means
+ * that containing an embedded arc separator character does NOT raise an
+ * exception.
+ *)
+ fun isArc s = List.length (String.fields isbad s) = 1
+
fun toString {arcs, isAbs, vol} =
if not (validVolume {isAbs = isAbs, vol = vol})
then raise Path
+ else if not isWindows andalso not isAbs andalso
+ case arcs of ("" :: _) => true | _ => false
+ then raise Path
else if List.exists (not o isArc) arcs
then raise InvalidArc
- else
- let
- fun h ([], res) = res
- | h (a :: ar, res) = h (ar, a :: slash :: res)
- in
- if isAbs
- then
- (case arcs of
- [] => vol ^ volslash
- | a1 :: arest =>
- String.concat
- (List.rev (h (arest, [a1, volslash, vol]))))
- else
- case arcs of
- [] => vol
- | a1 :: arest =>
- if a1 = ""
- then raise Path
- else String.concat (vol :: List.rev (h (arest, [a1])))
- end
-
+ else
+ vol ^
+ (if isAbs andalso (not volumeHack orelse vol <> "/") then slash else "") ^
+ String.concatWith slash arcs
+
+ (* The standard doesn't address:
+ * concat("E:foo", "\foo") --> I say, raise Path
+ *)
fun concat (p1, p2) =
- let fun stripslash path =
- if isslash (path sub (size path - 1)) then
- substring(path, 0, SOME(size path - 1))
- else path
- in
- if isAbsolute p2 then raise Path
- else
- let
- val (isAbs, v, path) = splitabsvolrest p1
- in
- if isAbs
- then if path = ""
- then v ^ volslash ^ p2
- else String.concat [v, volslash, stripslash path,
- slash, p2]
- else if v = "" andalso path = ""
- then p2
- else String.concat [v, stripslash path, slash, p2]
- end
- end
+ let
+ fun cutEmptyTail l =
+ List.rev (case List.rev l of ("" :: r) => r | l => l)
+ fun concatArcs (a1, []) = a1
+ | concatArcs (a1, a2) = cutEmptyTail a1 @ a2
+ fun illegalJoin (_ :: _, "" :: _) = true
+ | illegalJoin _ = false
+ in
+ case (fromString p1, fromString p2) of
+ (_, {isAbs=true, ...}) => raise Path
+ | ({isAbs, vol=v1, arcs=a1}, {vol=v2, arcs=a2, ...}) =>
+ if not (volumeMatch (v1, v2))
+ then raise Path
+ else if isWindows andalso illegalJoin (a1, a2)
+ then raise Path
+ else toString { isAbs=isAbs, vol=v1, arcs=concatArcs (a1, a2) }
+ end
fun getParent p =
- let open List
- val {isAbs, vol, arcs} = fromString p
- fun getpar xs =
- rev (case rev xs of
- [] => [parentArc]
- | last :: revrest =>
- if last = ""
- andalso (case revrest of [] => true | _ => false)
- then if isAbs then [] else [parentArc]
- else if last = "" orelse last = "."
- then parentArc :: revrest
- else if last = ".."
- then parentArc :: parentArc :: revrest
- else revrest)
+ let
+ val {isAbs, vol, arcs} = fromString p
+ val newarcs = List.rev (case List.rev arcs of
+ [] => [parentArc]
+ | "." :: r => parentArc :: r
+ | ".." :: r => parentArc :: parentArc :: r
+ | _ :: [] => if isAbs then [""] else [currentArc]
+ | _ :: "" :: [] => ["", ""] (* \ *)
+ | "" :: r => parentArc :: r
+ | _ :: r => r)
in
- case getpar arcs of
- [] =>
- if isAbs then toString {isAbs=true, vol=vol, arcs=[""]}
- else currentArc
- | arcs => toString {isAbs=isAbs, vol=vol, arcs=arcs}
+ toString {isAbs=isAbs, vol=vol, arcs=newarcs}
end
fun mkCanonical p =
let val {isAbs, vol, arcs} = fromString p
+
+ fun canonName a =
+ if isWindows
+ then String.translate (Char.toString o Char.toLower) a
+ else a
+
+ val driveTop = case arcs of "" :: _ => true | _ => false
+ val isRoot = isAbs orelse driveTop
+ val bump = if driveTop andalso not isAbs then [""] else []
+
fun backup l =
case l of
- [] => if isAbs then [] else [parentArc]
+ [] => if isRoot then [] else [parentArc]
| first :: res =>
if first = ".."
then parentArc :: parentArc :: res
else res
+
fun reduce arcs =
let
fun h l res =
case l of
[] => (case res of
- [] => if isAbs then [""] else [currentArc]
- | _ => res)
+ [] => if isRoot then bump @ [""] else [currentArc]
+ | _ => res @ bump)
| a1 :: ar =>
if a1 = "" orelse a1 = "."
then h ar res
else if a1 = ".."
then h ar (backup res)
- else h ar (a1 :: res)
+ else h ar (canonName a1 :: res)
in h arcs [] end
in
- toString {isAbs=isAbs, vol=vol, arcs=List.rev (reduce arcs)}
+ toString {isAbs=isAbs, vol=canonName vol, arcs=List.rev (reduce arcs)}
end
fun parentize [] = []
| parentize (_::ar) = parentArc :: parentize ar
+ fun hackRoot {vol, arcs=""::r, ...} = {isAbs=true, vol=vol, arcs=r}
+ | hackRoot x = x
+
fun mkRelative {path = p1, relativeTo = p2} =
- case (fromString p1, fromString (mkCanonical p2)) of
+ case (hackRoot (fromString p1), hackRoot (fromString (mkCanonical p2))) of
(_ , {isAbs=false,...}) => raise Path
| ({isAbs=false,...}, _ ) => p1
| ({vol=vol1, arcs=arcs1,...}, {vol=vol2, arcs=arcs2, ...}) =>
@@ -191,16 +261,16 @@
if a11=a21 then h a1r a2r
else parentize a2 @ (if arcs1 = [""] then [] else a1)
in
- if vol1 <> vol2 then raise Path
+ if not (volumeMatch (vol2, vol1)) then raise Path
else toString {isAbs=false, vol="", arcs=h arcs1 arcs2}
end
fun mkAbsolute {path = p1, relativeTo = p2} =
if isRelative p2 then raise Path
else if isAbsolute p1 then p1
- else mkCanonical(concat(p2, p1));
+ else mkCanonical (concat (p2, p1))
- fun isCanonical p = mkCanonical p = p;
+ fun isCanonical p = mkCanonical p = p
fun joinDirFile {dir, file} =
if isArc file then concat (dir, file) else raise InvalidArc
@@ -210,16 +280,15 @@
val {isAbs, vol, arcs} = fromString p
in
case rev arcs of
- [] =>
- {dir = toString {isAbs=isAbs, vol=vol, arcs=[]}, file = "" }
+ [] => {dir = p, file = "" }
| arcn :: farcs =>
{dir = toString {isAbs=isAbs, vol=vol, arcs=rev farcs},
file = arcn}
end
- fun dir s = #dir (splitDirFile s);
- fun file s = #file(splitDirFile s);
+ fun dir s = #dir (splitDirFile s)
+ fun file s = #file (splitDirFile s)
fun joinBaseExt {base, ext} =
case ext of
@@ -249,13 +318,24 @@
fun isRoot path =
case fromString path of
- {isAbs = true, arcs= [a], ...} => a = ""
+ {isAbs = true, arcs=[""], ...} => true
+ | {isAbs = false, arcs=["", ""], ...} => isWindows
| _ => false
+
+ fun fromUnixPath s =
+ if not isWindows then s else
+ if not (isArc s) then raise InvalidArc else
+ String.translate (fn c => if c = #"/" then slash else Char.toString c) s
+
+ fun toUnixPath s =
+ if not isWindows then s else
+ let
+ val {arcs, isAbs, vol} = fromString s
+ in
+ if vol <> "" andalso not (volumeHack andalso vol = "/")
+ then raise Path
+ else (if isAbs then "/" else "") ^ String.concatWith "/" arcs
+ end
+
end
-
- (* Since MLton only runs on Unix, there is nothing to do for these.*)
- fun fromUnixPath s = s
- fun toUnixPath s = s
end (*structure Path*)
-
-
--jI8keyz6grp/JLjh--