system.lisp 4.72 KB
Newer Older
1 2 3
;;;; -------------------------------------------------------------------------
;;;; Systems

4
(asdf/package:define-package :asdf/system
5
  (:recycle :asdf :asdf/system)
6
  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/component)
7
  (:export
8
   #:system #:proto-system
9
   #:system-source-file #:system-source-directory #:system-relative-pathname
10
   #:reset-system
11 12
   #:system-description #:system-long-description
   #:system-author #:system-maintainer #:system-licence #:system-license
13
   #:system-defsystem-depends-on
14
   #:component-build-pathname #:build-pathname
15
   #:component-entry-point #:entry-point
16 17 18
   #:homepage #:system-homepage
   #:bug-tracker #:system-bug-tracker
   #:mailto #:system-mailto
19 20
   #:long-name #:system-long-name
   #:source-control #:system-source-control
21
   #:find-system #:builtin-system-p)) ;; forward-reference, defined in find-system
22 23
(in-package :asdf/system)

24 25
(defgeneric* (find-system) (system &optional error-p))
(defgeneric* (system-source-file) (system)
26
  (:documentation "Return the source file in which system is defined."))
27
(defgeneric* component-build-pathname (component))
28

29 30 31 32 33 34
(defgeneric* component-entry-point (component))
(defmethod component-entry-point ((c component))
  (declare (ignorable c))
  nil)


35
;;;; The system class
36 37 38 39

(defclass proto-system () ; slots to keep when resetting a system
  ;; To preserve identity for all objects, we'd need keep the components slots
  ;; but also to modify parse-component-form to reset the recycled objects.
40
  ((name) (source-file) #|(children) (children-by-names)|#))
41 42

(defclass system (module proto-system)
43
  ;; Backward-compatibility: inherit from module. ASDF4: only inherit from parent-component.
44
  (;; {,long-}description is now inherited from component, but we add the legacy accessors
45 46
   (description :accessor system-description)
   (long-description :accessor system-long-description)
47 48
   (author :accessor system-author :initarg :author :initform nil)
   (maintainer :accessor system-maintainer :initarg :maintainer :initform nil)
49
   (licence :accessor system-licence :initarg :licence
50
            :accessor system-license :initarg :license :initform nil)
51 52 53
   (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)
54 55 56 57
   (long-name :accessor system-long-name :initarg :long-name :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)
58
   (builtin-system-p :accessor builtin-system-p :initform nil :initarg :builtin-system-p)
59 60
   (build-pathname
    :initform nil :initarg :build-pathname :accessor component-build-pathname)
61 62
   (entry-point
    :initform nil :initarg :entry-point :accessor component-entry-point)
63
   (source-file :initform nil :initarg :source-file :accessor system-source-file)
64 65 66 67 68 69 70 71 72 73 74 75 76 77 78
   (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))

(defun* reset-system (system &rest keys &key &allow-other-keys)
  (change-class (change-class system 'proto-system) 'system)
  (apply 'reinitialize-instance system keys))


;;;; Pathnames

(defmethod system-source-file ((system-name string))
  (system-source-file (find-system system-name)))
(defmethod system-source-file ((system-name symbol))
  (system-source-file (find-system system-name)))

(defun* system-source-directory (system-designator)
79 80
  "Return a pathname object corresponding to the directory
in which the system specification (.asd file) is located."
81 82
  (pathname-directory-pathname (system-source-file system-designator)))

83
(defun* (system-relative-pathname) (system name &key type)
84 85
  (subpathname (system-source-directory system) name :type type))

86
(defmethod component-pathname ((system system))
87 88 89 90 91
  (let ((pathname (or (call-next-method) (system-source-directory system))))
    (unless (and (slot-boundp system 'relative-pathname) ;; backward-compatibility with ASDF1-age
                 (slot-value system 'relative-pathname)) ;; systems that directly access this slot.
      (setf (slot-value system 'relative-pathname) pathname))
    pathname))
92 93 94 95 96 97 98 99 100 101 102 103 104

(defmethod component-relative-pathname ((system system))
  (parse-unix-namestring
   (and (slot-boundp system 'relative-pathname)
        (slot-value system 'relative-pathname))
   :want-relative t
   :type :directory
   :ensure-absolute t
   :defaults (system-source-directory system)))

(defmethod component-parent-pathname ((system system))
  (system-source-directory system))

105 106 107
(defmethod component-build-pathname ((c component))
  (declare (ignorable c))
  nil)