X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/aa14a4cddcb96b681d5c19a2ec8bad382f43b264..76618d28a01b4b65b530ac032372f2b22ad08d5d:/src/method-impl.lisp

diff --git a/src/method-impl.lisp b/src/method-impl.lisp
index b9045ce..49c6676 100644
--- a/src/method-impl.lisp
+++ b/src/method-impl.lisp
@@ -46,6 +46,7 @@
 (defmethod slot-unbound (class
 			 (message basic-message)
 			 (slot-name (eql 'argument-tail)))
+  (declare (ignore class))
   (let ((seq 0))
     (setf (slot-value message 'argument-tail)
 	  (mapcar (lambda (arg)
@@ -59,6 +60,7 @@
 (defmethod slot-unbound (class
 			 (message basic-message)
 			 (slot-name (eql 'no-varargs-tail)))
+  (declare (ignore class))
   (setf (slot-value message 'no-varargs-tail)
 	(mapcar (lambda (arg)
 		  (if (eq arg :ellipsis)
@@ -82,9 +84,9 @@
    "Base class for messages with `simple' method combinations.
 
    A simple method combination is one which has only one method role other
-   than the `before', `after' and `around' methods provided by BASIC-MESSAGE.
-   We call these `primary' methods, and the programmer designates them by not
-   specifying an explicit role.
+   than the `before', `after' and `around' methods provided by
+   `basic-message'.  We call these `primary' methods, and the programmer
+   designates them by not specifying an explicit role.
 
    If the programmer doesn't define any primary methods then the effective
    method is null -- i.e., the method entry pointer shows up as a null
@@ -96,6 +98,9 @@
       (call-next-method)
       (primary-method-class message)))
 
+(defmethod primary-method-class ((message simple-message))
+  'basic-direct-method)
+
 ;;;--------------------------------------------------------------------------
 ;;; Direct method classes.
 
@@ -125,6 +130,7 @@
 
 (defmethod slot-unbound
     (class (method basic-direct-method) (slot-name (eql 'function-type)))
+  (declare (ignore class))
   (let ((type (sod-method-type method)))
     (setf (slot-value method 'function-type)
 	  (c-type (fun (lisp (c-type-subtype type))
@@ -184,16 +190,19 @@
 (defmethod slot-unbound (class
 			 (method delegating-direct-method)
 			 (slot-name (eql 'next-method-type)))
+  (declare (ignore class))
   (let* ((message (sod-method-message method))
 	 (type (sod-message-type message)))
     (setf (slot-value method 'next-method-type)
 	  (c-type (fun (lisp (c-type-subtype type))
 		       ("me" (* (class (sod-method-class method))))
-		       . (c-function-arguments type))))))
+		       .
+		       (c-function-arguments type))))))
 
 (defmethod slot-unbound (class
 			 (method delegating-direct-method)
 			 (slot-name (eql 'function-type)))
+  (declare (ignore class))
   (let* ((message (sod-method-message method))
 	 (type (sod-method-type method))
 	 (method-args (c-function-arguments type)))
@@ -238,6 +247,7 @@
 (defmethod slot-unbound (class
 			 (method basic-effective-method)
 			 (slot-name (eql 'basic-argument-names)))
+  (declare (ignore class))
   (let ((message (effective-method-message method)))
     (setf (slot-value method 'basic-argument-names)
 	  (subst *sod-master-ap* *sod-ap*
@@ -255,6 +265,7 @@
 
 (defmethod slot-unbound
     (class (method basic-effective-method) (slot-name (eql 'functions)))
+  (declare (ignore class))
   (setf (slot-value method 'functions)
 	(compute-method-entry-functions method)))
 
@@ -285,6 +296,7 @@
 
 (defmethod shared-initialize :after
     ((codegen method-codegen) slot-names &key)
+  (declare (ignore slot-names))
   (with-slots (message target) codegen
     (setf target
 	  (if (eq (c-type-subtype (sod-message-type message)) (c-type void))
@@ -311,19 +323,18 @@
       method
     (let* ((message-type (sod-message-type message))
 	   (return-type (c-type-subtype message-type))
-	   (voidp (eq return-type (c-type void)))
 	   (basic-tail (effective-method-basic-argument-names method)))
       (flet ((method-kernel (target)
 	       (dolist (before before-methods)
 		 (invoke-method codegen :void basic-tail before))
-	       (if (or voidp (null after-methods))
+	       (if (null after-methods)
 		   (funcall body target)
 		   (convert-stmts codegen target return-type
 				  (lambda (target)
 				    (funcall body target)
 				    (dolist (after (reverse after-methods))
 				      (invoke-method codegen :void
-						     after basic-tail)))))))
+						     basic-tail after)))))))
 	(invoke-delegation-chain codegen target basic-tail
 				 around-methods #'method-kernel)))))
 
@@ -413,9 +424,6 @@
 	 (emf-type (c-type (fun (lisp return-type)
 				("sod__obj" (lisp ilayout-type))
 				. (sod-message-no-varargs-tail message))))
-	 (result (if (eq return-type (c-type void)) nil
-		     (temporary-var codegen return-type)))
-	 (emf-target (or result :void))
 
 	 ;; Method entry details.
 	 (chain-tails (remove-if-not (lambda (super)
@@ -453,48 +461,55 @@
 
       ;; Generate the method body.  We'll work out what to do with it later.
       (codegen-push codegen)
-      (compute-effective-method-body method codegen emf-target)
-      (multiple-value-bind (vars insts) (codegen-pop codegen)
-	(cond ((or (= n-entries 1)
-		   (<= (* n-entries (reduce #'+ insts :key #'inst-metric))
-		       *method-entry-inline-threshold*))
-
-	       ;; The effective method body is simple -- or there's only one
-	       ;; of them.  We'll inline the method body into the entry
-	       ;; functions.
-	       (dolist (tail chain-tails)
-		 (setup-entry tail)
-		 (dolist (var vars)
-		   (ensure-var codegen (inst-name var)
-			       (inst-type var) (inst-init var)))
-		 (when parm-n (varargs-prologue))
-		 (emit-insts codegen insts)
-		 (when parm-n (varargs-epilogue))
-		 (deliver-expr codegen entry-target result)
-		 (finish-entry tail)))
-
-	      (t
-
-	       ;; The effective method body is complicated and we'd need more
-	       ;; than one copy.  We'll generate an effective method function
-	       ;; and call it a lot.
-	       (codegen-build-function codegen emf-name emf-type vars
-		(nconc insts (and result (list (make-return-inst result)))))
-
-	       (let ((call (make-call-inst emf-name
-			    (cons "sod__obj" (mapcar #'argument-name
-						     emf-arg-tail)))))
+      (let* ((result (if (eq return-type c-type-void) nil
+			 (temporary-var codegen return-type)))
+	     (emf-target (or result :void)))
+	(compute-effective-method-body method codegen emf-target)
+	(multiple-value-bind (vars insts) (codegen-pop codegen)
+	  (cond ((or (= n-entries 1)
+		     (<= (* n-entries (reduce #'+ insts :key #'inst-metric))
+			 *method-entry-inline-threshold*))
+
+		 ;; The effective method body is simple -- or there's only
+		 ;; one of them.  We'll inline the method body into the entry
+		 ;; functions.
 		 (dolist (tail chain-tails)
 		   (setup-entry tail)
-		   (cond (parm-n
-			  (varargs-prologue)
-			  (convert-stmts codegen entry-target return-type
-					 (lambda (target)
-					   (deliver-expr codegen target call)
-					   (varargs-epilogue))))
-			 (t
-			  (deliver-expr codegen entry-target call)))
-		   (finish-entry tail))))))
+		   (dolist (var vars)
+		     (if (typep var 'var-inst)
+			 (ensure-var codegen (inst-name var)
+				     (inst-type var) (inst-init var))
+			 (emit-decl codegen var)))
+		   (when parm-n (varargs-prologue))
+		   (emit-insts codegen insts)
+		   (when parm-n (varargs-epilogue))
+		   (deliver-expr codegen entry-target result)
+		   (finish-entry tail)))
+
+		(t
+
+		 ;; The effective method body is complicated and we'd need
+		 ;; more than one copy.  We'll generate an effective method
+		 ;; function and call it a lot.
+		 (codegen-build-function codegen emf-name emf-type vars
+		  (nconc insts (and result
+				    (list (make-return-inst result)))))
+
+		 (let ((call (make-call-inst emf-name
+			      (cons "sod__obj" (mapcar #'argument-name
+						       emf-arg-tail)))))
+		   (dolist (tail chain-tails)
+		     (setup-entry tail)
+		     (cond (parm-n
+			    (varargs-prologue)
+			    (convert-stmts codegen entry-target return-type
+					   (lambda (target)
+					     (deliver-expr codegen
+							   target call)
+					     (varargs-epilogue))))
+			   (t
+			    (deliver-expr codegen entry-target call)))
+		     (finish-entry tail)))))))
 
       (codegen-functions codegen))))
 
@@ -506,12 +521,11 @@
 
 (defmethod compute-effective-method-body
     ((method simple-effective-method) codegen target)
-  (with-slots (message basic-argument-names primary-methods) method
-    (basic-effective-method-body codegen target method
-				 (lambda (target)
-				   (simple-method-body method
-						       codegen
-						       target)))))
+  (basic-effective-method-body codegen target method
+			       (lambda (target)
+				 (simple-method-body method
+						     codegen
+						     target))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Standard method combination.
@@ -520,7 +534,7 @@
 (defclass standard-message (simple-message)
   ()
   (:documentation
-   "Message class for standard method combination.
+   "Message class for standard method combinations.
 
    Standard method combination is a simple method combination where the
    primary methods are invoked as a delegation chain, from most- to