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