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

More fixes to issues found with LispWorks.

parent 30b84e80
Loading
Loading
Loading
Loading
+1 −2
Original line number Diff line number Diff line
@@ -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)
+1 −0
Original line number Diff line number Diff line
@@ -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.
+23 −25
Original line number Diff line number Diff line
@@ -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