;;; Slot initializers.
(defmethod make-sod-instance-initializer
- ((class sod-class) nick name value-kind value-form pset
- &optional location)
+ ((class sod-class) nick name value pset &optional location)
(with-default-error-location (location)
(let* ((slot (find-instance-slot-by-name class nick name))
- (initializer (make-sod-initializer-using-slot
- class slot 'sod-instance-initializer
- value-kind value-form pset
- (file-location location))))
+ (initializer (and value
+ (make-sod-initializer-using-slot
+ class slot 'sod-instance-initializer
+ value pset (file-location location)))))
(with-slots (instance-initializers) class
+
(setf instance-initializers
(append instance-initializers (list initializer))))
initializer)))
(defmethod make-sod-class-initializer
- ((class sod-class) nick name value-kind value-form pset
- &optional location)
+ ((class sod-class) nick name value pset &optional location)
(with-default-error-location (location)
(let* ((slot (find-class-slot-by-name class nick name))
(initializer (make-sod-initializer-using-slot
class slot 'sod-class-initializer
- value-kind value-form pset
- (file-location location))))
+ value pset (file-location location))))
(with-slots (class-initializers) class
(setf class-initializers
(append class-initializers (list initializer))))
initializer)))
(defmethod make-sod-initializer-using-slot
- ((class sod-class) (slot sod-slot)
- init-class value-kind value-form pset location)
+ ((class sod-class) (slot sod-slot) init-class value pset location)
(make-instance (get-property pset :initializer-class :symbol init-class)
:class class
:slot slot
- :value-kind value-kind
- :value-form value-form
+ :value value
:location (file-location location)
:pset pset))
nil)
;;;--------------------------------------------------------------------------
+;;; Initialization and teardown fragments.
+
+(defmethod make-sod-class-initfrag
+ ((class sod-class) frag pset &optional location)
+ (declare (ignore pset location))
+ (with-slots (initfrags) class
+ (setf initfrags (append initfrags (list frag)))))
+
+(defmethod make-sod-class-tearfrag
+ ((class sod-class) frag pset &optional location)
+ (declare (ignore pset location))
+ (with-slots (tearfrags) class
+ (setf tearfrags (append tearfrags (list frag)))))
+
+;;;--------------------------------------------------------------------------
;;; Messages.
(defmethod make-sod-message
"Signal an error unless METHOD-TYPE and MESSAGE-TYPE have matching argument
lists.
- This checks that the two types have matching lists of arguments."
+ This checks that (a) the two types have matching lists of mandatory
+ arguments, and (b) that either both or neither types accept keyword
+ arguments."
+ (let ((message-keywords-p (typep message-type 'c-keyword-function-type))
+ (method-keywords-p (typep method-type 'c-keyword-function-type)))
+ (cond (message-keywords-p
+ (unless method-keywords-p
+ (error "Method must declare a keyword argument list")))
+ (method-keywords-p
+ (error "Method must not declare a keyword argument list"))))
(unless (argument-lists-compatible-p (c-function-arguments message-type)
(c-function-arguments method-type))
(error "Method arguments ~A don't match message ~A"