;;;--------------------------------------------------------------------------
;;; 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.
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)
(: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.
"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.
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)
;;; 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.
(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)
(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)
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)
~mdw / sod / blobdiff