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