1 files changed, 94 insertions, 0 deletions
diff --git a/stdlib/path-test.tl b/stdlib/path-test.tl
index 5f28b352..9edbf5b3 100644
--- a/stdlib/path-test.tl
+++ b/stdlib/path-test.tl
@@ -152,6 +152,18 @@
                  (and (all g.mem (orf (op equal name)
                                       (op equal suname))))))))))
 
+(defun path-simplify (comp)
+  (let ((abs (equal (car comp) ""))
+        out)
+    (each ((c comp))
+      (casequal c
+        (".." (if (and (or out abs) (nequal (car out) ".."))
+                (pop out)
+                (push c out)))
+        (("." ""))
+        (t (push c out))))
+    (nreverse out)))
+
 (eval-only
   (defmacro if-windows (then : else)
     (if (eql 2 (sizeof wchar))
@@ -240,3 +252,85 @@
           (casequal ent
             (("." ".."))
             (t (return nil))))))))
+
+(defun path-split (str)
+  (let ((spl0 (sspl path-sep-chars str)))
+    (if-native-windows
+      (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)))
+    (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)
+  (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))
+      (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)))
+      (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)
+  (if (and (stringp left) (equal left right))
+    t
+    (let* ((lspl (path-split left))
+           (rspl (path-split right))
+           (lvol (path-volume lspl))
+           (rvol (path-volume rspl)))
+      (if (nequal lvol rvol)
+        nil
+        (equal (path-simplify lspl)
+               (path-simplify rspl))))))