diff --git a/bundle.lisp b/bundle.lisp index b6d40edaa19bf41a7938d07c360ab62861d3164c..916374d90fbb19e9313dc1d36c34c3f81a8f4542 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -159,7 +159,7 @@ itself.")) ;; operation on a system and its dependencies #+(or clasp ecl) ((member :dll :lib :shared-library :static-library :program :object :program) (compile-file-type :type bundle-type)) - ((member :image) #-allegro "image" #+allegro "dxl") + ((member :image) (or #+allegro "dxl" #+(and clisp os-windows) "exe" "image")) ((member :dll :shared-library) (os-cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll"))) ((member :lib :static-library) (os-cond ((os-unix-p) "a") ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib")))) diff --git a/uiop/filesystem.lisp b/uiop/filesystem.lisp index 422767f1a033402c2cfe654fe130c932f607b372..94b63a99a871f60940d8b607e1306d15f7f27964 100644 --- a/uiop/filesystem.lisp +++ b/uiop/filesystem.lisp @@ -87,59 +87,60 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" probes the filesystem for a file or directory with given pathname. If it exists, return its truename is ENSURE-PATHNAME is true, or the original (parsed) pathname if it is false (the default)." - (with-pathname-defaults () ;; avoids logical-pathname issues on some implementations - (etypecase p - (null nil) - (string (probe-file* (parse-namestring p) :truename truename)) - (pathname - (and (not (wild-pathname-p p)) - (handler-case - (or - #+allegro - (probe-file p :follow-symlinks truename) - #+gcl - (if truename - (truename* p) - (let ((kind (car (si::stat p)))) - (when (eq kind :link) - (setf kind (ignore-errors (car (si::stat (truename* p)))))) - (ecase kind - ((nil) nil) - ((:file :link) - (cond - ((file-pathname-p p) p) - ((directory-pathname-p p) - (subpathname p (car (last (pathname-directory p))))))) - (:directory (ensure-directory-pathname p))))) - #+clisp - #.(flet ((probe (probe) - `(let ((foundtrue ,probe)) - (cond - (truename foundtrue) - (foundtrue p))))) - (let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil))) - (pp (find-symbol* '#:probe-pathname :ext nil)) - (resolve (if pp - `(ignore-errors (,pp p)) - '(or (truename* p) - (truename* (ignore-errors (ensure-directory-pathname p))))))) - (if fs - `(if truename - ,resolve - (and (ignore-errors (,fs p)) p)) - (probe resolve)))) - #-(or allegro clisp gcl) - (if truename - (probe-file p) - (ignore-errors - (let ((pp (physicalize-pathname p))) - (and - #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp)) - #+(and lispworks unix) (system:get-file-stat pp) - #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp)) - #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp) - p))))) - (file-error () nil))))))) + (etypecase p + (null nil) + (string + ;; avoid logical-pathname issues on some implementations + (let ((pn (with-pathname-defaults () (parse-namestring p)))) + (probe-file* pn :truename truename))) + (pathname + (and (not (wild-pathname-p p)) + (handler-case + (or + #+allegro + (probe-file p :follow-symlinks truename) + #+gcl + (if truename + (truename* p) + (let ((kind (car (si::stat p)))) + (when (eq kind :link) + (setf kind (ignore-errors (car (si::stat (truename* p)))))) + (ecase kind + ((nil) nil) + ((:file :link) + (cond + ((file-pathname-p p) p) + ((directory-pathname-p p) + (subpathname p (car (last (pathname-directory p))))))) + (:directory (ensure-directory-pathname p))))) + #+clisp + #.(let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil))) + (pp (find-symbol* '#:probe-pathname :ext nil))) + `(if truename + ,(if pp + `(ignore-errors (,pp p)) + '(or (truename* p) + (truename* (ignore-errors (ensure-directory-pathname p))))) + ,(cond + (fs `(and (ignore-errors (,fs p)) p)) + (pp `(ignore-errors (nth-value 1 (,pp p)))) + (t '(if-let (q (ensure-absolute-pathname p + :defaults 'get-pathname-defaults :on-error nil)) + (or (and (truename* q) q) + (if-let (d (ignore-errors (ensure-directory-pathname q))) + (and (truename* d) d)))))))) + #-(or allegro clisp gcl) + (if truename + (probe-file p) + (ignore-errors + (let ((pp (physicalize-pathname p))) + (and + #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp)) + #+(and lispworks unix) (system:get-file-stat pp) + #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp)) + #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp) + p))))) + (file-error () nil)))))) (defun directory-exists-p (x) "Is X the name of a directory that exists on the filesystem?"