From 6a38b2d62722b2039f00da2c408aeb4c13bc4750 Mon Sep 17 00:00:00 2001 From: Eric Timmons Date: Fri, 14 May 2021 13:41:49 -0400 Subject: [PATCH 01/14] Turn CLASS-FOR-TYPE into a generic function --- parse-defsystem.lisp | 28 ++++++++++++++++++---------- 1 file changed, 18 insertions(+), 10 deletions(-) diff --git a/parse-defsystem.lisp b/parse-defsystem.lisp index db3217bb5..03cf5e0cd 100644 --- a/parse-defsystem.lisp +++ b/parse-defsystem.lisp @@ -20,7 +20,7 @@ #:*known-systems-with-bad-secondary-system-names* #:known-system-with-bad-secondary-system-names-p #:sysdef-error-component #:check-component-input - #:explain)) + #:explain #:compute-component-children)) (in-package :asdf/parse-defsystem) ;;; Pathname @@ -48,20 +48,28 @@ 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) + (:documentation + "Return a class to be used to instantiate the component TYPE in the context of PARENT.")) + + (defmethod 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)))) ;;; Check inputs -- GitLab From 1bcddbbbd934c411747e7275c74588dd065fb6e3 Mon Sep 17 00:00:00 2001 From: Eric Timmons Date: Fri, 14 May 2021 13:43:10 -0400 Subject: [PATCH 02/14] Turn COMPUTE-COMPONENT-CHILDREN into a generic function Additionally, move the work of setting the slot to PARSE-COMPONENT-FORM. --- parse-defsystem.lisp | 49 +++++++++++++++++++++++++------------------- 1 file changed, 28 insertions(+), 21 deletions(-) diff --git a/parse-defsystem.lisp b/parse-defsystem.lisp index 03cf5e0cd..9ec518c7c 100644 --- a/parse-defsystem.lisp +++ b/parse-defsystem.lisp @@ -287,26 +287,32 @@ system names contained using COERCE-NAME. Return the result." (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.")) + + (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) + :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))) (defun* stable-union (s1 s2 &key (test #'eql) (key 'identity)) (append s1 @@ -364,7 +370,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 -- GitLab From b4e4249b321fc9bda21ba2cdefe0c11f491985d5 Mon Sep 17 00:00:00 2001 From: Eric Timmons Date: Fri, 14 May 2021 15:23:56 -0400 Subject: [PATCH 03/14] Clean up The contents of the comment are now covered by the doc string. The declarations are no longer needed now that we can have the defgeneric before the first usage of the function. --- parse-defsystem.lisp | 47 +++++++++++++++++--------------------------- 1 file changed, 18 insertions(+), 29 deletions(-) diff --git a/parse-defsystem.lisp b/parse-defsystem.lisp index 9ec518c7c..b5b3c5a48 100644 --- a/parse-defsystem.lisp +++ b/parse-defsystem.lisp @@ -276,17 +276,6 @@ 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)) - (defgeneric compute-component-children (component components serial-p) (:documentation "Return a list of children for COMPONENT. @@ -296,24 +285,6 @@ 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.")) - (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) - :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))) - (defun* stable-union (s1 s2 &key (test #'eql) (key 'identity)) (append s1 (remove-if #'(lambda (e2) (member (funcall key e2) (funcall key s1) :test test)) s2))) @@ -388,6 +359,24 @@ children.")) (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) + :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))) + ;; 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* -- GitLab From 4fba50c78bd0f3fbd386c9fecc0800e0e580bc06 Mon Sep 17 00:00:00 2001 From: Robert Goldman Date: Wed, 2 Jun 2021 21:48:43 +0000 Subject: [PATCH 04/14] Proposed docstring change for `class-for-type`. --- parse-defsystem.lisp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/parse-defsystem.lisp b/parse-defsystem.lisp index b5b3c5a48..0119ee23a 100644 --- a/parse-defsystem.lisp +++ b/parse-defsystem.lisp @@ -57,9 +57,9 @@ ;; What :file gets interpreted as, unless overridden by a :default-component-class (defvar *default-component-class* 'cl-source-file) - (defgeneric class-for-type (parent type) + (defgeneric class-for-type (parent type-designator) (:documentation - "Return a class to be used to instantiate the component TYPE in the context of PARENT.")) + "Return a CLASS object to be used to instantiate the component TYPE-DESIGNATOR in the context of PARENT.")) (defmethod class-for-type (parent type) (or (coerce-class type :package :asdf/interface :super 'component :error nil) -- GitLab From 95e63cb98fd364b75c683077f3355d64e46cbcb2 Mon Sep 17 00:00:00 2001 From: Robert Goldman Date: Wed, 2 Jun 2021 21:55:36 +0000 Subject: [PATCH 05/14] Update Changelog --- doc/Changelog | 2 ++ 1 file changed, 2 insertions(+) diff --git a/doc/Changelog b/doc/Changelog index 898e17565..2f4646df9 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: -- GitLab From 03113dfd1aa3641d5c7026cfb2bdb658f260c5bc Mon Sep 17 00:00:00 2001 From: Robert Goldman Date: Wed, 2 Jun 2021 22:33:26 +0000 Subject: [PATCH 06/14] Fix mistake in `class-for-type` docstring. --- parse-defsystem.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parse-defsystem.lisp b/parse-defsystem.lisp index 0119ee23a..85f0ce2e0 100644 --- a/parse-defsystem.lisp +++ b/parse-defsystem.lisp @@ -59,7 +59,7 @@ (defgeneric class-for-type (parent type-designator) (:documentation - "Return a CLASS object to be used to instantiate the component TYPE-DESIGNATOR in the context of PARENT.")) + "Return a CLASS object to be used to instantiate components specified by TYPE-DESIGNATOR in the context of PARENT.")) (defmethod class-for-type (parent type) (or (coerce-class type :package :asdf/interface :super 'component :error nil) -- GitLab From 594f6cad4d939ed9191c891c1782448de4db34f5 Mon Sep 17 00:00:00 2001 From: "Robert P. Goldman" Date: Wed, 2 Jun 2021 17:36:49 -0500 Subject: [PATCH 07/14] Document new generic functions. --- doc/asdf.texinfo | 53 +++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 52 insertions(+), 1 deletion(-) diff --git a/doc/asdf.texinfo b/doc/asdf.texinfo index 0e9eaa1b1..a1e5801a6 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,55 @@ 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. + +@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} object to be used to instantiate a component whose +type is specified by @var{type-designator} in the context of +@var{parent} (which should be a @code{parent-component} object). + +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 -- GitLab From 6402d29d3346b886690a3521380c45ba4d268959 Mon Sep 17 00:00:00 2001 From: Eric Timmons Date: Thu, 3 Jun 2021 09:02:59 -0400 Subject: [PATCH 08/14] Make the loop in COMPUTE-COMPONENT-CHILDREN a little easier to understand --- parse-defsystem.lisp | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/parse-defsystem.lisp b/parse-defsystem.lisp index 85f0ce2e0..8e85a25d8 100644 --- a/parse-defsystem.lisp +++ b/parse-defsystem.lisp @@ -366,7 +366,6 @@ children.")) :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 @@ -374,8 +373,11 @@ children.")) ;; broken. :unless (component-if-feature c) :do (setf previous-components nil) + :end + :and + :do (push name previous-components) :end - :and :do (push name previous-components))) + :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. -- GitLab From 7eaec3b60b955bed0f5f56e55d85c7c94e70d077 Mon Sep 17 00:00:00 2001 From: Eric Timmons Date: Thu, 3 Jun 2021 09:29:34 -0400 Subject: [PATCH 09/14] Add PARENT-COMPONENT and NULL methods to CLASS-FOR-TYPE --- doc/asdf.texinfo | 6 +++--- package-inferred-system.lisp | 5 +---- parse-defsystem.lisp | 9 +++++++-- 3 files changed, 11 insertions(+), 9 deletions(-) diff --git a/doc/asdf.texinfo b/doc/asdf.texinfo index a1e5801a6..ef53fd39d 100644 --- a/doc/asdf.texinfo +++ b/doc/asdf.texinfo @@ -3422,9 +3422,9 @@ children. @deffn {Generic function} class-for-type @var{parent} @var{type-designator} -Return a @code{class} object to be used to instantiate a component whose -type is specified by @var{type-designator} in the context of -@var{parent} (which should be a @code{parent-component} object). +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}. This generic function provides a means for changing how ASDF translates type-designators (like @code{:file}) into CLOS classes. It is intended diff --git a/package-inferred-system.lisp b/package-inferred-system.lisp index 5a9db19cd..e34c06256 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 8e85a25d8..8a55efbce 100644 --- a/parse-defsystem.lisp +++ b/parse-defsystem.lisp @@ -61,7 +61,12 @@ (: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 type) + (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 @@ -442,7 +447,7 @@ children.")) (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))) -- GitLab From 945aff495115bc5a790b032d63d8ab4bc55de677 Mon Sep 17 00:00:00 2001 From: Robert Goldman Date: Thu, 3 Jun 2021 14:53:33 +0000 Subject: [PATCH 10/14] Proposed revision to class-for-type documentation. --- doc/asdf.texinfo | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/doc/asdf.texinfo b/doc/asdf.texinfo index ef53fd39d..f3bc5e729 100644 --- a/doc/asdf.texinfo +++ b/doc/asdf.texinfo @@ -3424,7 +3424,8 @@ children. 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}. +@var{parent} (which should be either a @code{parent-component} or +@code{nil} (if this is a system). This generic function provides a means for changing how ASDF translates type-designators (like @code{:file}) into CLOS classes. It is intended -- GitLab From aa80382aa26d450ca8a11b71d04cae5959b23f82 Mon Sep 17 00:00:00 2001 From: Robert Goldman Date: Thu, 3 Jun 2021 14:55:09 +0000 Subject: [PATCH 11/14] Further revision. --- doc/asdf.texinfo | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/asdf.texinfo b/doc/asdf.texinfo index f3bc5e729..c1ce13a5a 100644 --- a/doc/asdf.texinfo +++ b/doc/asdf.texinfo @@ -3424,8 +3424,8 @@ children. 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 -@code{nil} (if this is a system). +@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 -- GitLab From 6edb36350632d0ccee1b956b1723e32d08dbb6d5 Mon Sep 17 00:00:00 2001 From: Robert Goldman Date: Thu, 3 Jun 2021 14:59:59 +0000 Subject: [PATCH 12/14] Export `class-for-type`. --- parse-defsystem.lisp | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/parse-defsystem.lisp b/parse-defsystem.lisp index 8a55efbce..1b5ad9dd0 100644 --- a/parse-defsystem.lisp +++ b/parse-defsystem.lisp @@ -20,7 +20,10 @@ #:*known-systems-with-bad-secondary-system-names* #:known-system-with-bad-secondary-system-names-p #:sysdef-error-component #:check-component-input - #:explain #:compute-component-children)) + #:explain + ;; for extending the component types + #:compute-component-children + #:class-for-type)) (in-package :asdf/parse-defsystem) ;;; Pathname -- GitLab From 8d3c534d2cfb74ed97a9fcb1078e2ae7ef0a77b5 Mon Sep 17 00:00:00 2001 From: Eric Timmons Date: Thu, 3 Jun 2021 11:32:55 -0400 Subject: [PATCH 13/14] Remove extraneous export --- parse-defsystem.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parse-defsystem.lisp b/parse-defsystem.lisp index 1b5ad9dd0..a45868603 100644 --- a/parse-defsystem.lisp +++ b/parse-defsystem.lisp @@ -14,7 +14,7 @@ (: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* -- GitLab From 70f81265859f35b49b20ff7cd2c99705cd813623 Mon Sep 17 00:00:00 2001 From: Eric Timmons Date: Thu, 3 Jun 2021 11:39:17 -0400 Subject: [PATCH 14/14] Add experimental warning to system parsing generic function documentation --- doc/asdf.texinfo | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/doc/asdf.texinfo b/doc/asdf.texinfo index c1ce13a5a..60af00d59 100644 --- a/doc/asdf.texinfo +++ b/doc/asdf.texinfo @@ -3398,6 +3398,12 @@ as well as an inclusive lower bound. 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 -- GitLab