X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/4307347660f48628e307f299eb4fac58ba35fd1a..6c3c2dd3e236da72ce43b923e4eeac7d33eb5cbd:/src/method-impl.lisp?ds=sidebyside

diff --git a/src/method-impl.lisp b/src/method-impl.lisp
index 963f2fe..6c751a4 100644
--- a/src/method-impl.lisp
+++ b/src/method-impl.lisp
@@ -30,8 +30,7 @@
 
 (export 'basic-message)
 (defclass basic-message (sod-message)
-  ((argument-tail :type list :reader sod-message-argument-tail)
-   (no-varargs-tail :type list :reader sod-message-no-varargs-tail))
+  ((argument-tail :type list :reader sod-message-argument-tail))
   (:documentation
    "Base class for built-in message classes.
 
@@ -52,9 +51,6 @@
 				 (argument-type arg))))
 	    (c-function-arguments (sod-message-type message)))))
 
-(define-on-demand-slot basic-message no-varargs-tail (message)
-  (reify-variable-argument-tail (sod-message-argument-tail message)))
-
 (defmethod sod-message-method-class
     ((message basic-message) (class sod-class) pset)
   (let ((role (get-property pset :role :keyword nil)))
@@ -156,6 +152,11 @@
 		 ("me" (* (class (sod-method-class method))))
 		 . method-args))))
 
+(defmethod sod-method-description ((method basic-direct-method))
+  (with-slots (role) method
+    (if role (string-downcase role)
+	"primary")))
+
 (defmethod sod-method-function-name ((method basic-direct-method))
   (with-slots ((class %class) role message) method
     (format nil "~A__~@[~(~A~)_~]method_~A__~A" class role
@@ -248,21 +249,45 @@
 ;;;--------------------------------------------------------------------------
 ;;; Effective method classes.
 
+(defmethod sod-message-keyword-argument-lists
+    ((message sod-message) (class sod-class) direct-methods state)
+  (and (keyword-message-p message)
+       (cons (cons (lambda (arg)
+		     (let ((class (sod-message-class message)))
+		       (info-with-location
+			message "Type `~A' declared in message ~
+				 definition in `~A' (here)"
+			(argument-type arg) class)
+		       (report-inheritance-path state class)))
+		   (c-function-keywords (sod-message-type message)))
+	     (mapcar (lambda (method)
+		       (cons (lambda (arg)
+			       (let ((class (sod-method-class method)))
+				 (info-with-location
+				  method "Type `~A' declared in ~A direct ~
+					  method of `~A' (defined here)"
+				  (argument-type arg)
+				  (sod-method-description method) class)
+				 (report-inheritance-path state class)))
+			     (c-function-keywords (sod-method-type method))))
+		     direct-methods))))
+
+(defmethod sod-message-check-methods
+    ((message sod-message) (class sod-class) direct-methods)
+  (compute-effective-method-keyword-arguments message class direct-methods))
+
 (defmethod shared-initialize :after
     ((method effective-method) slot-names &key direct-methods)
   (declare (ignore slot-names))
 
-  ;; Set the keyword argument list.
-  (with-slots (message keywords) method
-    (setf keywords (and (keyword-message-p message)
-			(merge-keyword-lists
-			 (mapcar (lambda (m)
-				   (let ((type (sod-method-type m)))
-				     (cons (c-function-keywords type)
-					   (format nil "method for ~A on ~A"
-						   message
-						   (sod-method-class m)))))
-				 direct-methods))))))
+  ;; Set the keyword argument list.  Blame the class as a whole for mismatch
+  ;; errors, because they're fundamentally a non-local problem about the
+  ;; class construction.
+  (with-slots ((class %class) message keywords) method
+    (setf keywords
+	  (compute-effective-method-keyword-arguments message
+						      class
+						      direct-methods))))
 
 (export '(basic-effective-method
 	  effective-method-around-methods effective-method-before-methods
@@ -288,9 +313,9 @@
    using a slot reader method."))
 
 (define-on-demand-slot basic-effective-method basic-argument-names (method)
-  (let ((message (effective-method-message method)))
-    (mapcar #'argument-name
-	    (sod-message-no-varargs-tail message))))
+  (let* ((message (effective-method-message method))
+	 (raw-tail (sod-message-argument-tail message)))
+    (mapcar #'argument-name (reify-variable-argument-tail raw-tail))))
 
 (defmethod effective-method-function-name ((method effective-method))
   (let* ((class (effective-method-class method))
@@ -658,7 +683,8 @@
 	       (codegen-push codegen)
 	       (ensure-var codegen "sod__obj" ilayout-type
 			   (make-convert-to-ilayout-inst class
-							 head "me"))))
+							 head "me"))
+	       (deliver-call codegen :void "SOD__IGNORE" "sod__obj")))
 	   (finish-entry (tail)
 	     (let* ((head (sod-class-chain-head tail))
 		    (role (if parm-n :valist nil))
@@ -789,14 +815,24 @@
 		    (*keyword-struct-disposition* :local))
 	       (ensure-var codegen *sod-keywords* (c-type (struct tag)))
 	       (make-keyword-parser-function codegen method tag set keywords)
+	       (emit-insts codegen
+			   (mapcar (lambda (keyword)
+				     (make-set-inst
+				      (format nil "~A.~A__suppliedp"
+					      *sod-keywords*
+					      (argument-name keyword))
+				      0))
+				   keywords))
 	       (parse-keywords (lambda ()
 				 (call :void name kw-addr ap-addr
 				       *null-pointer* 0)))
 	       (call-next-method)))))))
 
-(defmethod compute-method-entry-functions
-    ((method simple-effective-method))
-  (if (effective-method-primary-methods method)
+(defmethod effective-method-live-p ((method simple-effective-method))
+  (effective-method-primary-methods method))
+
+(defmethod compute-method-entry-functions :around ((method effective-method))
+  (if (effective-method-live-p method)
       (call-next-method)
       nil))