From e22122d7d561a7906f35d6c7b36e667bfa615cc7 Mon Sep 17 00:00:00 2001 From: Didier Verna Date: Tue, 18 Sep 2018 11:45:42 +0200 Subject: [PATCH] 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 * 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'). --- interface.lisp | 1 + system.lisp | 57 ++++++++++++++++++++++++++++++++++++++------------ 2 files changed, 45 insertions(+), 13 deletions(-) diff --git a/interface.lisp b/interface.lisp index a1a79e2d..411ab547 100644 --- a/interface.lisp +++ b/interface.lisp @@ -77,6 +77,7 @@ #:system-maintainer #:system-license #:system-licence + #:system-version #:system-source-file #:system-source-directory #:system-relative-pathname diff --git a/system.lisp b/system.lisp index cdfc5723..6450df2b 100644 --- a/system.lisp +++ b/system.lisp @@ -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) - ;; 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-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 :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 () -- GitLab