|
@@ -30,33 +30,28 @@ BODY on files that match the given extension."
|
30
|
30
|
#',extension-p
|
31
|
31
|
(constantly t))))))
|
32
|
32
|
|
|
33
|
+(define-condition directory-does-not-exist (error)
|
|
34
|
+ ((directory :initarg dir :reader dir))
|
|
35
|
+ (:report (lambda (c stream)
|
|
36
|
+ (format stream "The directory '~A' does not exist" (dir c)))))
|
|
37
|
+
|
|
38
|
+(defun (setf getcwd) (path)
|
|
39
|
+ "Change the operating system's current directory to PATH."
|
|
40
|
+ (setf path (ensure-directory-pathname path))
|
|
41
|
+ (or (and (directory-exists-p path)
|
|
42
|
+ (chdir path))
|
|
43
|
+ (error 'directory-does-not-exist :dir path))
|
|
44
|
+ path)
|
|
45
|
+
|
33
|
46
|
(defmacro with-current-directory (path &body body)
|
34
|
47
|
"Change the current directory to PATH and execute BODY in
|
35
|
48
|
an UNWIND-PROTECT, then change back to the current directory."
|
36
|
49
|
(alexandria:with-gensyms (old)
|
37
|
|
- `(let ((,old (current-directory)))
|
|
50
|
+ `(let ((,old (getcwd)))
|
38
|
51
|
(unwind-protect (progn
|
39
|
|
- (setf (current-directory) ,path)
|
|
52
|
+ (setf (getcwd) ,path)
|
40
|
53
|
,@body)
|
41
|
|
- (setf (current-directory) ,old)))))
|
42
|
|
-
|
43
|
|
-(defun current-directory ()
|
44
|
|
- "Return the operating system's current directory."
|
45
|
|
- #+sbcl (sb-posix:getcwd)
|
46
|
|
- #+ccl (ccl:current-directory)
|
47
|
|
- #+ecl (si:getcwd)
|
48
|
|
- #+cmucl (unix:unix-current-directory)
|
49
|
|
- #+clisp (ext:cd)
|
50
|
|
- #-(or sbcl ccl ecl cmucl clisp) (error "Not implemented yet."))
|
51
|
|
-
|
52
|
|
-(defun (setf current-directory) (path)
|
53
|
|
- "Change the operating system's current directory to PATH."
|
54
|
|
- #+sbcl (sb-posix:chdir path)
|
55
|
|
- #+ccl (setf (ccl:current-directory) path)
|
56
|
|
- #+ecl (si:chdir path)
|
57
|
|
- #+cmucl (unix:unix-chdir (namestring path))
|
58
|
|
- #+clisp (ext:cd path)
|
59
|
|
- #-(or sbcl ccl ecl cmucl clisp) (error "Not implemented yet."))
|
|
54
|
+ (setf (getcwd) ,old)))))
|
60
|
55
|
|
61
|
56
|
(defun exit ()
|
62
|
57
|
"Exit the lisp system returning a 0 status code."
|