;;; Slot initializers.
(defmethod make-sod-instance-initializer
- ((class sod-class) nick name value pset &key location)
+ ((class sod-class) nick name value pset
+ &key location inhibit-initargs (add-to-class t))
(with-default-error-location (location)
(let* ((slot (find-instance-slot-by-name class nick name))
(initarg-name (get-property pset :initarg :id))
(with-slots (instance-initializers) class
(unless (or initarg-name initializer)
(error "Slot initializer declaration with no effect"))
- (when initarg-name
+ (when (and initarg-name (not inhibit-initargs))
(make-sod-slot-initarg-using-slot class initarg-name slot pset
:location location))
- (when initializer
+ (when (and initializer add-to-class)
(setf instance-initializers
(append instance-initializers (list initializer)))))
initializer)))
(defmethod make-sod-class-initializer
- ((class sod-class) nick name value pset &key location)
+ ((class sod-class) nick name value pset &key location (add-to-class t))
(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 pset (file-location location))))
- (with-slots (class-initializers) class
- (setf class-initializers
- (append class-initializers (list initializer))))
+ (when add-to-class
+ (with-slots (class-initializers) class
+ (setf class-initializers
+ (append class-initializers (list initializer)))))
initializer)))
(defmethod make-sod-initializer-using-slot
((class sod-class) name (slot sod-slot) pset &key location)
(with-slots (initargs) class
(with-slots ((type %type)) slot
- (push (make-instance (get-property pset :initarg-class :symbol
- 'sod-slot-initarg)
- :location (file-location location)
- :class class :name name :type type :slot slot)
- initargs))))
+ (setf initargs
+ (append initargs
+ (cons (make-instance (get-property pset :initarg-class
+ :symbol
+ 'sod-slot-initarg)
+ :location (file-location location)
+ :class class :name name
+ :type type :slot slot)
+ nil))))))
(defmethod sod-initarg-default ((initarg sod-initarg)) nil)
(defmethod shared-initialize :after
((message sod-message) slot-names &key pset)
- (declare (ignore slot-names pset))
(with-slots ((type %type)) message
- (check-message-type message type)))
+ (check-message-type message type))
+ (default-slot-from-property (message 'readonlyp slot-names)
+ (pset :readonly :boolean)
+ nil))
(defmethod check-message-type ((message sod-message) (type c-function-type))
nil)
(check-method-return-type-against-message type msgtype)
(check-method-argument-lists type msgtype)))
+;;;--------------------------------------------------------------------------
+;;; Static instances.
+
+(defmethod shared-initialize :after
+ ((instance static-instance) slot-names &key pset)
+ "Initialize a static instance."
+ (default-slot-from-property (instance 'externp slot-names)
+ (pset :extern :boolean)
+ nil)
+ (default-slot-from-property (instance 'constp slot-names)
+ (pset :const :boolean)
+ t))
+
+(defmethod make-static-instance ((class sod-class) name initializers
+ pset location &key)
+
+ ;; Check that the initializers are all for distinct slots.
+ (find-duplicates (lambda (initializer previous)
+ (let ((slot (sod-initializer-slot initializer)))
+ (cerror*-with-location initializer
+ "Duplicate initializer for ~
+ instance slot `~A' in ~
+ static instance `~A'"
+ slot name)
+ (info-with-location previous
+ "Previous definition was here")))
+ initializers
+ :key #'sod-initializer-slot)
+
+ ;; Ensure that every slot will have an initializer, either defined directly
+ ;; on the instance or as part of some class definition.
+ (let ((have (make-hash-table)))
+
+ ;; First, populate the hash table with all of the slots for which we have
+ ;; initializers.
+ (flet ((seen-slot-initializer (init)
+ (setf (gethash (sod-initializer-slot init) have) t)))
+ (mapc #'seen-slot-initializer
+ initializers)
+ (dolist (super (sod-class-precedence-list class))
+ (mapc #'seen-slot-initializer
+ (sod-class-instance-initializers super))))
+
+ ;; Now go through all of the slots and check that they have initializers.
+ (dolist (super (sod-class-precedence-list class))
+ (dolist (slot (sod-class-slots super))
+ (unless (gethash slot have)
+ (cerror*-with-location location
+ "No initializer for instance slot `~A', ~
+ required by static instance `~A'"
+ slot name)
+ (info-with-location slot "Slot `~A' defined here" slot)))))
+
+ ;; Make the instance.
+ (make-instance 'static-instance
+ :class class
+ :name name
+ :initializers initializers
+ :location (file-location location)
+ :pset pset))
+
;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff