3 ;;; Method combination implementation
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensible Object Design, an object system for C.
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.
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.
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.
28 ;;;--------------------------------------------------------------------------
31 (export 'basic-message)
32 (defclass basic-message (sod-message)
33 ((argument-tail :type list :reader sod-message-argument-tail))
35 "Base class for built-in message classes.
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.
41 The function type protocol is implemented on `basic-message' using slot
42 reader methods. The actual values are computed on demand."))
44 (define-on-demand-slot basic-message argument-tail (message)
47 (if (or (eq arg :ellipsis) (argument-name arg)) arg
48 (make-argument (make-instance 'temporary-argument
51 (argument-type arg))))
52 (c-function-arguments (sod-message-type message)))))
54 (defmethod sod-message-method-class
55 ((message basic-message) (class sod-class) pset)
56 (let ((role (get-property pset :role :keyword nil)))
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)))))
63 (defmethod sod-message-receiver-type ((message sod-message)
65 (c-type (* (class class
66 (and (sod-message-readonly-p message) :const)))))
68 (export 'simple-message)
69 (defclass simple-message (basic-message)
72 "Base class for messages with `simple' method combinations.
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.
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
83 (defmethod sod-message-method-class
84 ((message simple-message) (class sod-class) pset)
85 (if (get-property pset :role :keyword nil)
87 (primary-method-class message)))
89 (defmethod primary-method-class ((message simple-message))
92 ;;;--------------------------------------------------------------------------
93 ;;; Direct method classes.
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))
100 "Base class for built-in direct method classes.
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.
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
110 The function type protocol is implemented on `basic-direct-method' using
111 slot reader methods."))
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)))
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"
122 (sod-class-nickname (sod-message-class message))
123 (sod-message-name message))))
125 (defun effective-method-keyword-struct-tag (effective-method)
126 (with-slots ((class %class) message) effective-method
127 (format nil "~A__keywords_~A__~A"
129 (sod-class-nickname (sod-message-class message))
130 (sod-message-name message))))
132 (defun fix-up-keyword-method-args (method args)
133 "Adjust the ARGS to include METHOD's `suppliedp' and keyword arguments.
135 Return the adjusted list. The `suppliedp' argument, if any, is prepended
136 to the list; the keyword arguments are added to the end.
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)))
143 (list (make-argument "suppliedp" (c-type (struct tag)))))
145 (mapcar (lambda (key)
146 (make-argument (argument-name key)
147 (argument-type key)))
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))))
161 (defmethod sod-method-description ((method basic-direct-method))
162 (with-slots (role) method
163 (if role (string-downcase role)
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))))
172 (export 'daemon-direct-method)
173 (defclass daemon-direct-method (basic-direct-method)
176 "A daemon direct method is invoked for side effects and cannot override.
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.
182 In C terms, a daemon method must return `void', and is not passed a
183 `next_method' pointer."))
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)))
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))
197 "A delegating direct method can choose to override other methods.
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.
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.)
209 The function type protocol is implemented on `delegating-direct-method'
210 using slot reader methods.."))
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*
220 ((keyword-message-p message)
221 (cons (make-argument *sod-keywords*
222 (c-type (* (void :const))))
226 (c-type (fun (lisp return-type)
227 ("me" (lisp (sod-message-receiver-type
228 message (sod-method-class method))))
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
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)
243 (push next-method-arg method-args))
244 ((keyword-message-p message)
245 (push (make-argument *sod-keywords* (c-type (* (void :const))))
247 (push next-method-arg method-args)
249 (fix-up-keyword-method-args method method-args)))
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))))
257 ;;;--------------------------------------------------------------------------
258 ;;; Effective method classes.
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)))
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)
273 (let ((class (sod-method-class method)))
275 method "Type `~A' declared in ~A direct ~
276 method of `~A' (defined here)"
278 (sod-method-description method) class)
279 (report-inheritance-path state class)))
280 (c-function-keywords (sod-method-type method))))
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))
287 (defmethod shared-initialize :after
288 ((method effective-method) slot-names &key direct-methods)
289 (declare (ignore slot-names))
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
296 (compute-effective-method-keyword-arguments message
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))
314 "Base class for built-in effective method classes.
316 This class maintains lists of the applicable `before', `after' and
317 `around' methods and provides behaviour for invoking these methods
320 The argument names protocol is implemented on `basic-effective-method'
321 using a slot reader method."))
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))))
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"
334 (sod-class-nickname message-class)
335 (sod-message-name message))))
337 (define-on-demand-slot basic-effective-method functions (method)
338 (compute-method-entry-functions method))
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))
345 "Effective method counterpart to `simple-message'."))
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)
357 (setf primary-methods primary
358 before-methods before
359 after-methods (reverse after)
360 around-methods around))))
362 ;;;--------------------------------------------------------------------------
365 (defmethod shared-initialize :after
366 ((codegen method-codegen) slot-names &key)
367 (declare (ignore slot-names))
368 (with-slots (message target) codegen
370 (if (eq (c-type-subtype (sod-message-type message)) c-type-void)
374 ;;;--------------------------------------------------------------------------
375 ;;; Invoking direct methods.
377 (export 'basic-effective-method-body)
378 (defun basic-effective-method-body (codegen target method body)
379 "Build the common method-invocation structure.
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."
390 (with-slots (message (class %class)
391 before-methods after-methods around-methods)
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
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)))))
410 ;;;--------------------------------------------------------------------------
411 ;;; Method entry points.
413 (defparameter *method-entry-inline-threshold* 200
414 "Threshold below which effective method bodies are inlined into entries.
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.")
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"
431 (sod-class-nickname message-class)
432 (sod-message-name message)
433 (sod-class-nickname chain-head))
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)))
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)
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))))
458 (defgeneric effective-method-keyword-parser-function-name (method)
460 "Return the name of the keyword-parsing function for an effective METHOD.
462 See `make-keyword-parser-function' for details of what this function
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"
470 (sod-class-nickname (sod-message-class message))
471 (sod-message-name message))))
473 (defun make-keyword-parser-function (codegen method tag set keywords)
474 "Construct and return a keyword-argument parsing function.
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
482 The generated function has the signature
484 void NAME(struct TAG *kw, va_list *ap, struct kwval *v, size_t n)
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
492 ;; Let's start, then.
493 (codegen-push codegen)
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)))
504 (flet ((call (target func &rest args)
505 ;; Call FUNC with ARGS; return result in TARGET.
507 (apply #'deliver-call codegen target func args))
509 (convert (target type)
510 ;; Fetch the object of TYPE pointed to by `v->val', and store it
513 (deliver-expr codegen target
514 (format nil "*(~A)v->val"
515 (make-pointer-type (qualify-c-type
516 type (list :const))))))
518 (namecheck (var name conseq alt)
519 ;; Return an instruction: if VAR matches the string NAME then do
520 ;; CONSEQ; otherwise do ALT.
522 (make-if-inst (make-call-inst "!strcmp"
523 var (prin1-to-string name))
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"
533 (name (effective-method-keyword-parser-function-name method)))
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))
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))
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))
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))
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)))
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))
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))))
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))))
596 (make-if-inst "ap" (make-block-inst nil (list loop)))))
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)))
606 ;; Wrap the whole lot up with a nice bow.
607 (let ((message (effective-method-message method)))
608 (codegen-pop-function codegen name
610 ("kw" (* (struct tag)))
612 ("v" (* (struct "kwval" :const)))
614 "Keyword parsing for `~A.~A' on class `~A'."
616 (sod-message-class message))
617 (sod-message-name message)
618 (effective-method-class method))))))
620 (defmethod make-method-entries ((method basic-effective-method)
621 (chain-head sod-class)
622 (chain-tail sod-class))
624 (message (effective-method-message method)))
626 (push (make-instance 'method-entry
627 :method method :role role
628 :chain-head chain-head
629 :chain-tail chain-tail)
631 (when (or (varargs-message-p message)
632 (keyword-message-p message))
637 (defmethod compute-method-entry-functions ((method basic-effective-method))
639 ;; OK, there's quite a lot of this, so hold tight.
641 ;; The first thing we need to do is find all of the related objects. This
642 ;; is a bit verbose but fairly straightforward.
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.
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.
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.
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.
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
670 ;; Method entry details.
671 (chain-tails (remove-if-not (lambda (super)
672 (sod-subclass-p super message-class))
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)
679 (entry-args (reify-variable-argument-tail raw-entry-args))
680 (parm-n (let ((tail (last (cons (make-argument "me" c-type-void)
682 (and tail (eq (cadr tail) :ellipsis)
683 (argument-name (car tail)))))
684 (entry-target (codegen-target codegen))
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
692 (emf-type (c-type (fun (lisp return-type)
693 ("sod__obj" (lisp ilayout-type))
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
702 (deliver-call codegen :void "SOD__IGNORE" "sod__obj")))
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))
711 (codegen-pop-function codegen name type
712 "~@(~@[~A ~]entry~) function ~:_~
713 for method `~A.~A' ~:_~
714 via chain headed by `~A' ~:_~
716 (if parm-n "Indirect argument-tail" nil)
717 (sod-class-nickname message-class)
718 (sod-message-name message)
721 ;; If this is a varargs or keyword method then we've made the
722 ;; `:valist' role. Also make the `nil' role.
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))
730 (codegen-push codegen)
731 (ensure-var codegen *sod-ap* c-type-va-list)
732 (convert-stmts codegen entry-target return-type
734 (deliver-call codegen :void "va_start"
736 (deliver-expr codegen target call)
737 (deliver-call codegen :void "va_end"
739 (codegen-pop-function codegen main main-type
740 "Variable-length argument list ~:_~
742 for method `~A.~A' ~:_~
743 via chain headed by `~A' ~:_~
745 (sod-class-nickname message-class)
746 (sod-message-name message)
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*))
760 ;; The effective method body is simple -- or there's only
761 ;; one of them. We'll inline the method body into the entry
763 (dolist (tail chain-tails)
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)))
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' ~:_~
784 (sod-class-nickname message-class)
785 (sod-message-name message)
786 (effective-method-class method))
788 (let ((call (apply #'make-call-inst emf-name "sod__obj"
789 (mapcar #'argument-name entry-args))))
790 (dolist (tail chain-tails)
792 (deliver-expr codegen entry-target call)
793 (finish-entry tail)))))))
795 (codegen-functions codegen))))
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*)
813 (call :void "va_end" *sod-tmp-ap*)))
814 (cond ((not keywordsp)
817 (let ((*keyword-struct-disposition* :null))
818 (parse-keywords (lambda ()
820 (codegen kw c-type-const-string)
822 *sod-tmp-ap* c-type-const-string)
823 (call :void "kw_parseempty" set
824 kw ap-addr *null-pointer* 0))))
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)
835 (mapcar (lambda (keyword)
837 (format nil "~A.~A__suppliedp"
839 (argument-name keyword))
842 (parse-keywords (lambda ()
843 (call :void name kw-addr ap-addr
845 (call-next-method)))))))
847 (defmethod effective-method-live-p ((method simple-effective-method))
848 (effective-method-primary-methods method))
850 (defmethod compute-method-entry-functions :around ((method effective-method))
851 (if (effective-method-live-p method)
855 (defmethod compute-effective-method-body
856 ((method simple-effective-method) codegen target)
857 (basic-effective-method-body codegen target method
859 (simple-method-body method
863 ;;;--------------------------------------------------------------------------
864 ;;; Standard method combination.
866 (export 'standard-message)
867 (defclass standard-message (simple-message)
870 "Message class for standard method combinations.
872 Standard method combination is a simple method combination where the
873 primary methods are invoked as a delegation chain, from most- to
876 (export 'standard-effective-method)
877 (defclass standard-effective-method (simple-effective-method) ()
878 (:documentation "Effective method counterpart to `standard-message'."))
880 (defmethod primary-method-class ((message standard-message))
881 'delegating-direct-method)
883 (defmethod sod-message-effective-method-class ((message standard-message))
884 'standard-effective-method)
886 (defmethod simple-method-body
887 ((method standard-effective-method) codegen target)
888 (invoke-delegation-chain codegen
890 (effective-method-basic-argument-names method)
891 (effective-method-primary-methods method)
894 ;;;----- That's all, folks --------------------------------------------------