X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/9ec578d9fe450b7e7f9030dc9d930185593aa991..4effe5759a1229be4ce152db87172119ddcb45bb:/src/class-make-impl.lisp diff --git a/src/class-make-impl.lisp b/src/class-make-impl.lisp index 09ce441..dba6965 100644 --- a/src/class-make-impl.lisp +++ b/src/class-make-impl.lisp @@ -7,7 +7,7 @@ ;;;----- 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 @@ -28,20 +28,6 @@ ;;;-------------------------------------------------------------------------- ;;; 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. @@ -63,10 +49,11 @@ (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) @@ -79,7 +66,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 +74,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 +99,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,17 +113,18 @@ (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 :value-form value-form - :location location + :location (file-location location) :pset pset)) (defmethod shared-initialize :after @@ -152,20 +142,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,17 +179,18 @@ 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 :type type :body body - :location location + :location (file-location location) :pset pset)) (defmethod sod-message-method-class @@ -208,16 +203,18 @@ (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) - (eq (argument-type arg) (c-type void)))) + (or (eq arg :ellipsis) + (argument-name arg) + (c-type-equal-p (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 +223,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"