X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/blobdiff_plain/9e91c8e7b5fcdeb6389ac7ccbcd9c77348c4493a..4307347660f48628e307f299eb4fac58ba35fd1a:/src/method-proto.lisp diff --git a/src/method-proto.lisp b/src/method-proto.lisp index e0d8742..629e8a7 100644 --- a/src/method-proto.lisp +++ b/src/method-proto.lisp @@ -28,11 +28,14 @@ (cl:in-package #:sod) ;;;-------------------------------------------------------------------------- ;;; 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,9 @@ (defclass effective-method () 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-effective-method-class) (defgeneric sod-message-effective-method-class (message) @@ -174,6 +176,14 @@ (defgeneric sod-method-function-name (method) (: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. @@ -209,10 +219,11 @@ (defgeneric effective-method-basic-argument-names (method) "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.")) ;;;-------------------------------------------------------------------------- ;;; Code generation. @@ -243,9 +254,11 @@ (defgeneric compute-effective-method-body (method codegen target) 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) @@ -267,6 +280,42 @@ (definst convert-to-ilayout (stream :export t) ;;; Utilities. +(defvar *keyword-struct-disposition* :unset + "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. + + * `: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,22 +332,47 @@ (defun invoke-method (codegen target arguments-tail direct-method) (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) - (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*))) - (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) @@ -337,12 +411,21 @@ (defun make-trampoline (codegen super body) (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)))) + (*keyword-struct-disposition* t)) (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*))) (funcall body (codegen-target codegen)) (codegen-pop-function codegen (temporary-function) (c-type (fun (lisp return-type) @@ -406,9 +489,11 @@ (defun invoke-delegation-chain (codegen target basic-tail chain kernel) nil." (let* ((message (codegen-message codegen)) - (argument-tail (if (varargs-message-p message) - (cons *sod-tmp-ap* basic-tail) - basic-tail))) + (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)))) (labels ((next-trampoline (method chain) (if (or kernel chain) (make-trampoline codegen (sod-method-class method)