X-Git-Url: http://git.kpe.io/?p=vcs-tree.git;a=blobdiff_plain;f=kmrcl-excerpt.lisp;h=c24bb35438dd1bc8c0c3e1c86e1f2d76d830cb9a;hp=66e6bf18d009b5f6f8e7364ddd341c524b1923ab;hb=HEAD;hpb=5d66ace14bf1d859d364e0004335d1a6800e0d40 diff --git a/kmrcl-excerpt.lisp b/kmrcl-excerpt.lisp index 66e6bf1..c24bb35 100644 --- a/kmrcl-excerpt.lisp +++ b/kmrcl-excerpt.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Sep 2003 ;;;; -;;;; $Id: xlunit.asd 7061 2003-09-07 06:34:45Z kevin $ +;;;; $Id$ ;;;; ************************************************************************* (in-package vcs-tree) @@ -16,11 +16,11 @@ "Opens a reads a file. Returns the contents as a list of strings" (let ((lines '())) (with-open-file (in file :direction :input) - (let ((eof (gensym))) - (do ((line (read-line in nil eof) - (read-line in nil eof))) - ((eq line eof)) - (push line lines))) + (let ((eof (gensym))) + (do ((line (read-line in nil eof) + (read-line in nil eof))) + ((eq line eof)) + (push line lines))) (nreverse lines)))) @@ -35,9 +35,9 @@ (defun flatten (lis) (cond ((atom lis) lis) - ((listp (car lis)) - (append (flatten (car lis)) (flatten (cdr lis)))) - (t (append (list (car lis)) (flatten (cdr lis)))))) + ((listp (car lis)) + (append (flatten (car lis)) (flatten (cdr lis)))) + (t (append (list (car lis)) (flatten (cdr lis)))))) (defun mklist (obj) "Make into list if atom" @@ -46,52 +46,57 @@ (defun directory-tree (filename) "Returns a tree of pathnames for sub-directories of a directory" (let* ((root (canonicalize-directory-name filename)) - (subdirs (loop for path in (directory - (make-pathname :name :wild - :type :wild - :defaults root)) - when (probe-directory path) - collect (canonicalize-directory-name path)))) + (subdirs (loop for path in (directory + (make-pathname :name :wild + :type :wild + :defaults root)) + when (probe-directory path) + collect (canonicalize-directory-name path)))) (when (find nil subdirs) (error "~A" subdirs)) (when (null root) (error "~A" root)) (if subdirs - (cons root (mapcar #'directory-tree subdirs)) - (if (probe-directory root) - (list root) - (error "root not directory ~A" root))))) + (cons root (mapcar #'directory-tree subdirs)) + (if (probe-directory root) + (list root) + (error "root not directory ~A" root))))) (defun canonicalize-directory-name (filename) (flet ((un-unspecific (value) - (if (eq value :unspecific) nil value))) + (if (eq value :unspecific) nil value))) (let* ((path (pathname filename)) - (name (un-unspecific (pathname-name path))) - (type (un-unspecific (pathname-type path))) - (new-dir - (cond ((and name type) (list (concatenate 'string name "." type))) - (name (list name)) - (type (list type)) - (t nil)))) + (name (un-unspecific (pathname-name path))) + (type (un-unspecific (pathname-type path))) + (new-dir + (cond ((and name type) (list (concatenate 'string name "." type))) + (name (list name)) + (type (list type)) + (t nil)))) (if new-dir - (make-pathname - :directory (append (un-unspecific (pathname-directory path)) - new-dir) - :name nil :type nil :version nil :defaults path) - path)))) - + (make-pathname + :directory (append (un-unspecific (pathname-directory path)) + new-dir) + :name nil :type nil :version nil :defaults path) + path)))) + (defun probe-directory (filename) (let ((path (canonicalize-directory-name filename))) #+allegro (excl:probe-directory path) #+clisp (values - (ignore-errors - (#+lisp=cl ext:probe-directory #-lisp=cl lisp:probe-directory - path))) + (ignore-errors + (#+lisp=cl ext:probe-directory #-lisp=cl lisp:probe-directory + path))) #+(or cmu scl) (eq :directory (unix:unix-file-kind (namestring path))) + #+sbcl + (let ((file-kind-fun + (or (find-symbol "NATIVE-FILE-KIND" :sb-impl) + (find-symbol "UNIX-FILE-KIND" :sb-unix)))) + (when (eq :directory (funcall file-kind-fun (namestring path))) + path)) #+lispworks (lw:file-directory-p path) - #+sbcl (eq :directory (sb-unix:unix-file-kind (namestring path))) #-(or allegro clisp cmu lispworks sbcl scl) (probe-file path))) @@ -101,7 +106,7 @@ (cond ((not (null dir)) (when (and (typep dir 'logical-pathname) - (translate-logical-pathname dir)) + (translate-logical-pathname dir)) (setq dir (translate-logical-pathname dir))) (when (stringp dir) (setq dir (parse-namestring dir))) @@ -116,16 +121,16 @@ (setq cl:*default-pathname-defaults* dir)) (t (let ((dir - #+allegro (excl:current-directory) - #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory) - #+(or cmu scl) (ext:default-directory) - #+sbcl (sb-unix:posix-getcwd/) - #+cormanlisp (ccl:get-current-directory) - #+lispworks (hcl:get-working-directory) - #+mcl (ccl:mac-default-directory) - #-(or allegro clisp cmu scl cormanlisp mcl sbcl lispworks) (truename "."))) + #+allegro (excl:current-directory) + #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory) + #+(or cmu scl) (ext:default-directory) + #+sbcl (sb-unix:posix-getcwd/) + #+cormanlisp (ccl:get-current-directory) + #+lispworks (hcl:get-working-directory) + #+mcl (ccl:mac-default-directory) + #-(or allegro clisp cmu scl cormanlisp mcl sbcl lispworks) (truename "."))) (when (stringp dir) - (setq dir (parse-namestring dir))) + (setq dir (parse-namestring dir))) dir)))) @@ -153,17 +158,17 @@ (defun shell-command-output (cmd &key directory whole) #+allegro (excl.osi:command-output cmd :directory directory :whole whole) #+sbcl - (let* ((out (make-array '(0) :element-type 'base-char :fill-pointer 0 - :adjustable t)) - (err (make-array '(0) :element-type 'base-char :fill-pointer 0 - :adjustable t)) - (status - (sb-impl::process-exit-code - (with-output-to-string (out-stream out) - (with-output-to-string (err-stream err) - (sb-ext:run-program - "/bin/sh" - (list "-c" cmd) - :input nil :output out-stream :error err-stream)))))) + (let* ((out (make-array '(0) :element-type 'character :fill-pointer 0 + :adjustable t)) + (err (make-array '(0) :element-type 'character :fill-pointer 0 + :adjustable t)) + (status + (sb-impl::process-exit-code + (with-output-to-string (out-stream out) + (with-output-to-string (err-stream err) + (sb-ext:run-program + "/bin/sh" + (list "-c" cmd) + :input nil :output out-stream :error err-stream)))))) (values out err status)) )