X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/357885be46389c70dc9e7c7859f47af68aeb58ae..d5fdd49e70b734b791eb907706f92da5775e2a8b:/src/method-proto.lisp diff --git a/src/method-proto.lisp b/src/method-proto.lisp index c8b47ad..ed15ff2 100644 --- a/src/method-proto.lisp +++ b/src/method-proto.lisp @@ -28,11 +28,14 @@ ;;;-------------------------------------------------------------------------- ;;; Effective methods and entries. -(export '(effective-method effective-method-message effective-method-class)) +(export '(effective-method + effective-method-message effective-method-class + effective-method-keywords)) (defclass effective-method () ((message :initarg :message :type sod-message :reader effective-method-message) - (%class :initarg :class :type sod-class :reader effective-method-class)) + (%class :initarg :class :type sod-class :reader effective-method-class) + (keywords :type list :reader effective-method-keywords)) (:documentation "The behaviour invoked by sending a message to an instance of a class. @@ -42,10 +45,71 @@ This is not a useful class by itself. Message classes are expected to define their own effective-method classes. - An effective method class must accept a `:direct-methods' initarg, which + An effective method class may accept a `:direct-methods' initarg, which will be a list of applicable methods sorted in most-to-least specific - order. (Either that or you have to add an overriding method to - `compute-sod-effective-method'.")) + 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) @@ -78,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) @@ -86,7 +151,7 @@ :reader method-entry-chain-head) (chain-tail :initarg :chain-tail :type sod-class :reader method-entry-chain-tail) - (role :initarg :role :type (or :keyword null) :reader method-entry-role)) + (role :initarg :role :type (or keyword null) :reader method-entry-role)) (:documentation "An entry point into an effective method. @@ -136,14 +201,15 @@ No `me' argument is prepended; any `:ellipsis' is left as it is.")) -(export 'sod-message-no-varargs-tail) -(defgeneric sod-message-no-varargs-tail (message) +(export 'sod-method-description) +(defgeneric sod-method-description (method) (:documentation - "Return the argument tail for the message with `:ellipsis' substituted. + "Return an adjectival phrase describing METHOD. - As with `sod-message-argument-tail', no `me' argument is prepended. - However, an `:ellipsis' is replaced by an argument of type `va_list', - named `sod__ap'.")) + 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) @@ -174,6 +240,14 @@ (:documentation "Return the C function name for the direct method.")) +(export 'keyword-message-p) +(defun keyword-message-p (message) + "Answer whether the MESSAGE accepts a keyword arguments. + + Dealing with keyword messages is rather fiddly, so this is useful to + know." + (typep (sod-message-type message) 'c-keyword-function-type)) + (export 'varargs-message-p) (defun varargs-message-p (message) "Answer whether the MESSAGE accepts a variable-length argument list. @@ -197,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) @@ -209,10 +284,21 @@ "Return a list of argument names to be passed to direct methods. The argument names are constructed from the message's arguments returned - by `sod-message-no-varargs-tail'. The basic arguments are the ones - immediately derived from the programmer's explicitly stated arguments; the - `me' argument is not included, and neither are more exotic arguments added - as part of the method delegation protocol.")) + by `sod-message-argument-tail', with any ellipsis replaced by an explicit + `va_list' argument. The basic arguments are the ones immediately derived + from the programmer's explicitly stated arguments; the `me' argument is + 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. @@ -243,9 +329,11 @@ Writes the function body to the code generator. It can (obviously) generate auxiliary functions if it needs to. - The arguments are as specified by the `sod-message-no-varargs-tail', with - an additional argument `sod__obj' of type pointer-to-ilayout. The code - should deliver the result (if any) to the TARGET.")) + The arguments are as determined by agreement with the generic function + `compute-method-entry-functions'; usually this will be as specified by the + `sod-message-argument-tail', with any variable-argument tail reified to a + `va_list', and an additional argument `sod__obj' of type pointer-to- + ilayout. The code should deliver the result (if any) to the TARGET.")) (export 'simple-method-body) (defgeneric simple-method-body (method codegen target) @@ -257,16 +345,45 @@ ;;; 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-unbound *keyword-struct-disposition* + "The current state of the keyword structure. + + 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. + + * `:pointer' -- the structure is pointed to by the local variable + `sod__kw'. This is used by delegation-chain trampolines. + + * `:null' -- there is in fact no structure because none of the + applicable methods actually define any keywords.") + +(defun keyword-access (name &optional suffix) + "Return an lvalue designating a named member of the keyword struct. + + If a non-nil SUFFIX is provided, then the member is named NAMESUFFIX." + (flet ((mem (op) + (format nil "~A~A~A~@[~A~]" *sod-keywords* op name suffix))) + (ecase *keyword-struct-disposition* + (:local (mem ".")) + (:pointer (mem "->"))))) + +(let ((kw-addr (format nil "&~A" *sod-keywords*))) + (defun keyword-struct-pointer () + "Return a pointer to the keyword structure." + (ecase *keyword-struct-disposition* + (:local kw-addr) + (:pointer *sod-keywords*) + (:null *null-pointer*)))) + (export 'invoke-method) (defun invoke-method (codegen target arguments-tail direct-method) "Emit code to invoke DIRECT-METHOD, passing it ARGUMENTS-TAIL. @@ -283,24 +400,47 @@ (let* ((message (sod-method-message direct-method)) (class (sod-method-class direct-method)) (function (sod-method-function-name direct-method)) - (arguments (cons (format nil "&sod__obj->~A.~A" - (sod-class-nickname - (sod-class-chain-head class)) - (sod-class-nickname class)) - arguments-tail))) - (if (varargs-message-p message) - (convert-stmts codegen target - (c-type-subtype (sod-method-type direct-method)) - (lambda (var) - (ensure-var codegen *sod-tmp-ap* c-type-va-list) - (emit-inst codegen - (make-va-copy-inst *sod-tmp-ap* - *sod-ap*)) - (apply #'deliver-call codegen var - function arguments) - (emit-inst codegen - (make-va-end-inst *sod-tmp-ap*)))) - (apply #'deliver-call codegen target function arguments)))) + (type (sod-method-type direct-method)) + (keywordsp (keyword-message-p message)) + (keywords (and keywordsp (c-function-keywords type))) + (arguments (append (list (format nil "&sod__obj->~A.~A" + (sod-class-nickname + (sod-class-chain-head class)) + (sod-class-nickname class))) + arguments-tail + (mapcar (lambda (arg) + (let ((name (argument-name arg)) + (default (argument-default arg))) + (if default + (make-cond-inst + (keyword-access name + "__suppliedp") + (keyword-access name) + default) + (keyword-access name)))) + keywords)))) + (cond ((varargs-message-p message) + (convert-stmts codegen target (c-type-subtype type) + (lambda (var) + (ensure-var codegen *sod-tmp-ap* c-type-va-list) + (deliver-call codegen :void "va_copy" + *sod-tmp-ap* *sod-ap*) + (apply #'deliver-call codegen var + function arguments) + (deliver-call codegen :void "va_end" + *sod-tmp-ap*)))) + (keywords + (let ((tag (direct-method-suppliedp-struct-tag direct-method))) + (with-temporary-var (codegen spvar (c-type (struct tag))) + (dolist (arg keywords) + (let ((name (argument-name arg))) + (deliver-expr codegen (format nil "~A.~A" spvar name) + (keyword-access name "__suppliedp")))) + (setf arguments (list* (car arguments) spvar + (cdr arguments))) + (apply #'deliver-call codegen target function arguments)))) + (t + (apply #'deliver-call codegen target function arguments))))) (export 'ensure-ilayout-var) (defun ensure-ilayout-var (codegen super) @@ -335,19 +475,40 @@ (let* ((message (codegen-message codegen)) (message-type (sod-message-type message)) + (message-class (sod-message-class message)) + (method (codegen-method codegen)) (return-type (c-type-subtype message-type)) (raw-args (sod-message-argument-tail message)) - (arguments (if (varargs-message-p message) - (cons (make-argument *sod-ap* c-type-va-list) - (butlast raw-args)) - raw-args))) + (arguments (cond ((varargs-message-p message) + (cons (make-argument *sod-ap* c-type-va-list) + (butlast raw-args))) + ((keyword-message-p message) + (cons (make-argument *sod-key-pointer* + (c-type (* (void :const)))) + raw-args)) + (t raw-args))) + (*keyword-struct-disposition* (if (effective-method-keywords method) + :pointer :null))) (codegen-push codegen) (ensure-ilayout-var codegen super) + (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) ("me" (* (class super))) - . arguments))))) + . arguments)) + "Delegation-chain trampoline ~:_~ + for `~A.~A' ~:_on `~A'." + (sod-class-nickname message-class) + (sod-message-name message) + (effective-method-class method)))) ;;;-------------------------------------------------------------------------- ;;; Method entry protocol. @@ -409,14 +570,18 @@ (make-trampoline codegen (sod-method-class method) (lambda (target) (invoke chain target))) - 0)) + *null-pointer*)) (invoke (chain target) (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))))