X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/aa14a4cddcb96b681d5c19a2ec8bad382f43b264..e895be217c3be6769708da17c9ae87cb22db040e:/src/method-proto.lisp diff --git a/src/method-proto.lisp b/src/method-proto.lisp index 8909fc9..e72044e 100644 --- a/src/method-proto.lisp +++ b/src/method-proto.lisp @@ -7,7 +7,7 @@ ;;;----- Licensing notice --------------------------------------------------- ;;; -;;; This file is part of the Sensble Object Design, an object system for C. +;;; This file is part of the Sensible Object Design, an object system for C. ;;; ;;; SOD is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -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,13 +45,74 @@ 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 'message-effective-method-class) -(defgeneric message-effective-method-class (message) +(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 *' or `const 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 "Return the effective method class for the given MESSAGE. @@ -67,8 +131,8 @@ "Return the effective method when a CLASS instance receives MESSAGE. The default method constructs an instance of the message's chosen - `message-effective-method-class', passing the MESSAGE, the CLASS and the - list of applicable methods as initargs to `make-instance'.")) + `sod-message-effective-method-class', passing the MESSAGE, the CLASS and + the list of applicable methods as initargs to `make-instance'.")) (export 'compute-effective-methods) (defgeneric compute-effective-methods (class) @@ -78,21 +142,24 @@ 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) + ((%method :initarg :method :type effective-method + :reader method-entry-effective-method) (chain-head :initarg :chain-head :type sod-class :reader method-entry-chain-head) (chain-tail :initarg :chain-tail :type sod-class - :reader method-entry-chain-tail)) + :reader method-entry-chain-tail) + (role :initarg :role :type (or keyword null) :reader method-entry-role)) (:documentation "An entry point into an effective method. - Specifically, this is the entry point to the effective method METHOD - invoked via the vtable for the chain headed by CHAIN-HEAD. The CHAIN-TAIL - is the most specific class on this chain; this is useful because we can - reuse the types of method entries from superclasses on non-primary chains. + Specifically, this is the entry point to the effective METHOD invoked via + the vtable for the chain headed by CHAIN-HEAD, and serving the given ROLE. + The CHAIN-TAIL is the most specific class on this chain; this is useful + because we can reuse the types of method entries from superclasses on + non-primary chains. Each effective method may have several different method entries, because an effective method can be called via vtables attached to different @@ -101,16 +168,24 @@ job of the method entry to adjust the instance pointers correctly for the rest of the effective method. + A vtable can contain more than one entry for the same message. Such + entries are distinguished by their roles. A message always has an entry + with the `nil role; in addition, a varargs message also has a `:valist' + role, which accepts a `va_list' argument in place of the variable argument + listNo other roles are currently defined, though they may be introduced by + extensions. + The boundaries between a method entry and the effective method is (intentionally) somewhat fuzzy. In extreme cases, the effective method may not exist at all as a distinct entity in the output because its content is duplicated in all of the method entry functions. This is left up to the effective method protocol.")) -(export 'make-method-entry) -(defgeneric make-method-entry (effective-method chain-head chain-tail) +(export 'make-method-entries) +(defgeneric make-method-entries (effective-method chain-head chain-tail) (:documentation - "Return a METHOD-ENTRY for an EFFECTIVE-METHOD called via CHAIN-HEAD. + "Return a list of `method-entry' objects for an EFFECTIVE-METHOD called + via CHAIN-HEAD. There is no default method for this function. (Maybe when the effective-method/method-entry output protocol has settled down I'll know @@ -126,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) @@ -164,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. @@ -180,16 +264,41 @@ (:documentation "Return the C function type for a method entry.")) +(export 'method-entry-slot-name) +(defgeneric method-entry-slot-name (entry) + (:documentation + "Return the `vtmsgs' slot name for a method entry. + + 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) + (:method ((entry method-entry) (role (eql :valist)) name) + (format nil "~A__v" name))) + (export 'effective-method-basic-argument-names) (defgeneric effective-method-basic-argument-names (method) (:documentation "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. @@ -200,8 +309,8 @@ codegen-method codegen-target)) (defclass method-codegen (codegen) ((message :initarg :message :type sod-message :reader codegen-message) - (class :initarg :class :type sod-class :reader codegen-class) - (method :initarg :method :type effective-method :reader codegen-method) + (%class :initarg :class :type sod-class :reader codegen-class) + (%method :initarg :method :type effective-method :reader codegen-method) (target :initarg :target :reader codegen-target)) (:documentation "Augments CODEGEN with additional state regarding an effective method. @@ -220,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) @@ -234,13 +345,45 @@ ;;; Additional instructions. -(export 'convert-to-ilayout) -(definst convert-to-ilayout (stream) (class chain-head expr) +(definst convert-to-ilayout (stream :export t) + (%class chain-head %expr) (format stream "SOD_ILAYOUT(~@<~A, ~_~A, ~_~A~:>)" 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. @@ -252,30 +395,52 @@ CLASS where CLASS is the class on which the method was defined. If the message accepts a variable-length argument list then a copy of the - prevailing master argument pointer is provided in place of the - `:ellipsis'." + prevailing argument pointer is provided in place of the `:ellipsis'." (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-ap* (c-type va-list)) - (emit-inst codegen - (make-va-copy-inst *sod-ap* - *sod-master-ap*)) - (deliver-expr codegen var - (make-call-inst function arguments)) - (emit-inst codegen - (make-va-end-inst *sod-ap*)))) - (deliver-expr codegen target (make-call-inst 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) @@ -310,20 +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)) - (arguments (mapcar (lambda (arg) - (if (eq (argument-name arg) *sod-ap*) - (make-argument *sod-master-ap* - (c-type va-list)) - arg)) - (sod-message-no-varargs-tail message)))) + (raw-args (sod-message-argument-tail message)) + (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. @@ -334,13 +519,13 @@ "Returns the function name of an effective method.")) (export 'method-entry-function-name) -(defgeneric method-entry-function-name (method chain-head) +(defgeneric method-entry-function-name (method chain-head role) (:documentation "Returns the function name of a method entry. - The method entry is given as an effective method/chain-head pair, rather - than as a method entry object because we want the function name before - we've made the entry object.")) + The method entry is given as an effective method/chain-head/role triple, + rather than as a method entry object because we want the function name + before we've made the entry object.")) (export 'compute-method-entry-functions) (defgeneric compute-method-entry-functions (method) @@ -378,21 +563,25 @@ (let* ((message (codegen-message codegen)) (argument-tail (if (varargs-message-p message) - (cons *sod-master-ap* basic-tail) + (cons *sod-tmp-ap* basic-tail) basic-tail))) (labels ((next-trampoline (method chain) (if (or kernel chain) (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))))