X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/9ec578d9fe450b7e7f9030dc9d930185593aa991..3f725f73b9ae26a54f49b5feb744d37a8f1dd308:/src/class-make-impl.lisp diff --git a/src/class-make-impl.lisp b/src/class-make-impl.lisp index 09ce441..29a30c1 100644 --- a/src/class-make-impl.lisp +++ b/src/class-make-impl.lisp @@ -28,19 +28,23 @@ ;;;-------------------------------------------------------------------------- ;;; Classes. +(defun maximum (items order what) + "Return a maximum item according to the non-strict partial ORDER." + (reduce (lambda (best this) + (cond ((funcall order best this) best) + ((funcall order this best) this) + (t (error "Unable to choose best ~A." what)))) + items)) + (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))) + (maximum (mapcar #'sod-class-metaclass + (sod-class-direct-superclasses class)) + #'sod-subclass-p + (format nil "metaclass for `~A'" class))) (defmethod shared-initialize :after ((class sod-class) slot-names &key pset) "Specific behaviour for SOD class initialization. @@ -66,7 +70,8 @@ ;; If no metaclass, guess one in a (Lisp) class-specific way. (default-slot-from-property (class 'metaclass slot-names) (pset :metaclass :id meta (find-sod-class meta)) - (guess-metaclass class)) + (and (sod-class-direct-superclasses class) + (guess-metaclass class))) ;; If no chain-link, then start a new chain here. (default-slot-from-property (class 'chain-link slot-names) @@ -79,7 +84,7 @@ (defmethod make-sod-slot ((class sod-class) name type pset &optional location) (with-default-error-location (location) - (let ((slot (make-instance (get-property pset :lisp-class :symbol + (let ((slot (make-instance (get-property pset :slot-class :symbol 'sod-slot) :class class :name name @@ -87,7 +92,8 @@ :location (file-location location) :pset pset))) (with-slots (slots) class - (setf slots (append slots (list slot))))))) + (setf slots (append slots (list slot)))) + slot))) (defmethod shared-initialize :after ((slot sod-slot) slot-names &key pset) "This method does nothing. @@ -111,7 +117,8 @@ (file-location location)))) (with-slots (instance-initializers) class (setf instance-initializers - (append instance-initializers (list initializer))))))) + (append instance-initializers (list initializer)))) + initializer))) (defmethod make-sod-class-initializer ((class sod-class) nick name value-kind value-form pset @@ -124,12 +131,13 @@ (file-location location)))) (with-slots (class-initializers) class (setf class-initializers - (append class-initializers (list initializer))))))) + (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) - (make-instance (get-property pset :lisp-class :symbol init-class) + (make-instance (get-property pset :initializer-class :symbol init-class) :class class :slot slot :value-kind value-kind @@ -152,20 +160,24 @@ (defmethod make-sod-message ((class sod-class) name type pset &optional location) (with-default-error-location (location) - (let ((message (make-instance (get-property pset :lisp-class :symbol - 'standard-message) - :class class - :name name - :type type - :location (file-location location) - :pset pset))) + (let* ((msg-class (or (get-property pset :message-class :symbol) + (and (get-property pset :combination :keyword) + 'aggregating-message) + 'standard-message)) + (message (make-instance msg-class + :class class + :name name + :type type + :location (file-location location) + :pset pset))) (with-slots (messages) class - (setf messages (append messages (list message))))))) + (setf messages (append messages (list message)))) + message))) (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)) @@ -185,11 +197,12 @@ type body pset (file-location location)))) (with-slots (methods) class - (setf methods (append methods (list method))))))) + (setf methods (append methods (list method)))) + method))) (defmethod make-sod-method-using-message ((message sod-message) (class sod-class) type body pset location) - (make-instance (or (get-property pset :lisp-class :symbol) + (make-instance (or (get-property pset :method-class :symbol) (sod-message-method-class message class pset)) :message message :class class @@ -208,16 +221,17 @@ (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 (argument-name arg) + (or (eq arg :ellipsis) + (argument-name arg) (eq (argument-type arg) (c-type void)))) (c-function-arguments type))) (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 @@ -226,7 +240,7 @@ (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"