Commit d0abd362 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Some fixes for CLISP on Windows

Fix PROBE-FILE*, make the (executable) image suffix .exe on Windows.
parent 405e2b37
...@@ -159,7 +159,7 @@ itself.")) ;; operation on a system and its dependencies ...@@ -159,7 +159,7 @@ itself.")) ;; operation on a system and its dependencies
#+(or clasp ecl) #+(or clasp ecl)
((member :dll :lib :shared-library :static-library :program :object :program) ((member :dll :lib :shared-library :static-library :program :object :program)
(compile-file-type :type bundle-type)) (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 :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") ((member :lib :static-library) (os-cond ((os-unix-p) "a")
((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib")))) ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib"))))
......
...@@ -87,59 +87,60 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" ...@@ -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. probes the filesystem for a file or directory with given pathname.
If it exists, return its truename is ENSURE-PATHNAME is true, If it exists, return its truename is ENSURE-PATHNAME is true,
or the original (parsed) pathname if it is false (the default)." or the original (parsed) pathname if it is false (the default)."
(with-pathname-defaults () ;; avoids logical-pathname issues on some implementations (etypecase p
(etypecase p (null nil)
(null nil) (string
(string (probe-file* (parse-namestring p) :truename truename)) ;; avoid logical-pathname issues on some implementations
(pathname (let ((pn (with-pathname-defaults () (parse-namestring p))))
(and (not (wild-pathname-p p)) (probe-file* pn :truename truename)))
(handler-case (pathname
(or (and (not (wild-pathname-p p))
#+allegro (handler-case
(probe-file p :follow-symlinks truename) (or
#+gcl #+allegro
(if truename (probe-file p :follow-symlinks truename)
(truename* p) #+gcl
(let ((kind (car (si::stat p)))) (if truename
(when (eq kind :link) (truename* p)
(setf kind (ignore-errors (car (si::stat (truename* p)))))) (let ((kind (car (si::stat p))))
(ecase kind (when (eq kind :link)
((nil) nil) (setf kind (ignore-errors (car (si::stat (truename* p))))))
((:file :link) (ecase kind
(cond ((nil) nil)
((file-pathname-p p) p) ((:file :link)
((directory-pathname-p p) (cond
(subpathname p (car (last (pathname-directory p))))))) ((file-pathname-p p) p)
(:directory (ensure-directory-pathname p))))) ((directory-pathname-p p)
#+clisp (subpathname p (car (last (pathname-directory p)))))))
#.(flet ((probe (probe) (:directory (ensure-directory-pathname p)))))
`(let ((foundtrue ,probe)) #+clisp
(cond #.(let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil)))
(truename foundtrue) (pp (find-symbol* '#:probe-pathname :ext nil)))
(foundtrue p))))) `(if truename
(let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil))) ,(if pp
(pp (find-symbol* '#:probe-pathname :ext nil)) `(ignore-errors (,pp p))
(resolve (if pp '(or (truename* p)
`(ignore-errors (,pp p)) (truename* (ignore-errors (ensure-directory-pathname p)))))
'(or (truename* p) ,(cond
(truename* (ignore-errors (ensure-directory-pathname p))))))) (fs `(and (ignore-errors (,fs p)) p))
(if fs (pp `(ignore-errors (nth-value 1 (,pp p))))
`(if truename (t '(if-let (q (ensure-absolute-pathname p
,resolve :defaults 'get-pathname-defaults :on-error nil))
(and (ignore-errors (,fs p)) p)) (or (and (truename* q) q)
(probe resolve)))) (if-let (d (ignore-errors (ensure-directory-pathname q)))
#-(or allegro clisp gcl) (and (truename* d) d))))))))
(if truename #-(or allegro clisp gcl)
(probe-file p) (if truename
(ignore-errors (probe-file p)
(let ((pp (physicalize-pathname p))) (ignore-errors
(and (let ((pp (physicalize-pathname p)))
#+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp)) (and
#+(and lispworks unix) (system:get-file-stat pp) #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp))
#+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp)) #+(and lispworks unix) (system:get-file-stat pp)
#-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp) #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
p))))) #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)
(file-error () nil))))))) p)))))
(file-error () nil))))))
(defun directory-exists-p (x) (defun directory-exists-p (x)
"Is X the name of a directory that exists on the filesystem?" "Is X the name of a directory that exists on the filesystem?"
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment