Skip to content
Snippets Groups Projects
Commit b9070f45 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Reinstate some GCL support.

parent 614279d4
No related branches found
No related tags found
No related merge requests found
...@@ -35,7 +35,7 @@ Some constraints: ...@@ -35,7 +35,7 @@ Some constraints:
(declaim (optimize (speed 2) (safety #-gcl 3 #+gcl 0) #-(or allegro gcl genera) (debug 3) (declaim (optimize (speed 2) (safety #-gcl 3 #+gcl 0) #-(or allegro gcl genera) (debug 3)
#+(or cmu scl) (c::brevity 2))) #+(or cmu scl) (c::brevity 2)))
(proclaim '(optimize (speed 2) (safety #-gcl 3 #+gcl 0) #-(or allegro gcl genera) (debug 3) (proclaim '(optimize (speed #-gcl 2 #+gcl 0) (safety #-gcl 3 #+gcl 0) #-(or allegro gcl genera) (debug 3)
#+(or cmu scl) (c::brevity 2))) #+(or cmu scl) (c::brevity 2)))
(defvar *trace-symbols* (defvar *trace-symbols*
......
...@@ -65,7 +65,8 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" ...@@ -65,7 +65,8 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
(defun truename* (p) (defun truename* (p)
"Nicer variant of TRUENAME that plays well with NIL and avoids logical pathname contexts" "Nicer variant of TRUENAME that plays well with NIL and avoids logical pathname contexts"
;; avoids both logical-pathname merging and physical resolution issues ;; avoids both logical-pathname merging and physical resolution issues
(and p (handler-case (with-pathname-defaults () (truename p)) (file-error () nil)))) (and p (handler-case (with-pathname-defaults () (truename p))
(#-gcl file-error #+gcl error () nil))))
(defun safe-file-write-date (pathname) (defun safe-file-write-date (pathname)
"Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error." "Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error."
...@@ -107,7 +108,7 @@ or the original (parsed) pathname if it is false (the default)." ...@@ -107,7 +108,7 @@ or the original (parsed) pathname if it is false (the default)."
#+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp)) #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
#-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp) #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)
p)))) p))))
#+clisp #+(or clisp gcl)
#.(flet ((probe (probe) #.(flet ((probe (probe)
`(let ((foundtrue ,probe)) `(let ((foundtrue ,probe))
(cond (cond
...@@ -124,8 +125,11 @@ or the original (parsed) pathname if it is false (the default)." ...@@ -124,8 +125,11 @@ or the original (parsed) pathname if it is false (the default)."
`(if truename `(if truename
,resolve ,resolve
(and (ignore-errors (,fs p)) p)) (and (ignore-errors (,fs p)) p))
(probe resolve))))) (probe resolve)))
(file-error () nil))))))) #+gcl
(probe '(or (probe-file p)
(truename* (ensure-directory-pathname p))))))
(#-gcl file-error #+gcl 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?"
...@@ -523,7 +527,7 @@ in an atomic way if the implementation allows." ...@@ -523,7 +527,7 @@ in an atomic way if the implementation allows."
(defun delete-file-if-exists (x) (defun delete-file-if-exists (x)
"Delete a file X if it already exists" "Delete a file X if it already exists"
(when x (handler-case (delete-file x) (file-error () nil)))) (when x (handler-case (delete-file x) (#-gcl file-error #+gcl error () nil))))
(defun delete-empty-directory (directory-pathname) (defun delete-empty-directory (directory-pathname)
"Delete an empty directory" "Delete an empty directory"
......
...@@ -591,7 +591,7 @@ possibly in a different process. Otherwise just call THUNK." ...@@ -591,7 +591,7 @@ possibly in a different process. Otherwise just call THUNK."
(defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) (defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
"Variant of COMPILE-FILE-PATHNAME that works well with COMPILE-FILE*" "Variant of COMPILE-FILE-PATHNAME that works well with COMPILE-FILE*"
(let* ((keys (let* ((keys
(remove-plist-keys `(#+(and allegro (not (version>= 8 2))) :external-format (remove-plist-keys `(#+(or (and allegro (not (version>= 8 2))) gcl) :external-format
,@(unless output-file '(:output-file))) keys))) ,@(unless output-file '(:output-file))) keys)))
(if (absolute-pathname-p output-file) (if (absolute-pathname-p output-file)
;; what cfp should be doing, w/ mp* instead of mp ;; what cfp should be doing, w/ mp* instead of mp
...@@ -629,7 +629,7 @@ it will filter them appropriately." ...@@ -629,7 +629,7 @@ it will filter them appropriately."
'compile-file* output-file object-file) 'compile-file* output-file object-file)
(rotatef output-file object-file)) (rotatef output-file object-file))
(let* ((keywords (remove-plist-keys (let* ((keywords (remove-plist-keys
`(:output-file :compile-check :warnings-file `(:output-file :compile-check :warnings-file #+gcl :external-format
#+clisp :lib-file #+(or ecl mkcl) :object-file) keys)) #+clisp :lib-file #+(or ecl mkcl) :object-file) keys))
(output-file (output-file
(or output-file (or output-file
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment