(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)))