X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/1622ed8e30b05ba9025520cde3e68d186c8c7e50..d5fdd49e70b734b791eb907706f92da5775e2a8b:/src/method-proto.lisp diff --git a/src/method-proto.lisp b/src/method-proto.lisp index f5d8be7..ed15ff2 100644 --- a/src/method-proto.lisp +++ b/src/method-proto.lisp @@ -49,6 +49,68 @@ 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 + "Return a list of applicable methods for a MESSAGE. + + The list contains all methods applicable for MESSAGE when sent to an + instance of CLASS, most specific first.")) + +(export 'sod-message-keyword-argument-lists) +(defgeneric sod-message-keyword-argument-lists + (message class direct-methods state) + (:documentation + "Returns a list of keyword argument lists to be merged. + + This should return a list suitable for passing to `merge-keyword-lists', + i.e., each element should be a pair consisting of a function describing + the source of the argument list (returning location and description), and + a list of `argument' objects. + + The MESSAGE is the message being processed; CLASS is a receiver class + under consideration; DIRECT-METHODS is the complete list of applicable + direct methods (most specific first); and STATE is an `inheritance-path- + reporter-state' object which can be used by the returned reporting + functions.")) + +(export 'compute-effective-method-keyword-arguments) +(defun compute-effective-method-keyword-arguments + (message class direct-methods) + "Return a merged keyword argument list. + + The returned list combines all of the applicable methods, provided as + DIRECT-METHODS, applicable to MESSAGE when received by an instance of + CLASS, possibly with other keywords as determined by `sod-keyword- + argument-lists'." + (let ((state (make-inheritance-path-reporter-state class))) + (merge-keyword-lists (lambda () + (values class + (format nil + "methods for message `~A' ~ + applicable to class `~A'" + message class))) + (sod-message-keyword-argument-lists message + class + direct-methods + state)))) + +(export 'sod-message-check-methods) +(defgeneric sod-message-check-methods (message class direct-methods) + (:documentation + "Check that the applicable methods for a MESSAGE are compatible. + + Specifically, given the DIRECT-METHODS applicable for the message when + received by an instance of CLASS, signal errors if the methods don't + match the MESSAGE or each other.")) + (export 'sod-message-effective-method-class) (defgeneric sod-message-effective-method-class (message) (:documentation @@ -80,7 +142,8 @@ The list needn't be in any particular order.")) (export '(method-entry method-entry-effective-method - method-entry-chain-head method-entry-chain-tail)) + method-entry-chain-head method-entry-chain-tail + method-entry-role)) (defclass method-entry () ((%method :initarg :method :type effective-method :reader method-entry-effective-method) @@ -138,6 +201,16 @@ No `me' argument is prepended; any `:ellipsis' is left as it is.")) +(export 'sod-method-description) +(defgeneric sod-method-description (method) + (:documentation + "Return an adjectival phrase describing METHOD. + + The result will be placed into an error message reading something like + ``Conflicting definition of DESCRIPTION direct method `bogus'''. Two + direct methods which can coexist in the same class, defined on the same + message, should have differing descriptions.")) + (export 'sod-method-function-type) (defgeneric sod-method-function-type (method) (:documentation @@ -198,6 +271,7 @@ The default method indirects through `method-entry-slot-name-by-role'.")) +(export 'method-entry-slot-name-by-role) (defgeneric method-entry-slot-name-by-role (entry role name) (:documentation "Easier implementation for `method-entry-slot-name'.") (:method ((entry method-entry) (role (eql nil)) name) name) @@ -216,6 +290,16 @@ not included, and neither are more exotic arguments added as part of the method delegation protocol.")) +(export 'effective-method-live-p) +(defgeneric effective-method-live-p (method) + (:documentation + "Returns true if the effective METHOD is live. + + An effective method is `live' if it should actually have proper method + entry functions associated with it and stored in the class vtable. The + other possibility is that the method is `dead', in which case the function + pointers in the vtable are left null.")) + ;;;-------------------------------------------------------------------------- ;;; Code generation. @@ -261,24 +345,17 @@ ;;; Additional instructions. -;; HACK: use gensyms for the `class' and `expr' slots to avoid leaking the -;; slot names, because `expr' is exported by our package, and `class' is -;; actually from the `common-lisp' package. (definst convert-to-ilayout (stream :export t) - (#1=#:class chain-head #2=#:expr) + (%class chain-head %expr) (format stream "SOD_ILAYOUT(~@<~A, ~_~A, ~_~A~:>)" - #1# (sod-class-nickname chain-head) #2#)) + class (sod-class-nickname chain-head) expr)) ;;; Utilities. -(defvar *keyword-struct-disposition* :unset +(defvar-unbound *keyword-struct-disposition* "The current state of the keyword structure. - This can be one of four values. - - * `:unset' -- the top-level default, mostly because I can't leave it - unbound and write this documentation. Nothing that matters should see - this state. + This can be one of three values. * `:local' -- the structure itself is in a local variable `sod__kw'. This is used in the top-level effective method. @@ -408,15 +485,20 @@ ((keyword-message-p message) (cons (make-argument *sod-key-pointer* (c-type (* (void :const)))) - raw-args)))) - (*keyword-struct-disposition* t)) + raw-args)) + (t raw-args))) + (*keyword-struct-disposition* (if (effective-method-keywords method) + :pointer :null))) (codegen-push codegen) (ensure-ilayout-var codegen super) - (when (and (keyword-message-p message) - (not (eq *keyword-struct-disposition* :null))) - (let ((tag (effective-method-keyword-struct-tag method))) - (ensure-var codegen *sod-keywords* (c-type (* (struct tag :const))) - *sod-key-pointer*))) + (deliver-call codegen :void "SOD__IGNORE" "sod__obj") + (when (keyword-message-p message) + (if (eq *keyword-struct-disposition* :null) + (deliver-call codegen :void "SOD__IGNORE" *sod-key-pointer*) + (let ((tag (effective-method-keyword-struct-tag method))) + (ensure-var codegen *sod-keywords* + (c-type (* (struct tag :const))) + *sod-key-pointer*)))) (funcall body (codegen-target codegen)) (codegen-pop-function codegen (temporary-function) (c-type (fun (lisp return-type) @@ -480,11 +562,9 @@ nil." (let* ((message (codegen-message codegen)) - (argument-tail (cond ((varargs-message-p message) - (cons *sod-tmp-ap* basic-tail)) - ((keyword-message-p message) - (cons (keyword-struct-pointer) basic-tail)) - (t basic-tail)))) + (argument-tail (if (varargs-message-p message) + (cons *sod-tmp-ap* basic-tail) + basic-tail))) (labels ((next-trampoline (method chain) (if (or kernel chain) (make-trampoline codegen (sod-method-class method) @@ -495,9 +575,13 @@ (if (null chain) (funcall kernel target) (let ((trampoline (next-trampoline (car chain) - (cdr chain)))) + (cdr chain))) + (tail (if (keyword-message-p message) + (cons (keyword-struct-pointer) + argument-tail) + argument-tail))) (invoke-method codegen target - (cons trampoline argument-tail) + (cons trampoline tail) (car chain)))))) (invoke chain target))))