X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/d145f6df86aca5c0b520f300ce8821e762a9707b..ae0f15ee8427fa91cfd1945bfded847032cb8a25:/src/class-make-impl.lisp

diff --git a/src/class-make-impl.lisp b/src/class-make-impl.lisp
index 28c1958..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)
@@ -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,7 +113,8 @@
 			 (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)
@@ -134,7 +124,7 @@
 		 :slot slot
 		 :value-kind value-kind
 		 :value-form value-form
-		 :location location
+		 :location (file-location location)
 		 :pset pset))
 
 (defmethod shared-initialize :after
@@ -163,12 +153,13 @@
 				   :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))
@@ -188,7 +179,8 @@
 						  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)
@@ -198,7 +190,7 @@
 		 :class class
 		 :type type
 		 :body body
-		 :location location
+		 :location (file-location location)
 		 :pset pset))
 
 (defmethod sod-message-method-class
@@ -211,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
@@ -229,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"