defsystem.lisp 8.98 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
25
26
27
28
29
30
31
32
33
34
35
36
37
  ;; 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 CURRENT-LISP-FILE-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 WANT-DIRECTORY T)
  ;;    and merged into that DIRECTORY as per SUBPATHNAME.
  ;; If no absolute pathname was found, we return NIL.
  (check-type pathname (or null string pathname))
  (or (and (pathnamep pathname) (absolute-pathname-p pathname))
      (let* ((lisp-file-pathname (resolve-symlinks* (current-lisp-file-pathname))))
        (when (absolute-pathname-p lisp-file-pathname)
          (subpathname lisp-file-pathname pathname :type :directory)))))

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

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

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

89
90
91
92
93
94
95
96
(defun* normalize-version (form pathname)
  (cond
    ((typep form '(or string null)) form)
    ((length=n-p form 2)
     (ecase (first form)
       ((:read-file-form)
        (safe-read-first-file-form (subpathname pathname (second form))))))))

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
;;; 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 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
137
      (when versionp
138
        (unless (parse-version (normalize-version
139
                                version (system-source-directory (component-system ret))) nil)
140
141
          (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
                version name parent)))
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
      (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)))

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

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