;;;----- 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
;;;--------------------------------------------------------------------------
;;; 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 '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 *'."))
+
+(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.
"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)
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
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
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.
(: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.
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.
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.
-(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.
(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*))
- (deliver-expr codegen var
- (make-call-inst function arguments))
- (emit-inst codegen
- (make-va-end-inst *sod-tmp-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)
(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.
"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)
(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))))
~mdw / sod / blobdiff