rel-path: multiple bugs for native Windows.

The first bug is that we are using the spl function with
pat-sep-chars. But spl does not take a set of characters; we
need the sspl function.  Other bugs are handling drive letters
or UNC paths properly on Windows.

* stdlib/copy-file.tl (path-split, path-volume): New
functions.
(rel-path): Split path properly. Diagnose for all bad
combinations of mismatching absolute/relative paths
with or without a volume or incompatible volumes.

1 files changed, 55 insertions, 21 deletions

diff --git a/stdlib/copy-file.tl b/stdlib/copy-file.tl
index c8cbe59f..4e509538 100644
--- a/stdlib/copy-file.tl
+++ b/stdlib/copy-file.tl
@@ -224,28 +224,62 @@
         (t (push c out))))
     (nreverse out)))
 
+(defun path-split (str)
+  (let ((spl0 (sspl path-sep-chars str)))
+    (if (macro-time (find #\\ path-sep-chars))
+      (iflet ((head (car spl0))
+              (p (pos #\: head)))
+        (list* [head 0..(succ p)]
+               [head (succ p)..:]
+               (cdr spl0))
+        spl0)
+      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))))
+      (if (equal head "") :abs))))
+
 (defun rel-path (from to)
-  (unless (eq (abs-path-p from) (abs-path-p to))
-    (error "~s: mixture of absolute and relative paths ~s ~s given"
-           'rel-path from to))
-  (if (macro-time (find #\\ path-sep-chars))
-    (if-match `@{fdrv #/[A-Za-z0-9]+:/}@nil` from
-      (if-match `@{tdrv #/[A-Za-z0-9]+:/}@nil` to
-        (unless (equal fdrv tdrv)
-          (error "~s: paths on different drives ~s ~s given"
-                 'rel-path from to)))))
-  (let* ((fcomp (path-simplify (spl path-sep-chars from)))
-         (tcomp (path-simplify (spl path-sep-chars to)))
-         (ncommon (mismatch fcomp tcomp)))
-    (cond
-      ((null ncommon) ".")
-      ((find ".." (nthcdr ncommon fcomp))
-       (error "~s: from path uses .. to escape common prefix: ~s ~s"
-              'rel-path from to))
-      (t (let ((nup (- (len fcomp) ncommon))
-               (down [tcomp ncommon..:]))
-           (cat-str (append (repeat '("..") nup) down)
-                    [path-sep-chars 0]))))))
+  (let* ((fspl (path-split from))
+         (tspl (path-split to))
+         (fvol (path-volume fspl))
+         (tvol (path-volume tspl)))
+    (when (nequal fvol tvol)
+      (if (and (meq :abs fvol tvol) (meq nil fvol tvol))
+        (error "~s: mixture of absolute and relative paths ~s ~s given"
+               'rel-path from to))
+      (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))))
+    (let* ((fcomp (path-simplify fspl))
+           (tcomp (path-simplify tspl))
+           (ncommon (mismatch fcomp tcomp)))
+      (cond
+        ((null ncommon) ".")
+        ((find ".." (nthcdr ncommon fcomp))
+         (error "~s: from path uses .. to escape common prefix: ~s ~s"
+                'rel-path from to))
+        (t (let ((nup (- (len fcomp) ncommon))
+                 (down [tcomp ncommon..:]))
+             (cat-str (append (repeat '("..") nup) down)
+                      [path-sep-chars 0])))))))
 
 (defun path-equal (left right)
   (cond