From 32b945abf23928e432d5c01d51c48806bd947876 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <fare@tunes.org>
Date: Sat, 17 Sep 2016 11:44:09 -0400
Subject: [PATCH] UIOP: Fix long-standing pathname issue on CLISP

Make ENSURE-DIRECTORY-PATHNAME and TRUENAME* more robust in case
MAKE-PATHNAME throws an error when trying to synthetize a pathname
with components that the implementation considers invalid.

Uncomment the proper definition of LISP-IMPLEMENTATION-DIRECTORY on CLISP,
which now doesn't break asdf-pathname-test anymore.
---
 uiop/filesystem.lisp |  4 ++--
 uiop/pathname.lisp   | 12 +++++++-----
 2 files changed, 9 insertions(+), 7 deletions(-)

diff --git a/uiop/filesystem.lisp b/uiop/filesystem.lisp
index 7f1e199c2..a04334a9a 100644
--- a/uiop/filesystem.lisp
+++ b/uiop/filesystem.lisp
@@ -71,7 +71,7 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
        (or (ignore-errors (truename p))
            ;; this is here because trying to find the truename of a directory pathname WITHOUT supplying
            ;; a trailing directory separator, causes an error on some lisps.
-           #+(or clisp gcl) (if-let (d (ensure-directory-pathname p)) (ignore-errors (truename d)))))))
+           #+(or clisp gcl) (if-let (d (ensure-directory-pathname p nil)) (ignore-errors (truename d)))))))
 
   (defun safe-file-write-date (pathname)
     "Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error."
@@ -546,7 +546,7 @@ NILs."
     (let ((dir
             #+abcl extensions:*lisp-home*
             #+(or allegro clasp ecl mkcl) #p"SYS:"
-            ;;#+clisp custom:*lib-directory* ; causes failure in asdf-pathname-test(!)
+            #+clisp custom:*lib-directory*
             #+clozure #p"ccl:"
             #+cmucl (ignore-errors (pathname-parent-directory-pathname (truename #p"modules:")))
             #+gcl system::*system-directory*
diff --git a/uiop/pathname.lisp b/uiop/pathname.lisp
index 2d618a58e..15af1fb4b 100644
--- a/uiop/pathname.lisp
+++ b/uiop/pathname.lisp
@@ -326,11 +326,13 @@ actually-existing directory."
       ((directory-pathname-p pathspec)
        pathspec)
       (t
-       (make-pathname :directory (append (or (normalize-pathname-directory-component
-                                              (pathname-directory pathspec))
-                                             (list :relative))
-                                         (list (file-namestring pathspec)))
-                      :name nil :type nil :version nil :defaults pathspec)))))
+       (handler-case
+           (make-pathname :directory (append (or (normalize-pathname-directory-component
+                                                  (pathname-directory pathspec))
+                                                 (list :relative))
+                                             (list (file-namestring pathspec)))
+                          :name nil :type nil :version nil :defaults pathspec)
+         (error (c) (call-function on-error (compatfmt "~@<error while trying to create a directory pathname for ~S: ~A~@:>") pathspec c)))))))
 
 
 ;;; Parsing filenames
-- 
GitLab