53964 baggles (defun relative-pathname (base path) "Taking two true pathnames, return base relative to path." (let ((base (merge-pathnames base)) (path (merge-pathnames path))) (if (and (eql (pathname-host base) (pathname-host path)) (eql (pathname-device base) (pathname-device path))) (let ((base-directory (copy-list (pathname-directory base))) (path-directory (copy-list (pathname-directory path)))) (loop while (equal (car base-directory) (car path-directory)) do (pop base-directory) (pop path-directory)) (make-pathname :directory (nconc (list :relative) (when base-directory (loop repeat (length base-directory) collecting :up)) path-directory) :defaults path)) path))) WVR> (relative-pathname #P"/a/b/c/" #P"/a/b/d/e") #P"../d/e" WVR> (relative-pathname #P"/a/b/c/" #P"/a/b/c/d/e") #P"d/e" 3408976072 #lispcafe 1 baggles (defun relative-pathname (base path) "Taking two true pathnames, return base relative to path." (let ((base (merge-pathnames base)) (path (merge-pathnames path))) (if (and (eql (pathname-host base) (pathname-host path)) (eql (pathname-device base) (pathname-device path))) (let ((base-directory (pathname-directory base)) (path-directory (pathname-directory path))) (loop while (equal (car base-directory) (car path-directory)) do (pop base-directory) (pop path-directory)) (make-pathname :directory (append (list :relative) (when base-directory (loop repeat (length base-directory) collecting :up)) path-directory) :defaults path)) path))) 3408976282 #lispcafe