src/method-{proto,impl}.lisp: Abstract out the receiver type.

The code used to just assume that receiver (`me') arguments had type
`CLASS *'.  This is about to change...

diff --git a/doc/SYMBOLS b/doc/SYMBOLS
index 33f497f330ecb404a57144f05a7695dc2a4bb705..b1708274d4280ae5a4a9e83475493fc369a9fb05 100644 (file)
--- a/doc/SYMBOLS
+++ b/doc/SYMBOLS
@@ -623,6 +623,7 @@ method-proto.lisp
   sod-message-check-methods                     generic
   sod-message-effective-method-class            generic
   sod-message-keyword-argument-lists            generic
+  sod-message-receiver-type                     generic
   sod-method-description                        generic
   sod-method-function-name                      generic
   sod-method-function-type                      generic
@@ -1730,6 +1731,8 @@ sod-message-method-class
   sod-message sod-class t
 sod-message-name
   sod-message
+sod-message-receiver-type
+  sod-message sod-class
 sod-message-type
   sod-message
 sod-method-body

diff --git a/doc/layout.tex b/doc/layout.tex
index dfe67d29640024b75f1ccf0fdfba991c9468bb14..458ceef3911ef50817ce62e32d260db3a02c787a 100644 (file)
--- a/doc/layout.tex
+++ b/doc/layout.tex
@@ -234,6 +234,10 @@
      \dhead{gf}{effective-method-keywords @<method> @> @<list>}}
 \end{describe*}
 
+\begin{describe}{gf}
+    {sod-message-receiver-type @<message> @<class> @> @<c-type>}
+\end{describe}
+
 \begin{describe}{gf}
     {sod-message-applicable-methods @<message> @<class> @> list}
 \end{describe}

diff --git a/src/method-impl.lisp b/src/method-impl.lisp
index f2d71aa330f950ad213a8887bf8b49bb33cbd7ae..be33ecd38177d4b74dc27c8b0b309d8f3d9a742f 100644 (file)
--- a/src/method-impl.lisp
+++ b/src/method-impl.lisp
@@ -60,6 +60,10 @@ (defmethod sod-message-method-class
       ((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))))
+
 (export 'simple-message)
 (defclass simple-message (basic-message)
   ()
@@ -149,7 +153,8 @@ (define-on-demand-slot basic-direct-method function-type (method)
     (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))))
+                ("me" (lisp (sod-message-receiver-type
+                             message (sod-method-class method))))
                 . method-args))))
 
 (defmethod sod-method-description ((method basic-direct-method))
@@ -218,7 +223,8 @@ (define-on-demand-slot delegating-direct-method next-method-type (method)
                          (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)
@@ -243,7 +249,8 @@ (define-on-demand-slot delegating-direct-method function-type (method)
          (t
           (push next-method-arg method-args)))
     (c-type (fun (lisp (c-type-subtype type))
-                ("me" (* (class (sod-method-class method))))
+                ("me" (lisp (sod-message-receiver-type
+                             message (sod-method-class method))))
                 . method-args))))
 
 ;;;--------------------------------------------------------------------------
@@ -443,7 +450,8 @@ (defmethod method-entry-function-type ((entry method-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))))
+                ("me" (lisp (sod-message-receiver-type
+                             message (method-entry-chain-tail entry))))
                 . tail))))
 
 (defgeneric effective-method-keyword-parser-function-name (method)
@@ -690,10 +698,11 @@ (defmethod compute-method-entry-functions ((method basic-effective-method))
               (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 ~:_~
@@ -712,7 +721,7 @@ (defmethod compute-method-entry-functions ((method basic-effective-method))
                                    (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)

diff --git a/src/method-proto.lisp b/src/method-proto.lisp
index 048837439a1e1ace9b2aacdb230358a71062835b..ed15ff20ed833c098d8654bb30152e3f54ee3aed 100644 (file)
--- a/src/method-proto.lisp
+++ b/src/method-proto.lisp
@@ -49,6 +49,13 @@ (defclass effective-method ()
    will be a list of applicable methods sorted in most-to-least specific
    order."))
 
+(export 'sod-message-receiver-type)
+(defgeneric sod-message-receiver-type (message class)
+  (:documentation
+   "Return the type of the `me' argument in a MESSAGE received by CLASS.
+
+   Typically this will just be `CLASS *'."))
+
 (export 'sod-message-applicable-methods)
 (defgeneric sod-message-applicable-methods (message class)
   (:documentation