1
;;;; -------------------------------------------------------------------------
4
(asdf/package:define-package :asdf/defsystem
5
(:recycle :asdf/defsystem :asdf)
6
(:use :asdf/common-lisp :asdf/driver :asdf/upgrade
7
:asdf/component :asdf/system :asdf/cache
8
:asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate
9
:asdf/backward-internals)
11
#:defsystem #:register-system-definition
12
#:class-for-type #:*default-component-class*
13
#:determine-system-directory #:parse-component-form
14
#:duplicate-names #:non-toplevel-system #:non-system-system
15
#:sysdef-error-component #:check-component-input))
16
(in-package :asdf/defsystem)
19
(with-upgradability ()
20
(defun determine-system-directory (pathname)
21
;; The defsystem macro calls this function to determine
22
;; the pathname of a system as follows:
23
;; 1. if the pathname argument is an pathname object (NOT a namestring),
24
;; that is already an absolute pathname, return it.
25
;; 2. otherwise, the directory containing the LOAD-PATHNAME
26
;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and
27
;; if it is indeed available and an absolute pathname, then
28
;; the PATHNAME argument is normalized to a relative pathname
29
;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T)
30
;; and merged into that DIRECTORY as per SUBPATHNAME.
31
;; Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded,
32
;; and may be from within the EVAL-WHEN of a file compilation.
33
;; If no absolute pathname was found, we return NIL.
34
(check-type pathname (or null string pathname))
35
(pathname-directory-pathname
37
(ensure-absolute-pathname
38
(parse-unix-namestring pathname :type :directory)
39
#'(lambda () (ensure-absolute-pathname
40
(load-pathname) 'get-pathname-defaults nil))
45
(with-upgradability ()
46
(defvar *default-component-class* 'cl-source-file)
48
(defun class-for-type (parent type)
49
(or (loop :for symbol :in (list
51
(find-symbol* type *package* nil)
52
(find-symbol* type :asdf/interface nil)
53
(and (stringp type) (safe-read-from-string type :package :asdf/interface)))
54
:for class = (and symbol (symbolp symbol) (find-class* symbol nil))
56
(#-cormanlisp subtypep #+cormanlisp cl::subclassp
57
class (find-class* 'component)))
61
(or (loop :for p = parent :then (component-parent p) :while p
62
:thereis (module-default-component-class p))
63
*default-component-class*) nil))
64
(sysdef-error "don't recognize component type ~A" type))))
68
(with-upgradability ()
69
(define-condition duplicate-names (system-definition-error)
70
((name :initarg :name :reader duplicate-names-name))
71
(:report (lambda (c s)
72
(format s (compatfmt "~@<Error while defining system: multiple components are given same name ~S~@:>")
73
(duplicate-names-name c)))))
75
(define-condition non-system-system (system-definition-error)
76
((name :initarg :name :reader non-system-system-name)
77
(class-name :initarg :class-name :reader non-system-system-class-name))
78
(:report (lambda (c s)
79
(format s (compatfmt "~@<Error while defining system ~S: class ~S isn't a subclass of ~S~@:>")
80
(non-system-system-name c) (non-system-system-class-name c) 'system))))
82
(define-condition non-toplevel-system (system-definition-error)
83
((parent :initarg :parent :reader non-toplevel-system-parent)
84
(name :initarg :name :reader non-toplevel-system-name))
85
(:report (lambda (c s)
86
(format s (compatfmt "~@<Error while defining system: component ~S claims to have a system ~S as a child~@:>")
87
(non-toplevel-system-parent c) (non-toplevel-system-name c)))))
89
(defun sysdef-error-component (msg type name value)
90
(sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
93
(defun check-component-input (type name weakly-depends-on
94
depends-on components)
95
"A partial test of the values of a component."
96
(unless (listp depends-on)
97
(sysdef-error-component ":depends-on must be a list."
98
type name depends-on))
99
(unless (listp weakly-depends-on)
100
(sysdef-error-component ":weakly-depends-on must be a list."
101
type name weakly-depends-on))
102
(unless (listp components)
103
(sysdef-error-component ":components must be NIL or a list of components."
104
type name components)))
106
(defun* (normalize-version) (form &key pathname component parent)
107
(labels ((invalid (&optional (continuation "using NIL instead"))
108
(warn (compatfmt "~@<Invalid :version specifier ~S~@[ for component ~S~]~@[ in ~S~]~@[ from file ~S~]~@[, ~A~]~@:>")
109
form component parent pathname continuation))
110
(invalid-parse (control &rest args)
111
(unless (builtin-system-p (find-component parent component))
112
(apply 'warn control args)
114
(if-let (v (typecase form
115
((or string null) form)
117
(invalid "Substituting a string")
118
(format nil "~D" form)) ;; 1.0 becomes "1.0"
122
(destructuring-bind (subpath &key (at 0)) (rest form)
123
(safe-read-file-form (subpathname pathname subpath) :at at :package :asdf-user)))
125
(destructuring-bind (subpath &key (at 0)) (rest form)
126
(read-file-lines (subpathname pathname subpath) :at at)))
131
(if-let (pv (parse-version v #'invalid-parse))
136
;;; Main parsing function
137
(with-upgradability ()
138
(defun* (parse-component-form) (parent options &key previous-serial-component)
140
(type name &rest rest &key
141
(builtin-system-p () bspp)
142
;; the following list of keywords is reproduced below in the
143
;; remove-plist-keys form. important to keep them in sync
144
components pathname perform explain output-files operation-done-p
145
weakly-depends-on depends-on serial
146
do-first if-component-dep-fails version
148
&allow-other-keys) options
149
(declare (ignorable perform explain output-files operation-done-p builtin-system-p))
150
(check-component-input type name weakly-depends-on depends-on components)
152
(find-component parent name)
153
(not ;; ignore the same object when rereading the defsystem
154
(typep (find-component parent name)
155
(class-for-type parent type))))
156
(error 'duplicate-names :name name))
157
(when do-first (error "DO-FIRST is not supported anymore as of ASDF 3"))
158
(let* ((name (coerce-name name))
161
,@(when parent `(:parent ,parent))
163
'(:components :pathname :if-component-dep-fails :version
164
:perform :explain :output-files :operation-done-p
165
:weakly-depends-on :depends-on :serial)
167
(component (find-component parent name))
168
(class (class-for-type parent type)))
169
(when (and parent (subtypep class 'system))
170
(error 'non-toplevel-system :parent parent :name name))
171
(if component ; preserve identity
172
(apply 'reinitialize-instance component args)
173
(setf component (apply 'make-instance class args)))
174
(component-pathname component) ; eagerly compute the absolute pathname
175
(let ((sysfile (system-source-file (component-system component)))) ;; requires the previous
176
(when (and (typep component 'system) (not bspp))
177
(setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile)))
178
(setf version (normalize-version version :component name :parent parent :pathname sysfile)))
179
;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8.
180
;; A better fix is required.
181
(setf (slot-value component 'version) version)
182
(when (typep component 'parent-component)
183
(setf (component-children component)
185
:with previous-component = nil
186
:for c-form :in components
187
:for c = (parse-component-form component c-form
188
:previous-serial-component previous-component)
189
:for name = (component-name c)
191
:when serial :do (setf previous-component name)))
192
(compute-children-by-name component))
193
(when previous-serial-component
194
(push previous-serial-component depends-on))
195
(when weakly-depends-on
196
;; ASDF4: deprecate this feature and remove it.
198
(remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
199
;; Used by POIU. ASDF4: rename to component-depends-on?
200
(setf (component-sideway-dependencies component) depends-on)
201
(%refresh-component-inline-methods component rest)
202
(when if-component-dep-fails
203
(%resolve-if-component-dep-fails if-component-dep-fails component))
206
(defun register-system-definition
207
(name &rest options &key pathname (class 'system) (source-file () sfp)
208
defsystem-depends-on &allow-other-keys)
209
;; The system must be registered before we parse the body,
210
;; otherwise we recur when trying to find an existing system
211
;; of the same name to reuse options (e.g. pathname) from.
212
;; To avoid infinite recursion in cases where you defsystem a system
213
;; that is registered to a different location to find-system,
214
;; we also need to remember it in a special variable *systems-being-defined*.
215
(with-system-definitions ()
216
(let* ((name (coerce-name name))
217
(source-file (if sfp source-file (resolve-symlinks* (load-pathname))))
218
(registered (system-registered-p name))
219
(registered! (if registered
220
(rplaca registered (get-file-stamp source-file))
222
(make-instance 'system :name name :source-file source-file))))
223
(system (reset-system (cdr registered!)
224
:name name :source-file source-file))
225
(component-options (remove-plist-key :class options))
226
(defsystem-dependencies (loop :for spec :in defsystem-depends-on :collect
227
(resolve-dependency-spec nil spec))))
228
(setf (gethash name *systems-being-defined*) system)
229
(apply 'load-systems defsystem-dependencies)
230
;; We change-class AFTER we loaded the defsystem-depends-on
231
;; since the class might be defined as part of those.
232
(let ((class (class-for-type nil class)))
233
(unless (subtypep class 'system)
234
(error 'non-system-system :name name :class-name (class-name class)))
235
(unless (eq (type-of system) class)
236
(change-class system class)))
237
(parse-component-form
240
:pathname (determine-system-directory pathname)
241
component-options)))))
243
(defmacro defsystem (name &body options)
244
`(apply 'register-system-definition ',name ',options)))
added
removed
defsystem.lisp
