Commit e22122d7 authored by Didier Verna's avatar Didier Verna
Browse files

Support for system virtual slots. 

A system virtual slot is a slot the value of which is read either from the
system directly, or potentially from its primary system if needed. It avoids
duplicating meta-information (license, author etc.) in secondary systems.

As a side-effect of this implementation, the functions
system{-long}-description now behave virtually, as opposed to
component{-long}-description. Also, a new function called system-version is
provided, which also behaves virtually, as opposed to component-version.

2018-09-18  Didier Verna  <didier@didierverna.net>

	* interface.lisp (:asdf/interface): Export SYSTEM-VERSION.
	* system.lisp (:asdf/system): Ditto.
	(system): Only automatically define generic writers for virtual
	slots.
	(*system-virtual-slots*): New variable. List the virtual slot names.
	(system-virtual-slot-value): New function. General virtual slot
	reader.
	(define-system-virtual-slot-reader): New macro. Define specific
	virtual slot readers based on the above function.
	(define-system-virtual-slot-readers): New macro. Define all
	specific virtual slot readers.
	(system-license): New ad-hoc virtual slot reader, defined manually
	in addition to system-licenCe (note the 'c').
parent 8cf977a9

interface.lisp

+1 −0
Original line number Diff line number Diff line
@@ -77,6 +77,7 @@ 
   #:system-maintainer

   #:system-license

   #:system-licence

   #:system-version

   #:system-source-file

   #:system-source-directory

   #:system-relative-pathname

system.lisp

+44 −13
Original line number Diff line number Diff line
@@ -9,6 +9,7 @@ 
   #:system-source-file #:system-source-directory #:system-relative-pathname

   #:system-description #:system-long-description

   #:system-author #:system-maintainer #:system-licence #:system-license

   #:system-version

   #:definition-dependency-list #:definition-dependency-set #:system-defsystem-depends-on

   #:system-depends-on #:system-weakly-depends-on

   #:component-build-pathname #:build-pathname
@@ -72,21 +73,22 @@ NB: This interface is subject to change. Please contact ASDF maintainers if you 
a SYSTEM is redefined and its class is modified."))



  (defclass system (module proto-system)

    ((long-name :writer (setf system-long-name) :initarg :long-name :initform nil)

     ;; Backward-compatibility: inherit from module. ASDF4: only inherit from parent-component.

    (;; {,long-}description is now inherited from component, but we add the legacy accessors

     (description :accessor system-description)

     (long-description :accessor system-long-description)

     (author :accessor system-author :initarg :author :initform nil)

     (maintainer :accessor system-maintainer :initarg :maintainer :initform nil)

     (licence :accessor system-licence :initarg :licence

              :accessor system-license :initarg :license :initform nil)

     (homepage :accessor system-homepage :initarg :homepage :initform nil)

     (bug-tracker :accessor system-bug-tracker :initarg :bug-tracker :initform nil)

     (mailto :accessor system-mailto :initarg :mailto :initform nil)

     (long-name :accessor system-long-name :initarg :long-name :initform nil)

     ;; {,long-}description is now inherited from component, but we add the legacy accessors

     (description :writer (setf system-description))

     (long-description :writer (setf system-long-description))

     (author :writer (setf system-author) :initarg :author :initform nil)

     (maintainer :writer (setf system-maintainer) :initarg :maintainer :initform nil)

     (mailto :writer (setf system-mailto) :initarg :mailto :initform nil)

     (homepage :writer (setf system-homepage) :initarg :homepage :initform nil)

     ;; Conventions for this slot aren't clear yet as of ASDF 2.27, but whenever they are, they will be enforced.

     ;; I'm introducing the slot before the conventions are set for maximum compatibility.

     (source-control :accessor system-source-control :initarg :source-control :initform nil)

     (source-control :writer (setf system-source-control) :initarg :source-control :initform nil)

     (licence :writer (setf system-licence) :initarg :licence

	      :writer (setf system-license) :initarg :license

	      :initform nil)

     (bug-tracker :writer (setf system-bug-tracker) :initarg :bug-tracker :initform nil)

     (builtin-system-p :accessor builtin-system-p :initform nil :initarg :builtin-system-p)

     (build-pathname

      :initform nil :initarg :build-pathname :accessor component-build-pathname)
@@ -162,6 +164,35 @@ NB: The onus is unhappily on the user to avoid clashes." 
    (frob-substrings (coerce-name name) '("/" ":" "\\") "--")))





;;; System virtual slot readers, recursing to the primary system if needed.

(with-upgradability ()

  (defvar *system-virtual-slots* '(long-name description long-decsription

				   author maintainer mailto

				   homepage source-control

				   licence version bug-tracker)

    "The list of system virtual slot names.")

  (defun system-virtual-slot-value (system slot-name)

    "Return SYSTEM's virtual SLOT-NAME value.

If SYSTEM's SLOT-NAME value is NIL and SYSTEM is a secondary system, look in

the primary one."

    (or (slot-value system slot-name)

	(unless (primary-system-p system)

	  (slot-value (find-system (primary-system-name system))

		      slot-name))))

  (defmacro define-system-virtual-slot-reader (slot-name)

    `(defun* ,(intern (concatenate 'string (string :system-)

				   (string slot-name)))

	 (system)

       (system-virtual-slot-value system ',slot-name)))

  (defmacro define-system-virtual-slot-readers ()

    `(progn ,@(mapcar (lambda (slot-name)

			`(define-system-virtual-slot-reader ,slot-name))

		*system-virtual-slots*)))

  (define-system-virtual-slot-readers)

  (defun system-license (system)

    (system-virtual-slot-value system 'licence)))





;;;; Pathnames



(with-upgradability ()