system.lisp 12.8 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-class
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
Robert Goldman's avatar
Robert Goldman committed
12
   #:system-version
13
   #:definition-dependency-list #:definition-dependency-set #:system-defsystem-depends-on
14
   #:system-depends-on #:system-weakly-depends-on
15
   #:component-build-pathname #:build-pathname
16
   #:component-entry-point #:entry-point
17
18
19
   #:homepage #:system-homepage
   #:bug-tracker #:system-bug-tracker
   #:mailto #:system-mailto
20
21
   #:long-name #:system-long-name
   #:source-control #:system-source-control
22
   #:coerce-name #:primary-system-name #:primary-system-p #:coerce-filename
23
   #:find-system #:builtin-system-p)) ;; forward-reference, defined in find-system
24
25
(in-package :asdf/system)

26
(with-upgradability ()
27
28
  ;; The method is actually defined in asdf/find-system,
  ;; but we declare the function here to avoid a forward reference.
29
  (defgeneric find-system (system &optional error-p)
30
31
32
33
    (: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)."))
34

35
  (defgeneric system-source-file (system)
36
    (:documentation "Return the source file in which system is defined."))
37

38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
  ;; 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."))
56

57
58
  (defmethod component-entry-point ((c component))
    nil))
59
60


61
;;;; The system class
62

63
64
65
66
(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.
67
68
69
70
71
72
73
74
    ((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))
75
76
    (:documentation "PROTO-SYSTEM defines the elements of identity that are preserved when
a SYSTEM is redefined and its class is modified."))
77
78
79
80

  (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
Robert Goldman's avatar
Robert Goldman committed
81
82
83
84
85
86
87
88
89
90
91
     (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)
     (licence :writer (setf system-licence) :initarg :licence
              :writer (setf system-license) :initarg :license
              :initform nil)
     (homepage :writer (setf system-homepage) :initarg :homepage :initform nil)
     (bug-tracker :writer (setf system-bug-tracker) :initarg :bug-tracker :initform nil)
     (mailto :writer (setf system-mailto) :initarg :mailto :initform nil)
     (long-name :writer (setf system-long-name) :initarg :long-name :initform nil)
92
93
     ;; 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.
Robert Goldman's avatar
Robert Goldman committed
94
95
     (source-control :writer (setf system-source-control) :initarg :source-control :initform nil)

96
97
98
99
100
101
     (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)
102
     ;; This slot contains the *declared* defsystem-depends-on dependencies
103
104
105
106
     (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)
107
108
109
110
     (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."))

111
112
  (defclass undefined-system (system) ()
    (:documentation "System that was not defined yet."))
113

114
  (defun reset-system-class (system new-class &rest keys &key &allow-other-keys)
115
116
    "Erase any data from a SYSTEM except its basic identity, then reinitialize it
based on supplied KEYS."
117
    (change-class (change-class system 'proto-system) new-class)
118
    (apply 'reinitialize-instance system keys)))
119
120


121
122
123
124
125
126
127
128
129
130
131
132
133
;;; 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))))

134
  (defun primary-system-name (system-designator)
135
136
137
138
139
140
    "Given a system designator NAME, return the name of the corresponding
primary system, after which the .asd file in which it is defined is named.
If given a string or symbol (to downcase), do it syntactically
 by stripping anything from the first slash on.
If given a component, do it semantically by extracting
the system-primary-system-name of its system."
141
142
143
    (etypecase system-designator
      (string (if-let (p (position #\/ system-designator))
                (subseq system-designator 0 p) system-designator))
144
      (symbol (primary-system-name (coerce-name system-designator)))
145
146
147
148
149
      (component (let* ((system (component-system system-designator))
                        (source-file (physicalize-pathname (system-source-file system))))
                   (and source-file
                        (equal (pathname-type source-file) "asd")
                        (pathname-name source-file))))))
150
151
152

  (defun primary-system-p (system)
    "Given a system designator SYSTEM, return T if it designates a primary system, or else NIL.
153
154
155
156
157
If given a string, do it syntactically and return true if the name does not contain a slash.
If given a symbol, downcase to a string then fallback to previous case (NB: for NIL return T).
If given a component, do it semantically and return T if it's a SYSTEM and its primary-system-name
is the same as its component-name."
    (etypecase system
158
      (string (not (find #\/ system)))
159
160
161
      (symbol (primary-system-p (coerce-name system)))
      (component (and (typep system 'system)
                      (equal (component-name system) (primary-system-name system))))))
162
163
164
165
166
167
168
169
170

  (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) '("/" ":" "\\") "--")))


Robert Goldman's avatar
Robert Goldman committed
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
;;; System virtual slot readers, recursing to the primary system if needed.
(with-upgradability ()
  (defvar *system-virtual-slots* '(long-name description long-description
                                   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)))


200
201
;;;; Pathnames

202
(with-upgradability ()
203
  ;; Resolve a system designator to a system before extracting its system-source-file
204
205
206
  (defmethod system-source-file ((system-name string))
    (system-source-file (find-system system-name)))
  (defmethod system-source-file ((system-name symbol))
207
208
    (when system-name
      (system-source-file (find-system system-name))))
209

210
211
  (defun system-source-directory (system-designator)
    "Return a pathname object corresponding to the directory
212
in which the system specification (.asd file) is located."
213
214
    (pathname-directory-pathname (system-source-file system-designator)))

215
  (defun* (system-relative-pathname) (system name &key type)
216
217
    "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."
218
219
220
    (subpathname (system-source-directory system) name :type type))

  (defmethod component-pathname ((system system))
221
222
    "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."
223
224
225
226
227
228
    (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))

229
230
231
232
233
  ;; 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.
234
235
236
237
238
239
240
241
242
  (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)))

243
244
  ;; 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.
245
246
247
  (defmethod component-parent-pathname ((system system))
    (system-source-directory system))

248
249
  ;; Most components don't have a specified component-build-pathname, and therefore
  ;; no magic redirection of their output that disregards the output-translations.
250
251
252
  (defmethod component-build-pathname ((c component))
    nil))