Add some extension points for component parsing

Eric Timmonsrequested to merge
add-gfs-for-system-parsing into master

Apropos my complaints about package-inferred-system, I decided to make a system class that infers components instead of systems. It's called, creatively enough, asdf-inferred-components.

I imagine it will continue to live outside of ASDF proper (but if there's interest in it, I'm happy to bring it in). However, I found myself wanting a couple more points to intercede in the parsing of systems. This MR adds them. While I held off on exporting them from the ASDF package, I do think they're generally useful and would love to export them (or cleaned versions of them) after using them in practice for a while.

class-for-type is now a generic function that allows a custom parent-component class to control the mapping of component types (:file, :module, etc.) to classes.

I also turned compute-component-children into a GF (no backward compatibility issues there since the defun version of it has yet to be released) and moved a bit of the work it did back into parse-component-form.

Edited by Eric Timmons

Merge request reports

doc/Changelog

+2 −0
Changes for doc/Changelog: 2 added lines, 0 removed lines.
Original line number Diff line number Diff line
@@ -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:

doc/asdf.texinfo

+59 −1
Changes for doc/asdf.texinfo: 59 added lines, 1 removed line.
Original line number Diff line number Diff line
@@ -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

package-inferred-system.lisp

+1 −4
Changes for package-inferred-system.lisp: 1 added line, 4 removed lines.
Original line number Diff line number Diff line
@@ -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*)))

parse-defsystem.lisp

+50 −36
Changes for parse-defsystem.lisp: 50 added lines, 36 removed lines.
Original line number Diff line number Diff line
@@ -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,12 +51,25 @@ 
       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)

  (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
@@ -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)))