From d0abd362814cec0b8e43904a4cb6a0f57ff8d55f Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Mon, 6 Jul 2015 22:57:39 -0400 Subject: [PATCH] Some fixes for CLISP on Windows Fix PROBE-FILE*, make the (executable) image suffix .exe on Windows. --- bundle.lisp | 2 +- uiop/filesystem.lisp | 107 ++++++++++++++++++++++--------------------- 2 files changed, 55 insertions(+), 54 deletions(-) diff --git a/bundle.lisp b/bundle.lisp index b6d40edaa..916374d90 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 422767f1a..94b63a99a 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?" -- GitLab