| 1 | ;;; -*-lisp-*- |
| 2 | ;;; |
| 3 | ;;; Method combination protocol |
| 4 | ;;; |
| 5 | ;;; (c) 2009 Straylight/Edgeware |
| 6 | ;;; |
| 7 | |
| 8 | ;;;----- Licensing notice --------------------------------------------------- |
| 9 | ;;; |
| 10 | ;;; This file is part of the Sensible Object Design, an object system for C. |
| 11 | ;;; |
| 12 | ;;; SOD is free software; you can redistribute it and/or modify |
| 13 | ;;; it under the terms of the GNU General Public License as published by |
| 14 | ;;; the Free Software Foundation; either version 2 of the License, or |
| 15 | ;;; (at your option) any later version. |
| 16 | ;;; |
| 17 | ;;; SOD is distributed in the hope that it will be useful, |
| 18 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 19 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 20 | ;;; GNU General Public License for more details. |
| 21 | ;;; |
| 22 | ;;; You should have received a copy of the GNU General Public License |
| 23 | ;;; along with SOD; if not, write to the Free Software Foundation, |
| 24 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
| 25 | |
| 26 | (cl:in-package #:sod) |
| 27 | |
| 28 | ;;;-------------------------------------------------------------------------- |
| 29 | ;;; Effective methods and entries. |
| 30 | |
| 31 | (export '(effective-method |
| 32 | effective-method-message effective-method-class |
| 33 | effective-method-keywords)) |
| 34 | (defclass effective-method () |
| 35 | ((message :initarg :message :type sod-message |
| 36 | :reader effective-method-message) |
| 37 | (%class :initarg :class :type sod-class :reader effective-method-class) |
| 38 | (keywords :type list :reader effective-method-keywords)) |
| 39 | (:documentation |
| 40 | "The behaviour invoked by sending a message to an instance of a class. |
| 41 | |
| 42 | This class describes the behaviour when an instance of CLASS is sent |
| 43 | MESSAGE. |
| 44 | |
| 45 | This is not a useful class by itself. Message classes are expected to |
| 46 | define their own effective-method classes. |
| 47 | |
| 48 | An effective method class may accept a `:direct-methods' initarg, which |
| 49 | will be a list of applicable methods sorted in most-to-least specific |
| 50 | order.")) |
| 51 | |
| 52 | (export 'sod-message-effective-method-class) |
| 53 | (defgeneric sod-message-effective-method-class (message) |
| 54 | (:documentation |
| 55 | "Return the effective method class for the given MESSAGE. |
| 56 | |
| 57 | This function is invoked by `compute-sod-effective-method'.")) |
| 58 | |
| 59 | (export 'primary-method-class) |
| 60 | (defgeneric primary-method-class (message) |
| 61 | (:documentation |
| 62 | "Return the name of the primary direct method class for MESSAGE. |
| 63 | |
| 64 | This protocol is used by `simple-message' subclasses.")) |
| 65 | |
| 66 | (export 'method-keyword-argument-lists) |
| 67 | (defgeneric method-keyword-argument-lists (method direct-methods) |
| 68 | (:documentation |
| 69 | "Returns a list of keyword argument lists to be merged. |
| 70 | |
| 71 | This should return a list suitable for passing to `merge-keyword-lists', |
| 72 | i.e., each element should be a pair consisting of a list of `argument' |
| 73 | objects and a string describing the source of the argument list.")) |
| 74 | |
| 75 | (export 'compute-sod-effective-method) |
| 76 | (defgeneric compute-sod-effective-method (message class) |
| 77 | (:documentation |
| 78 | "Return the effective method when a CLASS instance receives MESSAGE. |
| 79 | |
| 80 | The default method constructs an instance of the message's chosen |
| 81 | `sod-message-effective-method-class', passing the MESSAGE, the CLASS and |
| 82 | the list of applicable methods as initargs to `make-instance'.")) |
| 83 | |
| 84 | (export 'compute-effective-methods) |
| 85 | (defgeneric compute-effective-methods (class) |
| 86 | (:documentation |
| 87 | "Return a list of all of the effective methods needed for CLASS. |
| 88 | |
| 89 | The list needn't be in any particular order.")) |
| 90 | |
| 91 | (export '(method-entry method-entry-effective-method |
| 92 | method-entry-chain-head method-entry-chain-tail)) |
| 93 | (defclass method-entry () |
| 94 | ((%method :initarg :method :type effective-method |
| 95 | :reader method-entry-effective-method) |
| 96 | (chain-head :initarg :chain-head :type sod-class |
| 97 | :reader method-entry-chain-head) |
| 98 | (chain-tail :initarg :chain-tail :type sod-class |
| 99 | :reader method-entry-chain-tail) |
| 100 | (role :initarg :role :type (or keyword null) :reader method-entry-role)) |
| 101 | (:documentation |
| 102 | "An entry point into an effective method. |
| 103 | |
| 104 | Specifically, this is the entry point to the effective METHOD invoked via |
| 105 | the vtable for the chain headed by CHAIN-HEAD, and serving the given ROLE. |
| 106 | The CHAIN-TAIL is the most specific class on this chain; this is useful |
| 107 | because we can reuse the types of method entries from superclasses on |
| 108 | non-primary chains. |
| 109 | |
| 110 | Each effective method may have several different method entries, because |
| 111 | an effective method can be called via vtables attached to different |
| 112 | chains, and such calls will pass instance pointers which point to |
| 113 | different `ichain' structures within the overall instance layout; it's the |
| 114 | job of the method entry to adjust the instance pointers correctly for the |
| 115 | rest of the effective method. |
| 116 | |
| 117 | A vtable can contain more than one entry for the same message. Such |
| 118 | entries are distinguished by their roles. A message always has an entry |
| 119 | with the `nil role; in addition, a varargs message also has a `:valist' |
| 120 | role, which accepts a `va_list' argument in place of the variable argument |
| 121 | listNo other roles are currently defined, though they may be introduced by |
| 122 | extensions. |
| 123 | |
| 124 | The boundaries between a method entry and the effective method |
| 125 | is (intentionally) somewhat fuzzy. In extreme cases, the effective method |
| 126 | may not exist at all as a distinct entity in the output because its |
| 127 | content is duplicated in all of the method entry functions. This is left |
| 128 | up to the effective method protocol.")) |
| 129 | |
| 130 | (export 'make-method-entries) |
| 131 | (defgeneric make-method-entries (effective-method chain-head chain-tail) |
| 132 | (:documentation |
| 133 | "Return a list of `method-entry' objects for an EFFECTIVE-METHOD called |
| 134 | via CHAIN-HEAD. |
| 135 | |
| 136 | There is no default method for this function. (Maybe when the |
| 137 | effective-method/method-entry output protocol has settled down I'll know |
| 138 | what a sensible default action would be.)")) |
| 139 | |
| 140 | ;;;-------------------------------------------------------------------------- |
| 141 | ;;; Protocol for messages and direct-methods. |
| 142 | |
| 143 | (export 'sod-message-argument-tail) |
| 144 | (defgeneric sod-message-argument-tail (message) |
| 145 | (:documentation |
| 146 | "Return the argument tail for the message, with invented argument names. |
| 147 | |
| 148 | No `me' argument is prepended; any `:ellipsis' is left as it is.")) |
| 149 | |
| 150 | (export 'sod-method-function-type) |
| 151 | (defgeneric sod-method-function-type (method) |
| 152 | (:documentation |
| 153 | "Return the C function type for the direct method. |
| 154 | |
| 155 | This is called during initialization of a direct method object, and the |
| 156 | result is cached. |
| 157 | |
| 158 | A default method is provided (by `basic-direct-method') which simply |
| 159 | prepends an appropriate `me' argument to the user-provided argument list. |
| 160 | Fancy method classes may need to override this behaviour.")) |
| 161 | |
| 162 | (export 'sod-method-next-method-type) |
| 163 | (defgeneric sod-method-next-method-type (method) |
| 164 | (:documentation |
| 165 | "Return the C function type for the next-method trampoline. |
| 166 | |
| 167 | This is called during initialization of a direct method object, and the |
| 168 | result is cached. It should return a function type, not a pointer type. |
| 169 | |
| 170 | A default method is provided (by `delegating-direct-method') which should |
| 171 | do the right job. Very fancy subclasses might need to do something |
| 172 | different.")) |
| 173 | |
| 174 | (export 'sod-method-function-name) |
| 175 | (defgeneric sod-method-function-name (method) |
| 176 | (:documentation |
| 177 | "Return the C function name for the direct method.")) |
| 178 | |
| 179 | (export 'keyword-message-p) |
| 180 | (defun keyword-message-p (message) |
| 181 | "Answer whether the MESSAGE accepts a keyword arguments. |
| 182 | |
| 183 | Dealing with keyword messages is rather fiddly, so this is useful to |
| 184 | know." |
| 185 | (typep (sod-message-type message) 'c-keyword-function-type)) |
| 186 | |
| 187 | (export 'varargs-message-p) |
| 188 | (defun varargs-message-p (message) |
| 189 | "Answer whether the MESSAGE accepts a variable-length argument list. |
| 190 | |
| 191 | We need to jump through some extra hoops in order to cope with varargs |
| 192 | messages, so this is useful to know." |
| 193 | (member :ellipsis (sod-message-argument-tail message))) |
| 194 | |
| 195 | ;;;-------------------------------------------------------------------------- |
| 196 | ;;; Protocol for effective methods and method entries. |
| 197 | |
| 198 | (export 'method-entry-function-type) |
| 199 | (defgeneric method-entry-function-type (entry) |
| 200 | (:documentation |
| 201 | "Return the C function type for a method entry.")) |
| 202 | |
| 203 | (export 'method-entry-slot-name) |
| 204 | (defgeneric method-entry-slot-name (entry) |
| 205 | (:documentation |
| 206 | "Return the `vtmsgs' slot name for a method entry. |
| 207 | |
| 208 | The default method indirects through `method-entry-slot-name-by-role'.")) |
| 209 | |
| 210 | (defgeneric method-entry-slot-name-by-role (entry role name) |
| 211 | (:documentation "Easier implementation for `method-entry-slot-name'.") |
| 212 | (:method ((entry method-entry) (role (eql nil)) name) name) |
| 213 | (:method ((entry method-entry) (role (eql :valist)) name) |
| 214 | (format nil "~A__v" name))) |
| 215 | |
| 216 | (export 'effective-method-basic-argument-names) |
| 217 | (defgeneric effective-method-basic-argument-names (method) |
| 218 | (:documentation |
| 219 | "Return a list of argument names to be passed to direct methods. |
| 220 | |
| 221 | The argument names are constructed from the message's arguments returned |
| 222 | by `sod-message-argument-tail', with any ellipsis replaced by an explicit |
| 223 | `va_list' argument. The basic arguments are the ones immediately derived |
| 224 | from the programmer's explicitly stated arguments; the `me' argument is |
| 225 | not included, and neither are more exotic arguments added as part of the |
| 226 | method delegation protocol.")) |
| 227 | |
| 228 | (export 'effective-method-live-p) |
| 229 | (defgeneric effective-method-live-p (method) |
| 230 | (:documentation |
| 231 | "Returns true if the effective METHOD is live. |
| 232 | |
| 233 | An effective method is `live' if it should actually have proper method entry |
| 234 | functions associated with it and stored in the class vtable. The other |
| 235 | possibility is that the method is `dead', in which case the function |
| 236 | pointers in the vtable are left null.")) |
| 237 | |
| 238 | ;;;-------------------------------------------------------------------------- |
| 239 | ;;; Code generation. |
| 240 | |
| 241 | ;;; Enhanced code-generator class. |
| 242 | |
| 243 | (export '(method-codegen codegen-message codegen-class |
| 244 | codegen-method codegen-target)) |
| 245 | (defclass method-codegen (codegen) |
| 246 | ((message :initarg :message :type sod-message :reader codegen-message) |
| 247 | (%class :initarg :class :type sod-class :reader codegen-class) |
| 248 | (%method :initarg :method :type effective-method :reader codegen-method) |
| 249 | (target :initarg :target :reader codegen-target)) |
| 250 | (:documentation |
| 251 | "Augments CODEGEN with additional state regarding an effective method. |
| 252 | |
| 253 | We store the effective method, and also its target class and owning |
| 254 | message, so that these values are readily available to the code-generating |
| 255 | functions.")) |
| 256 | |
| 257 | ;;; Protocol. |
| 258 | |
| 259 | (export 'compute-effective-method-body) |
| 260 | (defgeneric compute-effective-method-body (method codegen target) |
| 261 | (:documentation |
| 262 | "Generates the body of an effective method. |
| 263 | |
| 264 | Writes the function body to the code generator. It can (obviously) |
| 265 | generate auxiliary functions if it needs to. |
| 266 | |
| 267 | The arguments are as determined by agreement with the generic function |
| 268 | `compute-method-entry-functions'; usually this will be as specified by the |
| 269 | `sod-message-argument-tail', with any variable-argument tail reified to a |
| 270 | `va_list', and an additional argument `sod__obj' of type pointer-to- |
| 271 | ilayout. The code should deliver the result (if any) to the TARGET.")) |
| 272 | |
| 273 | (export 'simple-method-body) |
| 274 | (defgeneric simple-method-body (method codegen target) |
| 275 | (:documentation |
| 276 | "Generate the body of a simple effective method. |
| 277 | |
| 278 | The function is invoked on an effective METHOD, with a CODEGEN to which it |
| 279 | should emit code delivering the method's value to TARGET.")) |
| 280 | |
| 281 | ;;; Additional instructions. |
| 282 | |
| 283 | ;; HACK: use gensyms for the `class' and `expr' slots to avoid leaking the |
| 284 | ;; slot names, because `expr' is exported by our package, and `class' is |
| 285 | ;; actually from the `common-lisp' package. |
| 286 | (definst convert-to-ilayout (stream :export t) |
| 287 | (#1=#:class chain-head #2=#:expr) |
| 288 | (format stream "SOD_ILAYOUT(~@<~A, ~_~A, ~_~A~:>)" |
| 289 | #1# (sod-class-nickname chain-head) #2#)) |
| 290 | |
| 291 | ;;; Utilities. |
| 292 | |
| 293 | (defvar *keyword-struct-disposition* :unset |
| 294 | "The current state of the keyword structure. |
| 295 | |
| 296 | This can be one of four values. |
| 297 | |
| 298 | * `:unset' -- the top-level default, mostly because I can't leave it |
| 299 | unbound and write this documentation. Nothing that matters should see |
| 300 | this state. |
| 301 | |
| 302 | * `:local' -- the structure itself is in a local variable `sod__kw'. |
| 303 | This is used in the top-level effective method. |
| 304 | |
| 305 | * `:pointer' -- the structure is pointed to by the local variable |
| 306 | `sod__kw'. This is used by delegation-chain trampolines. |
| 307 | |
| 308 | * `:null' -- there is in fact no structure because none of the |
| 309 | applicable methods actually define any keywords.") |
| 310 | |
| 311 | (defun keyword-access (name &optional suffix) |
| 312 | "Return an lvalue designating a named member of the keyword struct. |
| 313 | |
| 314 | If a non-nil SUFFIX is provided, then the member is named NAMESUFFIX." |
| 315 | (flet ((mem (op) |
| 316 | (format nil "~A~A~A~@[~A~]" *sod-keywords* op name suffix))) |
| 317 | (ecase *keyword-struct-disposition* |
| 318 | (:local (mem ".")) |
| 319 | (:pointer (mem "->"))))) |
| 320 | |
| 321 | (let ((kw-addr (format nil "&~A" *sod-keywords*))) |
| 322 | (defun keyword-struct-pointer () |
| 323 | "Return a pointer to the keyword structure." |
| 324 | (ecase *keyword-struct-disposition* |
| 325 | (:local kw-addr) |
| 326 | (:pointer *sod-keywords*) |
| 327 | (:null *null-pointer*)))) |
| 328 | |
| 329 | (export 'invoke-method) |
| 330 | (defun invoke-method (codegen target arguments-tail direct-method) |
| 331 | "Emit code to invoke DIRECT-METHOD, passing it ARGUMENTS-TAIL. |
| 332 | |
| 333 | The code is generated in the context of CODEGEN, which can be any instance |
| 334 | of the `codegen' class -- it needn't be an instance of `method-codegen'. |
| 335 | The DIRECT-METHOD is called with the given ARGUMENTS-TAIL (a list of |
| 336 | argument expressions), preceded by a `me' argument of type pointer-to- |
| 337 | CLASS where CLASS is the class on which the method was defined. |
| 338 | |
| 339 | If the message accepts a variable-length argument list then a copy of the |
| 340 | prevailing argument pointer is provided in place of the `:ellipsis'." |
| 341 | |
| 342 | (let* ((message (sod-method-message direct-method)) |
| 343 | (class (sod-method-class direct-method)) |
| 344 | (function (sod-method-function-name direct-method)) |
| 345 | (type (sod-method-type direct-method)) |
| 346 | (keywordsp (keyword-message-p message)) |
| 347 | (keywords (and keywordsp (c-function-keywords type))) |
| 348 | (arguments (append (list (format nil "&sod__obj->~A.~A" |
| 349 | (sod-class-nickname |
| 350 | (sod-class-chain-head class)) |
| 351 | (sod-class-nickname class))) |
| 352 | arguments-tail |
| 353 | (mapcar (lambda (arg) |
| 354 | (let ((name (argument-name arg)) |
| 355 | (default (argument-default arg))) |
| 356 | (if default |
| 357 | (make-cond-inst |
| 358 | (keyword-access name |
| 359 | "__suppliedp") |
| 360 | (keyword-access name) |
| 361 | default) |
| 362 | (keyword-access name)))) |
| 363 | keywords)))) |
| 364 | (cond ((varargs-message-p message) |
| 365 | (convert-stmts codegen target (c-type-subtype type) |
| 366 | (lambda (var) |
| 367 | (ensure-var codegen *sod-tmp-ap* c-type-va-list) |
| 368 | (deliver-call codegen :void "va_copy" |
| 369 | *sod-tmp-ap* *sod-ap*) |
| 370 | (apply #'deliver-call codegen var |
| 371 | function arguments) |
| 372 | (deliver-call codegen :void "va_end" |
| 373 | *sod-tmp-ap*)))) |
| 374 | (keywords |
| 375 | (let ((tag (direct-method-suppliedp-struct-tag direct-method))) |
| 376 | (with-temporary-var (codegen spvar (c-type (struct tag))) |
| 377 | (dolist (arg keywords) |
| 378 | (let ((name (argument-name arg))) |
| 379 | (deliver-expr codegen (format nil "~A.~A" spvar name) |
| 380 | (keyword-access name "__suppliedp")))) |
| 381 | (setf arguments (list* (car arguments) spvar |
| 382 | (cdr arguments))) |
| 383 | (apply #'deliver-call codegen target function arguments)))) |
| 384 | (t |
| 385 | (apply #'deliver-call codegen target function arguments))))) |
| 386 | |
| 387 | (export 'ensure-ilayout-var) |
| 388 | (defun ensure-ilayout-var (codegen super) |
| 389 | "Define a variable `sod__obj' pointing to the class's ilayout structure. |
| 390 | |
| 391 | CODEGEN is a `method-codegen'. The class in question is CODEGEN's class, |
| 392 | i.e., the target class for the effective method. SUPER is one of the |
| 393 | class's superclasses; it is assumed that `me' is a pointer to a SUPER |
| 394 | (i.e., to SUPER's ichain within the ilayout)." |
| 395 | |
| 396 | (let* ((class (codegen-class codegen)) |
| 397 | (super-head (sod-class-chain-head super))) |
| 398 | (ensure-var codegen "sod__obj" |
| 399 | (c-type (* (struct (ilayout-struct-tag class)))) |
| 400 | (make-convert-to-ilayout-inst class super-head "me")))) |
| 401 | |
| 402 | (export 'make-trampoline) |
| 403 | (defun make-trampoline (codegen super body) |
| 404 | "Construct a trampoline function and return its name. |
| 405 | |
| 406 | CODEGEN is a `method-codegen'. SUPER is a superclass of the CODEGEN |
| 407 | class. We construct a new trampoline function (with an unimaginative |
| 408 | name) suitable for being passed to a direct method defined on SUPER as its |
| 409 | `next_method'. In particular, it will have a `me' argument whose type is |
| 410 | pointer-to-SUPER. |
| 411 | |
| 412 | The code of the function is generated by BODY, which will be invoked with |
| 413 | a single argument which is the TARGET to which it should deliver its |
| 414 | result. |
| 415 | |
| 416 | The return value is the name of the generated function." |
| 417 | |
| 418 | (let* ((message (codegen-message codegen)) |
| 419 | (message-type (sod-message-type message)) |
| 420 | (message-class (sod-message-class message)) |
| 421 | (method (codegen-method codegen)) |
| 422 | (return-type (c-type-subtype message-type)) |
| 423 | (raw-args (sod-message-argument-tail message)) |
| 424 | (arguments (cond ((varargs-message-p message) |
| 425 | (cons (make-argument *sod-ap* c-type-va-list) |
| 426 | (butlast raw-args))) |
| 427 | ((keyword-message-p message) |
| 428 | (cons (make-argument *sod-key-pointer* |
| 429 | (c-type (* (void :const)))) |
| 430 | raw-args)))) |
| 431 | (*keyword-struct-disposition* t)) |
| 432 | (codegen-push codegen) |
| 433 | (ensure-ilayout-var codegen super) |
| 434 | (when (and (keyword-message-p message) |
| 435 | (not (eq *keyword-struct-disposition* :null))) |
| 436 | (let ((tag (effective-method-keyword-struct-tag method))) |
| 437 | (ensure-var codegen *sod-keywords* (c-type (* (struct tag :const))) |
| 438 | *sod-key-pointer*))) |
| 439 | (funcall body (codegen-target codegen)) |
| 440 | (codegen-pop-function codegen (temporary-function) |
| 441 | (c-type (fun (lisp return-type) |
| 442 | ("me" (* (class super))) |
| 443 | . arguments)) |
| 444 | "Delegation-chain trampoline ~:_~ |
| 445 | for `~A.~A' ~:_on `~A'." |
| 446 | (sod-class-nickname message-class) |
| 447 | (sod-message-name message) |
| 448 | (effective-method-class method)))) |
| 449 | |
| 450 | ;;;-------------------------------------------------------------------------- |
| 451 | ;;; Method entry protocol. |
| 452 | |
| 453 | (export 'effective-method-function-name) |
| 454 | (defgeneric effective-method-function-name (method) |
| 455 | (:documentation |
| 456 | "Returns the function name of an effective method.")) |
| 457 | |
| 458 | (export 'method-entry-function-name) |
| 459 | (defgeneric method-entry-function-name (method chain-head role) |
| 460 | (:documentation |
| 461 | "Returns the function name of a method entry. |
| 462 | |
| 463 | The method entry is given as an effective method/chain-head/role triple, |
| 464 | rather than as a method entry object because we want the function name |
| 465 | before we've made the entry object.")) |
| 466 | |
| 467 | (export 'compute-method-entry-functions) |
| 468 | (defgeneric compute-method-entry-functions (method) |
| 469 | (:documentation |
| 470 | "Construct method entry functions. |
| 471 | |
| 472 | Builds the effective method function (if there is one) and the necessary |
| 473 | method entries. Returns a list of functions (i.e., `function-inst' |
| 474 | objects) which need to be defined in the generated source code.")) |
| 475 | |
| 476 | ;;;-------------------------------------------------------------------------- |
| 477 | ;;; Invoking direct methods. |
| 478 | |
| 479 | (export 'invoke-delegation-chain) |
| 480 | (defun invoke-delegation-chain (codegen target basic-tail chain kernel) |
| 481 | "Invoke a chain of delegating methods. |
| 482 | |
| 483 | CODEGEN is a `method-codegen'. BASIC-TAIL is a list of argument |
| 484 | expressions to provide to the methods. The result of the delegation chain |
| 485 | will be delivered to TARGET. |
| 486 | |
| 487 | The CHAIN is a list of method objects (it's intended to be used with |
| 488 | `delegating-direct-method' objects). The behaviour is as follows. The |
| 489 | first method in the chain is invoked with the necessary arguments (see |
| 490 | below) including a `next_method' pointer. If KERNEL is nil and there are |
| 491 | no more methods in the chain then the `next_method' pointer will be null; |
| 492 | otherwise it will point to a `trampoline' function, whose behaviour is to |
| 493 | call the remaining methods on the chain as a delegation chain. The method |
| 494 | may choose to call this function with its arguments. It will finally |
| 495 | return a value, which will be delivered to the TARGET. |
| 496 | |
| 497 | If the chain is empty, then the code generated by KERNEL (given a TARGET |
| 498 | argument) will be invoked. It is an error if both CHAIN and KERNEL are |
| 499 | nil." |
| 500 | |
| 501 | (let* ((message (codegen-message codegen)) |
| 502 | (argument-tail (cond ((varargs-message-p message) |
| 503 | (cons *sod-tmp-ap* basic-tail)) |
| 504 | ((keyword-message-p message) |
| 505 | (cons (keyword-struct-pointer) basic-tail)) |
| 506 | (t basic-tail)))) |
| 507 | (labels ((next-trampoline (method chain) |
| 508 | (if (or kernel chain) |
| 509 | (make-trampoline codegen (sod-method-class method) |
| 510 | (lambda (target) |
| 511 | (invoke chain target))) |
| 512 | *null-pointer*)) |
| 513 | (invoke (chain target) |
| 514 | (if (null chain) |
| 515 | (funcall kernel target) |
| 516 | (let ((trampoline (next-trampoline (car chain) |
| 517 | (cdr chain)))) |
| 518 | (invoke-method codegen target |
| 519 | (cons trampoline argument-tail) |
| 520 | (car chain)))))) |
| 521 | (invoke chain target)))) |
| 522 | |
| 523 | ;;;----- That's all, folks -------------------------------------------------- |