X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/9ec578d9fe450b7e7f9030dc9d930185593aa991..6e6b09589b6f6d0b260fd022e6a3b189f7f7d352:/src/method-impl.lisp

diff --git a/src/method-impl.lisp b/src/method-impl.lisp
index 09dbb2b..6c9b28d 100644
--- a/src/method-impl.lisp
+++ b/src/method-impl.lisp
@@ -40,33 +40,24 @@
    inheriting its default behaviour.
 
    The function type protocol is implemented on `basic-message' using slot
-   reader methods.  The actual values are computed on demand in methods
-   defined on `slot-unbound'."))
+   reader methods.  The actual values are computed on demand."))
 
-(defmethod slot-unbound (class
-			 (message basic-message)
-			 (slot-name (eql 'argument-tail)))
-  (declare (ignore class))
+(define-on-demand-slot basic-message argument-tail (message)
   (let ((seq 0))
-    (setf (slot-value message 'argument-tail)
-	  (mapcar (lambda (arg)
-		    (if (or (eq arg :ellipsis) (argument-name arg)) arg
-			(make-argument (make-instance 'temporary-argument
-						      :tag (prog1 seq
-							     (incf seq)))
-				       (argument-type arg))))
-		  (c-function-arguments (sod-message-type message))))))
-
-(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)
-		      (make-argument *sod-ap* (c-type va-list))
-		      arg))
-		(sod-message-argument-tail message))))
+    (mapcar (lambda (arg)
+	      (if (or (eq arg :ellipsis) (argument-name arg)) arg
+		  (make-argument (make-instance 'temporary-argument
+						:tag (prog1 seq
+						       (incf seq)))
+				 (argument-type arg))))
+	    (c-function-arguments (sod-message-type message)))))
+
+(define-on-demand-slot basic-message no-varargs-tail (message)
+  (mapcar (lambda (arg)
+	    (if (eq arg :ellipsis)
+		(make-argument *sod-ap* (c-type va-list))
+		arg))
+	  (sod-message-argument-tail message)))
 
 (defmethod sod-message-method-class
     ((message basic-message) (class sod-class) pset)
@@ -98,6 +89,9 @@
       (call-next-method)
       (primary-method-class message)))
 
+(defmethod primary-method-class ((message simple-message))
+  'basic-direct-method)
+
 ;;;--------------------------------------------------------------------------
 ;;; Direct method classes.
 
@@ -117,25 +111,21 @@
    categorization.
 
    The function type protocol is implemented on `basic-direct-method' using
-   slot reader methods.  The actual values are computed on demand in methods
-   defined on `slot-unbound'."))
+   slot reader methods."))
 
 (defmethod shared-initialize :after
     ((method basic-direct-method) slot-names &key pset)
   (declare (ignore slot-names))
   (default-slot (method 'role) (get-property pset :role :keyword nil)))
 
-(defmethod slot-unbound
-    (class (method basic-direct-method) (slot-name (eql 'function-type)))
-  (declare (ignore class))
+(define-on-demand-slot basic-direct-method function-type (method)
   (let ((type (sod-method-type method)))
-    (setf (slot-value method 'function-type)
-	  (c-type (fun (lisp (c-type-subtype type))
-		       ("me" (* (class (sod-method-class method))))
-		       . (c-function-arguments type))))))
+    (c-type (fun (lisp (c-type-subtype type))
+		 ("me" (* (class (sod-method-class method))))
+		 . (c-function-arguments type)))))
 
 (defmethod sod-method-function-name ((method basic-direct-method))
-  (with-slots (class role message) method
+  (with-slots ((class %class) role message) method
     (format nil "~A__~@[~(~A~)_~]method_~A__~A" class role
 	    (sod-class-nickname (sod-message-class message))
 	    (sod-message-name message))))
@@ -156,7 +146,7 @@
 (defmethod check-method-type ((method daemon-direct-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 type) (c-type void))
       (error "Method return type ~A must be `void'" (c-type-subtype type)))
     (unless (argument-lists-compatible-p (c-function-arguments msgtype)
@@ -181,40 +171,36 @@
    its `next_method' function if necessary.)
 
    The function type protocol is implemented on `delegating-direct-method'
-   using slot reader methods.  The actual values are computed on demand in
-   methods defined on `slot-unbound'."))
+   using slot reader methods.."))
 
-(defmethod slot-unbound (class
-			 (method delegating-direct-method)
-			 (slot-name (eql 'next-method-type)))
-  (declare (ignore class))
+(define-on-demand-slot delegating-direct-method next-method-type (method)
   (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))))))
-
-(defmethod slot-unbound (class
-			 (method delegating-direct-method)
-			 (slot-name (eql 'function-type)))
-  (declare (ignore class))
+	 (return-type (c-type-subtype (sod-message-type message)))
+	 (msgargs (sod-message-argument-tail message))
+	 (arguments (if (varargs-message-p message)
+			(cons (make-argument *sod-master-ap*
+					     (c-type va-list))
+			      (butlast msgargs))
+			msgargs)))
+    (c-type (fun (lisp return-type)
+		 ("me" (* (class (sod-method-class method))))
+		 . arguments))))
+
+(define-on-demand-slot delegating-direct-method function-type (method)
   (let* ((message (sod-method-message method))
 	 (type (sod-method-type method))
 	 (method-args (c-function-arguments type)))
-    (setf (slot-value method 'function-type)
-	  (c-type (fun (lisp (c-type-subtype type))
-		       ("me" (* (class (sod-method-class method))))
-		       ("next_method" (* (lisp (commentify-function-type
-						(sod-method-next-method-type
-						 method)))))
-		       .
-		       (if (varargs-message-p message)
-			   (cons (make-argument *sod-master-ap*
-						(c-type va-list))
-				 method-args)
-			   method-args))))))
+    (c-type (fun (lisp (c-type-subtype type))
+		 ("me" (* (class (sod-method-class method))))
+		 ("next_method" (* (lisp (commentify-function-type
+					  (sod-method-next-method-type
+					   method)))))
+		 .
+		 (if (varargs-message-p message)
+		     (cons (make-argument *sod-master-ap*
+					  (c-type va-list))
+			   method-args)
+		     method-args)))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Effective method classes.
@@ -238,18 +224,12 @@
    correctly.
 
    The argument names protocol is implemented on `basic-effective-method'
-   using a slot reader method.  The actual values are computed on demand in
-   methods defined on `slot-unbound'."))
+   using a slot reader method."))
 
-(defmethod slot-unbound (class
-			 (method basic-effective-method)
-			 (slot-name (eql 'basic-argument-names)))
-  (declare (ignore class))
+(define-on-demand-slot basic-effective-method basic-argument-names (method)
   (let ((message (effective-method-message method)))
-    (setf (slot-value method 'basic-argument-names)
-	  (subst *sod-master-ap* *sod-ap*
-		 (mapcar #'argument-name
-			 (sod-message-no-varargs-tail message))))))
+    (mapcar #'argument-name
+	    (sod-message-no-varargs-tail message))))
 
 (defmethod effective-method-function-name ((method effective-method))
   (let* ((class (effective-method-class method))
@@ -260,11 +240,8 @@
 	    (sod-class-nickname message-class)
 	    (sod-message-name message))))
 
-(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)))
+(define-on-demand-slot basic-effective-method functions (method)
+  (compute-method-entry-functions method))
 
 (export 'simple-effective-method)
 (defclass simple-effective-method (basic-effective-method)
@@ -316,23 +293,23 @@
    returned by the outermost `around' method -- or, if there are none,
    delivered by the BODY -- is finally delivered to the TARGET."
 
-  (with-slots (message class before-methods after-methods around-methods)
+  (with-slots (message (class %class)
+	       before-methods after-methods around-methods)
       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)))))
 
@@ -349,33 +326,51 @@
    effective method out into its own function.")
 
 (defmethod method-entry-function-name
-    ((method effective-method) (chain-head sod-class))
+    ((method effective-method) (chain-head sod-class) role)
   (let* ((class (effective-method-class method))
 	 (message (effective-method-message method))
 	 (message-class (sod-message-class message)))
     (if (or (not (slot-boundp method 'functions))
 	    (slot-value method 'functions))
-	(format nil "~A__mentry_~A__~A__chain_~A"
-		class
+	(format nil "~A__mentry~@[__~(~A~)~]_~A__~A__chain_~A"
+		class role
 		(sod-class-nickname message-class)
 		(sod-message-name message)
 		(sod-class-nickname chain-head))
 	0)))
 
+(defmethod method-entry-slot-name ((entry method-entry))
+  (let* ((method (method-entry-effective-method entry))
+	 (message (effective-method-message method))
+	 (name (sod-message-name message))
+	 (role (method-entry-role entry)))
+    (method-entry-slot-name-by-role entry role name)))
+
 (defmethod method-entry-function-type ((entry method-entry))
   (let* ((method (method-entry-effective-method entry))
 	 (message (effective-method-message method))
-	 (type (sod-message-type message)))
+	 (type (sod-message-type message))
+	 (tail (ecase (method-entry-role entry)
+		 ((nil) (sod-message-argument-tail message))
+		 (:valist (sod-message-no-varargs-tail message)))))
     (c-type (fun (lisp (c-type-subtype type))
 		 ("me" (* (class (method-entry-chain-tail entry))))
-		 . (sod-message-argument-tail message)))))
-
-(defmethod make-method-entry ((method basic-effective-method)
-			      (chain-head sod-class) (chain-tail sod-class))
-  (make-instance 'method-entry
-		 :method method
-		 :chain-head chain-head
-		 :chain-tail chain-tail))
+		 . tail))))
+
+(defmethod make-method-entries ((method basic-effective-method)
+				(chain-head sod-class)
+				(chain-tail sod-class))
+  (let ((entries nil)
+	(message (effective-method-message method)))
+    (flet ((make (role)
+	     (push (make-instance 'method-entry
+				  :method method :role role
+				  :chain-head chain-head
+				  :chain-tail chain-tail)
+		   entries)))
+      (when (varargs-message-p message) (make :valist))
+      (make nil)
+      entries)))
 
 (defmethod compute-method-entry-functions ((method basic-effective-method))
 
@@ -410,32 +405,25 @@
 				 :class class
 				 :method method))
 
-	 ;; Effective method function details.
-	 (emf-name (effective-method-function-name method))
-	 (ilayout-type (c-type (* (struct (ilayout-struct-tag class)))))
-	 (emf-arg-tail (mapcar (lambda (arg)
-				 (if (eq (argument-name arg) *sod-ap*)
-				     (make-argument *sod-master-ap*
-						    (c-type va-list))
-				     arg))
-			       (sod-message-no-varargs-tail message)))
-	 (emf-type (c-type (fun (lisp return-type)
-				("sod__obj" (lisp ilayout-type))
-				. (sod-message-no-varargs-tail message))))
-
 	 ;; Method entry details.
 	 (chain-tails (remove-if-not (lambda (super)
 				       (sod-subclass-p super message-class))
 				     (mapcar #'car
 					     (sod-class-chains class))))
 	 (n-entries (length chain-tails))
-	 (entry-args (sod-message-argument-tail message))
-	 (parm-n (do ((prev "me" (car args))
-		      (args entry-args (cdr args)))
-		     ((endp args) nil)
-		   (when (eq (car args) :ellipsis)
-		     (return prev))))
-	 (entry-target (codegen-target codegen)))
+	 (raw-entry-args (sod-message-argument-tail message))
+	 (entry-args (sod-message-no-varargs-tail message))
+	 (parm-n (let ((tail (last raw-entry-args 2)))
+		   (and tail (eq (cadr tail) :ellipsis) (car tail))))
+	 (entry-target (codegen-target codegen))
+
+	 ;; Effective method function details.
+	 (emf-name (effective-method-function-name method))
+	 (ilayout-type (c-type (* (struct (ilayout-struct-tag class)))))
+	 (emf-arg-tail (sod-message-no-varargs-tail message))
+	 (emf-type (c-type (fun (lisp return-type)
+				("sod__obj" (lisp ilayout-type))
+				. emf-arg-tail))))
 
     (flet ((setup-entry (tail)
 	     (let ((head (sod-class-chain-head tail)))
@@ -443,23 +431,40 @@
 	       (ensure-var codegen "sod__obj" ilayout-type
 			   (make-convert-to-ilayout-inst class
 							 head "me"))))
-	   (varargs-prologue ()
-	     (ensure-var codegen *sod-master-ap* (c-type va-list))
-	     (emit-inst codegen
-			(make-va-start-inst *sod-master-ap* parm-n)))
-	   (varargs-epilogue ()
-	     (emit-inst codegen (make-va-end-inst *sod-master-ap*)))
 	   (finish-entry (tail)
 	     (let* ((head (sod-class-chain-head tail))
-		    (name (method-entry-function-name method head))
+		    (role (if parm-n :valist nil))
+		    (name (method-entry-function-name method head role))
 		    (type (c-type (fun (lisp return-type)
 				       ("me" (* (class tail)))
 				       . entry-args))))
-	       (codegen-pop-function codegen name type))))
+	       (codegen-pop-function codegen name type)
+
+	       ;; If this is a varargs method then we've made the
+	       ;; `:valist' role.  Also make the `nil' role.
+	       (when parm-n
+		 (let ((call (make-call-inst name
+					     (cons "me"
+						   (mapcar #'argument-name
+							   entry-args))))
+		       (main (method-entry-function-name method head nil))
+		       (main-type (c-type (fun (lisp return-type)
+					       ("me" (* (class tail)))
+					       . raw-entry-args))))
+		   (codegen-push codegen)
+		   (ensure-var codegen *sod-ap* (c-type va-list))
+		   (emit-inst codegen
+			      (make-va-start-inst *sod-ap*
+						  (argument-name parm-n)))
+		   (convert-stmts codegen entry-target return-type
+				  (lambda (target)
+				    (deliver-expr codegen target call)))
+		   (emit-inst codegen (make-va-end-inst *sod-ap*))
+		   (codegen-pop-function codegen main main-type))))))
 
       ;; Generate the method body.  We'll work out what to do with it later.
       (codegen-push codegen)
-      (let* ((result (if (eq return-type (c-type void)) nil
+      (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)
@@ -474,11 +479,11 @@
 		 (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))
+		     (if (typep var 'var-inst)
+			 (ensure-var codegen (inst-name var)
+				     (inst-type var) (inst-init var))
+			 (emit-decl codegen var)))
 		   (emit-insts codegen insts)
-		   (when parm-n (varargs-epilogue))
 		   (deliver-expr codegen entry-target result)
 		   (finish-entry tail)))
 
@@ -496,15 +501,7 @@
 						       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)))
+		     (deliver-expr codegen entry-target call)
 		     (finish-entry tail)))))))
 
       (codegen-functions codegen))))
@@ -517,12 +514,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.
@@ -531,7 +527,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