Skip to content
Snippets Groups Projects
Commit a4fdf6f9 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Adopt for XCL same chdir pseudo-implementation as for ABCL.

parent 1ba453f8
No related branches found
No related tags found
No related merge requests found
...@@ -7,14 +7,12 @@ ...@@ -7,14 +7,12 @@
:output '(:string :stripped t)) :output '(:string :stripped t))
:ensure-directory t)) :ensure-directory t))
(with-expected-failure (#+xcl "chdir unsupported") (chdir *asdf-directory*)
(chdir *asdf-directory*) (assert (pathname-equal *asdf-directory* (getcwd)))
(assert (pathname-equal *asdf-directory* (getcwd))) (assert (pathname-equal *asdf-directory* (getcwd-from-run-program)))
(assert (pathname-equal *asdf-directory* (getcwd-from-run-program))) (assert (probe-file* "asdf.asd"))
(assert (probe-file* "asdf.asd")))
(chdir *test-directory*)
(with-expected-failure (#+xcl "chdir unsupported")
(chdir *test-directory*))
(assert (pathname-equal *test-directory* (getcwd))) (assert (pathname-equal *test-directory* (getcwd)))
(assert (pathname-equal *test-directory* (getcwd-from-run-program))) (assert (pathname-equal *test-directory* (getcwd-from-run-program)))
(assert (probe-file* "test-utilities.script")) (assert (probe-file* "test-utilities.script"))
......
...@@ -271,7 +271,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie ...@@ -271,7 +271,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
(defun getcwd () (defun getcwd ()
"Get the current working directory as per POSIX getcwd(3), as a pathname object" "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) #+allegro (excl::current-directory)
#+clisp (ext:default-directory) #+clisp (ext:default-directory)
#+clozure (ccl:current-directory) #+clozure (ccl:current-directory)
...@@ -289,7 +289,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie ...@@ -289,7 +289,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
(defun chdir (x) (defun chdir (x)
"Change current directory, as per POSIX chdir(2), to a given pathname object" "Change current directory, as per POSIX chdir(2), to a given pathname object"
(if-let (x (pathname x)) (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) #+allegro (excl:chdir x)
#+clisp (ext:cd x) #+clisp (ext:cd x)
#+clozure (setf (ccl:current-directory) 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 ...@@ -301,7 +301,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
#+lispworks (hcl:change-directory x) #+lispworks (hcl:change-directory x)
#+mkcl (mk-ext:chdir x) #+mkcl (mk-ext:chdir x)
#+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring 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")))) (error "chdir not supported on your implementation"))))
......
...@@ -204,10 +204,10 @@ when merging, making or parsing pathnames") ...@@ -204,10 +204,10 @@ when merging, making or parsing pathnames")
(defmacro with-pathname-defaults ((&optional defaults) &body body) (defmacro with-pathname-defaults ((&optional defaults) &body body)
"Execute BODY in a context where the *DEFAULT-PATHNAME-DEFAULTS* is as specified, "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 leaving the defaults NIL or unspecified means a (NIL-PATHNAME), except
where it remains unchanged for it doubles as current-directory." on ABCL, Genera and XCL, where it remains unchanged for it doubles as current-directory."
`(let ((*default-pathname-defaults* `(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))) ,@body)))
......
...@@ -758,7 +758,7 @@ It returns a process-info plist with possible keys: ...@@ -758,7 +758,7 @@ It returns a process-info plist with possible keys:
(escape-shell-token (native-namestring pathname))))))) (escape-shell-token (native-namestring pathname)))))))
(let* ((redirections (append (redirect in " <") (redirect out " >") (redirect err " 2>"))) (let* ((redirections (append (redirect in " <") (redirect out " >") (redirect err " 2>")))
(normalized (%normalize-system-command command)) (normalized (%normalize-system-command command))
(directory (or directory #+abcl (getcwd))) (directory (or directory #+(or abcl xcl) (getcwd)))
(chdir (when directory (chdir (when directory
(let ((dir-arg (escape-shell-token (native-namestring directory)))) (let ((dir-arg (escape-shell-token (native-namestring directory))))
(os-cond (os-cond
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment