X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/blobdiff_plain/9e91c8e7b5fcdeb6389ac7ccbcd9c77348c4493a..4307347660f48628e307f299eb4fac58ba35fd1a:/src/method-impl.lisp

diff --git a/src/method-impl.lisp b/src/method-impl.lisp
index 0564d81..963f2fe 100644
--- a/src/method-impl.lisp
+++ b/src/method-impl.lisp
@@ -114,11 +114,47 @@ (defmethod shared-initialize :after
   (declare (ignore slot-names))
   (default-slot (method 'role) (get-property pset :role :keyword nil)))
 
+(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 ((type (sod-method-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))))
-		 . (c-function-arguments type)))))
+		 . method-args))))
 
 (defmethod sod-method-function-name ((method basic-direct-method))
   (with-slots ((class %class) role message) method
@@ -170,10 +206,16 @@ (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)))
+	 (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))))
@@ -181,21 +223,47 @@ (define-on-demand-slot delegating-direct-method next-method-type (method)
 (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)))
+	 (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))))
-		 ("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))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Effective method classes.
 
+(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))))))
+
 (export '(basic-effective-method
 	  effective-method-around-methods effective-method-before-methods
 	  effective-method-after-methods))
@@ -343,13 +411,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))
@@ -361,7 +591,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)))
 
@@ -404,10 +636,14 @@ (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.
@@ -440,7 +676,7 @@ (defmethod compute-method-entry-functions ((method basic-effective-method))
 		(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 (apply #'make-call-inst name "me"
@@ -516,6 +752,48 @@ (defmethod compute-method-entry-functions ((method basic-effective-method))
 
       (codegen-functions codegen))))
 
+(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 compute-method-entry-functions
     ((method simple-effective-method))
   (if (effective-method-primary-methods method)