X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/blobdiff_plain/bf8aadd76bceba05d2a325181a71763a5625c89b..43ce48fd4112471e4c7ef083297688fc45add4a8:/src/method-impl.lisp

diff --git a/src/method-impl.lisp b/src/method-impl.lisp
index c5785a2..9f1a48f 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 @@ (cl:in-package #:sod)
 
 (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 @@ (defclass basic-message (sod-message)
    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)
@@ -104,7 +87,7 @@ (defmethod primary-method-class ((message simple-message))
 ;;;--------------------------------------------------------------------------
 ;;; 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 +103,57 @@ (defclass basic-direct-method (sod-method)
    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" (* (class (sod-method-class method))))
+		 . method-args))))
 
 (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 +174,9 @@ (defclass daemon-direct-method (basic-direct-method)
 (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 +196,80 @@ (defclass delegating-direct-method (basic-direct-method)
    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" (* (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))))))
+	 (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" (* (class (sod-method-class method))))
+		 . method-args))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Effective method classes.
 
-(export 'basic-effective-method)
+(defmethod method-keyword-argument-lists
+    ((method effective-method) direct-methods)
+  (with-slots (message) method
+     (and (keyword-message-p message)
+	  (mapcar (lambda (m)
+		    (let ((type (sod-method-type m)))
+		      (cons (c-function-keywords type)
+			    (format nil "method for ~A on ~A (at ~A)"
+				    message
+				    (sod-method-class m)
+				    (file-location m)))))
+		  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
+	  (merge-keyword-lists (method-keyword-argument-lists
+				method direct-methods)))))
+
+(export '(basic-effective-method
+	  effective-method-around-methods effective-method-before-methods
+	  effective-method-after-methods))
 (defclass basic-effective-method (effective-method)
   ((around-methods :initarg :around-methods :initform nil
 		   :type list :reader effective-method-around-methods)
@@ -246,17 +288,12 @@ (defclass basic-effective-method (effective-method)
    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 +304,8 @@ (defmethod effective-method-function-name ((method effective-method))
 	    (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 +337,7 @@ (defmethod shared-initialize :after
   (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 +357,8 @@ (defun basic-effective-method-body (codegen target method body)
    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))
@@ -366,7 +401,7 @@ (defmethod method-entry-function-name
 		(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))
@@ -379,13 +414,175 @@ (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))
+	 (keywordsp (keyword-message-p message))
+	 (raw-tail (append (sod-message-argument-tail message)
+			   (and keywordsp (list :ellipsis))))
 	 (tail (ecase (method-entry-role entry)
-		 ((nil) (sod-message-argument-tail message))
-		 (:valist (sod-message-no-varargs-tail message)))))
+		 ((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))))
 		 . 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)))
+
+      ;; 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))))
+
+      ;; Deal with the special `kw.' keywords read via varargs.
+      (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.va_list"
+			      (codegen-pop-block codegen) va-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)))))
+
+      ;; 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))
+
+      (emit-banner codegen "Parse keywords from the argument table.")
+      (codegen-push codegen)
+      (convert "aap" (c-type (* va-list)))
+      (call :void name "kw" "aap" *null-pointer* 0)
+      (setf tab-act (namecheck "v->kw" "kw.va_list"
+			       (codegen-pop-block codegen) tab-act))
+
+      ;; Finish off the table loop.
+      (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))
@@ -397,7 +594,9 @@ (defmethod make-method-entries ((method basic-effective-method)
 				  :chain-head chain-head
 				  :chain-tail chain-tail)
 		   entries)))
-      (when (varargs-message-p message) (make :valist))
+      (when (or (varargs-message-p message)
+		(keyword-message-p message))
+	(make :valist))
       (make nil)
       entries)))
 
@@ -440,19 +639,22 @@ (defmethod compute-method-entry-functions ((method basic-effective-method))
 				     (mapcar #'car
 					     (sod-class-chains class))))
 	 (n-entries (length chain-tails))
-	 (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))))
+	 (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)))))
-	 (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))))
+				. entry-args))))
 
     (flet ((setup-entry (tail)
 	     (let ((head (sod-class-chain-head tail)))
@@ -467,29 +669,43 @@ (defmethod compute-method-entry-functions ((method basic-effective-method))
 		    (type (c-type (fun (lisp return-type)
 				       ("me" (* (class tail)))
 				       . 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 method then we've made the
+	       ;; 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 (make-call-inst name
-					     (cons "me"
-						   (mapcar #'argument-name
-							   entry-args))))
+		 (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" (* (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)))
+		   (ensure-var codegen *sod-ap* c-type-va-list)
 		   (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))))))
+				    (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)
@@ -523,11 +739,15 @@ (defmethod compute-method-entry-functions ((method basic-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)))))
+				    (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)
 		     (deliver-expr codegen entry-target call)
@@ -535,9 +755,53 @@ (defmethod compute-method-entry-functions ((method basic-effective-method))
 
       (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)
+	       (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))
 
@@ -569,7 +833,7 @@ (defclass standard-effective-method (simple-effective-method) ()
 (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