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