Commit | Line | Data |
---|---|---|
1f1d88f5 MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Method combinations | |
4 | ;;; | |
5 | ;;; (c) 2009 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
10 | ;;; This file is part of the Simple Object Definition system. | |
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 | ;;; Common behaviour. | |
30 | ||
31 | (defclass simple-message (basic-message) | |
32 | () | |
33 | (:documentation | |
34 | "Base class for messages with `simple' method combinations. | |
35 | ||
36 | A simple method combination is one which has only one method role other | |
37 | than the `before', `after' and `around' methods provided by BASIC-MESSAGE. | |
38 | We call these `primary' methods, and the programmer designates them by not | |
39 | specifying an explicit role. | |
40 | ||
41 | If the programmer doesn't define any primary methods then the effective | |
42 | method is null -- i.e., the method entry pointer shows up as a null | |
43 | pointer.")) | |
44 | ||
45 | (defclass simple-effective-method (basic-effective-method) | |
46 | ((primary-methods :initarg :primary-methods | |
47 | :initform nil | |
48 | :type list | |
49 | :reader effective-method-primary-methods)) | |
50 | (:documentation | |
51 | "Effective method counterpart to SIMPLE-MESSAGE.")) | |
52 | ||
53 | (defgeneric primary-method-class (message) | |
54 | (:documentation | |
55 | "Return the name of the primary direct method class for MESSAGE.")) | |
56 | ||
57 | (defgeneric simple-method-body (method codegen target) | |
58 | (:documentation | |
59 | "Generate the body of a simple effective method. | |
60 | ||
61 | The function is invoked on an effective METHOD, with a CODEGEN to which it | |
62 | should emit code delivering the method's value to TARGET.")) | |
63 | ||
64 | (defmethod sod-message-method-class | |
65 | ((message standard-message) (class sod-class) pset) | |
66 | (if (get-property pset :role :keyword nil) | |
67 | (call-next-method) | |
68 | (primary-method-class message))) | |
69 | ||
70 | (defmethod shared-initialize :after | |
71 | ((method simple-effective-method) slot-names &key direct-methods) | |
72 | (declare (ignore slot-names)) | |
73 | (categorize (method direct-methods :bind ((role (sod-method-role method)))) | |
74 | ((primary (null role)) | |
75 | (before (eq role :before)) | |
76 | (after (eq role :after)) | |
77 | (around (eq role :around))) | |
78 | (with-slots (primary-methods before-methods after-methods around-methods) | |
79 | method | |
80 | (setf primary-methods primary | |
81 | before-methods before | |
82 | after-methods (reverse after) | |
83 | around-methods around)))) | |
84 | ||
85 | (defmethod compute-effective-method-entry-functions | |
86 | ((method standard-effective-method)) | |
87 | (if (effective-method-primary-methods method) | |
88 | (call-next-method) | |
89 | nil)) | |
90 | ||
91 | (defmethod compute-effective-method-body | |
92 | ((method simple-effective-method) codegen target) | |
93 | (with-slots (message basic-argument-names primary-methods) method | |
94 | (basic-effective-method-body codegen target method | |
95 | (lambda (target) | |
96 | (simple-method-body method | |
97 | codegen | |
98 | target))))) | |
99 | ||
100 | ;;;-------------------------------------------------------------------------- | |
101 | ;;; Standard method combination. | |
102 | ||
103 | (defclass standard-message (simple-message) | |
104 | () | |
105 | (:documentation | |
106 | "Message class for standard method combination. | |
107 | ||
108 | Standard method combination is a simple method combination where the | |
109 | primary methods are invoked as a delegation chain, from most- to | |
110 | least-specific.")) | |
111 | ||
112 | (defclass standard-effective-method (simple-effective-method) | |
113 | () | |
114 | (:documentation | |
115 | "Effective method counterpart to STANDARD-MESSAGE.")) | |
116 | ||
117 | (defmethod primary-method-class ((message standard-message)) | |
118 | 'delegating-direct-method) | |
119 | ||
120 | (defmethod message-effective-method-class ((message standard-message)) | |
121 | 'standard-effective-method) | |
122 | ||
123 | (defmethod simple-method-body | |
124 | ((method standard-effective-method) codegen target) | |
125 | (invoke-delegation-chain codegen | |
126 | target | |
127 | (effective-method-basic-argument-names method) | |
128 | (effective-method-primary-methods method) | |
129 | nil)) | |
130 | ||
131 | ;;;----- That's all, folks -------------------------------------------------- |