Skip to content
Snippets Groups Projects
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
No related branches found
No related tags found
No related merge requests found
...@@ -70,7 +70,7 @@ ...@@ -70,7 +70,7 @@
(eval-when (:load-toplevel :compile-toplevel :execute) (eval-when (:load-toplevel :compile-toplevel :execute)
(let* ((asdf-version ;; the 1+ helps the version bumping script discriminate (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)) (existing-asdf (find-package :asdf))
(vername '#:*asdf-version*) (vername '#:*asdf-version*)
(versym (and existing-asdf (versym (and existing-asdf
...@@ -384,6 +384,7 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when ...@@ -384,6 +384,7 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
(defdef defgeneric* defgeneric) (defdef defgeneric* defgeneric)
(defdef defun* defun)) (defdef defun* defun))
(defgeneric* find-system (system &optional error-p))
(defgeneric* perform-with-restarts (operation component)) (defgeneric* perform-with-restarts (operation component))
(defgeneric* perform (operation component)) (defgeneric* perform (operation component))
(defgeneric* operation-done-p (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 ...@@ -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* output-files (operation component))
(defgeneric* input-files (operation component)) (defgeneric* input-files (operation component))
(defgeneric* component-operation-time (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) (defgeneric* system-source-file (system)
(:documentation "Return the source file in which system is defined.")) (:documentation "Return the source file in which system is defined."))
...@@ -864,7 +869,9 @@ with given pathname and if it exists return its truename." ...@@ -864,7 +869,9 @@ with given pathname and if it exists return its truename."
(error-name c) (error-pathname c) (error-condition c))))) (error-name c) (error-pathname c) (error-condition c)))))
(define-condition circular-dependency (system-definition-error) (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) (define-condition duplicate-names (system-definition-error)
((name :initarg :name :reader duplicate-names-name)) ((name :initarg :name :reader duplicate-names-name))
...@@ -948,7 +955,7 @@ with given pathname and if it exists return its truename." ...@@ -948,7 +955,7 @@ with given pathname and if it exists return its truename."
;;;; methods: components ;;;; methods: components
(defmethod print-object ((c missing-component) s) (defmethod print-object ((c missing-component) s)
(format s "~@<component ~S not found~ (format s "~@<component ~S not found~
~@[ in ~A~]~@:>" ~@[ in ~A~]~@:>"
(missing-requires c) (missing-requires c)
(when (missing-parent c) (when (missing-parent c)
...@@ -957,10 +964,10 @@ with given pathname and if it exists return its truename." ...@@ -957,10 +964,10 @@ with given pathname and if it exists return its truename."
(defmethod print-object ((c missing-component-of-version) s) (defmethod print-object ((c missing-component-of-version) s)
(format s "~@<component ~S does not match version ~A~ (format s "~@<component ~S does not match version ~A~
~@[ in ~A~]~@:>" ~@[ in ~A~]~@:>"
(missing-requires c) (missing-requires c)
(missing-version c) (missing-version c)
(when (missing-parent c) (when (missing-parent c)
(component-name (missing-parent c))))) (component-name (missing-parent c)))))
(defmethod component-system ((component component)) (defmethod component-system ((component component))
(aif (component-parent component) (aif (component-parent component)
...@@ -1016,7 +1023,8 @@ with given pathname and if it exists return its truename." ...@@ -1016,7 +1023,8 @@ with given pathname and if it exists return its truename."
(component-relative-pathname component) (component-relative-pathname component)
(pathname-directory-pathname (component-parent-pathname component))))) (pathname-directory-pathname (component-parent-pathname component)))))
(unless (or (null pathname) (absolute-pathname-p pathname)) (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) (setf (slot-value component 'absolute-pathname) pathname)
pathname))) pathname)))
...@@ -1228,10 +1236,12 @@ to ~S which is not a directory.~@:>" ...@@ -1228,10 +1236,12 @@ to ~S which is not a directory.~@:>"
pathname)) pathname))
0))) 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 (catch 'find-system
(let* ((name (coerce-name name)) (let* ((in-memory (system-registered-p name))
(in-memory (system-registered-p name))
(on-disk (system-definition-pathname name))) (on-disk (system-definition-pathname name)))
(when (and on-disk (when (and on-disk
(or (not in-memory) (or (not in-memory)
...@@ -1581,7 +1591,7 @@ recursive calls to traverse.") ...@@ -1581,7 +1591,7 @@ recursive calls to traverse.")
(retry () (retry ()
:report (lambda (s) :report (lambda (s)
(format s "~@<Retry loading component ~S.~@:>" (format s "~@<Retry loading component ~S.~@:>"
required-c)) (component-find-path required-c)))
:test :test
(lambda (c) (lambda (c)
#| #|
...@@ -1845,6 +1855,9 @@ recursive calls to traverse.") ...@@ -1845,6 +1855,9 @@ recursive calls to traverse.")
(declare (ignorable operation c)) (declare (ignorable operation c))
nil) nil)
(defmethod operation-description ((operation compile-op) component)
(declare (ignorable operation component))
(format nil "compiling component ~S" (component-find-path component)))
;;;; ------------------------------------------------------------------------- ;;;; -------------------------------------------------------------------------
;;;; load-op ;;;; load-op
...@@ -1921,6 +1934,11 @@ recursive calls to traverse.") ...@@ -1921,6 +1934,11 @@ recursive calls to traverse.")
(cons (list 'compile-op (component-name c)) (cons (list 'compile-op (component-name c))
(call-next-method))) (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 ;;;; load-source-op
...@@ -1959,6 +1977,10 @@ recursive calls to traverse.") ...@@ -1959,6 +1977,10 @@ recursive calls to traverse.")
(component-property c 'last-loaded-as-source))) (component-property c 'last-loaded-as-source)))
nil t)) 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 ;;;; test-op
...@@ -2008,14 +2030,13 @@ recursive calls to traverse.") ...@@ -2008,14 +2030,13 @@ recursive calls to traverse.")
(retry () (retry ()
:report :report
(lambda (s) (lambda (s)
(format s "~@<Retry performing ~S on ~S.~@:>" (format s "~@<Retry ~A.~@:>" (operation-description op component))))
op component)))
(accept () (accept ()
:report :report
(lambda (s) (lambda (s)
(format s "~@<Continue, treating ~S on ~S as ~ (format s "~@<Continue, treating ~A as ~
having been successful.~@:>" having been successful.~@:>"
op component)) (operation-description op component)))
(setf (gethash (type-of op) (setf (gethash (type-of op)
(component-operation-times component)) (component-operation-times component))
(get-universal-time)) (get-universal-time))
......
...@@ -31,7 +31,6 @@ ...@@ -31,7 +31,6 @@
(defmethod find-component :around ((m (eql (find-quux))) (defmethod find-component :around ((m (eql (find-quux)))
(c string)) (c string))
"FIND-COMPONENT on a component is a no-op --- it's already found." "FIND-COMPONENT on a component is a no-op --- it's already found."
(declare (ignore version))
(if (string-equal c "file3-only") (if (string-equal c "file3-only")
(asdf:find-system c) (asdf:find-system c)
(call-next-method))) (call-next-method)))
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