;;;----- Licensing notice ---------------------------------------------------
;;;
-;;; This file is part of the Sensble Object Design, an object system for C.
+;;; This file is part of the Sensible Object Design, an object system for C.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;;--------------------------------------------------------------------------
;;; Classes.
-(defmethod guess-metaclass ((class sod-class))
- "Default metaclass-guessing function for classes.
-
- Return the most specific metaclass of any of the CLASS's direct
- superclasses."
- (do ((supers (sod-class-direct-superclasses class) (cdr supers))
- (meta nil (let ((candidate (sod-class-metaclass (car supers))))
- (cond ((null meta) candidate)
- ((sod-subclass-p meta candidate) meta)
- ((sod-subclass-p candidate meta) candidate)
- (t (error "Unable to choose metaclass for `~A'"
- class))))))
- ((endp supers) meta)))
-
(defmethod shared-initialize :after ((class sod-class) slot-names &key pset)
"Specific behaviour for SOD class initialization.
(pset :nick :id)
(string-downcase (slot-value class 'name)))
- ;; If no metaclass, guess one in a (Lisp) class-specific way.
+ ;; Set the metaclass if the appropriate property has been provided;
+ ;; otherwise leave it unbound for now, and we'll sort out the mess during
+ ;; finalization.
(default-slot-from-property (class 'metaclass slot-names)
- (pset :metaclass :id meta (find-sod-class meta))
- (guess-metaclass class))
+ (pset :metaclass :id meta (find-sod-class meta)))
;; If no chain-link, then start a new chain here.
(default-slot-from-property (class 'chain-link slot-names)
(defmethod shared-initialize :after
((message sod-message) slot-names &key pset)
(declare (ignore slot-names pset))
- (with-slots (type) message
+ (with-slots ((type %type)) message
(check-message-type message type)))
(defmethod check-message-type ((message sod-message) (type c-function-type))
(declare (ignore slot-names pset))
;; Check that the arguments are named if we have a method body.
- (with-slots (body type) method
+ (with-slots (body (type %type)) method
(unless (or (not body)
(every (lambda (arg)
(or (eq arg :ellipsis)
(error "Abstract declarators not permitted in method definitions")))
;; Check the method type.
- (with-slots (message type) method
+ (with-slots (message (type %type)) method
(check-method-type method message type)))
(defmethod check-method-type
(defmethod check-method-type
((method sod-method) (message sod-message) (type c-function-type))
- (with-slots ((msgtype type)) message
+ (with-slots ((msgtype %type)) message
(unless (c-type-equal-p (c-type-subtype msgtype)
(c-type-subtype type))
(error "Method return type ~A doesn't match message ~A"