about summary refs log tree commit diff
path: root/third_party/lisp/sclf/directory.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'third_party/lisp/sclf/directory.lisp')
-rw-r--r--third_party/lisp/sclf/directory.lisp216
1 files changed, 108 insertions, 108 deletions
diff --git a/third_party/lisp/sclf/directory.lisp b/third_party/lisp/sclf/directory.lisp
index 4684a8e7056a..3e479c4ac279 100644
--- a/third_party/lisp/sclf/directory.lisp
+++ b/third_party/lisp/sclf/directory.lisp
@@ -29,25 +29,25 @@
   (setf pathname (pathname pathname))
   (if (pathname-name pathname)
       (make-pathname :directory (append (or (pathname-directory pathname)
-					    '(:relative))
-					(list (file-namestring pathname)))
-		     :name nil
-		     :type nil
-		     :defaults pathname)
+                                            '(:relative))
+                                        (list (file-namestring pathname)))
+                     :name nil
+                     :type nil
+                     :defaults pathname)
       pathname))
 
 (defun d+ (path &rest rest)
   "Concatenate directory pathname parts and return a pathname."
   (make-pathname :defaults path
-		 :directory (append (pathname-directory path) rest)))
+                 :directory (append (pathname-directory path) rest)))
 
 (defun delete-directory (pathname)
   "Remove directory PATHNAME.  Return PATHNAME."
   #+cmu (multiple-value-bind (done errno)
-	     (unix:unix-rmdir (namestring pathname))
-	   (unless done
-	     (error "Unable to delete directory ~A (errno=~A)"
-		    pathname errno)))
+             (unix:unix-rmdir (namestring pathname))
+           (unless done
+             (error "Unable to delete directory ~A (errno=~A)"
+                    pathname errno)))
   #+sbcl (sb-posix:rmdir pathname)
   #+lispworks (lw:delete-directory pathname)
   #-(or cmu sbcl)
@@ -60,11 +60,11 @@ to follow symbolic links."
   #-(or sbcl cmu) (declare (ignore truenamep))
   (let (#+cmu (lisp::*ignore-wildcards* t))
     (directory (make-pathname :defaults (pathname-as-directory pathname)
-			      :name :wild
-			      :type :wild
-			      :version :wild)
-	       #+cmu :truenamep #+cmu truenamep
-	       #+sbcl :resolve-symlinks #+sbcl truenamep)))
+                              :name :wild
+                              :type :wild
+                              :version :wild)
+               #+cmu :truenamep #+cmu truenamep
+               #+sbcl :resolve-symlinks #+sbcl truenamep)))
 
 (defun traverse-directory-tree (root-pathname proc &key truenamep test depth-first)
   "Call PROC on all pathnames under ROOT-PATHNAME, both files and
@@ -76,42 +76,42 @@ broken symbolic links in your filesystem."
   (check-type proc (or function symbol))
   (check-type test (or function symbol null))
   (labels ((ls (dir)
-	     (declare (type pathname dir))
-	     (list-directory dir :truenamep truenamep))
-	   (traverse? (file)
-	     (declare (type pathname file))
-	     (and (not (pathname-name file))
-		  (or truenamep
-		      (not (symbolic-link-p file)))
-		  (or (not test)
-		      (funcall test file))))
-	   (traverse-pre-order (dir)
-	     (declare (type pathname dir))
-	     (loop
-		for file in (ls dir)
-		do (funcall proc file)
-		when (traverse? file)
-		do (traverse-pre-order file)))
-	   (traverse-post-order (dir)
-	     (declare (type pathname dir))
-	     (loop
-		for file in (ls dir)
-		when (traverse? file)
-		do (traverse-post-order file)
-		do (funcall proc file))))
+             (declare (type pathname dir))
+             (list-directory dir :truenamep truenamep))
+           (traverse? (file)
+             (declare (type pathname file))
+             (and (not (pathname-name file))
+                  (or truenamep
+                      (not (symbolic-link-p file)))
+                  (or (not test)
+                      (funcall test file))))
+           (traverse-pre-order (dir)
+             (declare (type pathname dir))
+             (loop
+                for file in (ls dir)
+                do (funcall proc file)
+                when (traverse? file)
+                do (traverse-pre-order file)))
+           (traverse-post-order (dir)
+             (declare (type pathname dir))
+             (loop
+                for file in (ls dir)
+                when (traverse? file)
+                do (traverse-post-order file)
+                do (funcall proc file))))
     (if depth-first
-	(traverse-post-order root-pathname)
-	(traverse-pre-order root-pathname))
+        (traverse-post-order root-pathname)
+        (traverse-pre-order root-pathname))
     (values)))
 
 (defmacro do-directory-tree ((file root-pathname &key truenamep test depth-first) &body body)
   "Call TRAVERSE-DIRECTORY-TREE with BODY es procedure."
   `(traverse-directory-tree ,root-pathname
-			    #'(lambda (,file)
-				,@body)
-			    :truenamep ,truenamep
-			    :test ,test
-			    :depth-first ,depth-first))
+                            #'(lambda (,file)
+                                ,@body)
+                            :truenamep ,truenamep
+                            :test ,test
+                            :depth-first ,depth-first))
 
 (defun empty-directory-p (pathname)
   (and (directory-p pathname)
@@ -142,7 +142,7 @@ system.)"
   (be files '()
     (do-directory-tree (file root-pathname :truenamep truenamep)
       (when (funcall matcher-function file)
-	(push file files)))
+        (push file files)))
     (nreverse files)))
 
 (defun delete-directory-tree (pathname)
@@ -156,17 +156,17 @@ this function in your programs."
   (if (pathname-name pathname)
       (delete-file pathname)
       (progn
-	(dolist (file (list-directory pathname))
-	  (delete-directory-tree file))
-	(delete-directory pathname))))
+        (dolist (file (list-directory pathname))
+          (delete-directory-tree file))
+        (delete-directory pathname))))
 
 (defun make-directory (pathname &optional (mode #o777))
   "Create a new directory in the filesystem.  Permissions MODE
 will be assigned to it.  Return PATHNAME."
   #+cmu (multiple-value-bind (done errno)
-	    (unix:unix-mkdir (native-namestring pathname) mode)
-	  (unless done
-	    (error "Unable to create directory ~A (errno=~A)." pathname errno)))
+            (unix:unix-mkdir (native-namestring pathname) mode)
+          (unless done
+            (error "Unable to create directory ~A (errno=~A)." pathname errno)))
   #+sbcl (sb-posix:mkdir pathname mode)
   #-(or cmu sbcl)
   (error "MAKE-DIRECTORY is not implemented for this Lisp system.")
@@ -180,19 +180,19 @@ will be assigned to it.  Return PATHNAME."
   "Just like ENSURE-DIRECTORIES-EXIST but, in some situations,
 it's faster."
   (labels ((ensure (path)
-	     (unless (probe-file path)
-	       (be* tail (last (pathname-directory path) 2)
-		    last (cdr tail)
-		 (setf (cdr tail) nil)
-		 (unwind-protect
-		      (ensure path)
-		   (setf (cdr tail) last))
-		 (make-directory path mode)
-		 (when verbose
-		   (format t "Created ~S~%" path))))))
+             (unless (probe-file path)
+               (be* tail (last (pathname-directory path) 2)
+                    last (cdr tail)
+                 (setf (cdr tail) nil)
+                 (unwind-protect
+                      (ensure path)
+                   (setf (cdr tail) last))
+                 (make-directory path mode)
+                 (when verbose
+                   (format t "Created ~S~%" path))))))
     (ensure (make-pathname :defaults pathname
-			   :name nil :type nil
-			   :version nil))))
+                           :name nil :type nil
+                           :version nil))))
 
 (defun make-temp-directory (&optional (default-pathname *tmp-file-defaults*) (mode #o777))
   "Create a new directory and return its pathname.
@@ -212,7 +212,7 @@ BODY returns.  BODY is _not_ executed within the PATH directory; the
 working directory is never changed."
   `(be ,path (make-temp-directory ,@make-temp-directory-args)
      (unwind-protect
-	  (progn ,@body)
+          (progn ,@body)
        (delete-directory-tree ,path))))
 
 (defun current-directory ()
@@ -229,44 +229,44 @@ are defined."
     ;; we should discard and replace whatever has been defined in any
     ;; rc file during compilation
     (setf (logical-pathname-translations "home")
-	  (list
-	   (list "**;*.*.*"
-		 (make-pathname :defaults home
-				:directory (append (pathname-directory home)
-						   '(:wild-inferiors))
-				:name :wild
-				:type :wild))))))
+          (list
+           (list "**;*.*.*"
+                 (make-pathname :defaults home
+                                :directory (append (pathname-directory home)
+                                                   '(:wild-inferiors))
+                                :name :wild
+                                :type :wild))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defun parse-native-namestring (string &optional host (defaults *default-pathname-defaults*)
-				&key (start 0) end junk-allowed)
+                                &key (start 0) end junk-allowed)
   #+sbcl (sb-ext:parse-native-namestring string host defaults
-					 :start start
-					 :end end
-					 :junk-allowed junk-allowed)
+                                         :start start
+                                         :end end
+                                         :junk-allowed junk-allowed)
   #-sbcl (let (#+cmu(lisp::*ignore-wildcards* t))
-	   (parse-namestring string host defaults
-			     :start start
-			     :end end
-			     :junk-allowed junk-allowed)))
+           (parse-namestring string host defaults
+                             :start start
+                             :end end
+                             :junk-allowed junk-allowed)))
 
 (defun native-namestring (pathname)
   #+sbcl (sb-ext:native-namestring pathname)
   #-sbcl (let (#+cmu (lisp::*ignore-wildcards* t))
-	   (namestring pathname)))
+           (namestring pathname)))
 
 (defun native-file-namestring (pathname)
   #+sbcl (sb-ext:native-namestring
-	  (make-pathname :name (pathname-name pathname)
-			 :type (pathname-type pathname)))
+          (make-pathname :name (pathname-name pathname)
+                         :type (pathname-type pathname)))
   #+cmu (be lisp::*ignore-wildcards* t
-	  (file-namestring pathname)))
+          (file-namestring pathname)))
 
 (defun native-pathname (thing)
   #+sbcl (sb-ext:native-pathname thing)
   #+cmu (be lisp::*ignore-wildcards* t
-	  (pathname thing)))
+          (pathname thing)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -277,9 +277,9 @@ are defined."
 (defun directory-p (pathname)
   "Return true if PATHNAME names a directory on the filesystem."
   #-clisp (awhen (unix-stat (native-namestring pathname))
-	    (bits-set-p (stat-mode it)
-			#+sbcl sb-posix:s-ifdir
-			#+cmu unix:s-ifdir))
+            (bits-set-p (stat-mode it)
+                        #+sbcl sb-posix:s-ifdir
+                        #+cmu unix:s-ifdir))
   #+clisp (ext:probe-directory (pathname-as-directory pathname)))
 
 (defun regular-file-p (pathname)
@@ -287,8 +287,8 @@ are defined."
   #-(or sbcl cmu) (error "don't know how to check whether a file might be a regular file")
   (awhen (unix-stat (native-namestring pathname))
     (bits-set-p (stat-mode it)
-		#+sbcl sb-posix:s-ifreg
-		#+cmu unix:s-ifreg)))
+                #+sbcl sb-posix:s-ifreg
+                #+cmu unix:s-ifreg)))
 
 (defun file-readable-p (pathname)
   #+sbcl (sb-unix:unix-access (native-namestring pathname) sb-unix:r_ok)
@@ -324,27 +324,27 @@ are defined."
 (defun unix-stat (pathname)
   ;; this could be different depending on the unix systems
   (multiple-value-bind (ok? device inode mode links uid gid rdev
-			    size atime mtime ctime
-			    blksize blocks)
+                            size atime mtime ctime
+                            blksize blocks)
       (#+cmu unix:unix-lstat
        #+sbcl sb-unix:unix-lstat
        (if (stringp pathname)
-	   pathname
-	   (native-namestring pathname)))
+           pathname
+           (native-namestring pathname)))
     (declare (ignore rdev))
     (when ok?
       (make-unix-file-stat :device device
-			   :inode inode
-			   :links links
-			   :atime atime
-			   :mtime mtime
-			   :ctime ctime
-			   :size size
-			   :blksize blksize
-			   :blocks blocks
-			   :uid uid
-			   :gid gid
-			   :mode mode))))
+                           :inode inode
+                           :links links
+                           :atime atime
+                           :mtime mtime
+                           :ctime ctime
+                           :size size
+                           :blksize blksize
+                           :blocks blocks
+                           :uid uid
+                           :gid gid
+                           :mode mode))))
 
 (defun stat-modification-time (stat)
   "Return the modification time of the STAT structure as Lisp
@@ -383,9 +383,9 @@ contents."
 (defun symbolic-link-p (pathname)
   #-(or sbcl cmu) (error "don't know hot to test for symbolic links.")
   (aand (unix-stat pathname)
-	(bits-set-p (stat-mode it)
-		    #+sbcl sb-posix:s-iflnk
-		    #+cmu unix:s-iflnk)))
+        (bits-set-p (stat-mode it)
+                    #+sbcl sb-posix:s-iflnk
+                    #+cmu unix:s-iflnk)))
 
 (defun broken-link-p (pathname)
  (when (symbolic-link-p pathname)