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

More fixes to issues found with LispWorks.

parent 30b84e80
No related branches found
No related tags found
No related merge requests found
......@@ -57,8 +57,7 @@ It notably doesn't work on:
(defun install-asdf-as-module ()
(let ((fasl (asdf-module-fasl)))
(ensure-directories-exist (translate-logical-pathname fasl))
(handler-bind ((warning #'muffle-warning))
(compile-file* (subpathname *asdf-dir* "build/asdf.lisp") :output-file fasl))))
(compile-file (subpathname *asdf-dir* "build/asdf.lisp") :output-file fasl)))
(trace compile-file*)
(install-asdf-as-module)
......@@ -242,6 +242,7 @@ depending on whether *LISP-INTERACTION* is set, enter debugger or die"
"Extract user arguments from command-line invocation of current process.
Assume the calling conventions of a generated script that uses --
if we are not called from a directly executable image."
(declare (ignorable arguments))
#+abcl arguments
;; LispWorks command-line processing isn't transparent to the user, and
;; we need to rely on cl-launch or some other script to set it for us.
......
......@@ -544,6 +544,25 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
;; scheme-specific parts: port username password, not others:
. #.(or #+scl '(:parameters nil :query nil :fragment nil))))
(defun ensure-absolute-pathname (path &optional defaults (on-error 'error))
"Given a pathname designator PATH, return an absolute pathname as specified by PATH
considering the DEFAULTS, or, if not possible, use CALL-FUNCTION on the specified ON-ERROR behavior,
with a format control-string and other arguments as arguments"
(cond
((absolute-pathname-p path))
((stringp path) (ensure-absolute-pathname (pathname path) defaults on-error))
((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path))
((let ((default-pathname (if (pathnamep defaults) defaults (call-function defaults))))
(or (if (absolute-pathname-p default-pathname)
(absolute-pathname-p (merge-pathnames* path default-pathname))
(call-function on-error "Default pathname ~S is not an absolute pathname"
default-pathname))
(call-function on-error "Failed to merge ~S with ~S into an absolute pathname"
path default-pathname))))
(t (call-function on-error
"Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S"
path defaults))))
(defun subpathp (maybe-subpath base-pathname)
"if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that
when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH."
......@@ -558,11 +577,9 @@ when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPA
(defun enough-pathname (maybe-subpath base-pathname)
"if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that
when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH."
(check-type maybe-subpath (or null pathname))
(check-type base-pathname (or null pathname))
(when (pathnamep base-pathname) (assert (absolute-pathname-p base-pathname)))
(or (and base-pathname (subpathp maybe-subpath base-pathname))
maybe-subpath))
(let ((sub (when maybe-subpath (pathname maybe-subpath)))
(base (when base-pathname (ensure-absolute-pathname (pathname base-pathname)))))
(or (and base (subpathp sub base)) sub)))
(defun call-with-enough-pathname (maybe-subpath defaults-pathname thunk)
"In a context where *DEFAULT-PATHNAME-DEFAULTS* is bound to DEFAULTS-PATHNAME (if not null,
......@@ -576,26 +593,7 @@ given DEFAULTS-PATHNAME as a base pathname."
(defaults *default-pathname-defaults*))
&body body)
"Shorthand syntax for CALL-WITH-ENOUGH-PATHNAME"
`(call-with-enough-pathname ,pathname ,defaults #'(lambda (,pathname-var) ,@body)))
(defun ensure-absolute-pathname (path &optional defaults (on-error 'error))
"Given a pathname designator PATH, return an absolute pathname as specified by PATH
considering the DEFAULTS, or, if not possible, use CALL-FUNCTION on the specified ON-ERROR behavior,
with a format control-string and other arguments as arguments"
(cond
((absolute-pathname-p path))
((stringp path) (ensure-absolute-pathname (pathname path) defaults on-error))
((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path))
((let ((default-pathname (if (pathnamep defaults) defaults (call-function defaults))))
(or (if (absolute-pathname-p default-pathname)
(absolute-pathname-p (merge-pathnames* path default-pathname))
(call-function on-error "Default pathname ~S is not an absolute pathname"
default-pathname))
(call-function on-error "Failed to merge ~S with ~S into an absolute pathname"
path default-pathname))))
(t (call-function on-error
"Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S"
path defaults)))))
`(call-with-enough-pathname ,pathname ,defaults #'(lambda (,pathname-var) ,@body))))
;;; Wildcard pathnames
......
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