+ (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 default-component-class
+ perform explain output-files operation-done-p
+ weakly-depends-on
+ depends-on serial in-order-to
+ ;; 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)
+ ;; ignore the same object when rereading the defsystem
+ (not
+ (typep (find-component parent name)
+ (class-for-type parent type))))
+ (error 'duplicate-names :name name))
+
+ (let* ((other-args (remove-keys
+ '(components pathname default-component-class
+ perform explain output-files operation-done-p
+ weakly-depends-on
+ depends-on serial in-order-to)
+ rest))
+ (ret
+ (or (find-component parent name)
+ (make-instance (class-for-type parent type)))))
+ (when weakly-depends-on
+ (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
+ (when (boundp '*serial-depends-on*)
+ (setf depends-on
+ (concatenate 'list *serial-depends-on* depends-on)))
+ (apply #'reinitialize-instance ret
+ :name (coerce-name name)
+ :pathname pathname
+ :parent parent
+ other-args)
+ (when (typep ret 'module)
+ (setf (module-default-component-class ret)
+ (or default-component-class
+ (and (typep parent 'module)
+ (module-default-component-class parent))))
+ (let ((*serial-depends-on* nil))
+ (setf (module-components ret)
+ (loop for c-form in components
+ for c = (parse-component-form ret c-form)
+ collect c
+ if serial
+ do (push (component-name c) *serial-depends-on*))))
+
+ ;; check for duplicate names
+ (let ((name-hash (make-hash-table :test #'equal)))
+ (loop for c in (module-components ret)
+ do
+ (if (gethash (component-name c)
+ name-hash)
+ (error 'duplicate-names
+ :name (component-name c))
+ (setf (gethash (component-name c)
+ name-hash)
+ t)))))
+
+ (setf (slot-value ret 'in-order-to)
+ (union-of-dependencies
+ in-order-to
+ `((compile-op (compile-op ,@depends-on))
+ (load-op (load-op ,@depends-on))))
+ (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on))))
+
+ (%remove-component-inline-methods ret rest)
+
+ ret)))
+
+(defun %remove-component-inline-methods (ret rest)
+ (loop for name in +asdf-methods+
+ do (map 'nil
+ ;; this is inefficient as most of the stored
+ ;; methods will not be for this particular gf n
+ ;; But this is hardly performance-critical
+ (lambda (m)
+ (remove-method (symbol-function name) m))
+ (component-inline-methods ret)))
+ ;; clear methods, then add the new ones
+ (setf (component-inline-methods ret) nil)
+ (loop for name in +asdf-methods+
+ for v = (getf rest (intern (symbol-name name) :keyword))
+ when v do
+ (destructuring-bind (op qual (o c) &body body) v
+ (pushnew
+ (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
+ ,@body))
+ (component-inline-methods ret)))))
+
+(defun check-component-input (type name weakly-depends-on depends-on components in-order-to)
+ "A partial test of the values of a component."
+ (when weakly-depends-on (warn "We got one! XXXXX"))
+ (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)))
+
+(defun sysdef-error-component (msg type name value)
+ (sysdef-error (concatenate 'string msg
+ "~&The value specified for ~(~A~) ~A is ~W")
+ type name value))