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

diff --git a/src/method-impl.lisp b/src/method-impl.lisp
index db1e8d6..c1e1b24 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,13 +51,6 @@
 				 (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)
   (let ((role (get-property pset :role :keyword nil)))
@@ -68,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)
   ()
@@ -118,11 +115,53 @@
   (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)))))
+		 ("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 %class) role message) method
@@ -147,11 +186,8 @@
 			      (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))))
+    (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)
@@ -177,35 +213,93 @@
   (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))))
+		 ("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)))
+	 (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)))))
+		 ("me" (lisp (sod-message-receiver-type
+			      message (sod-method-class method))))
+		 . method-args))))
 
 ;;;--------------------------------------------------------------------------
 ;;; 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.  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-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)
@@ -227,9 +321,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))
@@ -350,13 +444,179 @@
   (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))))
+		 ("me" (lisp (sod-message-receiver-type
+			      message (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)))
+
+      ;; 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))
@@ -368,7 +628,9 @@
 				  :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)))
 
@@ -411,15 +673,22 @@
 				     (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)))))
+	 (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))))
@@ -429,13 +698,15 @@
 	       (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))
+		    (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
 		"~@(~@[~A ~]entry~) function ~:_~
@@ -447,14 +718,14 @@
 		(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"
 				    (mapcar #'argument-name entry-args)))
 		       (main (method-entry-function-name method head nil))
 		       (main-type (c-type (fun (lisp return-type)
-					       ("me" (* (class tail)))
+					       ("me" (lisp my-type))
 					       . raw-entry-args))))
 		   (codegen-push codegen)
 		   (ensure-var codegen *sod-ap* c-type-va-list)
@@ -523,9 +794,61 @@
 
       (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))