-(defun parse-component-form (parent options)
- (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
- (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))))
-
- (loop for (n v) in `((perform ,perform) (explain ,explain)
- (output-files ,output-files)
- (operation-done-p ,operation-done-p))
- 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 n) m))
- (component-inline-methods ret))
- when v
- do (destructuring-bind (op qual (o c) &body body) v
- (pushnew
- (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret)))
- ,@body))
- (component-inline-methods ret))))
- ret)))