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

4
(uiop/package:define-package :asdf/system
5 6
  (:recycle :asdf :asdf/system :asdf/find-system)
  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component)
7
  (:export
8
   #:system #:proto-system #:undefined-system #:reset-system
9 10 11
   #:system-source-file #:system-source-directory #:system-relative-pathname
   #:system-description #:system-long-description
   #:system-author #:system-maintainer #:system-licence #:system-license
12
   #:definition-dependency-list #:definition-dependency-set #:system-defsystem-depends-on
13
   #:system-depends-on #:system-weakly-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
   #:coerce-name #:primary-system-name #:primary-system-p #:coerce-filename
22
   #:find-system #:builtin-system-p)) ;; forward-reference, defined in find-system
23 24
(in-package :asdf/system)

25
(with-upgradability ()
26 27
  ;; The method is actually defined in asdf/find-system,
  ;; but we declare the function here to avoid a forward reference.
28
  (defgeneric find-system (system &optional error-p)
29 30 31 32
    (:documentation "Given a system designator, find the actual corresponding system object.
If no system is found, then signal an error if ERROR-P is true (the default), or else return NIL.
A system designator is usually a string (conventionally all lowercase) or a symbol, designating
the same system as its downcased name; it can also be a system object (designating itself)."))
33
  (defgeneric system-source-file (system)
34
    (:documentation "Return the source file in which system is defined."))
35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52
  ;; This is bad design, but was the easiest kluge I found to let the user specify that
  ;; some special actions create outputs at locations controled by the user that are not affected
  ;; by the usual output-translations.
  ;; TODO: Fix operate to stop passing flags to operation (which in the current design shouldn't
  ;; have any flags, since the stamp cache, etc., can't distinguish them), and instead insert
  ;; *there* the ability of specifying special output paths, not in the system definition.
  (defgeneric component-build-pathname (component)
    (:documentation "The COMPONENT-BUILD-PATHNAME, when defined and not null, specifies the
output pathname for the action using the COMPONENT-BUILD-OPERATION.

NB: This interface is subject to change. Please contact ASDF maintainers if you use it."))

  ;; TODO: Should this have been made a SYSTEM-ENTRY-POINT instead?
  (defgeneric component-entry-point (component)
    (:documentation "The COMPONENT-ENTRY-POINT, when defined, specifies what function to call
(with no argument) when running an image dumped from the COMPONENT.

NB: This interface is subject to change. Please contact ASDF maintainers if you use it."))
53 54
  (defmethod component-entry-point ((c component))
    nil))
55 56


57
;;;; The system class
58

59 60 61 62
(with-upgradability ()
  (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.
63 64 65 66 67 68 69 70
    ((name)
     (source-file)
     ;; These two slots contains the *inferred* dependencies of define-op,
     ;; from loading the .asd file, as list and as set.
     (definition-dependency-list
         :initform nil :accessor definition-dependency-list)
     (definition-dependency-set
         :initform (list-to-hash-set nil) :accessor definition-dependency-set))
71 72
    (:documentation "PROTO-SYSTEM defines the elements of identity that are preserved when
a SYSTEM is redefined and its class is modified."))
73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95

  (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)
     ;; 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)
     (builtin-system-p :accessor builtin-system-p :initform nil :initarg :builtin-system-p)
     (build-pathname
      :initform nil :initarg :build-pathname :accessor component-build-pathname)
     (entry-point
      :initform nil :initarg :entry-point :accessor component-entry-point)
     (source-file :initform nil :initarg :source-file :accessor system-source-file)
96
     ;; This slot contains the *declared* defsystem-depends-on dependencies
97 98 99 100
     (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on
                           :initform nil)
     ;; these two are specially set in parse-component-form, so have no :INITARGs.
     (depends-on :reader system-depends-on :initform nil)
101 102 103 104
     (weakly-depends-on :reader system-weakly-depends-on :initform nil))
    (:documentation "SYSTEM is the base class for top-level components that users may request
ASDF to build."))

105 106
  (defclass undefined-system (system) ()
    (:documentation "System that was not defined yet."))
107 108

  (defun reset-system (system &rest keys &key &allow-other-keys)
109 110
    "Erase any data from a SYSTEM except its basic identity, then reinitialize it
based on supplied KEYS."
111
    (change-class (change-class system 'proto-system) 'undefined-system)
112
    (apply 'reinitialize-instance system keys)))
113 114


115 116 117 118 119 120 121 122 123 124 125 126 127
;;; Canonicalizing system names

(with-upgradability ()
  (defun coerce-name (name)
    "Given a designator for a component NAME, return the name as a string.
The designator can be a COMPONENT (designing its name; note that a SYSTEM is a component),
a SYMBOL (designing its name, downcased), or a STRING (designing itself)."
    (typecase name
      (component (component-name name))
      (symbol (string-downcase name))
      (string name)
      (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name))))

128
  (defun primary-system-name (system-designator)
129 130
    "Given a system designator NAME, return the name of the corresponding primary system,
after which the .asd file is named. That's the first component when dividing the name
131 132 133 134
as a string by / slashes. A component designates its system."
    (etypecase system-designator
      (string (if-let (p (position #\/ system-designator))
                (subseq system-designator 0 p) system-designator))
135
      (symbol (primary-system-name (coerce-name system-designator)))
136 137 138 139 140 141 142 143
      (component (primary-system-name (coerce-name (component-system system-designator))))))

  (defun primary-system-p (system)
    "Given a system designator SYSTEM, return T if it designates a primary system, or else NIL.
Also return NIL if system is neither a SYSTEM nor a string designating one."
    (typecase system
      (string (not (find #\/ system)))
      (system (primary-system-p (coerce-name system)))))
144 145 146 147 148 149 150 151 152

  (defun coerce-filename (name)
    "Coerce a system designator NAME into a string suitable as a filename component.
The (current) transformation is to replace characters /:\\ each by --,
the former being forbidden in a filename component.
NB: The onus is unhappily on the user to avoid clashes."
    (frob-substrings (coerce-name name) '("/" ":" "\\") "--")))


153 154
;;;; Pathnames

155
(with-upgradability ()
156
  ;; Resolve a system designator to a system before extracting its system-source-file
157 158 159
  (defmethod system-source-file ((system-name string))
    (system-source-file (find-system system-name)))
  (defmethod system-source-file ((system-name symbol))
160 161
    (when system-name
      (system-source-file (find-system system-name))))
162

163 164
  (defun system-source-directory (system-designator)
    "Return a pathname object corresponding to the directory
165
in which the system specification (.asd file) is located."
166 167
    (pathname-directory-pathname (system-source-file system-designator)))

168
  (defun* (system-relative-pathname) (system name &key type)
169 170
    "Given a SYSTEM, and a (Unix-style relative path) NAME of a file (or directory) of given TYPE,
return the absolute pathname of a corresponding file under that system's source code pathname."
171 172 173
    (subpathname (system-source-directory system) name :type type))

  (defmethod component-pathname ((system system))
174 175
    "Given a SYSTEM, and a (Unix-style relative path) NAME of a file (or directory) of given TYPE,
return the absolute pathname of a corresponding file under that system's source code pathname."
176 177 178 179 180 181
    (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))

182 183 184 185 186
  ;; The default method of component-relative-pathname for a system:
  ;; if a pathname was specified in the .asd file, it must be relative to the .asd file
  ;; (actually, to its truename* if *resolve-symlinks* it true, the default).
  ;; The method will return an *absolute* pathname, once again showing that the historical name
  ;; component-relative-pathname is misleading and should have been component-specified-pathname.
187 188 189 190 191 192 193 194 195
  (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)))

196 197
  ;; A system has no parent; if some method wants to make a path "relative to its parent",
  ;; it will instead be relative to the system itself.
198 199 200
  (defmethod component-parent-pathname ((system system))
    (system-source-directory system))

201 202
  ;; Most components don't have a specified component-build-pathname, and therefore
  ;; no magic redirection of their output that disregards the output-translations.
203 204 205
  (defmethod component-build-pathname ((c component))
    nil))