Newer
Older
;;;; -------------------------------------------------------------------------
;;;; Defsystem
Francois-Rene Rideau
committed
(asdf/package:define-package :asdf/defsystem
(:recycle :asdf/defsystem :asdf)
(:use :common-lisp :asdf/utility :asdf/pathname
:asdf/component :asdf/system :asdf/find-system :asdf/find-component
:asdf/lisp-action :asdf/operate
:asdf/backward-internals)
#+gcl<2.7 (:shadowing-import-from :asdf/implementation #:type-of)
(:export
#:defsystem #:do-defsystem #:parse-component-form
Francois-Rene Rideau
committed
#:*default-component-class*))
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
(in-package :asdf/defsystem)
;;; Pathname
(defun* determine-system-pathname (pathname)
;; The defsystem macro calls us to determine
;; the pathname of a system as follows:
;; 1. the one supplied,
;; 2. derived from *load-pathname* via load-pathname
;; 3. taken from the *default-pathname-defaults* via default-directory
(let* ((file-pathname (load-pathname))
(directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
(or (and pathname (subpathname directory-pathname pathname :type :directory))
directory-pathname
(default-directory))))
;;; Component class
(defvar *default-component-class* 'cl-source-file)
(defun* class-for-type (parent type)
(or (loop :for symbol :in (list
type
(find-symbol* type *package* nil)
(find-symbol* type :asdf/interface nil))
:for class = (and symbol (find-class* symbol nil))
:when (and class
(#-cormanlisp subtypep #+cormanlisp cl::subclassp
class (find-class* 'component)))
:return class)
(and (eq type :file)
(find-class*
(or (loop :for p = parent :then (component-parent p) :while p
:thereis (module-default-component-class p))
*default-component-class*) nil))
(sysdef-error "don't recognize component type ~A" type)))
;;; Check inputs
(define-condition duplicate-names (system-definition-error)
((name :initarg :name :reader duplicate-names-name))
(:report (lambda (c s)
(format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>")
(duplicate-names-name c)))))
(defun* sysdef-error-component (msg type name value)
(sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
type name value))
(defun* check-component-input (type name weakly-depends-on
depends-on components in-order-to)
"A partial test of the values of a component."
(unless (listp depends-on)
(sysdef-error-component ":depends-on must be a list."
type name depends-on))
(unless (listp weakly-depends-on)
(sysdef-error-component ":weakly-depends-on must be a list."
type name weakly-depends-on))
(unless (listp components)
(sysdef-error-component ":components must be NIL or a list of components."
type name components))
(unless (and (listp in-order-to) (listp (car in-order-to)))
(sysdef-error-component ":in-order-to must be NIL or a list of components."
type name in-order-to)))
;;; Main parsing function
(defun* parse-component-form (parent options &key previous-serial-component)
(destructuring-bind
(type name &rest rest &key
;; the following list of keywords is reproduced below in the
;; remove-keys form. important to keep them in sync
components pathname
perform explain output-files operation-done-p
weakly-depends-on depends-on serial in-order-to
do-first if-component-dep-fails
(version nil versionp)
;; list ends
&allow-other-keys) options
(declare (ignorable perform explain output-files operation-done-p))
(check-component-input type name weakly-depends-on depends-on components in-order-to)
(when (and parent
(find-component parent name)
(not ;; ignore the same object when rereading the defsystem
(typep (find-component parent name)
(class-for-type parent type))))
(error 'duplicate-names :name name))
(when versionp
(unless (parse-version version nil)
(warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
version name parent)))
(when do-first (error "DO-FIRST is not supported anymore since ASDF 2.27"))
(let* ((args `(:name ,(coerce-name name)
:pathname ,pathname
,@(when parent `(:parent ,parent))
,@(remove-keys
'(components pathname if-component-dep-fails
perform explain output-files operation-done-p
weakly-depends-on depends-on serial in-order-to)
rest)))
(ret (find-component parent name)))
(when weakly-depends-on
(appendf depends-on (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
(when previous-serial-component
(push previous-serial-component depends-on))
(if ret ; preserve identity
(apply 'reinitialize-instance ret args)
(setf ret (apply 'make-instance (class-for-type parent type) args)))
(component-pathname ret) ; eagerly compute the absolute pathname
(when (typep ret 'parent-component)
(setf (component-children ret)
(loop
:with previous-component = nil
:for c-form :in components
:for c = (parse-component-form ret c-form
:previous-serial-component previous-component)
:for name = (component-name c)
:collect c
:when serial :do (setf previous-component name)))
(compute-children-by-name ret))
(setf (component-sibling-dependencies ret) depends-on) ;; Used by POIU. ASDF3: rename to component-depends-on
(setf (component-in-order-to ret) in-order-to)
(%refresh-component-inline-methods ret rest)
(when if-component-dep-fails (%resolve-if-component-dep-fails if-component-dep-fails ret))
ret)))
(defun* do-defsystem (name &rest options
&key pathname (class 'system)
defsystem-depends-on &allow-other-keys)
;; The system must be registered before we parse the body,
;; otherwise we recur when trying to find an existing system
;; of the same name to reuse options (e.g. pathname) from.
;; To avoid infinite recursion in cases where you defsystem a system
;; that is registered to a different location to find-system,
;; we also need to remember it in a special variable *systems-being-defined*.
(with-system-definitions ()
(let* ((name (coerce-name name))
(load-pathname (load-pathname))
(registered (system-registered-p name))
(registered! (if registered
(rplaca registered (safe-file-write-date load-pathname))
(register-system (make-instance 'system :name name :source-file load-pathname))))
(system (reset-system (cdr registered!)
:name name :source-file load-pathname))
(component-options (remove-keys '(:class) options)))
(setf (gethash name *systems-being-defined*) system)
(apply 'load-systems defsystem-depends-on)
;; We change-class (when necessary) AFTER we load the defsystem-dep's
;; since the class might be defined as part of those.
(let ((class (class-for-type nil class)))
(unless (eq (type-of system) class)
(change-class system class)))
(parse-component-form
nil (list*
:module name
:pathname (determine-system-pathname pathname)
component-options)))))
(defmacro defsystem (name &body options)
`(apply 'do-defsystem ',name ',options))