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

4
5
(asdf/package:define-package :asdf/defsystem
  (:recycle :asdf/defsystem :asdf)
6
7
  (:use :common-lisp :asdf/driver :asdf/upgrade
   :asdf/component :asdf/system
8
   :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate
9
   :asdf/backward-internals)
10
  #+gcl<2.7 (:shadowing-import-from :asdf/compatibility #:type-of)
11
  (:export
12
13
14
   #:defsystem #:register-system-definition
   #:class-for-type #:*default-component-class*
   #:determine-system-directory #:parse-component-form
15
   #:duplicate-names #:sysdef-error-component #:check-component-input))
16
17
18
19
(in-package :asdf/defsystem)

;;; Pathname

20
21
(defun* determine-system-directory (pathname)
  ;; The defsystem macro calls this function to determine
22
  ;; the pathname of a system as follows:
23
24
  ;; 1. if the pathname argument is an pathname object (NOT a namestring),
  ;;    that is already an absolute pathname, return it.
25
  ;; 2. otherwise, the directory containing the LOAD-PATHNAME
26
27
28
  ;;    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
29
  ;;    as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T)
30
  ;;    and merged into that DIRECTORY as per SUBPATHNAME.
31
32
  ;;    Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded,
  ;;    and may be from within the EVAL-WHEN of a file compilation.
33
34
  ;; If no absolute pathname was found, we return NIL.
  (check-type pathname (or null string pathname))
35
  (or (and (pathnamep pathname) (absolute-pathname-p pathname) (resolve-symlinks* pathname))
36
37
38
      (let* ((load-pathname (resolve-symlinks* (load-pathname))))
        (when (absolute-pathname-p load-pathname)
          (subpathname load-pathname pathname :type :directory)))))
39

40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61

;;; 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)))

62

63
64
65
66
67
68
69
70
71
72
73
74
75
;;; 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
76
                                    depends-on components)
77
78
79
80
81
82
83
84
85
  "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."
86
                            type name components)))
87

88
(defun* normalize-version (form pathname)
89
90
91
  (etypecase form
    ((or string null) form)
    (cons
92
93
     (ecase (first form)
       ((:read-file-form)
94
95
96
        (destructuring-bind (subpath &key (path 0)) (rest form)
          (safe-read-file-form (subpathname pathname subpath) :path path)))))))

97

98
99
100
101
;;; Main parsing function

(defun* parse-component-form (parent options &key previous-serial-component)
  (destructuring-bind
102
103
      (type name &rest rest &key
       ;; the following list of keywords is reproduced below in the
104
       ;; remove-plist-keys form.  important to keep them in sync
105
106
107
108
109
       components pathname perform explain output-files operation-done-p
       weakly-depends-on depends-on serial
       do-first if-component-dep-fails (version nil versionp)
       ;; list ends
       &allow-other-keys) options
110
    (declare (ignorable perform explain output-files operation-done-p))
111
    (check-component-input type name weakly-depends-on depends-on components)
112
113
114
115
116
117
    (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))
118
    (when do-first (error "DO-FIRST is not supported anymore as of ASDF 2.27"))
119
120
121
    (let* ((args `(:name ,(coerce-name name)
                   :pathname ,pathname
                   ,@(when parent `(:parent ,parent))
122
                   ,@(remove-plist-keys
123
124
125
                      '(:components :pathname :if-component-dep-fails :version
                        :perform :explain :output-files :operation-done-p
                        :weakly-depends-on :depends-on :serial)
126
                      rest)))
127
           (component (find-component parent name)))
128
      (when weakly-depends-on
129
130
131
        ;; ASDF3: deprecate this feature and remove it.
        (appendf depends-on
                 (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
132
133
      (when previous-serial-component
        (push previous-serial-component depends-on))
134
135
136
137
138
      (if component ; preserve identity
          (apply 'reinitialize-instance component args)
          (setf component (apply 'make-instance (class-for-type parent type) args)))
      (component-pathname component) ; eagerly compute the absolute pathname
      (let ((sysdir (system-source-directory (component-system component)))) ;; requires the previous
139
140
141
142
143
        (setf version (normalize-version version sysdir)))
      (when (and versionp (not (parse-version version nil)))
        (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
              version name parent))
      (setf (component-version component) version)
144
145
      (when (typep component 'parent-component)
        (setf (component-children component)
146
147
148
              (loop
                :with previous-component = nil
                :for c-form :in components
149
                :for c = (parse-component-form component c-form
150
151
152
153
                                               :previous-serial-component previous-component)
                :for name = (component-name c)
                :collect c
                :when serial :do (setf previous-component name)))
154
155
156
157
158
159
160
        (compute-children-by-name component))
      ;; Used by POIU. ASDF3: rename to component-depends-on
      (setf (component-sibling-dependencies component) depends-on)
      (%refresh-component-inline-methods component rest)
      (when if-component-dep-fails
        (%resolve-if-component-dep-fails if-component-dep-fails component))
      component)))
161

162
163
164
(defun* register-system-definition
    (name &rest options &key pathname (class 'system) (source-file () sfp)
          defsystem-depends-on &allow-other-keys)
165
166
167
168
169
170
171
172
  ;; 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))
173
           (source-file (if sfp source-file (resolve-symlinks* (load-pathname))))
174
175
           (registered (system-registered-p name))
           (registered! (if registered
176
                            (rplaca registered (safe-file-write-date source-file))
177
178
                            (register-system
                             (make-instance 'system :name name :source-file source-file))))
179
           (system (reset-system (cdr registered!)
180
                                 :name name :source-file source-file))
181
           (component-options (remove-plist-key :class options)))
182
      (apply 'load-systems defsystem-depends-on)
183
      ;; We change-class AFTER we loaded the defsystem-depends-on
184
185
186
187
188
189
190
      ;; 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
191
            :pathname (determine-system-directory pathname)
192
193
194
            component-options)))))

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