mdw@git.distorted.org.uk Git - sod/blob - src/method-impl.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Method combination implementation
   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 ;;; Message classes.
  30
  31 (export 'basic-message)
  32 (defclass basic-message (sod-message)
  33   ((argument-tail :type list :reader sod-message-argument-tail))
  34   (:documentation
  35    "Base class for built-in message classes.
  36
  37    Provides the basic functionality for the built-in method combinations.
  38    This is a separate class so that `special effect' messages can avoid
  39    inheriting its default behaviour.
  40
  41    The function type protocol is implemented on `basic-message' using slot
  42    reader methods.  The actual values are computed on demand."))
  43
  44 (define-on-demand-slot basic-message argument-tail (message)
  45   (let ((seq 0))
  46     (mapcar (lambda (arg)
  47               (if (or (eq arg :ellipsis) (argument-name arg)) arg
  48                   (make-argument (make-instance 'temporary-argument
  49                                                 :tag (prog1 seq
  50                                                        (incf seq)))
  51                                  (argument-type arg))))
  52             (c-function-arguments (sod-message-type message)))))
  53
  54 (defmethod sod-message-method-class
  55     ((message basic-message) (class sod-class) pset)
  56   (let ((role (get-property pset :role :keyword nil)))
  57     (case role
  58       ((:before :after) 'daemon-direct-method)
  59       (:around 'delegating-direct-method)
  60       ((nil) (error "How odd: a primary method slipped through the net"))
  61       (t (error "Unknown method role ~A" role)))))
  62
  63 (export 'simple-message)
  64 (defclass simple-message (basic-message)
  65   ()
  66   (:documentation
  67    "Base class for messages with `simple' method combinations.
  68
  69    A simple method combination is one which has only one method role other
  70    than the `before', `after' and `around' methods provided by
  71    `basic-message'.  We call these `primary' methods, and the programmer
  72    designates them by not specifying an explicit role.
  73
  74    If the programmer doesn't define any primary methods then the effective
  75    method is null -- i.e., the method entry pointer shows up as a null
  76    pointer."))
  77
  78 (defmethod sod-message-method-class
  79     ((message simple-message) (class sod-class) pset)
  80   (if (get-property pset :role :keyword nil)
  81       (call-next-method)
  82       (primary-method-class message)))
  83
  84 (defmethod primary-method-class ((message simple-message))
  85   'basic-direct-method)
  86
  87 ;;;--------------------------------------------------------------------------
  88 ;;; Direct method classes.
  89
  90 (export '(basic-direct-method sod-method-role))
  91 (defclass basic-direct-method (sod-method)
  92   ((role :initarg :role :type symbol :reader sod-method-role)
  93    (function-type :type c-function-type :reader sod-method-function-type))
  94   (:documentation
  95    "Base class for built-in direct method classes.
  96
  97    Provides the basic functionality for the built-in direct-method classes.
  98    This is a separate class so that `special effect' methods can avoid
  99    inheriting its default behaviour and slots.
 100
 101    A basic method can be assigned a `role', which may be set either as an
 102    initarg or using the `:role' property.  Roles are used for method
 103    categorization.
 104
 105    The function type protocol is implemented on `basic-direct-method' using
 106    slot reader methods."))
 107
 108 (defmethod shared-initialize :after
 109     ((method basic-direct-method) slot-names &key pset)
 110   (declare (ignore slot-names))
 111   (default-slot (method 'role) (get-property pset :role :keyword nil)))
 112
 113 (defun direct-method-suppliedp-struct-tag (direct-method)
 114   (with-slots ((class %class) role message) direct-method
 115     (format nil "~A__~@[~(~A~)_~]suppliedp_~A__~A"
 116             class role
 117             (sod-class-nickname (sod-message-class message))
 118             (sod-message-name message))))
 119
 120 (defun effective-method-keyword-struct-tag (effective-method)
 121   (with-slots ((class %class) message) effective-method
 122     (format nil "~A__keywords_~A__~A"
 123             class
 124             (sod-class-nickname (sod-message-class message))
 125             (sod-message-name message))))
 126
 127 (defun fix-up-keyword-method-args (method args)
 128   "Adjust the ARGS to include METHOD's `suppliedp' and keyword arguments.
 129
 130    Return the adjusted list.  The `suppliedp' argument, if any, is prepended
 131    to the list; the keyword arguments are added to the end.
 132
 133    (The input ARGS list is not actually modified.)"
 134   (let* ((type (sod-method-type method))
 135          (keys (c-function-keywords type))
 136          (tag (direct-method-suppliedp-struct-tag method)))
 137     (append (and keys
 138                  (list (make-argument "suppliedp" (c-type (struct tag)))))
 139             args
 140             (mapcar (lambda (key)
 141                       (make-argument (argument-name key)
 142                                      (argument-type key)))
 143                     keys))))
 144
 145 (define-on-demand-slot basic-direct-method function-type (method)
 146   (let* ((message (sod-method-message method))
 147          (type (sod-method-type method))
 148          (method-args (c-function-arguments type)))
 149     (when (keyword-message-p message)
 150       (setf method-args (fix-up-keyword-method-args method method-args)))
 151     (c-type (fun (lisp (c-type-subtype type))
 152                  ("me" (* (class (sod-method-class method))))
 153                  . method-args))))
 154
 155 (defmethod sod-method-description ((method basic-direct-method))
 156   (with-slots (role) method
 157     (if role (string-downcase role)
 158         "primary")))
 159
 160 (defmethod sod-method-function-name ((method basic-direct-method))
 161   (with-slots ((class %class) role message) method
 162     (format nil "~A__~@[~(~A~)_~]method_~A__~A" class role
 163             (sod-class-nickname (sod-message-class message))
 164             (sod-message-name message))))
 165
 166 (export 'daemon-direct-method)
 167 (defclass daemon-direct-method (basic-direct-method)
 168   ()
 169   (:documentation
 170    "A daemon direct method is invoked for side effects and cannot override.
 171
 172    This is the direct method class for `before' and `after' methods, which
 173    cannot choose to override the remaining methods and are not involved in
 174    the computation of the final result.
 175
 176    In C terms, a daemon method must return `void', and is not passed a
 177    `next_method' pointer."))
 178
 179 (defmethod check-method-type ((method daemon-direct-method)
 180                               (message sod-message)
 181                               (type c-function-type))
 182   (with-slots ((msgtype %type)) message
 183     (check-method-return-type type c-type-void)
 184     (check-method-argument-lists type msgtype)))
 185
 186 (export 'delegating-direct-method)
 187 (defclass delegating-direct-method (basic-direct-method)
 188   ((next-method-type :type c-function-type
 189                      :reader sod-method-next-method-type))
 190   (:documentation
 191    "A delegating direct method can choose to override other methods.
 192
 193    This is the direct method class for `around' and standard-method-
 194    combination primary methods, which are given the choice of computing the
 195    entire method's result or delegating to (usually) less-specific methods.
 196
 197    In C terms, a delegating method is passed a `next_method' pointer so that
 198    it can delegate part of its behaviour.  (A delegating direct method for a
 199    varargs message is also given an additional `va_list' argument,
 200    conventionally named `sod__ap_master', which it is expected to pass on to
 201    its `next_method' function if necessary.)
 202
 203    The function type protocol is implemented on `delegating-direct-method'
 204    using slot reader methods.."))
 205
 206 (define-on-demand-slot delegating-direct-method next-method-type (method)
 207   (let* ((message (sod-method-message method))
 208          (return-type (c-type-subtype (sod-message-type message)))
 209          (msgargs (sod-message-argument-tail message))
 210          (arguments (cond ((varargs-message-p message)
 211                            (cons (make-argument *sod-master-ap*
 212                                                 c-type-va-list)
 213                                  (butlast msgargs)))
 214                           ((keyword-message-p message)
 215                            (cons (make-argument *sod-keywords*
 216                                                 (c-type (* (void :const))))
 217                                  msgargs))
 218                           (t
 219                            msgargs))))
 220     (c-type (fun (lisp return-type)
 221                  ("me" (* (class (sod-method-class method))))
 222                  . arguments))))
 223
 224 (define-on-demand-slot delegating-direct-method function-type (method)
 225   (let* ((message (sod-method-message method))
 226          (type (sod-method-type method))
 227          (method-args (c-function-arguments type))
 228          (next-method-arg (make-argument
 229                            "next_method"
 230                            (make-pointer-type
 231                             (commentify-function-type
 232                              (sod-method-next-method-type method))))))
 233     (cond ((varargs-message-p message)
 234            (push (make-argument *sod-master-ap* c-type-va-list)
 235                  method-args)
 236            (push next-method-arg method-args))
 237           ((keyword-message-p message)
 238            (push (make-argument *sod-keywords* (c-type (* (void :const))))
 239                  method-args)
 240            (push next-method-arg method-args)
 241            (setf method-args
 242                  (fix-up-keyword-method-args method method-args)))
 243           (t
 244            (push next-method-arg method-args)))
 245     (c-type (fun (lisp (c-type-subtype type))
 246                  ("me" (* (class (sod-method-class method))))
 247                  . method-args))))
 248
 249 ;;;--------------------------------------------------------------------------
 250 ;;; Effective method classes.
 251
 252 (defmethod sod-message-keyword-argument-lists
 253     ((message sod-message) (class sod-class) direct-methods state)
 254   (and (keyword-message-p message)
 255        (cons (cons (lambda (arg)
 256                      (let ((class (sod-message-class message)))
 257                        (info-with-location
 258                         message "Type `~A' declared in message ~
 259                                  definition in `~A' (here)"
 260                         (argument-type arg) class)
 261                        (report-inheritance-path state class)))
 262                    (c-function-keywords (sod-message-type message)))
 263              (mapcar (lambda (method)
 264                        (cons (lambda (arg)
 265                                (let ((class (sod-method-class method)))
 266                                  (info-with-location
 267                                   method "Type `~A' declared in ~A direct ~
 268                                           method of `~A' (defined here)"
 269                                   (argument-type arg)
 270                                   (sod-method-description method) class)
 271                                  (report-inheritance-path state class)))
 272                              (c-function-keywords (sod-method-type method))))
 273                      direct-methods))))
 274
 275
 276 (defmethod shared-initialize :after
 277     ((method effective-method) slot-names &key direct-methods)
 278   (declare (ignore slot-names))
 279
 280   ;; Set the keyword argument list.  Blame the class as a whole for mismatch
 281   ;; errors, because they're fundamentally a non-local problem about the
 282   ;; class construction.
 283   (with-slots ((class %class) message keywords) method
 284     (setf keywords
 285           (compute-effective-method-keyword-arguments message
 286                                                       class
 287                                                       direct-methods))))
 288
 289 (export '(basic-effective-method
 290           effective-method-around-methods effective-method-before-methods
 291           effective-method-after-methods))
 292 (defclass basic-effective-method (effective-method)
 293   ((around-methods :initarg :around-methods :initform nil
 294                    :type list :reader effective-method-around-methods)
 295    (before-methods :initarg :before-methods :initform nil
 296                    :type list :reader effective-method-before-methods)
 297    (after-methods :initarg :after-methods :initform nil
 298                   :type list :reader effective-method-after-methods)
 299    (basic-argument-names :type list
 300                          :reader effective-method-basic-argument-names)
 301    (functions :type list :reader effective-method-functions))
 302   (:documentation
 303    "Base class for built-in effective method classes.
 304
 305    This class maintains lists of the applicable `before', `after' and
 306    `around' methods and provides behaviour for invoking these methods
 307    correctly.
 308
 309    The argument names protocol is implemented on `basic-effective-method'
 310    using a slot reader method."))
 311
 312 (define-on-demand-slot basic-effective-method basic-argument-names (method)
 313   (let* ((message (effective-method-message method))
 314          (raw-tail (sod-message-argument-tail message)))
 315     (mapcar #'argument-name (reify-variable-argument-tail raw-tail))))
 316
 317 (defmethod effective-method-function-name ((method effective-method))
 318   (let* ((class (effective-method-class method))
 319          (message (effective-method-message method))
 320          (message-class (sod-message-class message)))
 321     (format nil "~A__emethod_~A__~A"
 322             class
 323             (sod-class-nickname message-class)
 324             (sod-message-name message))))
 325
 326 (define-on-demand-slot basic-effective-method functions (method)
 327   (compute-method-entry-functions method))
 328
 329 (export 'simple-effective-method)
 330 (defclass simple-effective-method (basic-effective-method)
 331   ((primary-methods :initarg :primary-methods :initform nil
 332                     :type list :reader effective-method-primary-methods))
 333   (:documentation
 334    "Effective method counterpart to `simple-message'."))
 335
 336 (defmethod shared-initialize :after
 337     ((method simple-effective-method) slot-names &key direct-methods)
 338   (declare (ignore slot-names))
 339   (categorize (method direct-methods :bind ((role (sod-method-role method))))
 340       ((primary (null role))
 341        (before (eq role :before))
 342        (after (eq role :after))
 343        (around (eq role :around)))
 344     (with-slots (primary-methods before-methods after-methods around-methods)
 345         method
 346       (setf primary-methods primary
 347             before-methods before
 348             after-methods (reverse after)
 349             around-methods around))))
 350
 351 ;;;--------------------------------------------------------------------------
 352 ;;; Code generation.
 353
 354 (defmethod shared-initialize :after
 355     ((codegen method-codegen) slot-names &key)
 356   (declare (ignore slot-names))
 357   (with-slots (message target) codegen
 358     (setf target
 359           (if (eq (c-type-subtype (sod-message-type message)) c-type-void)
 360               :void
 361               :return))))
 362
 363 ;;;--------------------------------------------------------------------------
 364 ;;; Invoking direct methods.
 365
 366 (export 'basic-effective-method-body)
 367 (defun basic-effective-method-body (codegen target method body)
 368   "Build the common method-invocation structure.
 369
 370    Writes to CODEGEN some basic method-invocation instructions.  It invokes
 371    the `around' methods, from most- to least-specific.  If they all delegate,
 372    then the `before' methods are run, most-specific first; next, the
 373    instructions generated by BODY (invoked with a target argument); then, the
 374    `after' methods are run, least-specific first; and, finally, the value
 375    delivered by the BODY is returned to the `around' methods.  The result
 376    returned by the outermost `around' method -- or, if there are none,
 377    delivered by the BODY -- is finally delivered to the TARGET."
 378
 379   (with-slots (message (class %class)
 380                before-methods after-methods around-methods)
 381       method
 382     (let* ((message-type (sod-message-type message))
 383            (return-type (c-type-subtype message-type))
 384            (basic-tail (effective-method-basic-argument-names method)))
 385       (flet ((method-kernel (target)
 386                (dolist (before before-methods)
 387                  (invoke-method codegen :void basic-tail before))
 388                (if (null after-methods)
 389                    (funcall body target)
 390                    (convert-stmts codegen target return-type
 391                                   (lambda (target)
 392                                     (funcall body target)
 393                                     (dolist (after (reverse after-methods))
 394                                       (invoke-method codegen :void
 395                                                      basic-tail after)))))))
 396         (invoke-delegation-chain codegen target basic-tail
 397                                  around-methods #'method-kernel)))))
 398
 399 ;;;--------------------------------------------------------------------------
 400 ;;; Method entry points.
 401
 402 (defparameter *method-entry-inline-threshold* 200
 403   "Threshold below which effective method bodies are inlined into entries.
 404
 405    After the effective method body has been computed, we calculate its
 406    metric, multiply by the number of entries we need to generate, and compare
 407    it with this threshold.  If the metric is below the threshold then we
 408    fold the method body into the entry functions; otherwise we split the
 409    effective method out into its own function.")
 410
 411 (defmethod method-entry-function-name
 412     ((method effective-method) (chain-head sod-class) role)
 413   (let* ((class (effective-method-class method))
 414          (message (effective-method-message method))
 415          (message-class (sod-message-class message)))
 416     (if (or (not (slot-boundp method 'functions))
 417             (slot-value method 'functions))
 418         (format nil "~A__mentry~@[__~(~A~)~]_~A__~A__chain_~A"
 419                 class role
 420                 (sod-class-nickname message-class)
 421                 (sod-message-name message)
 422                 (sod-class-nickname chain-head))
 423         *null-pointer*)))
 424
 425 (defmethod method-entry-slot-name ((entry method-entry))
 426   (let* ((method (method-entry-effective-method entry))
 427          (message (effective-method-message method))
 428          (name (sod-message-name message))
 429          (role (method-entry-role entry)))
 430     (method-entry-slot-name-by-role entry role name)))
 431
 432 (defmethod method-entry-function-type ((entry method-entry))
 433   (let* ((method (method-entry-effective-method entry))
 434          (message (effective-method-message method))
 435          (type (sod-message-type message))
 436          (keywordsp (keyword-message-p message))
 437          (raw-tail (append (sod-message-argument-tail message)
 438                            (and keywordsp (list :ellipsis))))
 439          (tail (ecase (method-entry-role entry)
 440                  ((nil) raw-tail)
 441                  (:valist (reify-variable-argument-tail raw-tail)))))
 442     (c-type (fun (lisp (c-type-subtype type))
 443                  ("me" (* (class (method-entry-chain-tail entry))))
 444                  . tail))))
 445
 446 (defgeneric effective-method-keyword-parser-function-name (method)
 447   (:documentation
 448    "Return the name of the keyword-parsing function for an effective METHOD.
 449
 450    See `make-keyword-parser-function' for details of what this function
 451    actually does."))
 452
 453 (defmethod effective-method-keyword-parser-function-name
 454     ((method basic-effective-method))
 455   (with-slots ((class %class) message) method
 456     (format nil "~A__kwparse_~A__~A"
 457             class
 458             (sod-class-nickname (sod-message-class message))
 459             (sod-message-name message))))
 460
 461 (defun make-keyword-parser-function (codegen method tag set keywords)
 462   "Construct and return a keyword-argument parsing function.
 463
 464    The function is contributed to the CODEGEN, with the name constructed from
 465    the effective METHOD.  It will populate an argument structure with the
 466    given TAG.  In case of error, it will mention the name SET in its report.
 467    The KEYWORDS are a list of `argument' objects naming the keywords to be
 468    accepted.
 469
 470    The generated function has the signature
 471
 472         void NAME(struct TAG *kw, va_list *ap, struct kwval *v, size_t n)
 473
 474     It assumes that AP includes the first keyword name.  (This makes it
 475     different from the keyword-parsing functions generated by the
 476     `KWSET_PARSEFN' macro, but this interface is slightly more convenient and
 477     we don't need to cope with functions which accept no required
 478     arguments.)"
 479
 480   ;; Let's start, then.
 481   (codegen-push codegen)
 482
 483   ;; Set up the local variables we'll need.
 484   (macrolet ((var (name type)
 485                `(ensure-var codegen ,name (c-type ,type))))
 486     (var "k" const-string)
 487     (var "aap" (* va-list))
 488     (var "t" (* (struct "kwtab" :const)))
 489     (var "vv" (* (struct "kwval" :const)))
 490     (var "nn" size-t))
 491
 492   (flet ((call (target func &rest args)
 493            ;; Call FUNC with ARGS; return result in TARGET.
 494
 495            (apply #'deliver-call codegen target func args))
 496
 497          (convert (target type)
 498            ;; Fetch the object of TYPE pointed to by `v->val', and store it
 499            ;; in TARGET.
 500
 501            (deliver-expr codegen target
 502                          (format nil "*(~A)v->val"
 503                                  (make-pointer-type (qualify-c-type
 504                                                      type (list :const))))))
 505
 506          (namecheck (var name conseq alt)
 507            ;; Return an instruction: if VAR matches the string NAME then do
 508            ;; CONSEQ; otherwise do ALT.
 509
 510            (make-if-inst (make-call-inst "!strcmp"
 511                                          var (prin1-to-string name))
 512                          conseq alt)))
 513
 514     ;; Prepare the main parsing loops.  We're going to construct them both at
 515     ;; the same time.  They're not quite similar enough for it to be
 516     ;; worthwhile abstracting this further, but carving up the keywords is
 517     ;; too tedious to write out more than once.
 518     (let ((va-act (make-expr-inst (make-call-inst "kw_unknown" set "k")))
 519           (tab-act (make-expr-inst (make-call-inst "kw_unknown"
 520                                                    set "v->kw")))
 521           (name (effective-method-keyword-parser-function-name method)))
 522
 523       ;; Work through the keywords.  We're going to be building up the
 524       ;; conditional dispatch from the end, so reverse the (nicely sorted)
 525       ;; list before processing it.
 526       (dolist (key (reverse keywords))
 527         (let* ((key-name (argument-name key))
 528                (key-type (argument-type key)))
 529
 530           ;; Handle the varargs case.
 531           (codegen-push codegen)
 532           (deliver-expr codegen (format nil "kw->~A__suppliedp" key-name) 1)
 533           (call (format nil "kw->~A" key-name) "va_arg" "*ap" key-type)
 534           (setf va-act (namecheck "k" key-name
 535                                   (codegen-pop-block codegen) va-act))
 536
 537           ;; Handle the table case.
 538           (codegen-push codegen)
 539           (deliver-expr codegen (format nil "kw->~A__suppliedp" key-name) 1)
 540           (convert (format nil "kw->~A" key-name) key-type)
 541           (setf tab-act (namecheck "v->kw" key-name
 542                                    (codegen-pop-block codegen) tab-act))))
 543
 544       ;; Deal with the special `kw.' keywords read via varargs.
 545       (codegen-push codegen)
 546       (call "vv" "va_arg" "*ap" (c-type (* (struct "kwval" :const))))
 547       (call "nn" "va_arg" "*ap" c-type-size-t)
 548       (call :void name "kw" *null-pointer* "vv" "nn")
 549       (setf va-act (namecheck "k" "kw.tab"
 550                               (codegen-pop-block codegen) va-act))
 551
 552       (codegen-push codegen)
 553       (call "aap" "va_arg" "*ap" (c-type (* va-list)))
 554       (call :void name "kw" "aap" *null-pointer* 0)
 555       (setf va-act (namecheck "k" "kw.va_list"
 556                               (codegen-pop-block codegen) va-act))
 557
 558       ;; Finish up the varargs loop.
 559       (emit-banner codegen "Parse keywords from the variable-length tail.")
 560       (codegen-push codegen)
 561       (call "k" "va_arg" "*ap" c-type-const-string)
 562       (emit-inst codegen (make-if-inst "!k" (make-break-inst)))
 563       (emit-inst codegen va-act)
 564       (let ((loop (make-for-inst nil nil nil (codegen-pop-block codegen))))
 565         (emit-inst codegen
 566                    (make-if-inst "ap" (make-block-inst nil (list loop)))))
 567
 568       ;; Deal with the special `kw.' keywords read from a table.
 569       (codegen-push codegen)
 570       (deliver-expr codegen "t"
 571                     (format nil "(~A)v->val"
 572                             (c-type (* (struct "kwtab" :const)))))
 573       (call :void name "kw" *null-pointer* "t->v" "t->n")
 574       (setf tab-act (namecheck "v->kw" "kw.tab"
 575                                (codegen-pop-block codegen) tab-act))
 576
 577       (emit-banner codegen "Parse keywords from the argument table.")
 578       (codegen-push codegen)
 579       (convert "aap" (c-type (* va-list)))
 580       (call :void name "kw" "aap" *null-pointer* 0)
 581       (setf tab-act (namecheck "v->kw" "kw.va_list"
 582                                (codegen-pop-block codegen) tab-act))
 583
 584       ;; Finish off the table loop.
 585       (codegen-push codegen)
 586       (emit-inst codegen tab-act)
 587       (emit-inst codegen (make-expr-inst "v++"))
 588       (emit-inst codegen (make-expr-inst "n--"))
 589       (emit-inst codegen (make-while-inst "n" (codegen-pop-block codegen)))
 590
 591       ;; Wrap the whole lot up with a nice bow.
 592       (let ((message (effective-method-message method)))
 593         (codegen-pop-function codegen name
 594                               (c-type (fun void
 595                                            ("kw" (* (struct tag)))
 596                                            ("ap" (* va-list))
 597                                            ("v" (* (struct "kwval" :const)))
 598                                            ("n" size-t)))
 599                               "Keyword parsing for `~A.~A' on class `~A'."
 600                               (sod-class-nickname
 601                                (sod-message-class message))
 602                               (sod-message-name message)
 603                               (effective-method-class method))))))
 604
 605 (defmethod make-method-entries ((method basic-effective-method)
 606                                 (chain-head sod-class)
 607                                 (chain-tail sod-class))
 608   (let ((entries nil)
 609         (message (effective-method-message method)))
 610     (flet ((make (role)
 611              (push (make-instance 'method-entry
 612                                   :method method :role role
 613                                   :chain-head chain-head
 614                                   :chain-tail chain-tail)
 615                    entries)))
 616       (when (or (varargs-message-p message)
 617                 (keyword-message-p message))
 618         (make :valist))
 619       (make nil)
 620       entries)))
 621
 622 (defmethod compute-method-entry-functions ((method basic-effective-method))
 623
 624   ;; OK, there's quite a lot of this, so hold tight.
 625   ;;
 626   ;; The first thing we need to do is find all of the related objects.  This
 627   ;; is a bit verbose but fairly straightforward.
 628   ;;
 629   ;; Next, we generate the effective method body -- using `compute-effective-
 630   ;; method-body' of all things.  This gives us the declarations and body for
 631   ;; an effective method function, but we don't have an actual function yet.
 632   ;;
 633   ;; Now we look at the chains which are actually going to need a method
 634   ;; entry: only those chains whose tail (most specific) class is a
 635   ;; superclass of the class which defined the message need an entry.  We
 636   ;; build a list of these tail classes.
 637   ;;
 638   ;; Having done this, we decide whether it's better to generate a standalone
 639   ;; effective-method function and call it from each of the method entries,
 640   ;; or to inline the effective method body into each of the entries.
 641   ;;
 642   ;; Most of the complexity here comes from (a) dealing with the two
 643   ;; different strategies for constructing method entry functions and (b)
 644   ;; (unsurprisingly) the mess involved with dealing with varargs messages.
 645
 646   (let* ((message (effective-method-message method))
 647          (class (effective-method-class method))
 648          (message-class (sod-message-class message))
 649          (return-type (c-type-subtype (sod-message-type message)))
 650          (codegen (make-instance 'method-codegen
 651                                  :message message
 652                                  :class class
 653                                  :method method))
 654
 655          ;; Method entry details.
 656          (chain-tails (remove-if-not (lambda (super)
 657                                        (sod-subclass-p super message-class))
 658                                      (mapcar #'car
 659                                              (sod-class-chains class))))
 660          (n-entries (length chain-tails))
 661          (raw-entry-args (append (sod-message-argument-tail message)
 662                                  (and (keyword-message-p message)
 663                                       (list :ellipsis))))
 664          (entry-args (reify-variable-argument-tail raw-entry-args))
 665          (parm-n (let ((tail (last (cons (make-argument "me" c-type-void)
 666                                          raw-entry-args) 2)))
 667                    (and tail (eq (cadr tail) :ellipsis)
 668                         (argument-name (car tail)))))
 669          (entry-target (codegen-target codegen))
 670
 671          ;; Effective method function details.
 672          (emf-name (effective-method-function-name method))
 673          (ilayout-type (c-type (* (struct (ilayout-struct-tag class)))))
 674          (emf-type (c-type (fun (lisp return-type)
 675                                 ("sod__obj" (lisp ilayout-type))
 676                                 . entry-args))))
 677
 678     (flet ((setup-entry (tail)
 679              (let ((head (sod-class-chain-head tail)))
 680                (codegen-push codegen)
 681                (ensure-var codegen "sod__obj" ilayout-type
 682                            (make-convert-to-ilayout-inst class
 683                                                          head "me"))
 684                (deliver-call codegen :void "SOD__IGNORE" "sod__obj")))
 685            (finish-entry (tail)
 686              (let* ((head (sod-class-chain-head tail))
 687                     (role (if parm-n :valist nil))
 688                     (name (method-entry-function-name method head role))
 689                     (type (c-type (fun (lisp return-type)
 690                                        ("me" (* (class tail)))
 691                                        . entry-args))))
 692                (codegen-pop-function codegen name type
 693                 "~@(~@[~A ~]entry~) function ~:_~
 694                  for method `~A.~A' ~:_~
 695                  via chain headed by `~A' ~:_~
 696                  defined on `~A'."
 697                 (if parm-n "Indirect argument-tail" nil)
 698                 (sod-class-nickname message-class)
 699                 (sod-message-name message)
 700                 head class)
 701
 702                ;; If this is a varargs or keyword method then we've made the
 703                ;; `:valist' role.  Also make the `nil' role.
 704                (when parm-n
 705                  (let ((call (apply #'make-call-inst name "me"
 706                                     (mapcar #'argument-name entry-args)))
 707                        (main (method-entry-function-name method head nil))
 708                        (main-type (c-type (fun (lisp return-type)
 709                                                ("me" (* (class tail)))
 710                                                . raw-entry-args))))
 711                    (codegen-push codegen)
 712                    (ensure-var codegen *sod-ap* c-type-va-list)
 713                    (convert-stmts codegen entry-target return-type
 714                                   (lambda (target)
 715                                     (deliver-call codegen :void "va_start"
 716                                                   *sod-ap* parm-n)
 717                                     (deliver-expr codegen target call)
 718                                     (deliver-call codegen :void "va_end"
 719                                                   *sod-ap*)))
 720                    (codegen-pop-function codegen main main-type
 721                     "Variable-length argument list ~:_~
 722                      entry function ~:_~
 723                      for method `~A.~A' ~:_~
 724                      via chain headed by `~A' ~:_~
 725                      defined on `~A'."
 726                 (sod-class-nickname message-class)
 727                 (sod-message-name message)
 728                 head class))))))
 729
 730       ;; Generate the method body.  We'll work out what to do with it later.
 731       (codegen-push codegen)
 732       (let* ((result (if (eq return-type c-type-void) nil
 733                          (temporary-var codegen return-type)))
 734              (emf-target (or result :void)))
 735         (compute-effective-method-body method codegen emf-target)
 736         (multiple-value-bind (vars insts) (codegen-pop codegen)
 737           (cond ((or (= n-entries 1)
 738                      (<= (* n-entries (reduce #'+ insts :key #'inst-metric))
 739                          *method-entry-inline-threshold*))
 740
 741                  ;; The effective method body is simple -- or there's only
 742                  ;; one of them.  We'll inline the method body into the entry
 743                  ;; functions.
 744                  (dolist (tail chain-tails)
 745                    (setup-entry tail)
 746                    (dolist (var vars)
 747                      (if (typep var 'var-inst)
 748                          (ensure-var codegen (inst-name var)
 749                                      (inst-type var) (inst-init var))
 750                          (emit-decl codegen var)))
 751                    (emit-insts codegen insts)
 752                    (deliver-expr codegen entry-target result)
 753                    (finish-entry tail)))
 754
 755                 (t
 756
 757                  ;; The effective method body is complicated and we'd need
 758                  ;; more than one copy.  We'll generate an effective method
 759                  ;; function and call it a lot.
 760                  (codegen-build-function codegen emf-name emf-type vars
 761                   (nconc insts (and result
 762                                     (list (make-return-inst result))))
 763                   "Effective method function ~:_for `~A.~A' ~:_~
 764                    defined on `~A'."
 765                   (sod-class-nickname message-class)
 766                   (sod-message-name message)
 767                   (effective-method-class method))
 768
 769                  (let ((call (apply #'make-call-inst emf-name "sod__obj"
 770                                     (mapcar #'argument-name entry-args))))
 771                    (dolist (tail chain-tails)
 772                      (setup-entry tail)
 773                      (deliver-expr codegen entry-target call)
 774                      (finish-entry tail)))))))
 775
 776       (codegen-functions codegen))))
 777
 778 (defmethod compute-effective-method-body :around
 779     ((method basic-effective-method) codegen target)
 780   (let* ((message (effective-method-message method))
 781          (keywordsp (keyword-message-p message))
 782          (keywords (effective-method-keywords method))
 783          (ap-addr (format nil "&~A" *sod-tmp-ap*))
 784          (set (format nil "\"~A:~A.~A\""
 785                       (sod-class-name (effective-method-class method))
 786                       (sod-class-nickname (sod-message-class message))
 787                       (sod-message-name message))))
 788     (labels ((call (target func &rest args)
 789                (apply #'deliver-call codegen target func args))
 790              (parse-keywords (body)
 791                (ensure-var codegen *sod-tmp-ap* c-type-va-list)
 792                (call :void "va_copy" *sod-tmp-ap* *sod-ap*)
 793                (funcall body)
 794                (call :void "va_end" *sod-tmp-ap*)))
 795       (cond ((not keywordsp)
 796              (call-next-method))
 797             ((null keywords)
 798              (let ((*keyword-struct-disposition* :null))
 799                (parse-keywords (lambda ()
 800                                  (with-temporary-var
 801                                      (codegen kw c-type-const-string)
 802                                    (call kw "va_arg"
 803                                          *sod-tmp-ap* c-type-const-string)
 804                                    (call :void "kw_parseempty" set
 805                                          kw ap-addr *null-pointer* 0))))
 806                (call-next-method)))
 807             (t
 808              (let* ((name
 809                      (effective-method-keyword-parser-function-name method))
 810                     (tag (effective-method-keyword-struct-tag method))
 811                     (kw-addr (format nil "&~A" *sod-keywords*))
 812                     (*keyword-struct-disposition* :local))
 813                (ensure-var codegen *sod-keywords* (c-type (struct tag)))
 814                (make-keyword-parser-function codegen method tag set keywords)
 815                (emit-insts codegen
 816                            (mapcar (lambda (keyword)
 817                                      (make-set-inst
 818                                       (format nil "~A.~A__suppliedp"
 819                                               *sod-keywords*
 820                                               (argument-name keyword))
 821                                       0))
 822                                    keywords))
 823                (parse-keywords (lambda ()
 824                                  (call :void name kw-addr ap-addr
 825                                        *null-pointer* 0)))
 826                (call-next-method)))))))
 827
 828 (defmethod effective-method-live-p ((method simple-effective-method))
 829   (effective-method-primary-methods method))
 830
 831 (defmethod compute-method-entry-functions :around ((method effective-method))
 832   (if (effective-method-live-p method)
 833       (call-next-method)
 834       nil))
 835
 836 (defmethod compute-effective-method-body
 837     ((method simple-effective-method) codegen target)
 838   (basic-effective-method-body codegen target method
 839                                (lambda (target)
 840                                  (simple-method-body method
 841                                                      codegen
 842                                                      target))))
 843
 844 ;;;--------------------------------------------------------------------------
 845 ;;; Standard method combination.
 846
 847 (export 'standard-message)
 848 (defclass standard-message (simple-message)
 849   ()
 850   (:documentation
 851    "Message class for standard method combinations.
 852
 853    Standard method combination is a simple method combination where the
 854    primary methods are invoked as a delegation chain, from most- to
 855    least-specific."))
 856
 857 (export 'standard-effective-method)
 858 (defclass standard-effective-method (simple-effective-method) ()
 859   (:documentation "Effective method counterpart to `standard-message'."))
 860
 861 (defmethod primary-method-class ((message standard-message))
 862   'delegating-direct-method)
 863
 864 (defmethod sod-message-effective-method-class ((message standard-message))
 865   'standard-effective-method)
 866
 867 (defmethod simple-method-body
 868     ((method standard-effective-method) codegen target)
 869   (invoke-delegation-chain codegen
 870                            target
 871                            (effective-method-basic-argument-names method)
 872                            (effective-method-primary-methods method)
 873                            nil))
 874
 875 ;;;----- That's all, folks --------------------------------------------------