parse-defsystem.lisp 14.3 KB
Newer Older
1
2
3
;;;; -------------------------------------------------------------------------
;;;; Defsystem

4
(uiop/package:define-package :asdf/parse-defsystem
5
6
7
  (:recycle :asdf/parse-defsystem :asdf/defsystem :asdf)
  (:nicknames :asdf/defsystem) ;; previous name, to be compatible with, in case anyone cares
  (:use :uiop/common-lisp :asdf/driver :asdf/upgrade
8
   :asdf/component :asdf/system :asdf/cache
9
   :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate
10
   :asdf/backward-internals)
11
  (:import-from :asdf/system #:depends-on #:weakly-depends-on)
12
  (:export
13
14
15
   #:defsystem #:register-system-definition
   #:class-for-type #:*default-component-class*
   #:determine-system-directory #:parse-component-form
16
   #:non-toplevel-system #:non-system-system
17
   #:sysdef-error-component #:check-component-input))
18
(in-package :asdf/parse-defsystem)
19
20

;;; Pathname
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
(with-upgradability ()
  (defun determine-system-directory (pathname)
    ;; The defsystem macro calls this function to determine
    ;; the pathname of a system as follows:
    ;; 1. if the pathname argument is an pathname object (NOT a namestring),
    ;;    that is already an absolute pathname, return it.
    ;; 2. otherwise, the directory containing the LOAD-PATHNAME
    ;;    is considered (as deduced from e.g. *LOAD-PATHNAME*), and
    ;;    if it is indeed available and an absolute pathname, then
    ;;    the PATHNAME argument is normalized to a relative pathname
    ;;    as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T)
    ;;    and merged into that DIRECTORY as per SUBPATHNAME.
    ;;    Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded,
    ;;    and may be from within the EVAL-WHEN of a file compilation.
    ;; If no absolute pathname was found, we return NIL.
    (check-type pathname (or null string pathname))
    (pathname-directory-pathname
     (resolve-symlinks*
      (ensure-absolute-pathname
       (parse-unix-namestring pathname :type :directory)
       #'(lambda () (ensure-absolute-pathname
                     (load-pathname) 'get-pathname-defaults nil))
       nil)))))
44

45
46

;;; Component class
47
48
49
50
51
52
53
(with-upgradability ()
  (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)
54
55
56
                               (find-symbol* type :asdf/interface nil)
                               (and (stringp type) (safe-read-from-string type :package :asdf/interface)))
              :for class = (and symbol (symbolp symbol) (find-class* symbol nil))
57
58
59
60
61
62
63
64
65
66
              :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))))
67

68

69
;;; Check inputs
70
(with-upgradability ()
71
72
73
74
75
76
77
  (define-condition non-system-system (system-definition-error)
    ((name :initarg :name :reader non-system-system-name)
     (class-name :initarg :class-name :reader non-system-system-class-name))
    (:report (lambda (c s)
               (format s (compatfmt "~@<Error while defining system ~S: class ~S isn't a subclass of ~S~@:>")
                       (non-system-system-name c) (non-system-system-class-name c) 'system))))

78
79
80
81
82
83
84
  (define-condition non-toplevel-system (system-definition-error)
    ((parent :initarg :parent :reader non-toplevel-system-parent)
     (name :initarg :name :reader non-toplevel-system-name))
    (:report (lambda (c s)
               (format s (compatfmt "~@<Error while defining system: component ~S claims to have a system ~S as a child~@:>")
                       (non-toplevel-system-parent c) (non-toplevel-system-name c)))))

85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
  (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)
    "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)))

102
103
104
105
106
  (defun* (normalize-version) (form &key pathname component parent)
    (labels ((invalid (&optional (continuation "using NIL instead"))
               (warn (compatfmt "~@<Invalid :version specifier ~S~@[ for component ~S~]~@[ in ~S~]~@[ from file ~S~]~@[, ~A~]~@:>")
                     form component parent pathname continuation))
             (invalid-parse (control &rest args)
107
               (unless (if-let (target (find-component parent component)) (builtin-system-p target))
108
109
110
111
112
113
114
115
116
117
118
                 (apply 'warn control args)
                 (invalid))))
      (if-let (v (typecase form
                   ((or string null) form)
                   (real
                    (invalid "Substituting a string")
                    (format nil "~D" form)) ;; 1.0 becomes "1.0"
                   (cons
                    (case (first form)
                      ((:read-file-form)
                       (destructuring-bind (subpath &key (at 0)) (rest form)
119
120
                         (safe-read-file-form (subpathname pathname subpath)
                                              :at at :package :asdf-user)))
121
122
                      ((:read-file-line)
                       (destructuring-bind (subpath &key (at 0)) (rest form)
123
124
                         (safe-read-file-line (subpathname pathname subpath)
                                              :at at)))
125
126
127
128
129
130
131
                      (otherwise
                       (invalid))))
                   (t
                    (invalid))))
        (if-let (pv (parse-version v #'invalid-parse))
          (unparse-version pv)
          (invalid))))))
132

133

134
;;; Main parsing function
135
(with-upgradability ()
136
137
138
139
140
141
142
143
  (defun* parse-dependency-def (dd)
    (if (listp dd)
        (case (first dd)
          (:feature
           (unless (= (length dd) 3)
             (sysdef-error "Ill-formed feature dependency: ~s" dd))
           (let ((embedded (parse-dependency-def (third dd))))
             `(:feature ,(second dd) ,embedded)))
144
145
          (feature
           (sysdef-error "`feature' has been removed from the dependency spec language of ASDF. Use :feature instead in ~s." dd))
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
          (:require
           (unless (= (length dd) 2)
             (sysdef-error "Ill-formed require dependency: ~s" dd))
           dd)
          (:version
           (unless (= (length dd) 3)
             (sysdef-error "Ill-formed version dependency: ~s" dd))
           `(:version ,(coerce-name (second dd)) ,(third dd)))
          (otherwise (sysdef-error "Ill-formed dependency: ~s" dd)))
      (coerce-name dd)))

  (defun* parse-dependency-defs (dd-list)
    "Parse the dependency defs in DD-LIST into canonical form by translating all
system names contained using COERCE-NAME. Return the result."
    (mapcar 'parse-dependency-def dd-list))

162
  (defun* (parse-component-form) (parent options &key previous-serial-component)
163
164
165
166
167
168
169
    (destructuring-bind
        (type name &rest rest &key
                                (builtin-system-p () bspp)
                                ;; the following list of keywords is reproduced below in the
                                ;; remove-plist-keys form.  important to keep them in sync
                                components pathname perform explain output-files operation-done-p
                                weakly-depends-on depends-on serial
170
                                do-first if-component-dep-fails version
171
172
                                ;; list ends
         &allow-other-keys) options
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
173
      (declare (ignore perform explain output-files operation-done-p builtin-system-p))
174
175
176
177
178
179
180
181
      (check-component-input type name weakly-depends-on depends-on components)
      (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 do-first (error "DO-FIRST is not supported anymore as of ASDF 3"))
182
183
      (let* ((name (coerce-name name))
             (args `(:name ,name
184
185
186
187
188
189
190
                     :pathname ,pathname
                     ,@(when parent `(:parent ,parent))
                     ,@(remove-plist-keys
                        '(:components :pathname :if-component-dep-fails :version
                          :perform :explain :output-files :operation-done-p
                          :weakly-depends-on :depends-on :serial)
                        rest)))
191
192
193
194
             (component (find-component parent name))
             (class (class-for-type parent type)))
        (when (and parent (subtypep class 'system))
          (error 'non-toplevel-system :parent parent :name name))
195
196
        (if component ; preserve identity
            (apply 'reinitialize-instance component args)
197
            (setf component (apply 'make-instance class args)))
198
        (component-pathname component) ; eagerly compute the absolute pathname
199
        (when (typep component 'system)
200
          ;; cache information for introspection
201
202
203
204
205
          (setf (slot-value component 'depends-on)
                (parse-dependency-defs depends-on)
                (slot-value component 'weakly-depends-on)
                ;; these must be a list of systems, cannot be features or versioned systems
                (mapcar 'coerce-name weakly-depends-on)))
206
        (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous
207
          (when (and (typep component 'system) (not bspp))
208
209
            (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile)))
          (setf version (normalize-version version :component name :parent parent :pathname sysfile)))
210
211
212
        ;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8.
        ;; A better fix is required.
        (setf (slot-value component 'version) version)
213
214
215
216
217
218
219
220
221
222
223
        (when (typep component 'parent-component)
          (setf (component-children component)
                (loop
                  :with previous-component = nil
                  :for c-form :in components
                  :for c = (parse-component-form component 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 component))
224
225
226
227
228
229
        (when previous-serial-component
          (push previous-serial-component depends-on))
        (when weakly-depends-on
          ;; ASDF4: deprecate this feature and remove it.
          (appendf depends-on
                   (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
230
        ;; Used by POIU. ASDF4: rename to component-depends-on?
231
        (setf (component-sideway-dependencies component) depends-on)
232
233
        (%refresh-component-inline-methods component rest)
        (when if-component-dep-fails
234
235
236
237
          (error "The system definition for ~S uses deprecated ~
            ASDF option :IF-COMPONENT-DEP-FAILS. ~
            Starting with ASDF 3, please use :IF-FEATURE instead"
           (coerce-name (component-system component))))
238
239
240
241
242
243
244
245
246
247
248
249
        component)))

  (defun register-system-definition
      (name &rest options &key pathname (class 'system) (source-file () sfp)
                            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 ()
250
      (let* ((name (string-downcase (coerce-name name)))
251
252
253
254
255
256
257
258
             (source-file (if sfp source-file (resolve-symlinks* (load-pathname))))
             (registered (system-registered-p name))
             (registered! (if registered
                              (rplaca registered (get-file-stamp source-file))
                              (register-system
                               (make-instance 'system :name name :source-file source-file))))
             (system (reset-system (cdr registered!)
                                   :name name :source-file source-file))
259
260
             (component-options
              (remove-plist-keys '(:defsystem-depends-on :class) options))
261
262
             (defsystem-dependencies (loop :for spec :in defsystem-depends-on :collect
                                           (resolve-dependency-spec nil spec))))
263
264
265
266
267
        ;; cache defsystem-depends-on in canonical form
        (when defsystem-depends-on
          (setf component-options
                (append `(:defsystem-depends-on ,(parse-dependency-defs defsystem-depends-on))
                        component-options)))
268
        (setf (gethash name *systems-being-defined*) system)
269
        (load-systems* defsystem-dependencies)
270
271
272
        ;; We change-class AFTER we loaded the defsystem-depends-on
        ;; since the class might be defined as part of those.
        (let ((class (class-for-type nil class)))
273
274
          (unless (subtypep class 'system)
            (error 'non-system-system :name name :class-name (class-name class)))
275
276
277
278
279
280
281
282
283
284
          (unless (eq (type-of system) class)
            (change-class system class)))
        (parse-component-form
         nil (list*
              :module name
              :pathname (determine-system-directory pathname)
              component-options)))))

  (defmacro defsystem (name &body options)
    `(apply 'register-system-definition ',name ',options)))