parse-defsystem.lisp 12.7 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 107 108 109 110 111 112 113 114 115 116 117 118
  (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)
               (unless (builtin-system-p (find-component parent component))
                 (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
  (defun* (parse-component-form) (parent options &key previous-serial-component)
137 138 139 140 141 142 143
    (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
144
                                do-first if-component-dep-fails version
145 146
                                ;; list ends
         &allow-other-keys) options
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
147
      (declare (ignore perform explain output-files operation-done-p builtin-system-p))
148 149 150 151 152 153 154 155
      (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"))
156 157
      (let* ((name (coerce-name name))
             (args `(:name ,name
158 159 160 161 162 163 164
                     :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)))
165 166 167 168
             (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))
169 170
        (if component ; preserve identity
            (apply 'reinitialize-instance component args)
171
            (setf component (apply 'make-instance class args)))
172
        (component-pathname component) ; eagerly compute the absolute pathname
173
        (when (typep component 'system)
174
          ;; cache information for introspection
175 176
          (setf (slot-value component 'depends-on) depends-on
                (slot-value component 'weakly-depends-on) weakly-depends-on))
177
        (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous
178
          (when (and (typep component 'system) (not bspp))
179 180
            (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile)))
          (setf version (normalize-version version :component name :parent parent :pathname sysfile)))
181 182 183
        ;; 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)
184 185 186 187 188 189 190 191 192 193 194
        (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))
195 196 197 198 199 200
        (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)))
201
        ;; Used by POIU. ASDF4: rename to component-depends-on?
202
        (setf (component-sideway-dependencies component) depends-on)
203 204
        (%refresh-component-inline-methods component rest)
        (when if-component-dep-fails
205 206 207 208
          (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))))
209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229
        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 ()
      (let* ((name (coerce-name name))
             (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))
230 231 232
             (component-options (remove-plist-key :class options))
             (defsystem-dependencies (loop :for spec :in defsystem-depends-on :collect
                                           (resolve-dependency-spec nil spec))))
233
        (setf (gethash name *systems-being-defined*) system)
234
        (load-systems* defsystem-dependencies)
235 236 237
        ;; 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)))
238 239
          (unless (subtypep class 'system)
            (error 'non-system-system :name name :class-name (class-name class)))
240 241 242 243 244 245 246 247 248 249
          (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)))