X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/4c3d168fcdd02d012f742a7b38ed52b9779c3f3c..e895be217c3be6769708da17c9ae87cb22db040e:/src/method-impl.lisp

diff --git a/src/method-impl.lisp b/src/method-impl.lisp
index 6508f57..c1e1b24 100644
--- a/src/method-impl.lisp
+++ b/src/method-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
@@ -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.
 
@@ -40,33 +39,17 @@
    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)))))
 
 (defmethod sod-message-method-class
     ((message basic-message) (class sod-class) pset)
@@ -77,6 +60,11 @@
       ((nil) (error "How odd: a primary method slipped through the net"))
       (t (error "Unknown method role ~A" role)))))
 
+(defmethod sod-message-receiver-type ((message sod-message)
+				      (class sod-class))
+  (c-type (* (class class
+		    (and (sod-message-readonly-p message) :const)))))
+
 (export 'simple-message)
 (defclass simple-message (basic-message)
   ()
@@ -104,7 +92,7 @@
 ;;;--------------------------------------------------------------------------
 ;;; Direct method classes.
 
-(export 'basic-direct-method)
+(export '(basic-direct-method sod-method-role))
 (defclass basic-direct-method (sod-method)
   ((role :initarg :role :type symbol :reader sod-method-role)
    (function-type :type c-function-type :reader sod-method-function-type))
@@ -120,25 +108,63 @@
    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))
-  (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))))))
+(defun direct-method-suppliedp-struct-tag (direct-method)
+  (with-slots ((class %class) role message) direct-method
+    (format nil "~A__~@[~(~A~)_~]suppliedp_~A__~A"
+	    class role
+	    (sod-class-nickname (sod-message-class message))
+	    (sod-message-name message))))
+
+(defun effective-method-keyword-struct-tag (effective-method)
+  (with-slots ((class %class) message) effective-method
+    (format nil "~A__keywords_~A__~A"
+	    class
+	    (sod-class-nickname (sod-message-class message))
+	    (sod-message-name message))))
+
+(defun fix-up-keyword-method-args (method args)
+  "Adjust the ARGS to include METHOD's `suppliedp' and keyword arguments.
+
+   Return the adjusted list.  The `suppliedp' argument, if any, is prepended
+   to the list; the keyword arguments are added to the end.
+
+   (The input ARGS list is not actually modified.)"
+  (let* ((type (sod-method-type method))
+	 (keys (c-function-keywords type))
+	 (tag (direct-method-suppliedp-struct-tag method)))
+    (append (and keys
+		 (list (make-argument "suppliedp" (c-type (struct tag)))))
+	    args
+	    (mapcar (lambda (key)
+		      (make-argument (argument-name key)
+				     (argument-type key)))
+		    keys))))
+
+(define-on-demand-slot basic-direct-method function-type (method)
+  (let* ((message (sod-method-message method))
+	 (type (sod-method-type method))
+	 (method-args (c-function-arguments type)))
+    (when (keyword-message-p message)
+      (setf method-args (fix-up-keyword-method-args method method-args)))
+    (c-type (fun (lisp (c-type-subtype type))
+		 ("me" (lisp (sod-message-receiver-type
+			      message (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 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))))
@@ -159,12 +185,9 @@
 (defmethod check-method-type ((method daemon-direct-method)
 			      (message sod-message)
 			      (type c-function-type))
-  (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)
-					 (c-function-arguments type))
-      (error "Method arguments ~A don't match message ~A" type msgtype))))
+  (with-slots ((msgtype %type)) message
+    (check-method-return-type type c-type-void)
+    (check-method-argument-lists type msgtype)))
 
 (export 'delegating-direct-method)
 (defclass delegating-direct-method (basic-direct-method)
@@ -184,50 +207,99 @@
    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))
 	 (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)))
-    (setf (slot-value method 'next-method-type)
-	  (c-type (fun (lisp return-type)
-		       ("me" (* (class (sod-method-class method))))
-		       . arguments)))))
-
-(defmethod slot-unbound (class
-			 (method delegating-direct-method)
-			 (slot-name (eql 'function-type)))
-  (declare (ignore class))
+	 (arguments (cond ((varargs-message-p message)
+			   (cons (make-argument *sod-master-ap*
+						c-type-va-list)
+				 (butlast msgargs)))
+			  ((keyword-message-p message)
+			   (cons (make-argument *sod-keywords*
+						(c-type (* (void :const))))
+				 msgargs))
+			  (t
+			   msgargs))))
+    (c-type (fun (lisp return-type)
+		 ("me" (lisp (sod-message-receiver-type
+			      message (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))))))
+	 (method-args (c-function-arguments type))
+	 (next-method-arg (make-argument
+			   "next_method"
+			   (make-pointer-type
+			    (commentify-function-type
+			     (sod-method-next-method-type method))))))
+    (cond ((varargs-message-p message)
+	   (push (make-argument *sod-master-ap* c-type-va-list)
+		 method-args)
+	   (push next-method-arg method-args))
+	  ((keyword-message-p message)
+	   (push (make-argument *sod-keywords* (c-type (* (void :const))))
+		 method-args)
+	   (push next-method-arg method-args)
+	   (setf method-args
+		 (fix-up-keyword-method-args method method-args)))
+	  (t
+	   (push next-method-arg method-args)))
+    (c-type (fun (lisp (c-type-subtype type))
+		 ("me" (lisp (sod-message-receiver-type
+			      message (sod-method-class method))))
+		 . method-args))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Effective method classes.
 
-(export 'basic-effective-method)
+(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.  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
+	  effective-method-after-methods effective-method-functions))
 (defclass basic-effective-method (effective-method)
   ((around-methods :initarg :around-methods :initform nil
 		   :type list :reader effective-method-around-methods)
@@ -246,17 +318,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'."))
-
-(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)
-	  (mapcar #'argument-name
-		  (sod-message-no-varargs-tail message)))))
+   using a slot reader method."))
+
+(define-on-demand-slot basic-effective-method basic-argument-names (method)
+  (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))
@@ -267,11 +334,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)
@@ -303,7 +367,7 @@
   (declare (ignore slot-names))
   (with-slots (message target) codegen
     (setf target
-	  (if (eq (c-type-subtype (sod-message-type message)) (c-type void))
+	  (if (eq (c-type-subtype (sod-message-type message)) c-type-void)
 	      :void
 	      :return))))
 
@@ -323,7 +387,8 @@
    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))
@@ -355,33 +420,219 @@
    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)))
+	*null-pointer*)))
+
+(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))
+	 (keywordsp (keyword-message-p message))
+	 (raw-tail (append (sod-message-argument-tail message)
+			   (and keywordsp (list :ellipsis))))
+	 (tail (ecase (method-entry-role entry)
+		 ((nil) raw-tail)
+		 (:valist (reify-variable-argument-tail raw-tail)))))
     (c-type (fun (lisp (c-type-subtype type))
-		 ("me" (* (class (method-entry-chain-tail entry))))
-		 . (sod-message-argument-tail message)))))
+		 ("me" (lisp (sod-message-receiver-type
+			      message (method-entry-chain-tail entry))))
+		 . tail))))
 
-(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))
+(defgeneric effective-method-keyword-parser-function-name (method)
+  (:documentation
+   "Return the name of the keyword-parsing function for an effective METHOD.
+
+   See `make-keyword-parser-function' for details of what this function
+   actually does."))
+
+(defmethod effective-method-keyword-parser-function-name
+    ((method basic-effective-method))
+  (with-slots ((class %class) message) method
+    (format nil "~A__kwparse_~A__~A"
+	    class
+	    (sod-class-nickname (sod-message-class message))
+	    (sod-message-name message))))
+
+(defun make-keyword-parser-function (codegen method tag set keywords)
+  "Construct and return a keyword-argument parsing function.
+
+   The function is contributed to the CODEGEN, with the name constructed from
+   the effective METHOD.  It will populate an argument structure with the
+   given TAG.  In case of error, it will mention the name SET in its report.
+   The KEYWORDS are a list of `argument' objects naming the keywords to be
+   accepted.
+
+   The generated function has the signature
+
+	void NAME(struct TAG *kw, va_list *ap, struct kwval *v, size_t n)
+
+    It assumes that AP includes the first keyword name.  (This makes it
+    different from the keyword-parsing functions generated by the
+    `KWSET_PARSEFN' macro, but this interface is slightly more convenient and
+    we don't need to cope with functions which accept no required
+    arguments.)"
+
+  ;; Let's start, then.
+  (codegen-push codegen)
+
+  ;; Set up the local variables we'll need.
+  (macrolet ((var (name type)
+	       `(ensure-var codegen ,name (c-type ,type))))
+    (var "k" const-string)
+    (var "aap" (* va-list))
+    (var "t" (* (struct "kwtab" :const)))
+    (var "vv" (* (struct "kwval" :const)))
+    (var "nn" size-t))
+
+  (flet ((call (target func &rest args)
+	   ;; Call FUNC with ARGS; return result in TARGET.
+
+	   (apply #'deliver-call codegen target func args))
+
+	 (convert (target type)
+	   ;; Fetch the object of TYPE pointed to by `v->val', and store it
+	   ;; in TARGET.
+
+	   (deliver-expr codegen target
+			 (format nil "*(~A)v->val"
+				 (make-pointer-type (qualify-c-type
+						     type (list :const))))))
+
+	 (namecheck (var name conseq alt)
+	   ;; Return an instruction: if VAR matches the string NAME then do
+	   ;; CONSEQ; otherwise do ALT.
+
+	   (make-if-inst (make-call-inst "!strcmp"
+					 var (prin1-to-string name))
+			 conseq alt)))
+
+    ;; Prepare the main parsing loops.  We're going to construct them both at
+    ;; the same time.  They're not quite similar enough for it to be
+    ;; worthwhile abstracting this further, but carving up the keywords is
+    ;; too tedious to write out more than once.
+    (let ((va-act (make-expr-inst (make-call-inst "kw_unknown" set "k")))
+	  (tab-act (make-expr-inst (make-call-inst "kw_unknown"
+						   set "v->kw")))
+	  (name (effective-method-keyword-parser-function-name method)))
+
+      ;; Deal with the special `kw.' keywords read via varargs.  We're
+      ;; building the dispatch up backwards, so if we do these first, they
+      ;; get checked last, which priviliges the function-specific arguments
+      ;; over these special effects.
+      (codegen-push codegen)
+      (call "vv" "va_arg" "*ap" (c-type (* (struct "kwval" :const))))
+      (call "nn" "va_arg" "*ap" c-type-size-t)
+      (call :void name "kw" *null-pointer* "vv" "nn")
+      (setf va-act (namecheck "k" "kw.tab"
+			      (codegen-pop-block codegen) va-act))
+
+      (codegen-push codegen)
+      (call "aap" "va_arg" "*ap" (c-type (* va-list)))
+      (call :void name "kw" "aap" *null-pointer* 0)
+      (setf va-act (namecheck "k" "kw.valist"
+			      (codegen-pop-block codegen) va-act))
+
+      ;; Deal with the special `kw.' keywords read from a table.
+      (codegen-push codegen)
+      (deliver-expr codegen "t"
+		    (format nil "(~A)v->val"
+			    (c-type (* (struct "kwtab" :const)))))
+      (call :void name "kw" *null-pointer* "t->v" "t->n")
+      (setf tab-act (namecheck "v->kw" "kw.tab"
+			       (codegen-pop-block codegen) tab-act))
+
+      (codegen-push codegen)
+      (convert "aap" (c-type (* va-list)))
+      (call :void name "kw" "aap" *null-pointer* 0)
+      (setf tab-act (namecheck "v->kw" "kw.valist"
+			       (codegen-pop-block codegen) tab-act))
+
+      ;; Work through the keywords.  We're going to be building up the
+      ;; conditional dispatch from the end, so reverse the (nicely sorted)
+      ;; list before processing it.
+      (dolist (key (reverse keywords))
+	(let* ((key-name (argument-name key))
+	       (key-type (argument-type key)))
+
+	  ;; Handle the varargs case.
+	  (codegen-push codegen)
+	  (deliver-expr codegen (format nil "kw->~A__suppliedp" key-name) 1)
+	  (call (format nil "kw->~A" key-name) "va_arg" "*ap" key-type)
+	  (setf va-act (namecheck "k" key-name
+				  (codegen-pop-block codegen) va-act))
+
+	  ;; Handle the table case.
+	  (codegen-push codegen)
+	  (deliver-expr codegen (format nil "kw->~A__suppliedp" key-name) 1)
+	  (convert (format nil "kw->~A" key-name) key-type)
+	  (setf tab-act (namecheck "v->kw" key-name
+				   (codegen-pop-block codegen) tab-act))))
+
+      ;; Finish up the varargs loop.
+      (emit-banner codegen "Parse keywords from the variable-length tail.")
+      (codegen-push codegen)
+      (call "k" "va_arg" "*ap" c-type-const-string)
+      (emit-inst codegen (make-if-inst "!k" (make-break-inst)))
+      (emit-inst codegen va-act)
+      (let ((loop (make-for-inst nil nil nil (codegen-pop-block codegen))))
+	(emit-inst codegen
+		   (make-if-inst "ap" (make-block-inst nil (list loop)))))
+
+      ;; Finish off the table loop.
+      (emit-banner codegen "Parse keywords from the argument table.")
+      (codegen-push codegen)
+      (emit-inst codegen tab-act)
+      (emit-inst codegen (make-expr-inst "v++"))
+      (emit-inst codegen (make-expr-inst "n--"))
+      (emit-inst codegen (make-while-inst "n" (codegen-pop-block codegen)))
+
+      ;; Wrap the whole lot up with a nice bow.
+      (let ((message (effective-method-message method)))
+	(codegen-pop-function codegen name
+			      (c-type (fun void
+					   ("kw" (* (struct tag)))
+					   ("ap" (* va-list))
+					   ("v" (* (struct "kwval" :const)))
+					   ("n" size-t)))
+			      "Keyword parsing for `~A.~A' on class `~A'."
+			      (sod-class-nickname
+			       (sod-message-class message))
+			      (sod-message-name message)
+			      (effective-method-class method))))))
+
+(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 (or (varargs-message-p message)
+		(keyword-message-p message))
+	(make :valist))
+      (make nil)
+      entries)))
 
 (defmethod compute-method-entry-functions ((method basic-effective-method))
 
@@ -416,53 +667,84 @@
 				 :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 (append (sod-message-argument-tail message)
+				 (and (keyword-message-p message)
+				      (list :ellipsis))))
+	 (entry-args (reify-variable-argument-tail raw-entry-args))
+	 (parm-n (let ((tail (last (cons (make-argument "me" c-type-void)
+					 raw-entry-args) 2)))
+		   (and tail (eq (cadr tail) :ellipsis)
+			(argument-name (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)
+					  (and (sod-message-readonly-p
+						message)
+					       :const)))))
+	 (emf-type (c-type (fun (lisp return-type)
+				("sod__obj" (lisp ilayout-type))
+				. entry-args))))
 
     (flet ((setup-entry (tail)
 	     (let ((head (sod-class-chain-head tail)))
 	       (codegen-push codegen)
 	       (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*
-					    (argument-name parm-n))))
-	   (varargs-epilogue ()
-	     (emit-inst codegen (make-va-end-inst *sod-master-ap*)))
+							 head "me"))
+	       (deliver-call codegen :void "SOD__IGNORE" "sod__obj")))
 	   (finish-entry (tail)
 	     (let* ((head (sod-class-chain-head tail))
-		    (name (method-entry-function-name method head))
+		    (my-type (sod-message-receiver-type message tail))
+		    (role (if parm-n :valist nil))
+		    (name (method-entry-function-name method head role))
 		    (type (c-type (fun (lisp return-type)
-				       ("me" (* (class tail)))
+				       ("me" (lisp my-type))
 				       . entry-args))))
-	       (codegen-pop-function codegen name type))))
+	       (codegen-pop-function codegen name type
+		"~@(~@[~A ~]entry~) function ~:_~
+		 for method `~A.~A' ~:_~
+		 via chain headed by `~A' ~:_~
+		 defined on `~A'."
+		(if parm-n "Indirect argument-tail" nil)
+		(sod-class-nickname message-class)
+		(sod-message-name message)
+		head class)
+
+	       ;; If this is a varargs or keyword method then we've made the
+	       ;; `:valist' role.  Also make the `nil' role.
+	       (when parm-n
+		 (let ((call (apply #'make-call-inst name "me"
+				    (mapcar #'argument-name entry-args)))
+		       (main (method-entry-function-name method head nil))
+		       (main-type (c-type (fun (lisp return-type)
+					       ("me" (lisp my-type))
+					       . raw-entry-args))))
+		   (codegen-push codegen)
+		   (ensure-var codegen *sod-ap* c-type-va-list)
+		   (convert-stmts codegen entry-target return-type
+				  (lambda (target)
+				    (deliver-call codegen :void "va_start"
+						  *sod-ap* parm-n)
+				    (deliver-expr codegen target call)
+				    (deliver-call codegen :void "va_end"
+						  *sod-ap*)))
+		   (codegen-pop-function codegen main main-type
+		    "Variable-length argument list ~:_~
+		     entry function ~:_~
+		     for method `~A.~A' ~:_~
+		     via chain headed by `~A' ~:_~
+		     defined on `~A'."
+		(sod-class-nickname message-class)
+		(sod-message-name message)
+		head class))))))
 
       ;; Generate the method body.  We'll work out what to do with it later.
       (codegen-push codegen)
@@ -485,9 +767,7 @@
 			 (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)))
 
@@ -498,29 +778,77 @@
 		 ;; 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)))))
+				    (list (make-return-inst result))))
+		  "Effective method function ~:_for `~A.~A' ~:_~
+		   defined on `~A'."
+		  (sod-class-nickname message-class)
+		  (sod-message-name message)
+		  (effective-method-class method))
+
+		 (let ((call (apply #'make-call-inst emf-name "sod__obj"
+				    (mapcar #'argument-name entry-args))))
 		   (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))))
 
-(defmethod compute-method-entry-functions
-    ((method simple-effective-method))
-  (if (effective-method-primary-methods method)
+(defmethod compute-effective-method-body :around
+    ((method basic-effective-method) codegen target)
+  (let* ((message (effective-method-message method))
+	 (keywordsp (keyword-message-p message))
+	 (keywords (effective-method-keywords method))
+	 (ap-addr (format nil "&~A" *sod-tmp-ap*))
+	 (set (format nil "\"~A:~A.~A\""
+		      (sod-class-name (effective-method-class method))
+		      (sod-class-nickname (sod-message-class message))
+		      (sod-message-name message))))
+    (labels ((call (target func &rest args)
+	       (apply #'deliver-call codegen target func args))
+	     (parse-keywords (body)
+	       (ensure-var codegen *sod-tmp-ap* c-type-va-list)
+	       (call :void "va_copy" *sod-tmp-ap* *sod-ap*)
+	       (funcall body)
+	       (call :void "va_end" *sod-tmp-ap*)))
+      (cond ((not keywordsp)
+	     (call-next-method))
+	    ((null keywords)
+	     (let ((*keyword-struct-disposition* :null))
+	       (parse-keywords (lambda ()
+				 (with-temporary-var
+				     (codegen kw c-type-const-string)
+				   (call kw "va_arg"
+					 *sod-tmp-ap* c-type-const-string)
+				   (call :void "kw_parseempty" set
+					 kw ap-addr *null-pointer* 0))))
+	       (call-next-method)))
+	    (t
+	     (let* ((name
+		     (effective-method-keyword-parser-function-name method))
+		    (tag (effective-method-keyword-struct-tag method))
+		    (kw-addr (format nil "&~A" *sod-keywords*))
+		    (*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 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))
 
@@ -552,7 +880,7 @@
 (defmethod primary-method-class ((message standard-message))
   'delegating-direct-method)
 
-(defmethod message-effective-method-class ((message standard-message))
+(defmethod sod-message-effective-method-class ((message standard-message))
   'standard-effective-method)
 
 (defmethod simple-method-body