実践Common Lispを読んでみる9

実践Common Lisp

動いたじゃん、昨日のソース。なにを勘違いしていたんだろう。
で、今日書いたソースコードがやっぱりうまく動かないので明日のおれ、がんばれ。
今日は、15章、パスネーム可搬ライブラリを読破。このペースでいければ、４月には読破できそうだ。
ちなみに、動作確認はemacs+slimeにsbcl。他の環境では試していません。悪しからず。
以下、ソースコード

(defun list-directory (dirname)
  (when (wild-pathname-p dirname)
    (error "Can only list concrete directory names."))
  (let ((wildcard (directory-wildcard dirname)))
    #+(or sbcl cmu lispworks)
    (directory wildcard)
    #+openmcl
    (directory wildcard :directories t)
    #+allegro
    (directory wildcard :directories-are-files nil)
    #+clisp
    (nconc
     (directory wildcard)
     (directory (clisp-subdirectories-wildcard wildcard)))
    #-(or sbcl cmu lispworks openmcl allegro clisp)
    (error "list-directory not implemented.")))
(defun file-exists-p (pathname)
  #+(or sbcl lispworks openmcl)
  (probe-file pathname)
  #+(or allegro cmu)
  (or (probe-file (pathname-as-directory pathname))
      (probe-file pathname))
  #+clisp
  (or (ignore-errors
	(probe-file (pathname-as-file pathname)))
      (ignore-errors
	(let ((directory-form (pathname-as-directory pathname)))
	  (when (ext:probe-directory directory-form)
	    directory-form))))
  #-(or sbcl cmu lispworks openmcl allegro clisp)
  (error "file-exists-p not implemented."))
;; CL-USER> (list-directory "/")
;; (#P"/AdobeReader.desktop" #P"/bin/" #P"/boot/"
;;  #P"/boot/initrd.img-2.6.27-11-generic"
;;  #P"/boot/initrd.img-2.6.27-9-generic" #P"/boot/vmlinuz-2.6.27-11-generic"
;;  #P"/boot/vmlinuz-2.6.27-9-generic" #P"/dev/" #P"/etc/" #P"/home/"
;;  #P"/initrd/" #P"/lib/" #P"/lost+found/" #P"/media/" #P"/media/cdrom0/"
;;  #P"/mnt/" #P"/opt/" #P"/proc/" #P"/root/" #P"/sbin/" #P"/share/"
;;  #P"/srv/" #P"/sys/" #P"/tmp/" #P"/usr/" #P"/var/")
;; ;;;; (defun file-exists-p (pathname)   #+(or sbcl lispworks openm ...
;; CL-USER> (file-exists-p "/home/veleno")
;; #P"/home/veleno/"
(defun pathname-as-file (name)
  (let ((pathname (pathname name)))
    (when (wild-pathname-p pathname)
      (error "Can't reliably convert wild pathnames."))
    (if (directory-pathname-p name)
	(let* ((directory (pathname-directory pathname))
	       (name-and-type (pathname (first (last directory)))))
	  (make-pathname
	   :directory (butlast directory)
	   :name (pathname-name name-and-type)
	   :type (pathname-type name-and-type)
	   :defaults pathname))
	pathname)))
(defun walk-directory (dirname fn &key directories (test (constantly t)))
  (labels
      ((walk (name)
	 (cond
	   ((directory-pathname-p name)
	    (when (and directories (funcall test name))
	      (funcall fn name))
	    (dolist (x (list-directory name)) (walk x)))
	   ((funcall test name) (funcall fn name)))))
    (walk (pathname-as-directory dirname))))

http://dl.getdropbox.com/u/228440/veleno-samples/lisp-samples/sample.lisp