rel-path, path-equal: native Windows fixes.

The checks for native Windows are incorrect, plus there
are some issues in the path-volume function.

We cannot check for native Windows at macro-expansion time simply by
calling (find #\\ path-sep-chars) because we compile on Cygwin where
that is false. What we must do is check for being on Windows at
macro-expansion time, and then in the "yes" branch of that decision, the
code must perform the path-sep-char test at run-time. In the "no"
branch, we can output smaller code that doesn't deal with Windows.

* stdlib/copy-file.tl (if-windows, if-native-windows): New macro, which
give a clear syntax to the above described testing.
(path-split): Use if-native-windows.
(path-volume): Use if-native-windows. In addition, fix some broken
tests. The tests for a UNC path "//whatever" cannot just test that the
first components are "", because that also matches the path "/".
It has t be that the first two components are "", and there are more
components. A similar issue occurs in the situation when there is
a drive letter. We cannot conclude that if the component after the
drive letter is "", then it's a drive absolute path, because that
situation occurs in a path like "c:" which is relative.
We also destructively manipulate the path to splice out the volume
part and turn it into a simple relative or absolute path. This is
because the path-simplify function deosn't deal with the volume prefix;
its logic like eliminating .. navigations from root do not work if the
prefix component is present.
(rel-path): We handle a missing error case here: one path has volume
prefix and the other doesn't. Also the error cases that can only occur
on Windows are wrapped with if-windows to remove them at compile time.

1 files changed, 43 insertions, 19 deletions

diff --git a/stdlib/copy-file.tl b/stdlib/copy-file.tl
index 258192fc..3198b76e 100644
--- a/stdlib/copy-file.tl
+++ b/stdlib/copy-file.tl
@@ -225,9 +225,20 @@
         (t (push c out))))
     (nreverse out)))
 
+(eval-only
+  (defmacro if-windows (then : else)
+    (if (eql 2 (sizeof wchar))
+      then
+      else))
+
+  (defmacro if-native-windows (then else)
+    (if-windows
+      ^(if (find #\\ path-sep-chars) ,then ,else)
+      else)))
+
 (defun path-split (str)
   (let ((spl0 (sspl path-sep-chars str)))
-    (if (macro-time (find #\\ path-sep-chars))
+    (if-native-windows
       (iflet ((head (car spl0))
               (p (pos #\: head)))
         (list* [head 0..(succ p)]
@@ -237,18 +248,25 @@
       spl0)))
 
 (defun path-volume (comp)
-  (let ((head (car comp))
-        (next (cadr comp)))
-    (if (macro-time (find #\\ path-sep-chars))
-      (cond
-        ((and (equal head "") (equal next ""))
-         (let ((vol (caddr comp)))
-           (if (nequal "" vol) vol :abs)))
-        ((equal head "") :abs)
-        ((and (m^ #/[A-Za-z0-9]+:/ head) head)
-         (if (equal "" next)
-           ^(:abs . ,head)
-           ^(:rel . ,head))))
+  (let ((head (car comp)))
+    (if-native-windows
+      (let ((next (cadr comp))
+            (more (cddr comp)))
+        (cond
+          ((and (equal head "") (equal next "") more)
+           (let ((vol (car more)))
+	     (cond
+	       ((nequal "" vol)
+		(set (car comp) "")
+		(set (cdr comp) (cdr more))
+		vol)
+	       (t :abs))))
+          ((and (m^ #/[A-Za-z0-9]+:/ head) head)
+           (set (car comp) next)
+           (set (cdr comp) more)
+           (if (and (equal "" next) more)
+             ^(:abs . ,head)
+             ^(:rel . ,head)))))
       (if (equal head "") :abs))))
 
 (defun rel-path (from to)
@@ -263,12 +281,18 @@
       (if (meq :abs fvol tvol)
         (error "~s: mixture of absolute and volume paths ~s ~s given"
                'rel-path from to))
-      (when (and (consp fvol) (consp tvol))
-        (if (neq (car fvol) (car tvol))
-          (error "~s: mixture of volume absolute and relative paths ~s ~s given"
-                 'rel-path from to)
-          (error "~s: paths on different volumes ~s ~s given"
-                 'rel-path from to))))
+      (if-windows
+        (progn
+          (when (and (consp fvol) (consp tvol))
+            (if (neq (car fvol) (car tvol))
+              (error "~s: mixture of volume absolute and relative paths \
+                     \ ~s ~s given"
+                     'rel-path from to)))
+        (when (neq (null fvol) (null tvol))
+          (error "~s: mixture of volume and non-volume paths ~s ~s given"
+                 'rel-path from to))
+        (error "~s: paths on different volumes ~s ~s given"
+               'rel-path from to))))
     (let* ((fcomp (path-simplify fspl))
            (tcomp (path-simplify tspl))
            (ncommon (mismatch fcomp tcomp)))