- (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
- depends-on serialize in-order-to
- ;; list ends
- &allow-other-keys) options
- (declare (ignore serialize))
- ;; XXX add dependencies for serialized subcomponents
- (let* ((other-args (remove-keys
- '(components pathname default-component-class
- perform explain output-files operation-done-p
- depends-on serialize in-order-to)
- rest))
- (ret
- (or (find-component parent name)
- (make-instance (class-for-type parent type)))))
- (apply #'reinitialize-instance
- ret
- :name (coerce-name name)
- :pathname pathname
- :parent parent
- :in-order-to (union-of-dependencies
- in-order-to
- `((compile-op (compile-op ,@depends-on))
- (load-op (load-op ,@depends-on))))
- :do-first `((compile-op (load-op ,@depends-on)))
- 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)))))
- (when components
- (setf (module-components ret)
- (mapcar (lambda (x) (parse-component-form ret x)) components)))
- (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)))
-
+ (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)))
+
+(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))