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

2.118: allow customization of find-system with :around and :before methods.

Also create a new gf operation-description that allows to pretty-print operations
in the context of retries and logging.
NB: these extension points are used at ITA in qres-build/enhance-asdf.lisp;
previous, ITA overrode operate, which is ugly and bitrotting.
parent f70b13b5
Loading
Loading
Loading
Loading
+37 −16
Original line number Diff line number Diff line
@@ -70,7 +70,7 @@

(eval-when (:load-toplevel :compile-toplevel :execute)
  (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate
          (subseq "VERSION:2.117" (1+ (length "VERSION"))))
          (subseq "VERSION:2.118" (1+ (length "VERSION"))))
         (existing-asdf (find-package :asdf))
         (vername '#:*asdf-version*)
         (versym (and existing-asdf
@@ -384,6 +384,7 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
  (defdef defgeneric* defgeneric)
  (defdef defun* defun))

(defgeneric* find-system (system &optional error-p))
(defgeneric* perform-with-restarts (operation component))
(defgeneric* perform (operation component))
(defgeneric* operation-done-p (operation component))
@@ -391,6 +392,10 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
(defgeneric* output-files (operation component))
(defgeneric* input-files (operation component))
(defgeneric* component-operation-time (operation component))
(defgeneric* operation-description (operation component)
  (:documentation "returns a phrase that describes performing this operation
on this component, e.g. \"loading /a/b/c\".
You can put together sentences using this phrase."))

(defgeneric* system-source-file (system)
  (:documentation "Return the source file in which system is defined."))
@@ -864,7 +869,9 @@ with given pathname and if it exists return its truename."
                     (error-name c) (error-pathname c) (error-condition c)))))

(define-condition circular-dependency (system-definition-error)
  ((components :initarg :components :reader circular-dependency-components)))
  ((components :initarg :components :reader circular-dependency-components))
  (:report (lambda (c s)
             (format s "~@<Circular dependency: ~S~@:>" (circular-dependency-components c)))))

(define-condition duplicate-names (system-definition-error)
  ((name :initarg :name :reader duplicate-names-name))
@@ -1016,7 +1023,8 @@ with given pathname and if it exists return its truename."
             (component-relative-pathname component)
             (pathname-directory-pathname (component-parent-pathname component)))))
        (unless (or (null pathname) (absolute-pathname-p pathname))
          (error "Invalid relative pathname ~S for component ~S" pathname component))
          (error "Invalid relative pathname ~S for component ~S"
                 pathname (component-find-path component)))
        (setf (slot-value component 'absolute-pathname) pathname)
        pathname)))

@@ -1228,10 +1236,12 @@ to ~S which is not a directory.~@:>"
                pathname))
        0)))

(defun* find-system (name &optional (error-p t))
(defmethod find-system (name &optional (error-p t))
  (find-system (coerce-name name) error-p))

(defmethod find-system ((name string) &optional (error-p t))
  (catch 'find-system
    (let* ((name (coerce-name name))
           (in-memory (system-registered-p name))
    (let* ((in-memory (system-registered-p name))
           (on-disk (system-definition-pathname name)))
      (when (and on-disk
                 (or (not in-memory)
@@ -1581,7 +1591,7 @@ recursive calls to traverse.")
      (retry ()
        :report (lambda (s)
                  (format s "~@<Retry loading component ~S.~@:>"
                          required-c))
                          (component-find-path required-c)))
        :test
        (lambda (c)
          #|
@@ -1845,6 +1855,9 @@ recursive calls to traverse.")
  (declare (ignorable operation c))
  nil)

(defmethod operation-description ((operation compile-op) component)
  (declare (ignorable operation component))
  (format nil "compiling component ~S" (component-find-path component)))

;;;; -------------------------------------------------------------------------
;;;; load-op
@@ -1921,6 +1934,11 @@ recursive calls to traverse.")
  (cons (list 'compile-op (component-name c))
        (call-next-method)))

(defmethod operation-description ((operation load-op) component)
  (declare (ignorable operation component))
  (format nil "loading component ~S" (component-find-path component)))


;;;; -------------------------------------------------------------------------
;;;; load-source-op

@@ -1959,6 +1977,10 @@ recursive calls to traverse.")
             (component-property c 'last-loaded-as-source)))
      nil t))

(defmethod operation-description ((operation load-source-op) component)
  (declare (ignorable operation component))
  (format nil "loading component ~S" (component-find-path component)))


;;;; -------------------------------------------------------------------------
;;;; test-op
@@ -2008,14 +2030,13 @@ recursive calls to traverse.")
              (retry ()
                :report
                (lambda (s)
                  (format s "~@<Retry performing ~S on ~S.~@:>"
                          op component)))
                  (format s "~@<Retry ~A.~@:>" (operation-description op component))))
              (accept ()
                :report
                (lambda (s)
                  (format s "~@<Continue, treating ~S on ~S as ~
                  (format s "~@<Continue, treating ~A as ~
                                   having been successful.~@:>"
                          op component))
                          (operation-description op component)))
                (setf (gethash (type-of op)
                               (component-operation-times component))
                      (get-universal-time))
+0 −1
Original line number Diff line number Diff line
@@ -31,7 +31,6 @@
(defmethod find-component :around ((m (eql (find-quux)))
                                   (c string))
  "FIND-COMPONENT on a component is a no-op --- it's already found."
  (declare (ignore version))
  (if (string-equal c "file3-only")
      (asdf:find-system c)
      (call-next-method)))