diff --git a/doc/Changelog b/doc/Changelog index 898e1756545858dc2399c81a62198561bd365747..2f4646df92013a0c9120f3d7735e52d3a8b2a0a9 100644 --- a/doc/Changelog +++ b/doc/Changelog @@ -17,6 +17,8 @@ cl-asdf (2:3.3.5-1) unstable; urgency=low IN PROGRESS Rideau, and Eric Schulte. * Fix for argument handling in LAUNCH-PROGRAM. * Fixes for feature handling from Eric Timmons. +* Replaced some of the internals of `parse-defsystem` with generic functions to + enable modular extension. Thanks to Eric Timmons. cl-asdf (2:3.3.4-1) unstable; urgency=low Bug fix release: diff --git a/doc/asdf.texinfo b/doc/asdf.texinfo index 0e9eaa1b1313910ace584d9c629ad75bb726a7f9..60af00d59df3ea86f063c9fc37cf96dee40fbc0c 100644 --- a/doc/asdf.texinfo +++ b/doc/asdf.texinfo @@ -147,6 +147,7 @@ The Object model of ASDF * Components:: * Dependencies:: * Functions:: +* Parsing system definitions:: Operations @@ -2261,6 +2262,7 @@ customize the behaviour of existing @emph{functions}. * Components:: * Dependencies:: * Functions:: +* Parsing system definitions:: @end menu @node Operations, Components, The object model of ASDF, The object model of ASDF @@ -3352,7 +3354,7 @@ remain at the system level, and are not propagated along the hierarchy, but instead do something global on the system. -@node Functions, , Dependencies, The object model of ASDF +@node Functions, Parsing system definitions, Dependencies, The object model of ASDF @comment node-name, next, previous, up @section Functions @@ -3388,6 +3390,62 @@ could be in the future extended to specify an exclusive upper bound for compatib as well as an inclusive lower bound. @end defun +@node Parsing system definitions, , Functions, The object model of ASDF +@section Parsing system definitions +@cindex Parsing system definitions +@cindex Extending ASDF's defsystem parser + +Thanks to Eric Timmons, ASDF now provides hooks to extend how it parses +@code{defsystem} forms. + +@strong{Warning!} These interfaces are experimental, and as such are not +exported from the ASDF package yet. We plan to export them in ASDF +3.4.0. If you use them before they are exported, please subscribe to +@url{https://gitlab.common-lisp.net/asdf/asdf/-/issues/76} so you are +made aware of any changes. + +@defun parse-component-form @var{parent} @var{options} &key @var{previous-serial-components} + +This is the core function for parsing a system definition. At the +moment, we do not expect ASDF extenders to modify this function. + +When being called on a @code{component} of type @code{system} (i.e., +inside the @code{defsystem} macro), @var{parent} will be @code{NIL}. +@end defun + +@deffn {Generic function} compute-component-children @var{component} @var{components} @var{serial-p} + +This generic function provides standard means for computing component +children, but can be extended with additional methods by a programmer. + +Returns a list of children (of type @code{component}) for @var{component}. +@var{components} is a list of the explicitly defined children descriptions. +@var{serial-p} is non-@code{NIL} if each child in @var{components} should depend on the previous +children. + + +@end deffn + +@deffn {Generic function} class-for-type @var{parent} @var{type-designator} + +Return a @code{class} designator to be used to instantiate a component +whose type is specified by @var{type-designator} in the context of +@var{parent}, which should be either a @code{parent-component} -- or subclass +thereof -- or @code{nil} (if the type designator is some class of system). + +This generic function provides a means for changing how ASDF translates +type-designators (like @code{:file}) into CLOS classes. It is intended +for programmers to extend by adding new methods. + +@strong{Warning!} Adding new methods for @code{class-for-type} is +typically @emph{not} necessary: much can already be done by using +@code{:default-component-class} and defining (and explicitly calling +for) new component types. + +@end deffn + + + @node Controlling where ASDF searches for systems, Controlling where ASDF saves compiled files, The object model of ASDF, Top @comment node-name, next, previous, up @chapter Controlling where ASDF searches for systems diff --git a/package-inferred-system.lisp b/package-inferred-system.lisp index 5a9db19cd067de2a9c049bfea22761da6394b0b0..e34c06256bfec8f264e887c5c12c64a035186974 100644 --- a/package-inferred-system.lisp +++ b/package-inferred-system.lisp @@ -138,10 +138,7 @@ otherwise return a default system name computed from PACKAGE-NAME." (when (typep top 'package-inferred-system) (if-let (dir (component-pathname top)) (let* ((sub (subseq system-name (1+ (length primary)))) - (component-type (class-for-type - nil - (or (module-default-component-class top) - *default-component-class*))) + (component-type (class-for-type top :file)) (file-type (file-type (make-instance component-type))) (f (probe-file* (subpathname dir sub :type file-type) :truename *resolve-symlinks*))) diff --git a/parse-defsystem.lisp b/parse-defsystem.lisp index db3217bb5f7a03eff78ec56d68f49672965318c0..a458686035c9b1e23a088101c60ca5e2274f1b1c 100644 --- a/parse-defsystem.lisp +++ b/parse-defsystem.lisp @@ -14,13 +14,16 @@ (:import-from :asdf/find-system #:define-op) (:export #:defsystem #:register-system-definition - #:class-for-type #:*default-component-class* + #:*default-component-class* #:determine-system-directory #:parse-component-form #:non-toplevel-system #:non-system-system #:bad-system-name #:*known-systems-with-bad-secondary-system-names* #:known-system-with-bad-secondary-system-names-p #:sysdef-error-component #:check-component-input - #:explain)) + #:explain + ;; for extending the component types + #:compute-component-children + #:class-for-type)) (in-package :asdf/parse-defsystem) ;;; Pathname @@ -48,20 +51,33 @@ nil))))) +(when-upgrading (:version "3.3.4.17") + ;; This turned into a generic function in 3.3.4.17 + (fmakunbound 'class-for-type)) + ;;; Component class (with-upgradability () ;; What :file gets interpreted as, unless overridden by a :default-component-class (defvar *default-component-class* 'cl-source-file) - (defun class-for-type (parent type) - (or (coerce-class type :package :asdf/interface :super 'component :error nil) - (and (eq type :file) - (coerce-class - (or (loop :for p = parent :then (component-parent p) :while p - :thereis (module-default-component-class p)) - *default-component-class*) - :package :asdf/interface :super 'component :error nil)) - (sysdef-error "don't recognize component type ~S" type)))) + (defgeneric class-for-type (parent type-designator) + (:documentation + "Return a CLASS object to be used to instantiate components specified by TYPE-DESIGNATOR in the context of PARENT.")) + + (defmethod class-for-type ((parent null) type) + "If the PARENT is NIL, then TYPE must designate a subclass of SYSTEM." + (or (coerce-class type :package :asdf/interface :super 'system :error nil) + (sysdef-error "don't recognize component type ~S in the context of no parent" type))) + + (defmethod class-for-type ((parent parent-component) type) + (or (coerce-class type :package :asdf/interface :super 'component :error nil) + (and (eq type :file) + (coerce-class + (or (loop :for p = parent :then (component-parent p) :while p + :thereis (module-default-component-class p)) + *default-component-class*) + :package :asdf/interface :super 'component :error nil)) + (sysdef-error "don't recognize component type ~S" type)))) ;;; Check inputs @@ -268,37 +284,14 @@ Please only define ~S and secondary systems with a name starting with ~S (e.g. ~ system names contained using COERCE-NAME. Return the result." (mapcar 'parse-dependency-def dd-list)) - ;;; Helper function for parse-component-form. Sets the CHILDREN slot of - ;;; COMPONENT, using COMPONENTS list, and adds dependency links if - ;;; the COMPONENT is a serial component. Should ONLY be called on a - ;;; PARENT-COMPONENT. - ;;; Returns the list of child components -- it's not entirely clear to me - ;;; what is the set of possible values for elements of this list. - (declaim (ftype (function (parent-component list (or t nil)) t) - compute-component-children) - (ftype (function ((or parent-component null) list &key (:previous-serial-components list))) - parse-component-form)) - - (defun* compute-component-children (component components serial-p) - (prog1 - (setf (component-children component) - (loop - :with previous-components = nil ; list of strings - :for c-form :in components - :for c = (parse-component-form component c-form - :previous-serial-components previous-components) - :for name :of-type string = (component-name c) - :collect c - :when serial-p - ;; if this is an if-feature component, we need to make a serial link - ;; from previous components to following components -- otherwise should - ;; the IF-FEATURE component drop out, the chain of serial dependencies will be - ;; broken. - :unless (component-if-feature c) - :do (setf previous-components nil) - :end - :and :do (push name previous-components))) - (compute-children-by-name component))) + (defgeneric compute-component-children (component components serial-p) + (:documentation + "Return a list of children for COMPONENT. + +COMPONENTS is a list of the explicitly defined children descriptions. + +SERIAL-P is non-NIL if each child in COMPONENTS should depend on the previous +children.")) (defun* stable-union (s1 s2 &key (test #'eql) (key 'identity)) (append s1 @@ -356,7 +349,8 @@ system names contained using COERCE-NAME. Return the result." ;; A better fix is required. (setf (slot-value component 'version) version) (when (typep component 'parent-component) - (compute-component-children component components serial)) + (setf (component-children component) (compute-component-children component components serial)) + (compute-children-by-name component)) (when previous-serial-components (setf depends-on (stable-union depends-on previous-serial-components :test #'equal))) (when weakly-depends-on @@ -373,6 +367,26 @@ system names contained using COERCE-NAME. Return the result." (coerce-name (component-system component)))) component))) + (defmethod compute-component-children ((component parent-component) components serial-p) + (loop + :with previous-components = nil ; list of strings + :for c-form :in components + :for c = (parse-component-form component c-form + :previous-serial-components previous-components) + :for name :of-type string = (component-name c) + :when serial-p + ;; if this is an if-feature component, we need to make a serial link + ;; from previous components to following components -- otherwise should + ;; the IF-FEATURE component drop out, the chain of serial dependencies will be + ;; broken. + :unless (component-if-feature c) + :do (setf previous-components nil) + :end + :and + :do (push name previous-components) + :end + :collect c)) + ;; the following are all systems that Stas Boukarev maintains and refuses to fix, ;; hoping instead to make my life miserable. Instead, I just make ASDF ignore them. (defparameter* *known-systems-with-bad-secondary-system-names* @@ -436,7 +450,7 @@ system names contained using COERCE-NAME. Return the result." (error 'non-system-system :name name :class-name (class-name class))) (unless (eq (type-of system) class) (reset-system-class system class))) - (parse-component-form nil (list* :module name :pathname directory component-options)))) + (parse-component-form nil (list* :system name :pathname directory component-options)))) (defmacro defsystem (name &body options) `(apply 'register-system-definition ',name ',options)))