diff --git a/bin/install-asdf-as-module b/bin/install-asdf-as-module index 62cafaca19240fcc857bc45dd71c334afba1b8f0..39df30a29337ceb7414d860885a6fbe8a69f48b8 100644 --- a/bin/install-asdf-as-module +++ b/bin/install-asdf-as-module @@ -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) diff --git a/uiop/image.lisp b/uiop/image.lisp index 3d9e320a2328aa1af80c06fa86fa4c2b11cb8389..292786c9ca4e25f54bd40c151962955dea352d1a 100644 --- a/uiop/image.lisp +++ b/uiop/image.lisp @@ -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. diff --git a/uiop/pathname.lisp b/uiop/pathname.lisp index edb4ee5e30b55768bcc8c569dc5c28842294205e..87440fc75473c7fa3f05f425153a8e012b2a5d18 100644 --- a/uiop/pathname.lisp +++ b/uiop/pathname.lisp @@ -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