From a4fdf6f997f02aed74606427332fa3a4a5c862f6 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Thu, 7 May 2015 23:16:24 -0400
Subject: [PATCH] Adopt for XCL same chdir pseudo-implementation as for ABCL.

---
 test/test-utilities.script | 14 ++++++--------
 uiop/os.lisp               |  6 +++---
 uiop/pathname.lisp         |  6 +++---
 uiop/run-program.lisp      |  2 +-
 4 files changed, 13 insertions(+), 15 deletions(-)

diff --git a/test/test-utilities.script b/test/test-utilities.script
index 2e0f0bfd..310451d3 100644
--- a/test/test-utilities.script
+++ b/test/test-utilities.script
@@ -7,14 +7,12 @@
     :output '(:string :stripped t))
    :ensure-directory t))
 
-(with-expected-failure (#+xcl "chdir unsupported")
-  (chdir *asdf-directory*)
-  (assert (pathname-equal *asdf-directory* (getcwd)))
-  (assert (pathname-equal *asdf-directory* (getcwd-from-run-program)))
-  (assert (probe-file* "asdf.asd")))
-
-(with-expected-failure (#+xcl "chdir unsupported")
-  (chdir *test-directory*))
+(chdir *asdf-directory*)
+(assert (pathname-equal *asdf-directory* (getcwd)))
+(assert (pathname-equal *asdf-directory* (getcwd-from-run-program)))
+(assert (probe-file* "asdf.asd"))
+
+(chdir *test-directory*)
 (assert (pathname-equal *test-directory* (getcwd)))
 (assert (pathname-equal *test-directory* (getcwd-from-run-program)))
 (assert (probe-file* "test-utilities.script"))
diff --git a/uiop/os.lisp b/uiop/os.lisp
index 66d6fc6f..bc36d918 100644
--- a/uiop/os.lisp
+++ b/uiop/os.lisp
@@ -271,7 +271,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
 
   (defun getcwd ()
     "Get the current working directory as per POSIX getcwd(3), as a pathname object"
-    (or #+(or abcl genera) (truename *default-pathname-defaults*) ;; d-p-d is canonical!
+    (or #+(or abcl genera xcl) (truename *default-pathname-defaults*) ;; d-p-d is canonical!
         #+allegro (excl::current-directory)
         #+clisp (ext:default-directory)
         #+clozure (ccl:current-directory)
@@ -289,7 +289,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
   (defun chdir (x)
     "Change current directory, as per POSIX chdir(2), to a given pathname object"
     (if-let (x (pathname x))
-      #+(or abcl genera) (setf *default-pathname-defaults* (truename x)) ;; d-p-d is canonical!
+      #+(or abcl genera xcl) (setf *default-pathname-defaults* (truename x)) ;; d-p-d is canonical!
       #+allegro (excl:chdir x)
       #+clisp (ext:cd x)
       #+clozure (setf (ccl:current-directory) x)
@@ -301,7 +301,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
       #+lispworks (hcl:change-directory x)
       #+mkcl (mk-ext:chdir x)
       #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x)))
-      #-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl genera lispworks mkcl sbcl scl)
+      #-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl genera lispworks mkcl sbcl scl xcl)
       (error "chdir not supported on your implementation"))))
 
 
diff --git a/uiop/pathname.lisp b/uiop/pathname.lisp
index debc5c69..d8f7ce5e 100644
--- a/uiop/pathname.lisp
+++ b/uiop/pathname.lisp
@@ -204,10 +204,10 @@ when merging, making or parsing pathnames")
 
   (defmacro with-pathname-defaults ((&optional defaults) &body body)
     "Execute BODY in a context where the *DEFAULT-PATHNAME-DEFAULTS* is as specified,
-where leaving the defaults NIL or unspecified means a (NIL-PATHNAME), except on ABCL and Genera,
-where it remains unchanged for it doubles as current-directory."
+where leaving the defaults NIL or unspecified means a (NIL-PATHNAME), except
+on ABCL, Genera and XCL, where it remains unchanged for it doubles as current-directory."
     `(let ((*default-pathname-defaults*
-             ,(or defaults #-(or abcl genera) '*nil-pathname* #+(or abcl genera) '*default-pathname-defaults*)))
+             ,(or defaults #-(or abcl genera xcl) '*nil-pathname* #+(or abcl genera) '*default-pathname-defaults*)))
        ,@body)))
 
 
diff --git a/uiop/run-program.lisp b/uiop/run-program.lisp
index fa4d3961..47d2bc39 100644
--- a/uiop/run-program.lisp
+++ b/uiop/run-program.lisp
@@ -758,7 +758,7 @@ It returns a process-info plist with possible keys:
                        (escape-shell-token (native-namestring pathname)))))))
       (let* ((redirections (append (redirect in " <") (redirect out " >") (redirect err " 2>")))
              (normalized (%normalize-system-command command))
-             (directory (or directory #+abcl (getcwd)))
+             (directory (or directory #+(or abcl xcl) (getcwd)))
              (chdir (when directory
                       (let ((dir-arg (escape-shell-token (native-namestring directory))))
                         (os-cond
-- 
GitLab