Commit | Line | Data |
---|---|---|
95f51977 C |
1 | ; Tasteful Flavors -*- Mode: Lisp; Package: SI; Base:8 -*- |
2 | ||
3 | ;; (c) copywrite 1982, Massachusetts Institute of Technology | |
4 | ||
5 | ;; This flavor system is derived from the original Lisp machine | |
6 | ;; flavor system. As such its distribution may be restricted to | |
7 | ;; Lisp machine software license holders. | |
8 | ||
9 | (environment-lmlisp (eval compile load) (files flavorm)) | |
10 | ||
11 | (setq |SCCS-flavors| "@(#) flavors.l 1.1 83/03/14 @(#)") | |
12 | ||
13 | (DECLARE (SPECIAL ERRPORT) | |
14 | (MACROS T)) | |
15 | ||
16 | ; A flavor-name is a symbol which names a type of objects defined | |
17 | ; by the combination of several flavors. The SI:FLAVOR | |
18 | ; property is a data-structure (of type FLAVOR) defining the | |
19 | ; nature of the flavor, as defined below. | |
20 | ||
21 | ; Flavors come in essentially three kinds. The first kind defines a class | |
22 | ; of flavors, and provides the basic instance variables and methods for | |
23 | ; that class. This kind typically includes only VANILLA-FLAVOR as a | |
24 | ; component, and uses the :REQUIRED-INSTANCE-VARIABLES and | |
25 | ; :REQUIRED-METHODS options. The second kind of flavor represents a | |
26 | ; particular option that may be combined in (a "mix-in"). The third | |
27 | ; kind of flavor is the kind that can usefully be instantiated; it is | |
28 | ; a combination of one of the first kind and several of the second kind, | |
29 | ; to achieve the behavior desired for a particular application. | |
30 | ||
31 | ; The following symbols are interesting to outsiders: | |
32 | ; DEFFLAVOR - macro for defining a flavor | |
33 | ; DEFMETHOD - macro for defining a method | |
34 | ; DEFWRAPPER - macro for defining a flavor-wrapper | |
35 | ; INSTANTIATE-FLAVOR - create an object of a specified flavor | |
36 | ; MAKE-INSTANCE - easier to call version of INSTANTIATE-FLAVOR | |
37 | ; COMPILE-FLAVOR-METHODS - macro which does the right thing in the compiler | |
38 | ; RECOMPILE-FLAVOR - function to recompile a flavor and maybe any flavors | |
39 | ; that depend on it. Usually this happens automatically. | |
40 | ; FUNCALL-SELF - a macro which, assuming you are a flavor instance, will | |
41 | ; call yourself without bothering about rebinding the | |
42 | ; variables. Will do something totally random if SELF | |
43 | ; isn't a flavor instance. | |
44 | ; LEXPR-FUNCALL-SELF - LEXPR-FUNCALL version of above | |
45 | ; *ALL-FLAVOR-NAMES* - list of all symbols which have been used as the | |
46 | ; name of a flavor | |
47 | ; *FLAVOR-COMPILATIONS* - list of all methods which had to be compiled | |
48 | ; this is useful for finding flavors which weren't compiled | |
49 | ; in qfasl files or which need to be recompiled to bring | |
50 | ; them up to date. | |
51 | ; *FLAVOR-COMPILE-TRACE* - if non-NIL, a FORMAT destination for messages about | |
52 | ; recompilation of combined methods | |
53 | ; FLAVOR-ALLOWS-INIT-KEYWORD-P - determine whether a certain flavor allows | |
54 | ; a certain keyword in its init-plist. | |
55 | ; FLAVOR-ALLOWED-INIT-KEYWORDS - returns all the init keywords a flavor | |
56 | ; handles. | |
57 | ||
58 | ; Roads not taken: | |
59 | ; o Changing the size of all extant instances of a flavor. | |
60 | ; o Nothing to stop you from instantiating a flavor of the first or | |
61 | ; second kind. In practice you will usually get an error if you try it. | |
62 | \f | |
63 | ; This macro is used to define a flavor. Use DEFMETHOD to define | |
64 | ; methods (responses to messages sent to an instance of a flavor.) | |
65 | (DEFMACRO DEFFLAVOR (NAME INSTANCE-VARIABLES COMPONENT-FLAVORS &REST OPTIONS) | |
66 | ;INSTANCE-VARIABLES can be symbols, or lists of symbol and initialization. | |
67 | ;COMPONENT-FLAVORS are searched from left to right for methods, | |
68 | ; and contribute their instance variables. | |
69 | ;OPTIONS are: | |
70 | ; (:GETTABLE-INSTANCE-VARIABLES v1 v2...) - enables automatic generation of methods | |
71 | ; for retrieving the values of those instance variables | |
72 | ; :GETTABLE-INSTANCE-VARIABLES - (the atomic form) does it for all instance | |
73 | ; variables local to this flavor (declared in this DEFFLAVOR). | |
74 | ; (:SETTABLE-INSTANCE-VARIABLES v1 v2...) - enables automatic generation of methods | |
75 | ; for changing the values of instance variables | |
76 | ; The atomic form works too. | |
77 | ; (:REQUIRED-INSTANCE-VARIABLES v1 v2...) - any flavor incorporating this | |
78 | ; flavor and actually instantiated must have instance variables with | |
79 | ; the specified names. This is used for defining general types of | |
80 | ; flavors. | |
81 | ; (:REQUIRED-METHODS m1 m2...) - any flavor incorporating this | |
82 | ; flavor and actually instantiated must have methods for the specified | |
83 | ; operations. This is used for defining general types of flavors. | |
84 | ; (:REQUIRED-FLAVORS f1 f2...) - similar, for component flavors | |
85 | ; rather than methods. | |
86 | ; (:INITABLE-INSTANCE-VARIABLES v1 v2...) - these instance variables | |
87 | ; may be initialized via the options to INSTANTIATE-FLAVOR. | |
88 | ; The atomic form works too. | |
89 | ; Settable instance variables are also INITABLE. | |
90 | ; (:INIT-KEYWORDS k1 k2...) - specifies keywords for the :INIT operation | |
91 | ; which are legal to give to this flavor. Just used for error checking. | |
92 | ; (:DEFAULT-INIT-PLIST k1 v1 k2 v2...) - specifies defaults to be put | |
93 | ; into the init-plist, if the keywords k1, k2, ... are not already | |
94 | ; specified, when instantiating. The values v1, v2, ... get evaluated | |
95 | ; when and if they are used. | |
96 | ; (:DEFAULT-HANDLER function) - causes function to be called if a message | |
97 | ; is sent for which there is no method. Defaults to a function which | |
98 | ; gives an error. | |
99 | ; (:INCLUDED-FLAVORS f1 f2...) - specifies flavors to be included in this | |
100 | ; flavor. The difference between this and specifying them as components | |
101 | ; is that included flavors go at the end, so they act as defaults. This | |
102 | ; makes a difference when this flavor is depended on by other flavors. | |
103 | ; :NO-VANILLA-FLAVOR - do not include VANILLA-FLAVOR. | |
104 | ; Normally it is included automatically. This is for esoteric hacks. | |
105 | ; (:ORDERED-INSTANCE-VARIABLES v1 v2...) - requires that in any instance, | |
106 | ; instance variables with these names must exist and come first. This might | |
107 | ; be for instance variable slots specially referenced by microcode. | |
108 | ; The atomic form works too. | |
109 | ; (:OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES v1 v2...) - defines defsubsts which | |
110 | ; act like defstruct accessors for the variables; that is, using these with | |
111 | ; an argument of an instance gets the value of that variable in that instance. | |
112 | ; The name of the defsubst is the flavor-name, hyphen, the variable name. | |
113 | ; If the instance variable is ordered, the accessor will know its index | |
114 | ; in the instance and access it directly, otherwise it will call | |
115 | ; SYMEVAL-IN-CLOSURE at run-time. | |
116 | ; The atomic form works too. | |
117 | ; (:ACCESSOR-PREFIX sym) - uses "sym" as the prefix on the names of the above | |
118 | ; defsubsts instead of "flavor-". | |
119 | ; (:SELECT-METHOD-ORDER m1 m2...) - specifies that the keywords m1, m2, ... are | |
120 | ; are important and should have their methods first in the select-method | |
121 | ; table for increased efficiency. | |
122 | ; (:METHOD-COMBINATION (type order operation1 operation2...)...) | |
123 | ; Specify ways of combining methods from different flavors. :DAEMON NIL is the | |
124 | ; the default. order is usually :BASE-FLAVOR-FIRST or :BASE-FLAVOR-LAST, | |
125 | ; but this depends on type. | |
126 | ; (:DOCUMENTATION <args>...) | |
127 | ; The list of args is simply put on the flavor's :DOCUMENTATION property. | |
128 | ; The standard for this is that the arguments may include keyword symbols and | |
129 | ; a documentation string. To be specified more later. | |
130 | ; There may be more. | |
131 | (LET ((COPIED-OPTIONS (COPYLIST OPTIONS))) | |
132 | (DEFFLAVOR1 NAME INSTANCE-VARIABLES COMPONENT-FLAVORS COPIED-OPTIONS) | |
133 | ;; The following is done to determine all the instance variables | |
134 | ;; that need to be declared special. | |
135 | (IF (NOT (NULL (GETD 'LISZT))) | |
136 | (COMPOSE-FLAVOR-COMBINATION (GET-FLAVOR NAME))) | |
137 | `(PROGN 'COMPILE | |
138 | ;; Define flavor at load time. | |
139 | ;; Must come before the compile-time COMPOSE-AUTOMATIC-METHODS, | |
140 | ;; which puts methods in the QFASL file. | |
141 | (EVAL-WHEN (LOAD) | |
142 | (DEFFLAVOR1 ',NAME ',INSTANCE-VARIABLES ',COMPONENT-FLAVORS | |
143 | ',COPIED-OPTIONS)) | |
144 | ,@(COMPOSE-AUTOMATIC-METHODS (GET NAME 'FLAVOR)) | |
145 | ;; Make any instance-variable accessor macros. | |
146 | ,@(DO ((VS (DO ((OPTS OPTIONS (CDR OPTS))) | |
147 | ((NULL OPTS) NIL) | |
148 | (AND (LISTP (CAR OPTS)) | |
149 | (EQ (CAAR OPTS) ':OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES) | |
150 | (RETURN (CDAR OPTS))) | |
151 | (AND (EQ (CAR OPTS) ':OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES) | |
152 | (RETURN (MAPCAR #'(LAMBDA (X) (IF (ATOM X) X (CAR X))) | |
153 | INSTANCE-VARIABLES)))) | |
154 | (CDR VS)) | |
155 | (PREFIX (OR (CADR (ASSQ ':ACCESSOR-PREFIX OPTIONS)) | |
156 | (CONCAT NAME "-"))) | |
157 | (ORDS (DO ((OPTS OPTIONS (CDR OPTS))) | |
158 | ((NULL OPTS) NIL) | |
159 | (AND (LISTP (CAR OPTS)) | |
160 | (EQ (CAAR OPTS) ':ORDERED-INSTANCE-VARIABLES) | |
161 | (RETURN (CDAR OPTS))) | |
162 | (AND (EQ (CAR OPTS) ':ORDERED-INSTANCE-VARIABLES) | |
163 | (RETURN (MAPCAR #'(LAMBDA (X) (IF (ATOM X) X (CAR X))) | |
164 | INSTANCE-VARIABLES))))) | |
165 | (RES NIL (CONS `(DEFSUBST ,(INTERN (CONCAT PREFIX (CAR VS))) | |
166 | (,NAME) | |
167 | ,(IF (MEMQ (CAR VS) ORDS) | |
168 | ; SMH@EMS VVV `(VREF ,NAME | |
169 | ; ,(+ 9 (* 3 (FIND-POSITION-IN-LIST | |
170 | ; (CAR VS) ORDS)))) | |
171 | `(INT:FCLOSURE-STACK-STUFF | |
172 | (VREF ,NAME ,(+ 3 (FIND-POSITION-IN-LIST | |
173 | (CAR VS) ORDS)))) | |
174 | ; SMH@EMS ^^^ | |
175 | `(SYMEVAL-IN-FCLOSURE ,NAME ',(CAR VS)))) | |
176 | RES))) | |
177 | ((NULL VS) RES)) | |
178 | ',NAME))) | |
179 | ||
180 | (DEFMACRO DEFUN-METHOD (FSPEC FLAVOR-NAME ARGLIST &BODY BODY) | |
181 | `(DEFUN ,FSPEC ,ARGLIST | |
182 | (DECLARE (SPECIAL SELF .OWN-FLAVOR. | |
183 | ,@(FLAVOR-ALL-INSTANCE-VARIABLES | |
184 | (GET-FLAVOR FLAVOR-NAME)))) | |
185 | . ,BODY)) | |
186 | ||
187 | (DEFMACRO INSTANCE-VARIABLE-BOUNDP (X) | |
188 | `(BOUNDP ',X)) | |
189 | ||
190 | (DEFVAR *ALL-FLAVOR-NAMES* NIL) ;List of names of all flavors (mostly for editor) | |
191 | ||
192 | (DEFVAR *USE-OLD-COMBINED-METHODS* T) | |
193 | ;;T means recycle old, NIL means generate new. | |
194 | ;; This is an implicit argument to certain routines. | |
195 | ||
196 | (DEFVAR *FLAVOR-PENDING-DEPENDS* NIL) ;Used by DEFFLAVOR1 | |
197 | ||
198 | (DEFVAR *FLAVOR-COMPILATIONS* NIL) ;List of methods compiled | |
199 | ||
200 | (DEFVAR *FLAVOR-COMPILE-TRACE* NIL) | |
201 | \f | |
202 | (DEFSUBST INSTANCE-FLAVOR (INSTANCE) | |
203 | (SYMEVAL-IN-FCLOSURE INSTANCE '.OWN-FLAVOR.)) | |
204 | ||
205 | (DEFSUBST INSTANCE-FUNCTION (INSTANCE) | |
206 | (FCLOSURE-FUNCTION INSTANCE)) | |
207 | ||
208 | (DEFUN GET-FLAVOR (FLAVOR-OR-NAME &AUX TEMP) | |
209 | (COND ((:TYPEP FLAVOR-OR-NAME 'FLAVOR) FLAVOR-OR-NAME) | |
210 | ((SYMBOLP FLAVOR-OR-NAME) | |
211 | (SETQ TEMP (GET FLAVOR-OR-NAME 'FLAVOR)) | |
212 | (CHECK-ARG FLAVOR-OR-NAME (:TYPEP TEMP 'FLAVOR) | |
213 | "the name of a flavor") | |
214 | TEMP) | |
215 | (T (CHECK-ARG FLAVOR-OR-NAME (:TYPEP TEMP 'FLAVOR) | |
216 | "the name of a flavor")))) | |
217 | ||
218 | ;;(DEFSUBST INSTANCEP (X) | |
219 | ;; (AND (FCLOSUREP X) (EQ (FCLOSURE-FUNCTION X) #'FLAVOR-DISPATCH))) | |
220 | ||
221 | (DEFUN INSTANCE-TYPEP (OB TYPE) | |
222 | (IF (NULL TYPE) | |
223 | (FLAVOR-NAME (INSTANCE-FLAVOR OB)) | |
224 | (NOT (NULL (MEMQ TYPE (FLAVOR-DEPENDS-ON-ALL | |
225 | (INSTANCE-FLAVOR OB))))))) | |
226 | ||
227 | ||
228 | ;These properties are not discarded by redoing a DEFFLAVOR. | |
229 | (DEFCONST DEFFLAVOR1-PRESERVED-PROPERTIES | |
230 | '(ADDITIONAL-INSTANCE-VARIABLES | |
231 | COMPILE-FLAVOR-METHODS | |
232 | MAPPED-COMPONENT-FLAVORS | |
233 | INSTANCE-VARIABLE-INITIALIZATIONS | |
234 | ALL-INITABLE-INSTANCE-VARIABLES | |
235 | REMAINING-DEFAULT-PLIST | |
236 | REMAINING-INIT-KEYWORDS)) | |
237 | ||
238 | ;These are instance variables that don't belong to this flavor or its components | |
239 | ;but can be accessed by methods of this flavor. | |
240 | (DEFSUBST FLAVOR-ADDITIONAL-INSTANCE-VARIABLES (FLAVOR) | |
241 | (GET (FLAVOR-PLIST FLAVOR) 'ADDITIONAL-INSTANCE-VARIABLES)) | |
242 | ||
243 | ;The next four are distillations of info taken from this flavor and its components, | |
244 | ;used for instantiating this flavor. See COMPOSE-FLAVOR-INITIALIZATIONS. | |
245 | (DEFSUBST FLAVOR-INSTANCE-VARIABLE-INITIALIZATIONS (FLAVOR) | |
246 | (GET (FLAVOR-PLIST FLAVOR) 'INSTANCE-VARIABLE-INITIALIZATIONS)) | |
247 | ||
248 | (DEFSUBST FLAVOR-REMAINING-DEFAULT-PLIST (FLAVOR) | |
249 | (GET (FLAVOR-PLIST FLAVOR) 'REMAINING-DEFAULT-PLIST)) | |
250 | ||
251 | (DEFSUBST FLAVOR-REMAINING-INIT-KEYWORDS (FLAVOR) | |
252 | (GET (FLAVOR-PLIST FLAVOR) 'REMAINING-INIT-KEYWORDS)) | |
253 | ||
254 | (DEFSUBST FLAVOR-ALL-INITABLE-INSTANCE-VARIABLES (FLAVOR) | |
255 | (GET (FLAVOR-PLIST FLAVOR) 'ALL-INITABLE-INSTANCE-VARIABLES)) | |
256 | ||
257 | (DEFUN (FLAVOR :NAMED-STRUCTURE-INVOKE) (OPERATION &OPTIONAL SELF &REST ARGS) | |
258 | (SELECTQ OPERATION | |
259 | (:WHICH-OPERATIONS '(:PRINT-SELF :DESCRIBE)) | |
260 | (:PRINT-SELF | |
261 | (SI:PRINTING-RANDOM-OBJECT (SELF (CAR ARGS)) | |
262 | (FORMAT (CAR ARGS) "FLAVOR ~S" (FLAVOR-NAME SELF)))) | |
263 | (:DESCRIBE (DESCRIBE-FLAVOR SELF)) | |
264 | (OTHERWISE | |
265 | (FERROR NIL "~S UNKNOWN OPERATION FOR FLAVOR" OPERATION)))) | |
266 | \f | |
267 | ;Format of flavor-method-table: | |
268 | ; New format of a flavor-method-table entry is: | |
269 | ; (message combination-type combination-order meth...) | |
270 | ; A meth is: | |
271 | ; (function-spec definition plist) | |
272 | ; Thus the second element of a meth is actually a function-cell. | |
273 | ; The meth's are stored in permanent-storage-area so that they will be compact. | |
274 | ; [That might not be the best area, the select-methods, and component | |
275 | ; lists, and instanc-variable lists, and which-operations's, are also there.] | |
276 | ; A magic-list entry is: | |
277 | ; (message combination-type combination-order (method-type function-spec...)...) | |
278 | ; In the magic-list, there can be more than one method listed under a method-type, | |
279 | ; the base flavor always comes first. The :COMBINED methods are elided from | |
280 | ; the magic-list. | |
281 | ; | |
282 | ; Special method-types: | |
283 | ; NIL - no type specified | |
284 | ; :DEFAULT - like NIL but only taken if there are no type-NIL methods | |
285 | ; :WRAPPER - wrappers are remembered this way | |
286 | ; :COMBINED - a daemon-caller; the symbol has a COMBINED-METHOD-DERIVATION property | |
287 | ; whose value is the complete method table entry from the magic-list. | |
288 | ; The CDDDR is canonicalized; each contained list of method symbols is | |
289 | ; of course ordered by the order in which flavors are combined (base | |
290 | ; flavor first). Canonical order is alphabetical by method-type. | |
291 | ; Non-special method-types: | |
292 | ; :BEFORE, :AFTER - these are used by the default combination-type, :DAEMON | |
293 | ; | |
294 | ; Special hair for wrappers: changing a wrapper can invalidate the combined method | |
295 | ; without changing anything in the flavor-method-table entry. Rather than having | |
296 | ; it automatically recompile, which turns out to be a pain when the wrapper was | |
297 | ; just reloaded or changed trivially, it will fail to recompile and you must use | |
298 | ; RECOMPILE-FLAVOR with a 3rd argument of NIL. | |
299 | ; | |
300 | ; A combination-type of NIL means it has not been explicitly specified. | |
301 | ||
302 | ; Method-combination functions. Found on the SI:METHOD-COMBINATION property | |
303 | ; of the combination-type. These are passed the flavor structure, and the | |
304 | ; magic-list entry, and must return the function spec to use as the handler. | |
305 | ; It should also define or compile thew definition for that function spec if nec. | |
306 | ; This function interprets combination-type-arg, | |
307 | ; which for many combination-types is either :BASE-FLAVOR-FIRST or :BASE-FLAVOR-LAST. | |
308 | ||
309 | ;This is an a-list from method type to function to write the code to go | |
310 | ;in the combined method. Users can add to this. | |
311 | (DEFCONST *SPECIALLY-COMBINED-METHOD-TYPES* | |
312 | '((:WRAPPER PUT-WRAPPER-INTO-COMBINED-METHOD))) | |
313 | ||
314 | ;Definitions of a meth (the datum which stands for a method) | |
315 | ||
316 | (DEFSTRUCT (METH :LIST :CONC-NAME (:CONSTRUCTOR NIL)) | |
317 | ;No constructor because defstruct doesn't let me specify the area | |
318 | FUNCTION-SPEC | |
319 | DEFINITION | |
320 | (PLIST NIL)) | |
321 | ||
322 | ; If there is no definition, it contains DTP-NULL and a pointer to the meth | |
323 | ||
324 | ; Extract the method-type of a meth | |
325 | (DEFMACRO METH-METHOD-TYPE (METH) | |
326 | `(AND (CDDDR (METH-FUNCTION-SPEC ,METH)) | |
327 | (THIRD (METH-FUNCTION-SPEC ,METH)))) | |
328 | ||
329 | ; Return a meth of specified type from a list of meth's. | |
330 | (DEFUN METH-LOOKUP (METHOD-TYPE METH-LIST) | |
331 | (LOOP FOR METH IN METH-LIST | |
332 | WHEN (EQ (METH-METHOD-TYPE METH) METHOD-TYPE) | |
333 | RETURN METH)) | |
334 | ||
335 | (DEFUN NULLIFY-METHOD-DEFINITION (METH) | |
336 | (SETF (METH-DEFINITION METH) NIL)) | |
337 | ||
338 | (DEFUN METH-DEFINEDP (METH) | |
339 | (NOT (NULL (METH-DEFINITION METH)))) | |
340 | \f | |
341 | ;Function to define or redefine a flavor (used by DEFFLAVOR macro). | |
342 | ;Note that to ease initialization problems, the flavors depended upon need | |
343 | ;not be defined yet. You will get an error the first time you try to create | |
344 | ;an instance of this flavor if a flavor it depends on is still undefined. | |
345 | ;When redefining a flavor, we reuse the same FLAVOR defstruct so that | |
346 | ;old instances continue to get the latest methods, unless you change | |
347 | ;something incompatibly, in which case you will get a warning. | |
348 | (DEFUN DEFFLAVOR1 (FLAVOR-NAME INSTANCE-VARIABLES COMPONENT-FLAVORS OPTIONS | |
349 | &AUX FFL ALREADY-EXISTS INSTV IDENTICAL-COMPONENTS | |
350 | GETTABLE SETTABLE INITABLE OLD-DEFAULT-HANDLER | |
351 | OLD-DEFAULT-INIT-PLIST OLD-LOCAL-IVS OLD-INITABLE-IVS | |
352 | OLD-INIT-KWDS | |
353 | INIT-KEYWORDS INCLUDES METH-COMB | |
354 | (PL (LIST 'FLAVOR-PLIST))) | |
355 | (COND ((NOT (MEMQ FLAVOR-NAME *ALL-FLAVOR-NAMES*)) | |
356 | (PUSH FLAVOR-NAME *ALL-FLAVOR-NAMES*))) | |
357 | ;; Analyze and error check the instance-variable and component-flavor lists | |
358 | (SETQ INSTV (MAPCAR #'(LAMBDA (X) (IF (ATOM X) X (CAR X))) | |
359 | INSTANCE-VARIABLES)) | |
360 | (DOLIST (IV INSTV) | |
361 | (IF (OR (NULL IV) (NOT (SYMBOLP IV))) | |
362 | (FERROR () "~S, which is not a symbol, was specified as an instance variable" IV))) | |
363 | (DOLIST (CF COMPONENT-FLAVORS) | |
364 | (IF (OR (NULL CF) (NOT (SYMBOLP CF))) | |
365 | (FERROR () "~S, which is not a symbol, was specified as a component flavor" CF))) | |
366 | ;; Certain properties are inherited from the old property list, while | |
367 | ;; others are generated afresh each time from the defflavor-options. | |
368 | (COND ((SETQ ALREADY-EXISTS (GET FLAVOR-NAME 'FLAVOR)) | |
369 | (DOLIST (PROP DEFFLAVOR1-PRESERVED-PROPERTIES) | |
370 | (PUTPROP PL (GET (FLAVOR-PLIST ALREADY-EXISTS) PROP) | |
371 | PROP)))) | |
372 | ;; First, parse all the defflavor options into local variables so we can see | |
373 | ;; whether the flavor is being redefined incompatibly. | |
374 | (DO ((L OPTIONS (CDR L)) | |
375 | (OPTION) (ARGS)) | |
376 | ((NULL L)) | |
377 | (IF (ATOM (CAR L)) | |
378 | (SETQ OPTION (CAR L) ARGS NIL) | |
379 | (SETQ OPTION (CAAR L) ARGS (CDAR L))) | |
380 | (SELECTQ OPTION | |
381 | (:GETTABLE-INSTANCE-VARIABLES | |
382 | (VALIDATE-INSTANCE-VARIABLES-SPEC ARGS INSTV FLAVOR-NAME OPTION) | |
383 | (SETQ GETTABLE (OR ARGS INSTV))) | |
384 | (:SETTABLE-INSTANCE-VARIABLES | |
385 | (VALIDATE-INSTANCE-VARIABLES-SPEC ARGS INSTV FLAVOR-NAME OPTION) | |
386 | (SETQ SETTABLE (OR ARGS INSTV))) | |
387 | ((:INITABLE-INSTANCE-VARIABLES :INITABLE-INSTANCE-VARIABLES) | |
388 | (VALIDATE-INSTANCE-VARIABLES-SPEC ARGS INSTV FLAVOR-NAME OPTION) | |
389 | (SETQ INITABLE (OR ARGS INSTV))) | |
390 | (:SPECIAL-INSTANCE-VARIABLES) ; Ignored since all IVs are special | |
391 | (:INIT-KEYWORDS | |
392 | (SETQ INIT-KEYWORDS ARGS)) | |
393 | (:INCLUDED-FLAVORS | |
394 | (SETQ INCLUDES ARGS)) | |
395 | (:NO-VANILLA-FLAVOR | |
396 | (PUTPROP PL T OPTION)) | |
397 | (:ORDERED-INSTANCE-VARIABLES | |
398 | ;Don't validate. User may reasonably want to specify non-local instance | |
399 | ;variables, and any bogus names here will get detected by COMPOSE-FLAVOR-COMBINATION | |
400 | ;(VALIDATE-INSTANCE-VARIABLES-SPEC ARGS INSTV FLAVOR-NAME OPTION) | |
401 | (PUTPROP PL (OR ARGS INSTV) ':ORDERED-INSTANCE-VARIABLES)) | |
402 | (:OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES | |
403 | (VALIDATE-INSTANCE-VARIABLES-SPEC ARGS INSTV FLAVOR-NAME OPTION) | |
404 | (PUTPROP PL (OR ARGS INSTV) ':OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES)) | |
405 | (:METHOD-COMBINATION | |
406 | (SETQ METH-COMB ARGS)) | |
407 | (:DEFAULT-HANDLER | |
408 | (PUTPROP PL (CAR ARGS) OPTION)) | |
409 | ((:REQUIRED-INSTANCE-VARIABLES :REQUIRED-METHODS :REQUIRED-FLAVORS :DOCUMENTATION | |
410 | :DEFAULT-INIT-PLIST :SELECT-METHOD-ORDER :ACCESSOR-PREFIX) | |
411 | (PUTPROP PL ARGS OPTION)) | |
412 | (OTHERWISE (FERROR () "~S unknown option to DEFFLAVOR" OPTION)))) | |
413 | ;; All settable instance variables should also be gettable and INITABLE. | |
414 | (DOLIST (V SETTABLE) | |
415 | (OR (MEMQ V GETTABLE) | |
416 | (PUSH V GETTABLE)) | |
417 | (OR (MEMQ V INITABLE) | |
418 | (PUSH V INITABLE))) | |
419 | ;; See whether there are any changes in component flavor structure from last time | |
420 | (SETQ IDENTICAL-COMPONENTS | |
421 | (AND ALREADY-EXISTS | |
422 | (EQUAL COMPONENT-FLAVORS (FLAVOR-DEPENDS-ON ALREADY-EXISTS)) | |
423 | (EQUAL INCLUDES (FLAVOR-INCLUDES ALREADY-EXISTS)) | |
424 | (EQUAL (GET PL ':REQUIRED-FLAVORS) | |
425 | (GET (FLAVOR-PLIST ALREADY-EXISTS) ':REQUIRED-FLAVORS)))) | |
426 | (AND ALREADY-EXISTS | |
427 | (SETQ OLD-DEFAULT-HANDLER (GET (FLAVOR-PLIST ALREADY-EXISTS) | |
428 | ':DEFAULT-HANDLER) | |
429 | OLD-DEFAULT-INIT-PLIST (GET (FLAVOR-PLIST ALREADY-EXISTS) | |
430 | ':DEFAULT-INIT-PLIST) | |
431 | OLD-LOCAL-IVS (FLAVOR-LOCAL-INSTANCE-VARIABLES ALREADY-EXISTS) | |
432 | OLD-INITABLE-IVS (FLAVOR-INITABLE-INSTANCE-VARIABLES ALREADY-EXISTS) | |
433 | OLD-INIT-KWDS (FLAVOR-INIT-KEYWORDS ALREADY-EXISTS))) | |
434 | ;; If the flavor is being redefined, and the number or order of instance | |
435 | ;; variables is being changed, and this flavor or any that depends on it | |
436 | ;; has a select-method table (i.e. has probably been instantiated), give | |
437 | ;; a warning and disconnect from the old FLAVOR defstruct so that old | |
438 | ;; instances will retain the old information. The instance variables can | |
439 | ;; get changed either locally or by rearrangement of the component flavors. | |
440 | (AND ALREADY-EXISTS | |
441 | (IF (AND (EQUAL (GET PL ':ORDERED-INSTANCE-VARIABLES) | |
442 | (GET (FLAVOR-PLIST ALREADY-EXISTS) | |
443 | ':ORDERED-INSTANCE-VARIABLES)) | |
444 | (OR (EQUAL (FLAVOR-LOCAL-INSTANCE-VARIABLES ALREADY-EXISTS) | |
445 | INSTANCE-VARIABLES) | |
446 | (EQUAL (MAPCAR #'(LAMBDA (X) (IF (ATOM X) X (CAR X))) | |
447 | (FLAVOR-LOCAL-INSTANCE-VARIABLES ALREADY-EXISTS)) | |
448 | INSTV)) | |
449 | (OR IDENTICAL-COMPONENTS | |
450 | (EQUAL (FLAVOR-RELEVANT-COMPONENTS ALREADY-EXISTS | |
451 | COMPONENT-FLAVORS INCLUDES) | |
452 | (FLAVOR-RELEVANT-COMPONENTS ALREADY-EXISTS | |
453 | (FLAVOR-DEPENDS-ON ALREADY-EXISTS) | |
454 | (FLAVOR-INCLUDES ALREADY-EXISTS))))) | |
455 | NIL | |
456 | (SETQ ALREADY-EXISTS (PERFORM-FLAVOR-REDEFINITION FLAVOR-NAME)))) | |
457 | ;; Make the information structure unless the flavor already exists. | |
458 | (LET ((FL (OR ALREADY-EXISTS | |
459 | (GET FLAVOR-NAME 'UNDEFINED-FLAVOR) | |
460 | (MAKE-FLAVOR FLAVOR-NAME FLAVOR-NAME)))) | |
461 | (SETF (FLAVOR-LOCAL-INSTANCE-VARIABLES FL) INSTANCE-VARIABLES) | |
462 | (SETF (FLAVOR-DEPENDS-ON FL) COMPONENT-FLAVORS) | |
463 | (SETF (FLAVOR-PLIST FL) PL) | |
464 | (IF GETTABLE | |
465 | (SETF (FLAVOR-GETTABLE-INSTANCE-VARIABLES FL) GETTABLE)) | |
466 | (IF SETTABLE | |
467 | (SETF (FLAVOR-SETTABLE-INSTANCE-VARIABLES FL) SETTABLE)) | |
468 | (SETF (FLAVOR-INITABLE-INSTANCE-VARIABLES FL) | |
469 | (LOOP FOR V IN INITABLE COLLECT (CONS (CORRESPONDING-KEYWORD V) V))) | |
470 | (SETF (FLAVOR-INIT-KEYWORDS FL) INIT-KEYWORDS) | |
471 | (SETF (FLAVOR-INCLUDES FL) INCLUDES) | |
472 | ;; First remove old method-combination declarations, then add new ones | |
473 | (DOLIST (MTE (FLAVOR-METHOD-TABLE FL)) | |
474 | (COND ((LOOP FOR DECL IN METH-COMB NEVER (MEMQ (CAR MTE) (CDDR DECL))) | |
475 | (SETF (SECOND MTE) NIL) | |
476 | (SETF (THIRD MTE) NIL)))) | |
477 | (DOLIST (DECL METH-COMB) | |
478 | (LET ((TYPE (CAR DECL)) (ORDER (CADR DECL)) ELEM) | |
479 | ;; Don't error-check TYPE now, its definition might not be loaded yet | |
480 | (DOLIST (MSG (CDDR DECL)) | |
481 | (OR (SETQ ELEM (ASSQ MSG (FLAVOR-METHOD-TABLE FL))) | |
482 | (PUSH (SETQ ELEM (LIST* MSG NIL NIL NIL)) (FLAVOR-METHOD-TABLE FL))) | |
483 | (SETF (SECOND ELEM) TYPE) | |
484 | (SETF (THIRD ELEM) ORDER)))) | |
485 | ;; Make this a depended-on-by of its depends-on, or remember to do it | |
486 | ;; later in the case of depends-on's not yet defined. | |
487 | (DOLIST (COMPONENT-FLAVOR COMPONENT-FLAVORS) | |
488 | (COND ((SETQ FFL (GET COMPONENT-FLAVOR 'FLAVOR)) | |
489 | (OR (MEMQ FLAVOR-NAME (FLAVOR-DEPENDED-ON-BY FFL)) | |
490 | (PUSH FLAVOR-NAME (FLAVOR-DEPENDED-ON-BY FFL)))) | |
491 | (T (PUSH (CONS COMPONENT-FLAVOR FLAVOR-NAME) | |
492 | *FLAVOR-PENDING-DEPENDS*)))) | |
493 | ;; Likewise for its includes | |
494 | (DOLIST (INCLUDED-FLAVOR (FLAVOR-INCLUDES FL)) | |
495 | (COND ((SETQ FFL (GET INCLUDED-FLAVOR 'FLAVOR)) | |
496 | (OR (MEMQ FLAVOR-NAME (FLAVOR-DEPENDED-ON-BY FFL)) | |
497 | (PUSH FLAVOR-NAME (FLAVOR-DEPENDED-ON-BY FFL)))) | |
498 | (T (PUSH (CONS INCLUDED-FLAVOR FLAVOR-NAME) | |
499 | *FLAVOR-PENDING-DEPENDS*)))) | |
500 | ;; If someone depends on this flavor, which wasn't defined until now, | |
501 | ;; link them up. If that flavor was flavor-composed, recompose it now. | |
502 | (DOLIST (X *FLAVOR-PENDING-DEPENDS*) | |
503 | (COND ((EQ (CAR X) FLAVOR-NAME) | |
504 | (OR (MEMQ (CDR X) (FLAVOR-DEPENDED-ON-BY FL)) | |
505 | (PUSH (CDR X) (FLAVOR-DEPENDED-ON-BY FL))) | |
506 | (SETQ *FLAVOR-PENDING-DEPENDS* | |
507 | (DELQ X *FLAVOR-PENDING-DEPENDS*))))) | |
508 | (PUTPROP FLAVOR-NAME FL 'FLAVOR) | |
509 | ;; Now, if the flavor was redefined in a way that changes the methods but | |
510 | ;; doesn't invalidate old instances, we have to propagate some changes. | |
511 | (IF (AND ALREADY-EXISTS | |
512 | (NOT IDENTICAL-COMPONENTS)) | |
513 | (PERFORM-FLAVOR-METHOD-ONLY-REDEFINITION FLAVOR-NAME)) | |
514 | FLAVOR-NAME)) | |
515 | \f | |
516 | ;Check for typos in user-specified lists of instance variables. | |
517 | ;This assumes that only locally-specified (not inherited) instance variables | |
518 | ;may be mentioned in DEFFLAVOR declaration clauses. | |
519 | (DEFUN VALIDATE-INSTANCE-VARIABLES-SPEC (VARS-SPECD VARS-ALLOWED FLAVOR-NAME | |
520 | OPTION &AUX BAD) | |
521 | (DOLIST (VAR VARS-SPECD) | |
522 | (OR (MEMQ VAR VARS-ALLOWED) (PUSH VAR BAD))) | |
523 | (COND (BAD (FORMAT ERRPORT "~&ERROR: Flavor ~S has misspelled :~A ~%~S" | |
524 | FLAVOR-NAME OPTION (NREVERSE BAD))))) | |
525 | ||
526 | ;List of those components which affect the names, number, and ordering of the | |
527 | ;instance variables. Don't worry about undefined components, by definition | |
528 | ;they must be different from the already-existing flavor, so the right | |
529 | ;thing will happen. (I wonder what that comment means? Undefined components | |
530 | ;will not even appear in the list.) | |
531 | (DEFUN FLAVOR-RELEVANT-COMPONENTS (FL COMPONENT-FLAVORS INCLUDED-FLAVORS) | |
532 | (SETF (FLAVOR-DEPENDS-ON FL) COMPONENT-FLAVORS) | |
533 | (SETF (FLAVOR-INCLUDES FL) INCLUDED-FLAVORS) | |
534 | (DEL-IF-NOT #'(LAMBDA (FLAVOR) ;Splice out the uninteresting ones | |
535 | (FLAVOR-LOCAL-INSTANCE-VARIABLES FLAVOR)) | |
536 | (COMPOSE-FLAVOR-INCLUSION (FLAVOR-NAME FL) NIL))) | |
537 | ||
538 | ;; Now that default structs are vectors, and plain copy works for vectors, | |
539 | ;; this has been removed and replaced by copy. - SMH@EMS | |
540 | ;(DEFUN COPY-HUNK-CONTENTS (H1 H2) | |
541 | ; (LOOP FOR I FROM 0 TO (1- (HUNKSIZE H2)) | |
542 | ; DO (SETF (CXR I H2) (CXR I H1)))) | |
543 | ||
544 | ;Propagate things from an old flavor to a new one which we construct, | |
545 | ;for compiling a file. | |
546 | (DEFUN FLAVOR-REDEFINITION-FOR-COMPILATION (OLD-FLAVOR NEW-COMPONENTS-P) | |
547 | NEW-COMPONENTS-P | |
548 | (LET ((NEW-FLAVOR (MAKE-FLAVOR FLAVOR-NAME (FLAVOR-NAME OLD-FLAVOR)))) | |
549 | ;(COPY-HUNK-CONTENTS OLD-FLAVOR NEW-FLAVOR) ; SMH@EMS | |
550 | (SETQ NEW-FLAVOR (COPY OLD-FLAVOR)) ; Now works only if vector. | |
551 | ;; Do copy any combined methods. If we have dependents also in this file | |
552 | ;; and they have COMPILE-FLAVOR-METHODS in this file, | |
553 | ;; they will want to see our combined methods in case they can use them. | |
554 | (COPY-METHOD-TABLE OLD-FLAVOR NEW-FLAVOR NIL) | |
555 | (SETF (FLAVOR-DEPENDS-ON-ALL NEW-FLAVOR) NIL) ;Will need to be flavor-composed again | |
556 | ;; Cause an error if these are looked at before they are valid. | |
557 | (SETF (FLAVOR-ALL-INSTANCE-VARIABLES NEW-FLAVOR) 'NOT-COMPUTED) | |
558 | (SETF (FLAVOR-DEPENDED-ON-BY NEW-FLAVOR) 'COMPILATION) | |
559 | (SETF (FLAVOR-METHOD-HASH-TABLE NEW-FLAVOR) NIL) ;Will need to be method-composed again | |
560 | (SETF (FLAVOR-WHICH-OPERATIONS NEW-FLAVOR) NIL) | |
561 | NEW-FLAVOR)) | |
562 | ||
563 | (DEFUN COPY-METHOD-TABLE (OLD-FLAVOR NEW-FLAVOR DISCARD-COMBINED-METHODS) | |
564 | (LET ((L (COPYLIST (FLAVOR-METHOD-TABLE OLD-FLAVOR)))) | |
565 | (DO ((TAIL L (CDR TAIL))) | |
566 | ((NULL TAIL)) | |
567 | ;; Copy the method-table element, including the list of METH's. | |
568 | (SETF (CAR TAIL) (COPYLIST (CAR TAIL))) | |
569 | (IF DISCARD-COMBINED-METHODS | |
570 | ;; Flush from the copy all combined methods. | |
571 | (DO ((TAIL2 (CDDDR (CAR TAIL)) (CDR TAIL2))) | |
572 | ((NULL TAIL2)) | |
573 | (AND (EQ (METH-METHOD-TYPE (CAR TAIL2)) ':COMBINED) | |
574 | (SETF (CDDDAR TAIL) | |
575 | (DELQ (CAR TAIL2) (CDDDAR TAIL)))))) | |
576 | ;; Now copy each METH that we didn't delete. | |
577 | ;; Copying a METH is not trivial because it can contain a DTP-NULL. | |
578 | (DO ((TAIL2 (CDDDR (CAR TAIL)) (CDR TAIL2))) | |
579 | ((NULL TAIL2)) | |
580 | (LET ((NEW-METH (LIST (FIRST (CAR TAIL2)) | |
581 | NIL | |
582 | (COPYLIST (THIRD (CAR TAIL2)))))) | |
583 | (IF (METH-DEFINEDP (CAR TAIL2)) | |
584 | (SETF (METH-DEFINITION NEW-METH) (METH-DEFINITION (CAR TAIL2))) | |
585 | (NULLIFY-METHOD-DEFINITION NEW-METH)) | |
586 | (SETF (CAR TAIL2) NEW-METH)))) | |
587 | (SETF (FLAVOR-METHOD-TABLE NEW-FLAVOR) L))) | |
588 | ||
589 | ;Record a flavor definition, during compiling a file. | |
590 | ;Instead of setting the name's FLAVOR property, we put an entry on the | |
591 | ;FLAVORS element in the FILE-LOCAL-DECLARATIONS, where COMPILATION-FLAVOR looks. | |
592 | (DEFVAR FILE-LOCAL-DECLARATIONS ()) | |
593 | ||
594 | (DEFUN COMPILATION-DEFINE-FLAVOR (FLAVOR-NAME FL) | |
595 | (LET ((FLL (ASSQ 'FLAVORS FILE-LOCAL-DECLARATIONS))) | |
596 | (COND ((NULL FLL) | |
597 | (PUSH (NCONS 'FLAVORS) FILE-LOCAL-DECLARATIONS) | |
598 | (SETQ FLL (CAR FILE-LOCAL-DECLARATIONS)))) | |
599 | (PUTPROP FLL FL FLAVOR-NAME))) | |
600 | ||
601 | ;Call here when a flavor has been changed in a way that is not compatible | |
602 | ;with old instances of this flavor or its dependents. | |
603 | ;Arranges for those old instances to keep the old flavor structures and | |
604 | ;methods. Return new copy of the FLAVOR defstruct, and propagate to those | |
605 | ;that depend on it. Note that we tell copy-method-table to discard our | |
606 | ;combined methods. This is because they point to METHs in our method table, | |
607 | ;so we must make new combined methods that point at our new method table. | |
608 | (DEFUN PERFORM-FLAVOR-REDEFINITION (FLAVOR-NAME &AUX FL NFL) | |
609 | (SETQ FL (GET FLAVOR-NAME 'FLAVOR)) | |
610 | (COND ((FLAVOR-METHOD-HASH-TABLE FL) | |
611 | (SETQ NFL (MAKE-FLAVOR)) | |
612 | ; (COPY-HUNK-CONTENTS FL NFL) ; SMH@EMS | |
613 | (SETQ NFL (COPY FL)) ; Now works only if FL is a vector! | |
614 | (COPY-METHOD-TABLE FL NFL T) ;Copy, but discard combined methods | |
615 | (SETQ FL NFL) | |
616 | (SETF (FLAVOR-PLIST FL) (COPYLIST (FLAVOR-PLIST FL))) | |
617 | (PUTPROP FLAVOR-NAME FL 'FLAVOR) | |
618 | (FORMAT ERRPORT "~&Flavor ~S changed incompatibly, old instances will not get the new version.~%" | |
619 | FLAVOR-NAME)) | |
620 | ;; Even if this flavor wasn't instantiated, | |
621 | ;; probably some of its dependents were, | |
622 | ;; and their hash tables and combined methods point to our method table. | |
623 | (T (COPY-METHOD-TABLE FL FL T))) | |
624 | (SETF (FLAVOR-DEPENDS-ON-ALL FL) NIL) ;Will need to be flavor-composed again | |
625 | (SETF (FLAVOR-METHOD-HASH-TABLE FL) NIL) ;Will need to be method-composed again | |
626 | (SETF (FLAVOR-WHICH-OPERATIONS FL) NIL) | |
627 | (DOLIST (FN (FLAVOR-DEPENDED-ON-BY FL)) | |
628 | (PERFORM-FLAVOR-REDEFINITION FN)) | |
629 | FL) | |
630 | ||
631 | ;This one is when the old instances don't have to be discarded, but recomposition | |
632 | ;does have to occur because something was changed in the order of flavor combination | |
633 | (DEFUN PERFORM-FLAVOR-METHOD-ONLY-REDEFINITION (FLAVOR-NAME) | |
634 | (LET ((FDEFINE-FILE-PATHNAME NIL)) ;Don't give warnings for combined methods | |
635 | ;; Reverse the list so that this flavor comes first, followed by directest descendents. | |
636 | (DOLIST (FN (REVERSE (FLAVOR-DEPENDED-ON-BY-ALL (GET FLAVOR-NAME 'FLAVOR) | |
637 | (LIST FLAVOR-NAME)))) | |
638 | (LET ((FL (GET FN 'FLAVOR))) | |
639 | (IF (FLAVOR-DEPENDS-ON-ALL FL) (COMPOSE-FLAVOR-COMBINATION FL)) | |
640 | (IF (FLAVOR-METHOD-HASH-TABLE FL) (COMPOSE-METHOD-COMBINATION FL)))))) | |
641 | \f | |
642 | (DEFUN DESCRIBE-FLAVOR (FLAVOR-NAME &AUX FL) | |
643 | (SETQ FL (IF (SYMBOLP FLAVOR-NAME) (GET-FLAVOR FLAVOR-NAME) | |
644 | FLAVOR-NAME)) | |
645 | (CHECK-ARG FLAVOR-NAME (:TYPEP FL 'FLAVOR) | |
646 | "a flavor or the name of one") | |
647 | (FORMAT T "~&Flavor ~S directly depends on flavors: ~:[none~;~1G~{~S~^, ~}~]~%" | |
648 | FLAVOR-NAME (FLAVOR-DEPENDS-ON FL)) | |
649 | (AND (FLAVOR-INCLUDES FL) | |
650 | (FORMAT T " and directly includes ~{~S~^, ~}~%" (FLAVOR-INCLUDES FL))) | |
651 | (AND (FLAVOR-DEPENDED-ON-BY FL) | |
652 | (FORMAT T " and is directly depended on by ~{~S~^, ~}~%" (FLAVOR-DEPENDED-ON-BY FL))) | |
653 | (AND (FLAVOR-DEPENDS-ON-ALL FL) ;If this has been computed, show it | |
654 | (FORMAT T " and directly or indirectly depends on ~{~S~^, ~}~%" | |
655 | (FLAVOR-DEPENDS-ON-ALL FL))) | |
656 | (AND (FLAVOR-METHOD-HASH-TABLE FL) ;If has been composed | |
657 | (FORMAT T "Flavor ~S has instance variables ~:S~%" | |
658 | FLAVOR-NAME (FLAVOR-ALL-INSTANCE-VARIABLES FL))) | |
659 | (COND ((NOT (NULL (FLAVOR-METHOD-TABLE FL))) | |
660 | (FORMAT T "Not counting inherited methods, the methods for ~S are:~%" | |
661 | FLAVOR-NAME) | |
662 | (DOLIST (M (FLAVOR-METHOD-TABLE FL)) | |
663 | (FORMAT T " ") | |
664 | (DO ((TPL (SUBSET 'METH-DEFINEDP (CDDDR M)) (CDR TPL))) | |
665 | ((NULL TPL)) | |
666 | (IF (METH-METHOD-TYPE (CAR TPL)) | |
667 | (FORMAT T "~A " (METH-METHOD-TYPE (CAR TPL)))) | |
668 | (FORMAT T "~A" (CAR M)) | |
669 | (IF (CDR TPL) (PRINC ", "))) | |
670 | ;; Print the method combination type if there is any. | |
671 | (AND (CADR M) | |
672 | (FORMAT T " :~A~@[ :~A~]" (CADR M) (CADDR M))) | |
673 | (TERPRI)))) | |
674 | (AND (FLAVOR-ALL-INSTANCE-VARIABLES FL) | |
675 | (FORMAT T "Instance variables: ~{~S~^, ~}~%" (FLAVOR-ALL-INSTANCE-VARIABLES FL))) | |
676 | (AND (FLAVOR-GETTABLE-INSTANCE-VARIABLES FL) | |
677 | (FORMAT T "Automatically-generated methods to get instance variables: ~{~S~^, ~}~%" | |
678 | (FLAVOR-GETTABLE-INSTANCE-VARIABLES FL))) | |
679 | (AND (FLAVOR-SETTABLE-INSTANCE-VARIABLES FL) | |
680 | (FORMAT T "Automatically-generated methods to set instance variables: ~{~S~^, ~}~%" | |
681 | (FLAVOR-SETTABLE-INSTANCE-VARIABLES FL))) | |
682 | (AND (FLAVOR-INITABLE-INSTANCE-VARIABLES FL) | |
683 | (FORMAT T "Instance variables that may be set by initialization: ~{~S~^, ~}~%" | |
684 | (MAPCAR #'CDR (FLAVOR-INITABLE-INSTANCE-VARIABLES FL)))) | |
685 | (AND (FLAVOR-INIT-KEYWORDS FL) | |
686 | (FORMAT T "Keywords in the :INIT message handled by this flavor: ~{~S~^, ~}~%" | |
687 | (FLAVOR-INIT-KEYWORDS FL))) | |
688 | (COND ((FLAVOR-PLIST FL) | |
689 | (FORMAT T "Properties:~%") | |
690 | (DO L (CDR (FLAVOR-PLIST FL)) (CDDR L) (NULL L) | |
691 | (FORMAT T "~5X~S: ~S~%" (CAR L) (CADR L))))) | |
692 | (COND ((NULL (FLAVOR-METHOD-HASH-TABLE FL)) | |
693 | (FORMAT T "Flavor ~S does not yet have a method hash table~%" FLAVOR-NAME)) | |
694 | (T (FORMAT T "Flavor ~S has method hash table:~%" FLAVOR-NAME) | |
695 | (PRINT (FLAVOR-METHOD-HASH-TABLE FL))))) | |
696 | \f | |
697 | ;; This is the standard way of defining a method of a class, | |
698 | ;; so that the code will be compiled. | |
699 | ;; If in place of the lambda-list you have a symbol, and the body | |
700 | ;; is null, that symbol is a function which stands in for the method. | |
701 | (DEFMACRO DEFMETHOD (SPEC LAMBDA-LIST . BODY) | |
702 | (LET ((CLASS-NAME (CAR SPEC)) | |
703 | (FUNCTION-SPEC (CONS ':METHOD SPEC)) | |
704 | FUNCTION-NAME) | |
705 | (SETQ FUNCTION-NAME (METHOD-FUNCTION-NAME FUNCTION-SPEC)) | |
706 | `(PROGN 'COMPILE | |
707 | (EVAL-WHEN (COMPILE LOAD EVAL) | |
708 | (FLAVOR-NOTICE-METHOD ',FUNCTION-SPEC)) | |
709 | ;; At load-time, define the method function | |
710 | ,(COND ((AND (SYMBOLP LAMBDA-LIST) (NOT (NULL LAMBDA-LIST)) | |
711 | (NULL BODY)) | |
712 | #-Franz `(FDEFINE ',FUNCTION-SPEC ',LAMBDA-LIST) | |
713 | #+Franz `(DEFUN ,FUNCTION-NAME (OPERATION . ,LAMBDA-LIST) | |
714 | (,lambda-list (operation . ,lambda-list)))) | |
715 | ((GET CLASS-NAME 'FLAVOR) | |
716 | `(DEFUN ,FUNCTION-NAME (OPERATION . ,LAMBDA-LIST) | |
717 | (DECLARE (SPECIAL SELF .OWN-FLAVOR. | |
718 | ,@(FLAVOR-ALL-INSTANCE-VARIABLES | |
719 | (GET-FLAVOR CLASS-NAME)))) | |
720 | . ,BODY)) | |
721 | (T ;; The non-flavor class system | |
722 | (FERROR () "Old Class system is not SUPPORTED"))) | |
723 | ',FUNCTION-SPEC))) | |
724 | ||
725 | (DEFUN REMOVE-COLON (SYMBOL) | |
726 | (IF (= (GETCHARN SYMBOL 1) #/:) | |
727 | (CONCAT (SUBSTRING SYMBOL 2)) | |
728 | SYMBOL)) | |
729 | ||
730 | ; This lets you specify code to be wrapped around the invocation of the | |
731 | ; various methods for an operation. For example, | |
732 | ; (DEFWRAPPER (FOO-FLAVOR :OPERATION) ((ARG1 ARG2) . BODY) | |
733 | ; `(WITH-FOO-LOCKED (SELF) | |
734 | ; (PRE-FROBULATE SELF ARG1 ARG2) | |
735 | ; ,@BODY | |
736 | ; (POST-FROBULATE SELF ARG2 ARG1))) | |
737 | ;Note that the wrapper needs to be defined at both compile and run times | |
738 | ;so that compiling combined methods as part of the qfasl file works. | |
739 | ||
740 | #+Franz | |
741 | (defmacro destructuring-bind (template values . body) | |
742 | `(let ((,template ,values)) . ,body)) | |
743 | ||
744 | (DEFMACRO DEFWRAPPER | |
745 | ((FLAVOR-NAME OPERATION) (DEFMACRO-LAMBDA . GUTS) &BODY BODY) | |
746 | (LET ((FUNCTION-SPEC `(:METHOD ,FLAVOR-NAME :WRAPPER ,OPERATION)) | |
747 | function-name) | |
748 | (setq function-name (method-function-name function-spec)) | |
749 | `(PROGN ;; 'COMPILE | |
750 | ;; Unfortunately, in Franz wrappers should not be compiled | |
751 | ;; since the actual definition is needed by macrocall. | |
752 | ;; Macrocall is clearly a crock! | |
753 | ;; The following optimization could go away if defmacro were | |
754 | ;; very smart. | |
755 | ,(IF (AND (SYMBOLP DEFMACRO-LAMBDA) | |
756 | (EQUAL DEFMACRO-LAMBDA 'IGNORE)) | |
757 | `(DEFMACRO ,function-name (IGNORE . ,GUTS) . ,BODY) | |
758 | `(DEFMACRO ,function-name (ARGLISTNAME . ,GUTS) | |
759 | `(DESTRUCTURING-BIND ,',DEFMACRO-LAMBDA (CDR ,ARGLISTNAME) | |
760 | ,,@BODY))) | |
761 | (flavor-notice-method ',function-spec)))) | |
762 | ||
763 | ;This just exists to be called at compile-time from the DEFMETHOD macro, | |
764 | ;so that any combined methods generated by COMPILE-FLAVOR-METHODS will | |
765 | ;know that this method will be around at run time and should be called. | |
766 | (DEFUN FLAVOR-NOTICE-METHOD (FUNCTION-SPEC) | |
767 | (LET ((METH (FLAVOR-METHOD-ENTRY FUNCTION-SPEC NIL T))) | |
768 | (COND ((NOT (EQ (METH-DEFINITION METH) | |
769 | (METHOD-FUNCTION-NAME FUNCTION-SPEC))) | |
770 | (SETF (METH-DEFINITION METH) (METHOD-FUNCTION-NAME FUNCTION-SPEC)) | |
771 | (RECOMPILE-FLAVOR (SECOND FUNCTION-SPEC) | |
772 | (CAR (LAST FUNCTION-SPEC))))))) | |
773 | ||
774 | (DEFUN METHOD-FUNCTION-NAME (FUNCTION-SPEC) | |
775 | (LET ((FLAVOR (SECOND FUNCTION-SPEC)) | |
776 | (METHOD-TYPE (THIRD FUNCTION-SPEC)) | |
777 | (MESSAGE (FOURTH FUNCTION-SPEC))) | |
778 | (IF (NULL (CDDDR FUNCTION-SPEC)) | |
779 | (SETQ MESSAGE (THIRD FUNCTION-SPEC) METHOD-TYPE NIL)) | |
780 | (IF (NULL METHOD-TYPE) | |
781 | (INTERN (FORMAT () "~A-~A-method" FLAVOR (REMOVE-COLON MESSAGE))) | |
782 | (INTERN | |
783 | (FORMAT () "~A-~A-~A-method" | |
784 | FLAVOR (REMOVE-COLON METHOD-TYPE) (REMOVE-COLON MESSAGE)))))) | |
785 | ||
786 | ;Find or create a method-table entry for the specified method. | |
787 | ;DONT-CREATE is NIL if method is to be created if necessary. | |
788 | ; The flavor is "created" too, as an UNDEFINED-FLAVOR property | |
789 | ; of the flavor name, just to record any properties of methods. | |
790 | ;COPY-FLAVOR-IF-UNDEFINED-METH says we are going to alter the METH | |
791 | ;for compilation if it is not defined, so the flavor should be copied in that case. | |
792 | (DEFUN FLAVOR-METHOD-ENTRY (FUNCTION-SPEC DONT-CREATE | |
793 | &OPTIONAL COPY-FLAVOR-IF-UNDEFINED-METH) | |
794 | ;; Huh? Unused! -SMH | |
795 | (LET ((FLAVOR-NAME (SECOND FUNCTION-SPEC)) | |
796 | (TYPE (THIRD FUNCTION-SPEC)) | |
797 | (MESSAGE (FOURTH FUNCTION-SPEC))) | |
798 | (IF (NULL MESSAGE) (SETQ MESSAGE TYPE TYPE NIL)) ;If no type | |
799 | (IF (OR (NULL MESSAGE) (NEQ (FIRST FUNCTION-SPEC) ':METHOD) | |
800 | (> (LENGTH FUNCTION-SPEC) 4) | |
801 | (NOT (SYMBOLP FLAVOR-NAME)) (NOT (SYMBOLP TYPE)) | |
802 | (NOT (SYMBOLP MESSAGE))) | |
803 | (FERROR () "~S is not a valid function-spec" FUNCTION-SPEC)) | |
804 | (LET* ((FL (OR (GET-FLAVOR FLAVOR-NAME) | |
805 | (GET FLAVOR-NAME 'UNDEFINED-FLAVOR) | |
806 | (AND (NOT DONT-CREATE) | |
807 | (PUTPROP FLAVOR-NAME | |
808 | (MAKE-FLAVOR FLAVOR-NAME FLAVOR-NAME) | |
809 | 'UNDEFINED-FLAVOR)))) | |
810 | (MTE (AND FL (ASSQ MESSAGE (FLAVOR-METHOD-TABLE FL)))) | |
811 | (METH (METH-LOOKUP TYPE (CDDDR MTE)))) | |
812 | (AND (NULL MTE) (NOT DONT-CREATE) | |
813 | ;; Message not previously known about, put into table | |
814 | FL | |
815 | (PUSH (SETQ MTE (LIST* MESSAGE NIL NIL NIL)) (FLAVOR-METHOD-TABLE FL))) | |
816 | ;; Message known, search for the type entry | |
817 | (COND (METH) ;Known by flavor | |
818 | (DONT-CREATE NIL) ;Not to be created | |
819 | ((NULL FL) NIL) ;Create, but no flavor defined | |
820 | (T ;; Type not known, create a new meth with an unbound definition cell | |
821 | (LET ((METH (LIST FUNCTION-SPEC NIL NIL))) | |
822 | (NULLIFY-METHOD-DEFINITION METH) | |
823 | (PUSH METH (CDDDR MTE)) | |
824 | METH)))))) | |
825 | ||
826 | ;;; See if a certain method exists in a flavor | |
827 | (DEFUN FLAVOR-METHOD-EXISTS (FL TYPE OPERATION &AUX MTE) | |
828 | (AND (SETQ MTE (ASSQ OPERATION (FLAVOR-METHOD-TABLE FL))) | |
829 | (LET ((METH (METH-LOOKUP TYPE (CDDDR MTE)))) | |
830 | (AND METH (METH-DEFINEDP METH))))) | |
831 | ||
832 | ;;; Forcibly remove a method definition from a flavor's method table | |
833 | ;;; Syntax is identical to the beginning of a defmethod for the same method. | |
834 | (DEFMACRO UNDEFMETHOD (SPEC) | |
835 | `(FUNDEFINE '(:METHOD . ,SPEC))) | |
836 | \f | |
837 | ;Make an object of a particular flavor, taking the init-plist options | |
838 | ;as a rest argument and sending the :INIT message if the flavor | |
839 | ;handles it. | |
840 | (DEFUN MAKE-INSTANCE (FLAVOR-NAME &REST INIT-OPTIONS) | |
841 | (INSTANTIATE-FLAVOR FLAVOR-NAME (CONS 'INSTANCE-OPTIONS INIT-OPTIONS) | |
842 | 'MAYBE)) | |
843 | ||
844 | (DEFUN FLAVOR-DISPATCH (MESSAGE &REST ARGUMENTS &AUX FUN) | |
845 | (DECLARE (SPECIAL .OWN-FLAVOR.)) | |
846 | (SETQ FUN (OR (GETHASH MESSAGE (FLAVOR-METHOD-HASH-TABLE .OWN-FLAVOR.)) | |
847 | (FLAVOR-DEFAULT-HANDLER .OWN-FLAVOR.))) | |
848 | (IF (NOT (NULL FUN)) | |
849 | (LEXPR-FUNCALL FUN MESSAGE ARGUMENTS) | |
850 | (FLAVOR-UNCLAIMED-MESSAGE MESSAGE ARGUMENTS))) | |
851 | ||
852 | ;; The first six slots are for SELF and .OWN-FLAVOR. The values are in the | |
853 | ;; third slot. | |
854 | ; SMH@EMS VVV | |
855 | ; Perforce, %instance-ref no longer used. | |
856 | ; (DEFSUBST %INSTANCE-REF (INSTANCE INDEX) | |
857 | ; (VREF INSTANCE (+ 9. (* 3 INDEX)))) | |
858 | ; (DEFSUBST INSTANCE-FLAVOR (INSTANCE) (VREF INSTANCE 6)) | |
859 | ; The previous instance-flavor ought always to be good, if inefficient. | |
860 | ; (DEFSUBST INSTANCE-FLAVOR (INSTANCE) (VREF INSTANCE 3)) | |
861 | ; SMH@EMS ^^^ | |
862 | ||
863 | ;Make an object of a particular flavor. | |
864 | ;If the flavor hasn't been composed yet, must do so now. | |
865 | ; Delaying it until the first time it is needed aids initialization, | |
866 | ; e.g. up until now we haven't depended on the depended-on flavors being defined yet. | |
867 | ;Note that INIT-PLIST can be modified, if the :DEFAULT-INIT-PLIST option was | |
868 | ; used or the init methods modify it. | |
869 | (DEFUN INSTANTIATE-FLAVOR (FLAVOR-NAME INIT-PLIST | |
870 | &OPTIONAL SEND-INIT-MESSAGE-P | |
871 | RETURN-UNHANDLED-KEYWORDS-P ;as second value | |
872 | &AUX FL FFL UNHANDLED-KEYWORDS INSTANCE VARS N TEM) | |
873 | (CHECK-ARG FLAVOR-NAME (SETQ FL (GET FLAVOR-NAME 'FLAVOR)) "the name of a flavor") | |
874 | ;; Do any composition (compilation) of combined stuff, if not done already | |
875 | (OR (FLAVOR-DEPENDS-ON-ALL FL) (COMPOSE-FLAVOR-COMBINATION FL)) | |
876 | (OR (FLAVOR-METHOD-HASH-TABLE FL) (COMPOSE-METHOD-COMBINATION FL)) | |
877 | (SETQ VARS (FLAVOR-ALL-INSTANCE-VARIABLES FL)) | |
878 | ;; Make the instance object, then fill in its various fields | |
879 | (SETQ INSTANCE | |
880 | (PROGV `(SELF .OWN-FLAVOR. ,@VARS) | |
881 | `(NIL ,FL) | |
882 | (FCLOSURE `(SELF .OWN-FLAVOR. ,@VARS) | |
883 | #'FLAVOR-DISPATCH))) | |
884 | (LOOP FOR I FROM 0 TO (LENGTH VARS) | |
885 | WITH IVS = (FLAVOR-INSTANCE-VARIABLE-INITIALIZATIONS FL) | |
886 | WHEN (= I (CAAR IVS)) | |
887 | ; SMH@EMS VVV | |
888 | ; DO (PROGN (SETF (%INSTANCE-REF INSTANCE I) | |
889 | ; (FAST-EVAL (CADAR IVS))) | |
890 | ; (POP IVS))) | |
891 | DO (PROGN (INT:FCLOSURE-STACK-STUFF (VREF INSTANCE (+ 3 I)) | |
892 | (FAST-EVAL (CADAR IVS))) | |
893 | (POP IVS))) | |
894 | ; SMH@EMS ^^^ | |
895 | (SET-IN-FCLOSURE INSTANCE 'SELF INSTANCE) | |
896 | (LET ((VAR-KEYWORDS (FLAVOR-ALL-INITABLE-INSTANCE-VARIABLES FL)) | |
897 | (REMAINING-KEYWORDS (FLAVOR-REMAINING-INIT-KEYWORDS FL))) | |
898 | (COND (VAR-KEYWORDS | |
899 | ;; First, process any user-specified init keywords that | |
900 | ;; set instance variables. When we process the defaults, | |
901 | ;; we will see that these are already set, and will | |
902 | ;; refrain from evaluating the default forms. At the same time, | |
903 | ;; we record any init keywords that this flavor doesn't handle. | |
904 | (DO ((PL (CDR INIT-PLIST) (CDDR PL))) ((NULL PL)) | |
905 | (COND ((MEMQ (CAR PL) VAR-KEYWORDS) | |
906 | (SET-IN-FCLOSURE INSTANCE (REMOVE-COLON (CAR PL)) | |
907 | (CADR PL))) | |
908 | ((NOT (MEMQ (CAR PL) REMAINING-KEYWORDS)) | |
909 | (PUSH (CAR PL) UNHANDLED-KEYWORDS)))) | |
910 | ;; Now stick any default init plist items that aren't handled by | |
911 | ;; that onto the actual init plist. | |
912 | (DO ((PL (FLAVOR-REMAINING-DEFAULT-PLIST FL) (CDDR PL))) | |
913 | ((NULL PL)) | |
914 | (OR (MEMQ-ALTERNATED (CAR PL) (CDR INIT-PLIST)) | |
915 | (PUTPROP INIT-PLIST (FAST-EVAL (CADR PL)) (CAR PL))))) | |
916 | (T | |
917 | ;; Put defaults into the INIT-PLIST | |
918 | (FLAVOR-DEFAULT-INIT-PLIST FLAVOR-NAME INIT-PLIST) | |
919 | ;; For each init keyword, either initialize the corresponding | |
920 | ;; variable, remember that it will be handled later by an :INIT | |
921 | ;; method, or give an error for not being handled. | |
922 | (DO L (CDR INIT-PLIST) (CDDR L) (NULL L) | |
923 | (LET ((KEYWORD (CAR L)) (ARG (CADR L))) | |
924 | (DO ((FFLS (FLAVOR-DEPENDS-ON-ALL FL) (CDR FFLS))) | |
925 | ((NULL FFLS) (PUSH KEYWORD UNHANDLED-KEYWORDS)) | |
926 | (SETQ FFL (GET (CAR FFLS) 'FLAVOR)) | |
927 | (COND ((SETQ TEM (ASSQ KEYWORD (FLAVOR-INITABLE-INSTANCE-VARIABLES FFL))) | |
928 | (SET-IN-FCLOSURE INSTANCE (REMOVE-COLON KEYWORD) | |
929 | ARG) | |
930 | (RETURN)) | |
931 | ((MEMQ KEYWORD (FLAVOR-INIT-KEYWORDS FFL)) | |
932 | (RETURN))))))))) | |
933 | ;; Complain if any keywords weren't handled, unless our caller | |
934 | ;; said it wanted to take care of this. | |
935 | (AND (NOT RETURN-UNHANDLED-KEYWORDS-P) | |
936 | UNHANDLED-KEYWORDS | |
937 | (FERROR () "Flavor ~S does not handle the init keyword~P ~{~S~^, ~}" | |
938 | FLAVOR-NAME | |
939 | (LENGTH UNHANDLED-KEYWORDS) | |
940 | UNHANDLED-KEYWORDS)) | |
941 | (AND (EQ SEND-INIT-MESSAGE-P 'MAYBE) | |
942 | (NOT (GET-HANDLER-FOR INSTANCE ':INIT)) | |
943 | (SETQ SEND-INIT-MESSAGE-P NIL)) | |
944 | (AND SEND-INIT-MESSAGE-P | |
945 | (SEND INSTANCE ':INIT INIT-PLIST)) | |
946 | (VALUES INSTANCE UNHANDLED-KEYWORDS)) | |
947 | ||
948 | (DEFUN MEMQ-ALTERNATED (ELT LIST) | |
949 | (DO ((L LIST (CDDR L))) ((NULL L) NIL) | |
950 | (IF (EQ (CAR L) ELT) (RETURN L)))) | |
951 | ||
952 | (DEFUN FAST-EVAL (EXP) | |
953 | (COND ((OR (NUMBERP EXP) (STRINGP EXP) | |
954 | (MEMQ EXP '(T NIL))) | |
955 | EXP) | |
956 | ((SYMBOLP EXP) (SYMEVAL EXP)) | |
957 | ((AND (LISTP EXP) (EQ (CAR EXP) 'QUOTE)) | |
958 | (CADR EXP)) | |
959 | (T (EVAL EXP)))) | |
960 | ||
961 | (DEFUN FLAVOR-DEFAULT-INIT-PLIST (FLAVOR-NAME | |
962 | &OPTIONAL (INIT-PLIST (NCONS NIL)) | |
963 | &AUX FL) | |
964 | (CHECK-ARG FLAVOR-NAME (SETQ FL (GET FLAVOR-NAME 'FLAVOR)) | |
965 | "the name of a flavor") | |
966 | ;; Do any composition (compilation) of combined stuff, if not done already | |
967 | (OR (FLAVOR-DEPENDS-ON-ALL FL) (COMPOSE-FLAVOR-COMBINATION FL)) | |
968 | (DOLIST (FFL (FLAVOR-DEPENDS-ON-ALL FL)) | |
969 | (SETQ FFL (GET FFL 'FLAVOR)) | |
970 | (DO L (GET (FLAVOR-PLIST FFL) ':DEFAULT-INIT-PLIST) (CDDR L) (NULL L) | |
971 | (DO ((M (CDR INIT-PLIST) (CDDR M))) | |
972 | ((NULL M) (PUTPROP INIT-PLIST (EVAL (CADR L)) (CAR L))) | |
973 | (AND (EQ (CAR M) (CAR L)) (RETURN))))) | |
974 | INIT-PLIST) | |
975 | ||
976 | ;Returns non-NIL if the flavor allows the specified keyword in its init-plist, | |
977 | ;NIL if it doesn't. The return value is the name of the component flavor | |
978 | ;that actually handles it. | |
979 | (DEFUN FLAVOR-ALLOWS-INIT-KEYWORD-P (FLAVOR-NAME KEYWORD) | |
980 | (MAP-OVER-COMPONENT-FLAVORS 0 T T | |
981 | #'(LAMBDA (FL IGNORE KEYWORD) | |
982 | (AND (OR (ASSQ KEYWORD (FLAVOR-INITABLE-INSTANCE-VARIABLES FL)) | |
983 | (MEMQ KEYWORD (FLAVOR-INIT-KEYWORDS FL))) | |
984 | (FLAVOR-NAME FL))) | |
985 | FLAVOR-NAME NIL KEYWORD)) | |
986 | ||
987 | ;;; Given the name of a flavor, return a list of all of the symbols that | |
988 | ;;; are valid init-options for the flavor, sorted alphabetically. | |
989 | ;;; Primary for inquiries by humans. | |
990 | (DEFUN FLAVOR-ALLOWED-INIT-KEYWORDS (FLAVOR-NAME) | |
991 | (LET ((INIT-KEYWORDS NIL)) | |
992 | (DECLARE (SPECIAL INIT-KEYWORDS)) | |
993 | (MAP-OVER-COMPONENT-FLAVORS 0 T NIL | |
994 | #'(LAMBDA (FLAVOR IGNORE) | |
995 | (DECLARE (SPECIAL INIT-KEYWORDS)) | |
996 | (SETQ INIT-KEYWORDS | |
997 | (NCONC (MAPCAR #'(LAMBDA (KWD) | |
998 | (IF (LISTP KWD) (CAR KWD) KWD)) | |
999 | (FLAVOR-LOCAL-INIT-KEYWORDS FLAVOR)) | |
1000 | INIT-KEYWORDS))) | |
1001 | FLAVOR-NAME NIL) | |
1002 | (SORT (ELIMINATE-DUPLICATES INIT-KEYWORDS) #'ALPHALESSP))) | |
1003 | ||
1004 | (DEFUN FLAVOR-LOCAL-INIT-KEYWORDS (FLAVOR) | |
1005 | (APPEND (FLAVOR-INITABLE-INSTANCE-VARIABLES FLAVOR) | |
1006 | (FLAVOR-INIT-KEYWORDS FLAVOR))) | |
1007 | ||
1008 | (DEFUN ELIMINATE-DUPLICATES (LIST &AUX L) | |
1009 | (DOLIST (E LIST) (OR (MEMQ E L) (PUSH E L))) | |
1010 | L) | |
1011 | \f | |
1012 | ; Function to map over all components of a specified flavor. We must do the | |
1013 | ; DEPENDS-ON's to all levels first, then the INCLUDES's at all levels and | |
1014 | ; what they depend on. | |
1015 | ; Note that it does the specified flavor itself as well as all its components. | |
1016 | ; Note well: if there are included flavors, this does not do them in the | |
1017 | ; right order. Also note well: if there are multiple paths to a component, | |
1018 | ; it will be done more than once. | |
1019 | ; RECURSION-STATE is 0 except when recursively calling itself. | |
1020 | ; ERROR-P is T if not-yet-defflavored flavors are to be complained about, | |
1021 | ; NIL if they are to be ignored. This exists to get rid of certain | |
1022 | ; bootstrapping problems. | |
1023 | ; RETURN-FIRST-NON-NIL is T if the iteration should terminate as soon | |
1024 | ; as FUNCTION returns a non-null result. | |
1025 | ; At each stage FUNCTION is applied to the flavor (not the name), the | |
1026 | ; STATE, and any ARGS. STATE is updated to whatever the function returns. | |
1027 | ; The final STATE is the final result of this function. | |
1028 | ; RECURSION-STATE is: | |
1029 | ; 0 top-level | |
1030 | ; 1 first-pass over just depends-on's | |
1031 | ; 6 second-pass, this flavor reached via depends-on's so don't do it again | |
1032 | ; 2 second-pass, this flavor reached via includes's so do it. | |
1033 | (DEFVAR SOME-COMPONENT-UNDEFINED NIL) ;If we find an undefined component, we put its name here. | |
1034 | ||
1035 | (DEFUN MAP-OVER-COMPONENT-FLAVORS (RECURSION-STATE ERROR-P | |
1036 | RETURN-FIRST-NON-NIL FUNCTION FLAVOR-NAME | |
1037 | STATE &REST ARGS) | |
1038 | (PROG (FL) | |
1039 | (*CATCH 'MAP-OVER-COMPONENT-FLAVORS | |
1040 | (COND ((OR ERROR-P (GET-FLAVOR FLAVOR-NAME)) | |
1041 | (CHECK-ARG FLAVOR-NAME (SETQ FL (GET-FLAVOR FLAVOR-NAME)) | |
1042 | "a defined flavor") | |
1043 | ;; First do this flavor, unless this is the second pass and it shouldn't be done | |
1044 | (OR (BIT-TEST 4 RECURSION-STATE) | |
1045 | (SETQ STATE (LEXPR-FUNCALL FUNCTION FL STATE ARGS))) | |
1046 | ;; After each call to the function, see if we're supposed to be done now | |
1047 | (AND RETURN-FIRST-NON-NIL (NOT (NULL STATE)) | |
1048 | (*THROW 'MAP-OVER-COMPONENT-FLAVORS NIL)) | |
1049 | ;; Now do the depends-on's. | |
1050 | (DOLIST (COMPONENT-FLAVOR (FLAVOR-DEPENDS-ON FL)) | |
1051 | (SETQ STATE (LEXPR-FUNCALL #'MAP-OVER-COMPONENT-FLAVORS | |
1052 | (IF (ZEROP RECURSION-STATE) 1 RECURSION-STATE) | |
1053 | ERROR-P RETURN-FIRST-NON-NIL | |
1054 | FUNCTION COMPONENT-FLAVOR STATE ARGS)) | |
1055 | (AND RETURN-FIRST-NON-NIL (NOT (NULL STATE)) | |
1056 | (*THROW 'MAP-OVER-COMPONENT-FLAVORS NIL))) | |
1057 | ;; Unless this is the first pass, do the includes. | |
1058 | (OR (BIT-TEST 1 RECURSION-STATE) | |
1059 | (DOLIST (COMPONENT-FLAVOR (FLAVOR-INCLUDES FL)) | |
1060 | (SETQ STATE (LEXPR-FUNCALL #'MAP-OVER-COMPONENT-FLAVORS | |
1061 | 2 ERROR-P RETURN-FIRST-NON-NIL | |
1062 | FUNCTION COMPONENT-FLAVOR STATE ARGS)) | |
1063 | (AND RETURN-FIRST-NON-NIL (NOT (NULL STATE)) | |
1064 | (*THROW 'MAP-OVER-COMPONENT-FLAVORS NIL)))) | |
1065 | ;; If this is the top-level, run the second pass on its depends-on's | |
1066 | ;; which doesn't do them but does do what they include. | |
1067 | (OR (NOT (ZEROP RECURSION-STATE)) | |
1068 | (DOLIST (COMPONENT-FLAVOR (FLAVOR-DEPENDS-ON FL)) | |
1069 | (SETQ STATE (LEXPR-FUNCALL #'MAP-OVER-COMPONENT-FLAVORS | |
1070 | 6 ERROR-P RETURN-FIRST-NON-NIL | |
1071 | FUNCTION COMPONENT-FLAVOR STATE ARGS)) | |
1072 | (AND RETURN-FIRST-NON-NIL (NOT (NULL STATE)) | |
1073 | (*THROW 'MAP-OVER-COMPONENT-FLAVORS NIL))))) | |
1074 | ((NULL SOME-COMPONENT-UNDEFINED) | |
1075 | (SETQ SOME-COMPONENT-UNDEFINED FLAVOR-NAME))))) | |
1076 | STATE) | |
1077 | ||
1078 | ;Call this when a flavor has been changed, it updates that flavor's compiled | |
1079 | ; information and that of any that depend on it. | |
1080 | ;If a compilation is in progress the compilations performed | |
1081 | ; will get output as part of that compilation. | |
1082 | ;SINGLE-OPERATION is NIL to do all operations, or the name of an operation | |
1083 | ; which needs incremental compilation. | |
1084 | ;USE-OLD-COMBINED-METHODS can be NIL to force regeneration of all combined methods. | |
1085 | ; This is used if a wrapper has changed or there was a bug in the method-combining routine. | |
1086 | ;DO-DEPENDENTS controls whether flavors that depend on this one are also compiled. | |
1087 | (DEFUN RECOMPILE-FLAVOR (FLAVOR-NAME | |
1088 | &OPTIONAL (SINGLE-OPERATION NIL) (*USE-OLD-COMBINED-METHODS* T) | |
1089 | (DO-DEPENDENTS T) | |
1090 | &AUX FL) | |
1091 | (CHECK-ARG FLAVOR-NAME (SETQ FL (GET FLAVOR-NAME 'FLAVOR)) "the name of a flavor") | |
1092 | ;; Only update the method combination if it has been done before, else | |
1093 | ;; doesn't matter | |
1094 | (COND ((FLAVOR-METHOD-HASH-TABLE FL) | |
1095 | (OR (FLAVOR-DEPENDS-ON-ALL FL) | |
1096 | (COMPOSE-FLAVOR-COMBINATION FL)) | |
1097 | (COMPOSE-METHOD-COMBINATION FL SINGLE-OPERATION))) | |
1098 | (IF DO-DEPENDENTS | |
1099 | (LET ((FDEFINE-FILE-PATHNAME NIL)) ;Don't give warnings for combined methods | |
1100 | (DOLIST (FN (FLAVOR-DEPENDED-ON-BY-ALL FL)) | |
1101 | (IF (FLAVOR-METHOD-HASH-TABLE (GET FN 'FLAVOR)) | |
1102 | (RECOMPILE-FLAVOR FN SINGLE-OPERATION *USE-OLD-COMBINED-METHODS* NIL)))))) | |
1103 | ||
1104 | ;Make a list of all flavors that depend on this one, not including this flavor itself. | |
1105 | ;This is a list of the names, not the defstructs. | |
1106 | (DEFUN FLAVOR-DEPENDED-ON-BY-ALL (FL &OPTIONAL (LIST-SO-FAR NIL) &AUX FFL) | |
1107 | (DOLIST (FN (FLAVOR-DEPENDED-ON-BY FL)) | |
1108 | (OR (MEMQ FN LIST-SO-FAR) | |
1109 | (NOT (SETQ FFL (GET FN 'FLAVOR))) | |
1110 | (SETQ LIST-SO-FAR (FLAVOR-DEPENDED-ON-BY-ALL FFL (CONS FN LIST-SO-FAR))))) | |
1111 | LIST-SO-FAR) | |
1112 | \f | |
1113 | ;This function takes care of flavor-combination. It sets up the list | |
1114 | ;of all component flavors, in appropriate order, and the list of all | |
1115 | ;instance variables. It generally needs to be called only once for a | |
1116 | ;flavor, and must be called before method-combination can be dealt with. | |
1117 | (DEFVAR FLAVORS-BEING-COMPOSED NIL) | |
1118 | ||
1119 | (DEFUN COMPOSE-FLAVOR-COMBINATION (FL &AUX FLS VARS ORDS REQS SIZE | |
1120 | (SOME-COMPONENT-UNDEFINED NIL) | |
1121 | (FLAVORS-BEING-COMPOSED | |
1122 | (CONS FL FLAVORS-BEING-COMPOSED))) | |
1123 | ;; Make list of all component flavors' names. | |
1124 | ;; This list is in outermost-first order. | |
1125 | ;; Would be nice for this not to have to search to all levels, but for | |
1126 | ;; the moment that is hard, so I won't do it. | |
1127 | ;; Included-flavors are hairy: if not otherwise in the list of components, they | |
1128 | ;; are stuck in after the rightmost component that includes them, along with | |
1129 | ;; any components of their own not otherwise in the list. | |
1130 | (SETQ FLS (COPYLIST (COMPOSE-FLAVOR-INCLUSION (FLAVOR-NAME FL) T))) | |
1131 | ;; Don't mark this flavor as "composed" if there were errors. | |
1132 | (OR SOME-COMPONENT-UNDEFINED | |
1133 | (SETF (FLAVOR-DEPENDS-ON-ALL FL) FLS)) | |
1134 | ;; Vanilla-flavor may have been put in by magic, so maintain the dependencies | |
1135 | ;; in case new methods get added to it later. | |
1136 | (LET ((VAN (GET-FLAVOR 'SI:VANILLA-FLAVOR)) | |
1137 | (FLAV (FLAVOR-NAME FL))) | |
1138 | (AND (NOT (NULL VAN)) | |
1139 | (NEQ FLAV 'SI:VANILLA-FLAVOR) | |
1140 | (MEMQ 'SI:VANILLA-FLAVOR FLS) | |
1141 | (NOT (MEMQ FLAV (FLAVOR-DEPENDED-ON-BY VAN))) | |
1142 | (PUSH FLAV (FLAVOR-DEPENDED-ON-BY VAN)))) | |
1143 | ;; Compute what the instance variables will be, and in what order. | |
1144 | ;; Also collect the required but not present instance variables, which go onto the | |
1145 | ;; ADDITIONAL-INSTANCE-VARIABLES property. The instance variables of the | |
1146 | ;; :REQUIRED-FLAVORS work the same way. Such instance variables are ok | |
1147 | ;; for our methods to access. | |
1148 | (DOLIST (F FLS) | |
1149 | (SETQ F (GET-FLAVOR F)) | |
1150 | (DOLIST (V (FLAVOR-LOCAL-INSTANCE-VARIABLES F)) | |
1151 | (OR (ATOM V) (SETQ V (CAR V))) | |
1152 | (OR (MEMQ V VARS) (PUSH V VARS))) | |
1153 | (SETQ REQS (UNION REQS | |
1154 | (GET (FLAVOR-PLIST F) ':REQUIRED-INSTANCE-VARIABLES))) | |
1155 | ;; Any variables our required flavors have or require, we require. | |
1156 | (DOLIST (FF (GET (FLAVOR-PLIST F) ':REQUIRED-FLAVORS)) | |
1157 | (COND ((AND (NOT (MEMQ FF FLS)) | |
1158 | (SETQ FF (GET-FLAVOR FF)) | |
1159 | (NOT (MEMQ FF (CDR FLAVORS-BEING-COMPOSED)))) | |
1160 | (OR (FLAVOR-DEPENDS-ON-ALL FF) (COMPOSE-FLAVOR-COMBINATION FF)) | |
1161 | (SETQ REQS | |
1162 | (UNION REQS (FLAVOR-ALL-INSTANCE-VARIABLES FF) | |
1163 | (GET (FLAVOR-PLIST FF) 'ADDITIONAL-INSTANCE-VARIABLES)))))) | |
1164 | (LET ((ORD (GET (FLAVOR-PLIST F) ':ORDERED-INSTANCE-VARIABLES))) | |
1165 | ;; Merge into existing order requirement. Shorter of the two must be | |
1166 | ;; a prefix of the longer, and we take the longer. | |
1167 | (DO ((L1 ORD (CDR L1)) | |
1168 | (L2 ORDS (CDR L2))) | |
1169 | (NIL) | |
1170 | (COND ((NULL L1) (RETURN NIL)) | |
1171 | ((NULL L2) (RETURN (SETQ ORDS ORD))) | |
1172 | ((NEQ (CAR L1) (CAR L2)) | |
1173 | (FERROR () ":ORDERED-INSTANCE-VARIABLES conflict, ~S vs ~S" | |
1174 | (CAR L1) (CAR L2))))))) | |
1175 | ;; Must not merge this with the previous loop, | |
1176 | ;; to avoid altering order of instance variables | |
1177 | ;; if a DEFFLAVOR is redone. | |
1178 | (DOLIST (F FLS) | |
1179 | (SETQ F (GET-FLAVOR F))) | |
1180 | ;; This NREVERSE makes it compatible with the old code. There is no other reason for it. | |
1181 | (SETQ VARS (NREVERSE VARS)) | |
1182 | ;; Apply ordering requirement by moving those variables to the front. | |
1183 | (DOLIST (V ORDS) | |
1184 | (OR (MEMQ V VARS) | |
1185 | (FERROR () "Flavor ~S lacks instance variable ~S which has an order requirement" | |
1186 | (FLAVOR-NAME FL) V)) | |
1187 | (SETQ VARS (DELQ V VARS))) | |
1188 | (SETQ VARS (APPEND ORDS VARS)) | |
1189 | (SETF (FLAVOR-ALL-INSTANCE-VARIABLES FL) (COPYLIST VARS)) | |
1190 | ;; If there are any instance variables required but not present, save them | |
1191 | ;; so that they can be declared special in methods. | |
1192 | (DOLIST (V VARS) | |
1193 | (SETQ REQS (DELQ V REQS))) | |
1194 | (AND REQS (PUTPROP (FLAVOR-PLIST FL) | |
1195 | (COPYLIST REQS) | |
1196 | 'ADDITIONAL-INSTANCE-VARIABLES)) | |
1197 | NIL) | |
1198 | ||
1199 | (DEFUN COMPOSE-FLAVOR-INCLUSION (FLAVOR ERROR-P) | |
1200 | (MULTIPLE-VALUE-BIND (FLS ADDITIONS) (COMPOSE-FLAVOR-INCLUSION-1 FLAVOR NIL ERROR-P) | |
1201 | ;; The new additions may themselves imply more components | |
1202 | (DO L ADDITIONS (CDR L) (NULL L) | |
1203 | (LET ((MORE-FLS (COMPOSE-FLAVOR-INCLUSION-1 (CAR L) FLS ERROR-P))) | |
1204 | (DOLIST (F MORE-FLS) | |
1205 | ;; This hair inserts F before (after) the thing that indirectly included it | |
1206 | ;; and then puts that next on ADDITIONS so it gets composed also | |
1207 | (LET ((LL (MEMQ (CAR L) FLS))) | |
1208 | (RPLACA (RPLACD LL (CONS (CAR LL) (CDR LL))) F) | |
1209 | (RPLACD L (CONS F (CDR L))))))) | |
1210 | ;; Now attach vanilla-flavor if desired | |
1211 | (OR (LOOP FOR FLAVOR IN FLS | |
1212 | THEREIS (GET (FLAVOR-PLIST (GET-FLAVOR FLAVOR)) | |
1213 | ':NO-VANILLA-FLAVOR)) | |
1214 | (PUSH 'SI:VANILLA-FLAVOR FLS)) | |
1215 | (NREVERSE FLS))) | |
1216 | ||
1217 | (local-declare ((special other-components)) | |
1218 | (DEFUN COMPOSE-FLAVOR-INCLUSION-1 (FLAVOR OTHER-COMPONENTS ERROR-P) | |
1219 | ;; First, make a backwards list of all the normal (non-included) components | |
1220 | (LET ((FLS (MAP-OVER-COMPONENT-FLAVORS 1 ERROR-P NIL | |
1221 | #'(LAMBDA (FL LIST) | |
1222 | (SETQ FL (FLAVOR-NAME FL)) | |
1223 | (OR (MEMQ FL LIST) | |
1224 | (MEMQ FL OTHER-COMPONENTS) | |
1225 | (PUSH FL LIST)) | |
1226 | LIST) | |
1227 | FLAVOR NIL)) | |
1228 | (ADDITIONS NIL)) | |
1229 | ;; If there are any inclusions that aren't in the list, plug | |
1230 | ;; them in right after (before in backwards list) their last (first) includer | |
1231 | (DO L FLS (CDR L) (NULL L) | |
1232 | (DOLIST (FL (FLAVOR-INCLUDES (GET-FLAVOR (CAR L)))) | |
1233 | (OR (MEMQ FL FLS) | |
1234 | (MEMQ FL OTHER-COMPONENTS) | |
1235 | (PUSH (CAR (RPLACA (RPLACD L (CONS (CAR L) (CDR L))) FL)) ADDITIONS)))) | |
1236 | (OR (MEMQ FLAVOR FLS) | |
1237 | (SETQ FLS (NCONC FLS | |
1238 | (NREVERSE | |
1239 | (LOOP FOR FL IN (FLAVOR-INCLUDES (GET-FLAVOR FLAVOR)) | |
1240 | UNLESS (OR (MEMQ FL FLS) (MEMQ FL OTHER-COMPONENTS)) | |
1241 | COLLECT FL | |
1242 | AND DO (PUSH FL ADDITIONS)))))) | |
1243 | (VALUES FLS ADDITIONS)))) | |
1244 | \f | |
1245 | ;Once the flavor-combination stuff has been done, do the method-combination stuff. | |
1246 | ;The above function usually only gets called once, but this function gets called | |
1247 | ;when a new method is added. | |
1248 | ;Specify SINGLE-OPERATION to do this for just one operation, for incremental update. | |
1249 | ;NOTE WELL: If a meth is in the method-table at all, it is considered to be defined | |
1250 | ; for purposes of compose-method-combination. Thus merely putprop'ing a method, | |
1251 | ; or calling flavor-notice-method, will make the flavor think that method exists | |
1252 | ; when it is next composed. This is necessary to make compile-flavor-methods work. | |
1253 | ; (Putprop must create the meth because loading does putprop before fdefine.) | |
1254 | (DEFUN COMPOSE-METHOD-COMBINATION (FL &OPTIONAL (SINGLE-OPERATION NIL) | |
1255 | &AUX TEM MAGIC-LIST ORDER DEF HT | |
1256 | MSG ELEM HANDLERS FFL PL) | |
1257 | ;; If we are doing wholesale method composition, | |
1258 | ;; compose the flavor bindings list also. | |
1259 | ;; This way it is done often enough, but not at every defmethod. | |
1260 | (IF (NOT SINGLE-OPERATION) | |
1261 | (COMPOSE-FLAVOR-INITIALIZATIONS FL)) | |
1262 | ;; Look through all the flavors depended upon and collect the following: | |
1263 | ;; A list of all the operations handled and all the methods for each, called MAGIC-LIST. | |
1264 | ;; The default handler for unknown operations. | |
1265 | ;; The declared order of entries in the select-method alist. | |
1266 | ;; Also generate any automatically-created methods not already present. | |
1267 | ;; MAGIC-LIST is roughly the same format as the flavor-method-table, see its comments. | |
1268 | ;; Each magic-list entry is (message comb-type comb-order (type function-spec...)...) | |
1269 | (DO ((FFLS (FLAVOR-DEPENDS-ON-ALL FL) (CDR FFLS))) | |
1270 | ((NULL FFLS)) | |
1271 | (SETQ FFL (GET-FLAVOR (CAR FFLS)) | |
1272 | PL (FLAVOR-PLIST FFL)) | |
1273 | (COND ((NOT SINGLE-OPERATION) | |
1274 | (AND (SETQ TEM (GET PL ':SELECT-METHOD-ORDER)) | |
1275 | (SETQ ORDER (NCONC ORDER (COPYLIST TEM)))))) | |
1276 | ;; Add data from flavor method-table to magic-list | |
1277 | ;; But skip over combined methods, they are not relevant here | |
1278 | (DOLIST (MTE (FLAVOR-METHOD-TABLE FFL)) | |
1279 | (SETQ MSG (CAR MTE)) | |
1280 | (COND ((OR (NOT SINGLE-OPERATION) (EQ MSG SINGLE-OPERATION)) | |
1281 | ;; Well, we're supposed to concern ourselves with this operation | |
1282 | (SETQ ELEM (ASSQ MSG MAGIC-LIST)) ;What we already know about it | |
1283 | (COND ((DOLIST (METH (CDDDR MTE)) | |
1284 | (OR (EQ (METH-METHOD-TYPE METH) ':COMBINED) | |
1285 | (NOT (METH-DEFINEDP METH)) | |
1286 | (RETURN T))) | |
1287 | ;; OK, this flavor really contributes to handling this operation | |
1288 | (OR ELEM (PUSH (SETQ ELEM (LIST* MSG NIL NIL NIL)) MAGIC-LIST)) | |
1289 | ;; For each non-combined method for this operation, add it to the front | |
1290 | ;; of the magic-list element, thus they are in base-flavor-first order. | |
1291 | (DOLIST (METH (CDDDR MTE)) | |
1292 | (LET ((TYPE (METH-METHOD-TYPE METH))) | |
1293 | (COND ((EQ TYPE ':COMBINED)) | |
1294 | ((NOT (METH-DEFINEDP METH))) | |
1295 | ((NOT (SETQ TEM (ASSQ TYPE (CDDDR ELEM)))) | |
1296 | (PUSH (LIST TYPE (METH-FUNCTION-SPEC METH)) (CDDDR ELEM))) | |
1297 | ;; Don't let the same method get in twice (how could it?) | |
1298 | ((NOT (MEMQ (METH-FUNCTION-SPEC METH) (CDR TEM))) | |
1299 | (PUSH (METH-FUNCTION-SPEC METH) (CDR TEM)))))))) | |
1300 | ;; Pick up method-combination declarations | |
1301 | (AND (CADR MTE) (CADR ELEM) ;If both specify combination-type, check | |
1302 | (OR (NEQ (CADR MTE) (CADR ELEM)) (NEQ (CADDR MTE) (CADDR ELEM))) | |
1303 | (FERROR () | |
1304 | "Method-combination mismatch ~S-~S vs. ~S-~S, check your DEFFLAVOR's" | |
1305 | (CADR MTE) (CADDR MTE) (CADR ELEM) (CADDR ELEM))) | |
1306 | (COND ((CADR MTE) ;Save combination-type when specified | |
1307 | (OR ELEM (PUSH (SETQ ELEM (LIST* MSG NIL NIL NIL)) MAGIC-LIST)) | |
1308 | (SETF (CADR ELEM) (CADR MTE)) | |
1309 | (SETF (CADDR ELEM) (CADDR MTE)))) )))) | |
1310 | ;; This NREVERSE tends to put base-flavor methods last | |
1311 | (SETQ MAGIC-LIST (NREVERSE MAGIC-LIST)) | |
1312 | ;; Re-order the magic-list according to any declared required order | |
1313 | (DOLIST (MSG (NREVERSE ORDER)) | |
1314 | (AND (SETQ TEM (ASSQ MSG MAGIC-LIST)) | |
1315 | (SETQ MAGIC-LIST (CONS TEM (DELQ TEM MAGIC-LIST 1))))) | |
1316 | ;; Map over the magic-list. For each entry call the appropriate | |
1317 | ;; method-combining routine, which will return a function spec for | |
1318 | ;; the handler to use for this operation. | |
1319 | (DOLIST (MTE MAGIC-LIST) | |
1320 | ;; Punt if there are no methods at all (just a method-combination declaration) | |
1321 | (COND ((CDDDR MTE) | |
1322 | ;; Process the :DEFAULT methods; if there are any untyped methods the | |
1323 | ;; default methods go away, otherwise they become untyped methods. | |
1324 | (AND (SETQ TEM (ASSQ ':DEFAULT (CDDDR MTE))) | |
1325 | (IF (ASSQ NIL (CDDDR MTE)) | |
1326 | (SETF (CDDDR MTE) (DELQ TEM (CDDDR MTE))) | |
1327 | (RPLACA TEM NIL))) | |
1328 | (OR (SETQ TEM (GET (OR (CADR MTE) ':DAEMON) 'METHOD-COMBINATION)) | |
1329 | (FERROR () "~S unknown method combination type for ~S operation" | |
1330 | (CADR MTE) (CAR MTE))) | |
1331 | (PUSH (FUNCALL TEM FL MTE) HANDLERS)) | |
1332 | (T (SETQ MAGIC-LIST (DELQ MTE MAGIC-LIST 1))))) | |
1333 | ;; Get back into declared order. We now have a list of function specs for handlers. | |
1334 | (SETQ HANDLERS (NREVERSE HANDLERS)) | |
1335 | (COND (SINGLE-OPERATION | |
1336 | ;; If doing SINGLE-OPERATION, put it into the hash table. | |
1337 | ;; If the operation is becoming defined and wasn't, or vice versa, | |
1338 | ;; must recompute the which-operations list. | |
1339 | (OR (COND ((NULL HANDLERS) ;Deleting method | |
1340 | (NOT (REMHASH SINGLE-OPERATION | |
1341 | (FLAVOR-METHOD-HASH-TABLE FL)))) | |
1342 | (T | |
1343 | (MULTIPLE-VALUE-BIND (NIL PREVIOUSLY-PRESENT) | |
1344 | (SWAPHASH SINGLE-OPERATION | |
1345 | (SETQ DEF (METHOD-FUNCTION-NAME | |
1346 | (CAR HANDLERS))) | |
1347 | (FLAVOR-METHOD-HASH-TABLE FL)) | |
1348 | PREVIOUSLY-PRESENT))) | |
1349 | (SETF (FLAVOR-WHICH-OPERATIONS FL) NIL))) | |
1350 | ;; Working on all operations at once. | |
1351 | (T | |
1352 | (SETQ HT (MAKE-HASH-TABLE | |
1353 | ':SIZE (FIX (TIMES 1.5 (LENGTH MAGIC-LIST))))) | |
1354 | ;; If flavor currently has no hash table, it can't hurt to set | |
1355 | ;; it early | |
1356 | (OR (FLAVOR-METHOD-HASH-TABLE FL) | |
1357 | (SETF (FLAVOR-METHOD-HASH-TABLE FL) HT)) | |
1358 | (DO ((HANDLERS HANDLERS (CDR HANDLERS)) | |
1359 | (ML MAGIC-LIST (CDR ML))) | |
1360 | ((NULL ML)) | |
1361 | (PUTHASH (CAAR ML) (SETQ DEF (METHOD-FUNCTION-NAME (CAR HANDLERS))) | |
1362 | HT) | |
1363 | (SETF (FLAVOR-METHOD-HASH-TABLE FL) HT) | |
1364 | (SETF (FLAVOR-WHICH-OPERATIONS FL) NIL)) ;This will have to be recomputed | |
1365 | ;; Make sure that the required variables and methods are present. | |
1366 | (VERIFY-REQUIRED-FLAVORS-METHODS-AND-IVARS FL MAGIC-LIST))) | |
1367 | NIL) | |
1368 | ||
1369 | (DEFUN VERIFY-REQUIRED-FLAVORS-METHODS-AND-IVARS (FL MAGIC-LIST) | |
1370 | (DO ((FFLS (FLAVOR-DEPENDS-ON-ALL FL) (CDR FFLS)) | |
1371 | (MISSING-METHODS NIL) | |
1372 | (MISSING-INSTANCE-VARIABLES NIL) | |
1373 | (MISSING-FLAVORS NIL) | |
1374 | (REQUIRING-FLAVOR-ALIST NIL)) | |
1375 | ((NULL FFLS) | |
1376 | (AND (OR MISSING-INSTANCE-VARIABLES MISSING-METHODS MISSING-FLAVORS) | |
1377 | (FERROR () "Flavor ~S is missing ~ | |
1378 | ~:[~2*~;instance variable~P ~{~S~^, ~} ~]~ | |
1379 | ~:[~3*~;~:[~;and ~]method~P ~{~S~^, ~}~]~ | |
1380 | ~:[~3*~;~:[~;and ~]component flavor~P ~{~S~^, ~}~] | |
1381 | Requiring Flavor alist: ~S" | |
1382 | (FLAVOR-NAME FL) | |
1383 | MISSING-INSTANCE-VARIABLES | |
1384 | (LENGTH MISSING-INSTANCE-VARIABLES) | |
1385 | MISSING-INSTANCE-VARIABLES | |
1386 | MISSING-METHODS | |
1387 | MISSING-INSTANCE-VARIABLES | |
1388 | (LENGTH MISSING-METHODS) | |
1389 | MISSING-METHODS | |
1390 | MISSING-FLAVORS | |
1391 | (OR MISSING-INSTANCE-VARIABLES MISSING-METHODS) | |
1392 | (LENGTH MISSING-FLAVORS) | |
1393 | MISSING-FLAVORS | |
1394 | REQUIRING-FLAVOR-ALIST))) | |
1395 | (LET ((PL (FLAVOR-PLIST (GET (CAR FFLS) 'FLAVOR)))) | |
1396 | (DOLIST (REQM (GET PL ':REQUIRED-METHODS)) | |
1397 | (OR (ASSQ REQM MAGIC-LIST) | |
1398 | (MEMQ REQM MISSING-METHODS) | |
1399 | (PROGN (PUSH REQM MISSING-METHODS) | |
1400 | (PUSH (CONS (FIRST FFLS) REQM) REQUIRING-FLAVOR-ALIST)))) | |
1401 | (DOLIST (REQV (GET PL ':REQUIRED-INSTANCE-VARIABLES)) | |
1402 | (OR (MEMQ REQV (FLAVOR-ALL-INSTANCE-VARIABLES FL)) | |
1403 | (MEMQ REQV MISSING-INSTANCE-VARIABLES) | |
1404 | (PROGN (PUSH REQV MISSING-INSTANCE-VARIABLES) | |
1405 | (PUSH (CONS (FIRST FFLS) REQV) REQUIRING-FLAVOR-ALIST)))) | |
1406 | (DOLIST (REQF (GET PL ':REQUIRED-FLAVORS)) | |
1407 | (OR (MEMQ REQF (FLAVOR-DEPENDS-ON-ALL FL)) | |
1408 | (MEMQ REQF MISSING-FLAVORS) | |
1409 | (PROGN (PUSH REQF MISSING-FLAVORS) | |
1410 | (PUSH (CONS (FIRST FFLS) REQF) REQUIRING-FLAVOR-ALIST))))))) | |
1411 | ||
1412 | ;This is the default handler for flavors. | |
1413 | (DEFUN FLAVOR-UNCLAIMED-MESSAGE (MESSAGE ARGS) | |
1414 | (DECLARE (SPECIAL SELF)) | |
1415 | (FORMAT T "The object ") | |
1416 | (PRINT SELF) | |
1417 | (FERROR ':UNCLAIMED-MESSAGE " received a ~S message, which went unclaimed. | |
1418 | The rest of the message was ~S~%" MESSAGE ARGS)) | |
1419 | ||
1420 | ;Return an alist of operations and their handlers. | |
1421 | (DEFUN FLAVOR-METHOD-ALIST (FL) | |
1422 | (IF (SYMBOLP FL) (SETQ FL (GET FL 'FLAVOR))) | |
1423 | (IF FL | |
1424 | (LET ((HT (FLAVOR-METHOD-HASH-TABLE FL)) | |
1425 | (ALIST NIL)) | |
1426 | (AND HT | |
1427 | (MAPHASH #'(LAMBDA (OP METH-LOCATIVE &REST IGNORE) | |
1428 | (DECLARE (SPECIAL ALIST)) | |
1429 | (PUSH (CONS OP (CAR METH-LOCATIVE)) ALIST)) | |
1430 | HT)) | |
1431 | ALIST))) | |
1432 | ||
1433 | ;; Make the instance-variable getting and setting methods | |
1434 | ;; Updated 7Jul84 SMH@MIT-EMS: As an apparent efficiency hack, the original | |
1435 | ;; Lisp Machine code pushed each defmethod only if **just-compiling** were set | |
1436 | ;; or the method were not yet defined. The **just-compiling** switch has | |
1437 | ;; unfortunately disappeared from the Franz version. This caused | |
1438 | ;; REcompilations of a flavor by a single instance of Liszt to omit all | |
1439 | ;; automatic methods. The bypass of the defmethod if the method is already | |
1440 | ;; defined has thus been deleted. | |
1441 | (DEFUN COMPOSE-AUTOMATIC-METHODS (FL &AUX VV FORMS) | |
1442 | (DOLIST (V (FLAVOR-GETTABLE-INSTANCE-VARIABLES FL)) | |
1443 | (SETQ VV (CORRESPONDING-KEYWORD V)) | |
1444 | (LET ((METH `(:METHOD ,(FLAVOR-NAME FL) ,VV))) | |
1445 | (PUSH `(DEFMETHOD (,(FLAVOR-NAME FL) ,VV) () ,V) | |
1446 | FORMS))) | |
1447 | (DOLIST (V (FLAVOR-SETTABLE-INSTANCE-VARIABLES FL)) | |
1448 | (SETQ VV (INTERN (FORMAT () ":set-~A" V))) | |
1449 | (LET ((METH `(:METHOD ,(FLAVOR-NAME FL) ,VV))) | |
1450 | (PUSH `(DEFMETHOD (,(FLAVOR-NAME FL) ,VV) (VALUE) | |
1451 | (SETQ ,V VALUE)) | |
1452 | FORMS))) | |
1453 | (NREVERSE FORMS)) | |
1454 | ||
1455 | ;Given a symbol return the corresponding one in the keyword package | |
1456 | (DEFUN CORRESPONDING-KEYWORD (SYMBOL) | |
1457 | (IF (= #/: (GETCHARN SYMBOL 1)) SYMBOL | |
1458 | (INTERN (CONCAT ":" SYMBOL)))) | |
1459 | \f | |
1460 | ;Figure out the information needed to instantiate a flavor quickly. | |
1461 | ||
1462 | ;We store these three properties on the flavor: | |
1463 | ;INSTANCE-VARIABLE-INITIALIZATIONS - alist of (ivar-index . init-form) | |
1464 | ;REMAINING-DEFAULT-PLIST - a default plist from which kwds that init ivars | |
1465 | ; have been removed. | |
1466 | ;ALL-INITABLE-INSTANCE-VARIABLES - | |
1467 | ; a list parallel to FLAVOR-ALL-INSTANCE-VARIABLES which has either | |
1468 | ; the keyword to init with or NIL. | |
1469 | ;REMAINING-INIT-KEYWORDS - | |
1470 | ; the init keywords that are handled and don't just init ivars. | |
1471 | ||
1472 | ;We also set up the FLAVOR-DEFAULT-HANDLER of the flavor. | |
1473 | ||
1474 | (DEFUN COMPOSE-FLAVOR-INITIALIZATIONS (FL &AUX ALIST | |
1475 | (REMAINING-DEFAULT-PLIST (LIST NIL)) | |
1476 | ALL-INITABLE-IVARS) | |
1477 | (SETQ ALL-INITABLE-IVARS (MAKE-LIST | |
1478 | (LENGTH (FLAVOR-ALL-INSTANCE-VARIABLES FL)))) | |
1479 | ;; First make the mask saying which ivars can be inited by init keywords. | |
1480 | (DOLIST (FFL (FLAVOR-DEPENDS-ON-ALL FL)) | |
1481 | (LET ((FFL (GET-FLAVOR FFL))) | |
1482 | (OR (FLAVOR-DEFAULT-HANDLER FL) | |
1483 | (SETF (FLAVOR-DEFAULT-HANDLER FL) | |
1484 | (GET (FLAVOR-PLIST FFL) ':DEFAULT-HANDLER))) | |
1485 | (DOLIST (IIV (FLAVOR-INITABLE-INSTANCE-VARIABLES FFL)) | |
1486 | (LET ((INDEX (FIND-POSITION-IN-LIST (CDR IIV) | |
1487 | (FLAVOR-ALL-INSTANCE-VARIABLES FL)))) | |
1488 | (AND INDEX | |
1489 | (SETF (NTH INDEX ALL-INITABLE-IVARS) | |
1490 | (CAR IIV))))))) | |
1491 | ;; Then look at all the default init plists, for anything there that | |
1492 | ;; initializes an instance variable. If it does, make an entry on ALIST. | |
1493 | ;; Any that doesn't initialize a variable, put on the "remaining" list. | |
1494 | (DOLIST (FFL (FLAVOR-DEPENDS-ON-ALL FL)) | |
1495 | (SETQ FFL (GET-FLAVOR FFL)) | |
1496 | (DO ((L (GET (FLAVOR-PLIST FFL) ':DEFAULT-INIT-PLIST) (CDDR L))) ((NULL L)) | |
1497 | (LET* ((KEYWORD (CAR L)) (ARG (CADR L)) | |
1498 | (INDEX (FIND-POSITION-IN-LIST KEYWORD ALL-INITABLE-IVARS))) | |
1499 | (IF INDEX | |
1500 | (OR (ASSQ INDEX ALIST) | |
1501 | (PUSH (LIST INDEX ARG) | |
1502 | ALIST)) | |
1503 | ;; This keyword does not just initialize an instance variable. | |
1504 | (OR (MEMQ-ALTERNATED KEYWORD (CDR REMAINING-DEFAULT-PLIST)) | |
1505 | (PUTPROP REMAINING-DEFAULT-PLIST ARG KEYWORD)))))) | |
1506 | ;; Then, look for default values provided in list of instance vars. | |
1507 | (DOLIST (FFL (FLAVOR-DEPENDS-ON-ALL FL)) | |
1508 | (SETQ FFL (GET-FLAVOR FFL)) | |
1509 | (DOLIST (V (FLAVOR-LOCAL-INSTANCE-VARIABLES FFL)) | |
1510 | (AND (NOT (ATOM V)) | |
1511 | ;; When we find one, put it in if there is no init for that variable yet. | |
1512 | (LET ((INDEX (FIND-POSITION-IN-LIST (CAR V) | |
1513 | (FLAVOR-ALL-INSTANCE-VARIABLES FL)))) | |
1514 | (AND (NOT (ASSQ INDEX ALIST)) | |
1515 | (PUSH (LIST INDEX | |
1516 | (CADR V)) | |
1517 | ALIST)))))) | |
1518 | (SETF (FLAVOR-INSTANCE-VARIABLE-INITIALIZATIONS FL) | |
1519 | (SORTCAR ALIST #'LESSP)) | |
1520 | (SETF (FLAVOR-REMAINING-DEFAULT-PLIST FL) (CDR REMAINING-DEFAULT-PLIST)) | |
1521 | (SETF (FLAVOR-ALL-INITABLE-INSTANCE-VARIABLES FL) ALL-INITABLE-IVARS) | |
1522 | (SETF (FLAVOR-REMAINING-INIT-KEYWORDS FL) | |
1523 | (LOOP FOR K IN (FLAVOR-ALLOWED-INIT-KEYWORDS FL) | |
1524 | UNLESS (MEMQ K ALL-INITABLE-IVARS) | |
1525 | COLLECT K))) | |
1526 | \f | |
1527 | ; Method-combination functions. Found on the SI:METHOD-COMBINATION property | |
1528 | ; of the combination-type. These are passed the flavor structure, and the | |
1529 | ; magic-list entry, and must return the function-spec for the handler | |
1530 | ; to go into the select-method, defining any necessary functions. | |
1531 | ; This function interprets combination-type-arg, | |
1532 | ; which for many combination-types is either :BASE-FLAVOR-FIRST or :BASE-FLAVOR-LAST. | |
1533 | ||
1534 | ; :DAEMON combination | |
1535 | ; The primary method is the outermost untyped-method (or :DEFAULT). | |
1536 | ; The :BEFORE methods are called base-flavor-last, the :AFTER methods are called | |
1537 | ; base-flavor-first. An important optimization is not to generate a combined-method | |
1538 | ; if there is only a primary method. You are allowed to omit the primary method | |
1539 | ; if there are any daemons (I'm not convinced this is really a good idea) in which | |
1540 | ; case the method's returned value will be NIL. | |
1541 | (DEFUN (:DAEMON METHOD-COMBINATION) (FL MAGIC-LIST-ENTRY) | |
1542 | (LET ((PRIMARY-METHOD (CAR (GET-CERTAIN-METHODS MAGIC-LIST-ENTRY NIL '(:BEFORE :AFTER) T | |
1543 | ':BASE-FLAVOR-LAST))) | |
1544 | (BEFORE-METHODS (GET-CERTAIN-METHODS MAGIC-LIST-ENTRY ':BEFORE T T | |
1545 | ':BASE-FLAVOR-LAST)) | |
1546 | (AFTER-METHODS (GET-CERTAIN-METHODS MAGIC-LIST-ENTRY ':AFTER T T | |
1547 | ':BASE-FLAVOR-FIRST)) | |
1548 | (WRAPPERS-P (SPECIALLY-COMBINED-METHODS-PRESENT MAGIC-LIST-ENTRY))) | |
1549 | ;; Remove shadowed primary methods from the magic-list-entry so that it won't look like | |
1550 | ;; we depend on them (which could cause extraneous combined-method recompilation). | |
1551 | (LET ((MLE (ASSQ NIL (CDDDR MAGIC-LIST-ENTRY)))) | |
1552 | (AND (CDDR MLE) | |
1553 | (SETF (CDR MLE) (LIST PRIMARY-METHOD)))) | |
1554 | (OR (AND (NOT WRAPPERS-P) (NULL BEFORE-METHODS) (NULL AFTER-METHODS) PRIMARY-METHOD) | |
1555 | (HAVE-COMBINED-METHOD FL MAGIC-LIST-ENTRY) | |
1556 | (MAKE-COMBINED-METHOD FL MAGIC-LIST-ENTRY | |
1557 | (DAEMON-COMBINATION PRIMARY-METHOD BEFORE-METHODS AFTER-METHODS))))) | |
1558 | ||
1559 | (DEFUN DAEMON-COMBINATION (PRIMARY-METHOD BEFORE-METHODS AFTER-METHODS | |
1560 | &OPTIONAL OR-METHODS AND-METHODS) | |
1561 | (LET ((INNER-CALL (AND PRIMARY-METHOD (METHOD-CALL PRIMARY-METHOD)))) | |
1562 | (IF (AND INNER-CALL AFTER-METHODS) | |
1563 | (SETQ INNER-CALL `(MULTIPLE-VALUE (.VAL1. .VAL2. .VAL3.) | |
1564 | ,INNER-CALL))) | |
1565 | (AND OR-METHODS (SETQ INNER-CALL | |
1566 | `(OR ,@(MAPCAR 'METHOD-CALL OR-METHODS) | |
1567 | ,INNER-CALL))) | |
1568 | (AND AND-METHODS (SETQ INNER-CALL | |
1569 | `(AND ,@(MAPCAR 'METHOD-CALL AND-METHODS) | |
1570 | ,INNER-CALL))) | |
1571 | `(PROGN | |
1572 | ,@(MAPCAR 'METHOD-CALL BEFORE-METHODS) | |
1573 | ,(IF AFTER-METHODS | |
1574 | ;; Kludge to return a few multiple values | |
1575 | `(PROG (.VAL1. .VAL2. .VAL3.) | |
1576 | ,INNER-CALL | |
1577 | ,@(MAPCAR 'METHOD-CALL AFTER-METHODS) | |
1578 | (RETURN .VAL1. .VAL2. .VAL3.)) | |
1579 | ;; No :AFTER methods, hair not required | |
1580 | ;; You are allowed to not have a primary method | |
1581 | INNER-CALL)))) | |
1582 | ||
1583 | (DEFUN METHOD-CALL (METHOD) | |
1584 | `(LEXPR-FUNCALL #',(METHOD-FUNCTION-NAME METHOD) .DAEMON-CALLER-ARGS.)) | |
1585 | ||
1586 | ; :DAEMON-WITH-OVERRIDE combination | |
1587 | ; This is the same as :DAEMON (the default), except that :OVERRIDE type methods | |
1588 | ; are combined with the :BEFORE-primary-:AFTER methods in an OR. This allows | |
1589 | ; overriding of the main methods function. For example, a combined method as follows | |
1590 | ; might be generated: (OR (FOO-OVERRIDE-BAR-METHOD) (PROGN (FOO-BEFORE-BAR-METHOD))) | |
1591 | (DEFUN (:DAEMON-WITH-OVERRIDE METHOD-COMBINATION) (FL MAGIC-LIST-ENTRY) | |
1592 | (LET ((PRIMARY-METHOD (CAR (GET-CERTAIN-METHODS MAGIC-LIST-ENTRY NIL | |
1593 | '(:BEFORE :AFTER :OVERRIDE) T | |
1594 | ':BASE-FLAVOR-LAST))) | |
1595 | (BEFORE-METHODS (GET-CERTAIN-METHODS MAGIC-LIST-ENTRY ':BEFORE T T | |
1596 | ':BASE-FLAVOR-LAST)) | |
1597 | (AFTER-METHODS (GET-CERTAIN-METHODS MAGIC-LIST-ENTRY ':AFTER T T | |
1598 | ':BASE-FLAVOR-FIRST)) | |
1599 | (WRAPPERS-P (SPECIALLY-COMBINED-METHODS-PRESENT MAGIC-LIST-ENTRY)) | |
1600 | (OVERRIDE-METHODS (GET-CERTAIN-METHODS MAGIC-LIST-ENTRY | |
1601 | ':OVERRIDE T T NIL))) | |
1602 | ;; Remove shadowed primary methods from the magic-list-entry so that it won't look like | |
1603 | ;; we depend on them (which could cause extraneous combined-method recompilation). | |
1604 | (LET ((MLE (ASSQ NIL (CDDDR MAGIC-LIST-ENTRY)))) | |
1605 | (AND (CDDR MLE) | |
1606 | (SETF (CDR MLE) (LIST PRIMARY-METHOD)))) | |
1607 | (OR (AND (NOT WRAPPERS-P) (NULL BEFORE-METHODS) (NULL AFTER-METHODS) | |
1608 | (NULL OVERRIDE-METHODS) | |
1609 | PRIMARY-METHOD) | |
1610 | (HAVE-COMBINED-METHOD FL MAGIC-LIST-ENTRY) | |
1611 | (MAKE-COMBINED-METHOD FL MAGIC-LIST-ENTRY | |
1612 | `(OR ,@(MAPCAR 'METHOD-CALL OVERRIDE-METHODS) | |
1613 | ,(DAEMON-COMBINATION PRIMARY-METHOD BEFORE-METHODS AFTER-METHODS)))))) | |
1614 | ||
1615 | ; :DAEMON-WITH-OR combination | |
1616 | ; This is the same as :DAEMON (the default), except that :OR type methods | |
1617 | ; are combined with the primary methods inside an OR, and used in place of | |
1618 | ; the primary method in :DAEMON type combination. | |
1619 | ; For example, the following combined method might be generated: | |
1620 | ; (PROGN (FOO-BEFORE-BAR-METHOD) | |
1621 | ; (PROG (.VAL1. .VAL2. .VAL3.) | |
1622 | ; (OR (FOO-OR-BAR-METHOD) | |
1623 | ; (BAZ-OR-BAR-METHOD) | |
1624 | ; (MULTIPLE-VALUE (.VAL1. .VAL2. .VAL3.) | |
1625 | ; (BUZZ-PRIMARY-METHOD))) | |
1626 | ; (FOO-AFTER-BAR-METHOD) | |
1627 | ; (RETURN .VAL1. .VAL2. .VAL3.))) | |
1628 | ||
1629 | (DEFUN (:DAEMON-WITH-OR METHOD-COMBINATION) (FL MAGIC-LIST-ENTRY) | |
1630 | (LET ((PRIMARY-METHOD (CAR (GET-CERTAIN-METHODS MAGIC-LIST-ENTRY NIL '(:BEFORE :AFTER :OR) T | |
1631 | ':BASE-FLAVOR-LAST))) | |
1632 | (BEFORE-METHODS (GET-CERTAIN-METHODS MAGIC-LIST-ENTRY ':BEFORE T T | |
1633 | ':BASE-FLAVOR-LAST)) | |
1634 | (AFTER-METHODS (GET-CERTAIN-METHODS MAGIC-LIST-ENTRY ':AFTER T T | |
1635 | ':BASE-FLAVOR-FIRST)) | |
1636 | (WRAPPERS-P (SPECIALLY-COMBINED-METHODS-PRESENT MAGIC-LIST-ENTRY)) | |
1637 | (OR-METHODS (GET-CERTAIN-METHODS MAGIC-LIST-ENTRY ':OR T T NIL))) | |
1638 | ;; Remove shadowed primary methods from the magic-list-entry so that it won't look like | |
1639 | ;; we depend on them (which could cause extraneous combined-method recompilation). | |
1640 | (LET ((MLE (ASSQ NIL (CDDDR MAGIC-LIST-ENTRY)))) | |
1641 | (AND (CDDR MLE) | |
1642 | (SETF (CDR MLE) (LIST PRIMARY-METHOD)))) | |
1643 | (OR (AND (NOT WRAPPERS-P) (NULL BEFORE-METHODS) (NULL AFTER-METHODS) | |
1644 | (NULL OR-METHODS) | |
1645 | PRIMARY-METHOD) | |
1646 | (HAVE-COMBINED-METHOD FL MAGIC-LIST-ENTRY) | |
1647 | (MAKE-COMBINED-METHOD FL MAGIC-LIST-ENTRY | |
1648 | (DAEMON-COMBINATION PRIMARY-METHOD BEFORE-METHODS AFTER-METHODS | |
1649 | OR-METHODS))))) | |
1650 | ||
1651 | ; :DAEMON-WITH-AND combination | |
1652 | ; This is the same as :DAEMON (the default), except that :AND type methods | |
1653 | ; are combined with the primary methods inside an AND, and used in place of | |
1654 | ; the primary method in :DAEMON type combination. | |
1655 | ; For example, the following combined method might be generated: | |
1656 | ; (PROGN (FOO-BEFORE-BAR-METHOD) | |
1657 | ; (PROG (.VAL1. .VAL2. .VAL3.) | |
1658 | ; (AND (FOO-AND-BAR-METHOD) | |
1659 | ; (BAZ-AND-BAR-METHOD) | |
1660 | ; (MULTIPLE-VALUE (.VAL1. .VAL2. .VAL3.) | |
1661 | ; (BUZZ-PRIMARY-METHOD))) | |
1662 | ; (FOO-AFTER-BAR-METHOD) | |
1663 | ; (RETURN .VAL1. .VAL2. .VAL3.))) | |
1664 | ||
1665 | (DEFUN (:DAEMON-WITH-AND METHOD-COMBINATION) (FL MAGIC-LIST-ENTRY) | |
1666 | (LET ((PRIMARY-METHOD (CAR (GET-CERTAIN-METHODS MAGIC-LIST-ENTRY NIL '(:BEFORE :AFTER :AND) | |
1667 | T ':BASE-FLAVOR-LAST))) | |
1668 | (BEFORE-METHODS (GET-CERTAIN-METHODS MAGIC-LIST-ENTRY ':BEFORE T T | |
1669 | ':BASE-FLAVOR-LAST)) | |
1670 | (AFTER-METHODS (GET-CERTAIN-METHODS MAGIC-LIST-ENTRY ':AFTER T T | |
1671 | ':BASE-FLAVOR-FIRST)) | |
1672 | (WRAPPERS-P (SPECIALLY-COMBINED-METHODS-PRESENT MAGIC-LIST-ENTRY)) | |
1673 | (AND-METHODS (GET-CERTAIN-METHODS MAGIC-LIST-ENTRY ':AND T T NIL))) | |
1674 | ;; Remove shadowed primary methods from the magic-list-entry so that it won't look like | |
1675 | ;; we depend on them (which could cause extraneous combined-method recompilation). | |
1676 | (LET ((MLE (ASSQ NIL (CDDDR MAGIC-LIST-ENTRY)))) | |
1677 | (AND (CDDR MLE) | |
1678 | (SETF (CDR MLE) (LIST PRIMARY-METHOD)))) | |
1679 | (OR (AND (NOT WRAPPERS-P) (NULL BEFORE-METHODS) (NULL AFTER-METHODS) | |
1680 | (NULL AND-METHODS) | |
1681 | PRIMARY-METHOD) | |
1682 | (HAVE-COMBINED-METHOD FL MAGIC-LIST-ENTRY) | |
1683 | (MAKE-COMBINED-METHOD FL MAGIC-LIST-ENTRY | |
1684 | (DAEMON-COMBINATION PRIMARY-METHOD BEFORE-METHODS AFTER-METHODS | |
1685 | NIL AND-METHODS))))) | |
1686 | ||
1687 | ; :LIST combination | |
1688 | ; No typed-methods allowed. Returns a list of the results of all the methods. | |
1689 | ; There will always be a combined-method, even if only one method to be called. | |
1690 | (DEFUN (:LIST METHOD-COMBINATION) (FL MAGIC-LIST-ENTRY) | |
1691 | (OR (HAVE-COMBINED-METHOD FL MAGIC-LIST-ENTRY) | |
1692 | (MAKE-COMBINED-METHOD FL MAGIC-LIST-ENTRY | |
1693 | (CONS 'LIST (MAPCAR 'METHOD-CALL | |
1694 | (GET-CERTAIN-METHODS MAGIC-LIST-ENTRY NIL NIL NIL NIL)))))) | |
1695 | ||
1696 | ; :INVERSE-LIST combination | |
1697 | ; No typed-methods allowed. Apply each method to an element of the list. Given | |
1698 | ; the result of a :LIST-combined method with the same ordering, and corresponding | |
1699 | ; method definitions, the result that emerged from each component flavor gets handed | |
1700 | ; back to that same flavor. The combined-method returns no particular value. | |
1701 | (DEFUN (:INVERSE-LIST METHOD-COMBINATION) (FL MAGIC-LIST-ENTRY) | |
1702 | (OR (HAVE-COMBINED-METHOD FL MAGIC-LIST-ENTRY) | |
1703 | (MAKE-COMBINED-METHOD FL MAGIC-LIST-ENTRY | |
1704 | `(LET ((.FOO. (CADR .DAEMON-CALLER-ARGS.))) | |
1705 | . ,(DO ((ML (GET-CERTAIN-METHODS MAGIC-LIST-ENTRY NIL NIL NIL NIL) (CDR ML)) | |
1706 | (R NIL)) | |
1707 | ((NULL ML) (NREVERSE R)) | |
1708 | (PUSH `(FUNCALL #',(CAR ML) | |
1709 | (CAR .DAEMON-CALLER-ARGS.) (CAR .FOO.)) | |
1710 | R) | |
1711 | (AND (CDR ML) (PUSH '(SETQ .FOO. (CDR .FOO.)) R))))))) | |
1712 | ||
1713 | ; Combination types PROGN, AND, OR, MAX, MIN, +, APPEND, NCONC | |
1714 | ; These just call all the untyped methods, inside the indicated special form. | |
1715 | ; As an optimization, if there is only one method it is simply called. | |
1716 | ; ?? There should be hair where methods with an extra keyword in them | |
1717 | ; get to act as conditionals controlling which other methods get called, | |
1718 | ; if anyone can ever specify exactly what this means. | |
1719 | (DEFPROP :PROGN SIMPLE-METHOD-COMBINATION METHOD-COMBINATION) | |
1720 | (DEFPROP :AND SIMPLE-METHOD-COMBINATION METHOD-COMBINATION) | |
1721 | (DEFPROP :OR SIMPLE-METHOD-COMBINATION METHOD-COMBINATION) | |
1722 | (DEFPROP :MAX SIMPLE-METHOD-COMBINATION METHOD-COMBINATION) | |
1723 | (DEFPROP :MIN SIMPLE-METHOD-COMBINATION METHOD-COMBINATION) | |
1724 | (DEFPROP :+ SIMPLE-METHOD-COMBINATION METHOD-COMBINATION) | |
1725 | (DEFPROP :APPEND SIMPLE-METHOD-COMBINATION METHOD-COMBINATION) | |
1726 | (DEFPROP :NCONC SIMPLE-METHOD-COMBINATION METHOD-COMBINATION) | |
1727 | ||
1728 | ; The following "tasteless" crock is necessary to make all work in Franz: | |
1729 | (eval-when (load eval) (loop for (to . from) in | |
1730 | '((:progn . progn) | |
1731 | (:and . and) | |
1732 | (:or . or) | |
1733 | (:max . max) | |
1734 | (:min . min) | |
1735 | (:+ . +) | |
1736 | (:append . append) | |
1737 | (:nconc . nconc)) | |
1738 | do | |
1739 | (putd to (getd from)))) | |
1740 | ||
1741 | (DEFUN SIMPLE-METHOD-COMBINATION (FL MAGIC-LIST-ENTRY) | |
1742 | (LET ((METHODS (GET-CERTAIN-METHODS MAGIC-LIST-ENTRY NIL NIL NIL NIL)) | |
1743 | (WRAPPERS-P (SPECIALLY-COMBINED-METHODS-PRESENT MAGIC-LIST-ENTRY))) | |
1744 | (OR (AND (NOT WRAPPERS-P) (NULL (CDR METHODS)) (CAR METHODS)) | |
1745 | (HAVE-COMBINED-METHOD FL MAGIC-LIST-ENTRY) | |
1746 | (MAKE-COMBINED-METHOD FL MAGIC-LIST-ENTRY | |
1747 | (CONS (CADR MAGIC-LIST-ENTRY) | |
1748 | (MAPCAR 'METHOD-CALL | |
1749 | METHODS)))))) | |
1750 | ||
1751 | ; :PASS-ON combination | |
1752 | ; The values from the individual methods are the arguments to the next one; | |
1753 | ; the values from the last method are the values returned by the combined | |
1754 | ; method. Format is | |
1755 | ; (:METHOD-COMBINATION (:PASS-ON (ORDERING . ARGLIST)) . OPERATION-NAMES) | |
1756 | ; ORDERING is :BASE-FLAVOR-FIRST or :BASE-FLAVOR-LAST. ARGLIST can have | |
1757 | ; &AUX and &OPTIONAL. | |
1758 | ||
1759 | (DEFUN (:PASS-ON METHOD-COMBINATION) (FL MAGIC-LIST-ENTRY) | |
1760 | (LET ((METHODS (GET-CERTAIN-METHODS MAGIC-LIST-ENTRY NIL NIL NIL | |
1761 | (CAADDR MAGIC-LIST-ENTRY))) | |
1762 | (ARGLIST (CDADDR MAGIC-LIST-ENTRY)) | |
1763 | ARGS REST-ARG-P) | |
1764 | (DO ((L ARGLIST (CDR L)) | |
1765 | (ARG) | |
1766 | (NL NIL)) | |
1767 | ((NULL L) | |
1768 | (SETQ ARGS (NREVERSE NL))) | |
1769 | (SETQ ARG (CAR L)) | |
1770 | (AND (LISTP ARG) | |
1771 | (SETQ ARG (CAR ARG))) | |
1772 | (COND ((EQ ARG '&REST) | |
1773 | (SETQ REST-ARG-P T)) | |
1774 | ((EQ ARG '&AUX)) | |
1775 | (T | |
1776 | (PUSH ARG NL)))) | |
1777 | (OR (HAVE-COMBINED-METHOD FL MAGIC-LIST-ENTRY) | |
1778 | (MAKE-COMBINED-METHOD FL MAGIC-LIST-ENTRY | |
1779 | `(DESTRUCTURING-BIND ,(CONS '.OPERATION. ARGLIST) SI:.DAEMON-CALLER-ARGS. | |
1780 | . ,(DO ((METHS METHODS (CDR METHS)) | |
1781 | (LIST NIL) | |
1782 | (METH)) | |
1783 | ((NULL METHS) | |
1784 | (NREVERSE LIST)) | |
1785 | (SETQ METH `(,(IF REST-ARG-P | |
1786 | 'LEXPR-FUNCALL | |
1787 | 'FUNCALL) | |
1788 | #',(CAR METHS) .OPERATION. . ,ARGS)) | |
1789 | (AND (CDR METHS) | |
1790 | (SETQ METH (IF (NULL (CDR ARGS)) | |
1791 | `(SETQ ,(CAR ARGS) ,METH) | |
1792 | `(MULTIPLE-VALUE ,ARGS ,METH)))) | |
1793 | (PUSH METH LIST))))))) | |
1794 | \f | |
1795 | ; This function does most of the analysis of the magic-list-entry needed by | |
1796 | ; method-combination functions, including most error checking. | |
1797 | ; Returns a list of the method symbols for METHOD-TYPE extracted from | |
1798 | ; MAGIC-LIST-ENTRY. This value is shared with the data structure, don't | |
1799 | ; bash it. OTHER-METHODS-ALLOWED is a list of method types not to complain | |
1800 | ;about (T = allow all). | |
1801 | ; NO-METHODS-OK = NIL means to complain if the returned value would be NIL. | |
1802 | ; ORDERING-DECLARATION is :BASE-FLAVOR-FIRST, :BASE-FLAVOR-LAST, or NIL | |
1803 | ; meaning take one of those symbols from the MAGIC-LIST-ENTRY." | |
1804 | ||
1805 | (DEFUN GET-CERTAIN-METHODS (MAGIC-LIST-ENTRY METHOD-TYPE OTHER-METHODS-ALLOWED | |
1806 | NO-METHODS-OK ORDERING-DECLARATION | |
1807 | &AUX (METHODS NIL)) | |
1808 | ;; Find the methods of the desired type, and barf at any extraneous methods | |
1809 | (DOLIST (X (CDDDR MAGIC-LIST-ENTRY)) | |
1810 | (COND ((EQ (CAR X) METHOD-TYPE) (SETQ METHODS (CDR X))) | |
1811 | ((ASSQ (CAR X) *SPECIALLY-COMBINED-METHOD-TYPES*) ) ;Wrappers ignored at this level | |
1812 | ((OR (EQ OTHER-METHODS-ALLOWED T) (MEMQ (CAR X) OTHER-METHODS-ALLOWED)) ) | |
1813 | (T (FERROR () "~S ~S method(s) illegal when using :~A method-combination" | |
1814 | (CAR X) (CAR MAGIC-LIST-ENTRY) | |
1815 | (OR (CADR MAGIC-LIST-ENTRY) ':DAEMON))))) | |
1816 | ;; Complain if no methods supplied | |
1817 | (AND (NULL METHODS) (NOT NO-METHODS-OK) | |
1818 | (FERROR () "No ~S ~S method(s) supplied to :~A method-combination" | |
1819 | METHOD-TYPE (CAR MAGIC-LIST-ENTRY) (CADR MAGIC-LIST-ENTRY))) | |
1820 | ;; Get methods into proper order. Don't use NREVERSE! | |
1821 | (SELECTQ (OR ORDERING-DECLARATION (SETQ ORDERING-DECLARATION (CADDR MAGIC-LIST-ENTRY))) | |
1822 | (:BASE-FLAVOR-FIRST ) | |
1823 | (:BASE-FLAVOR-LAST (SETQ METHODS (REVERSE METHODS))) | |
1824 | (OTHERWISE (FERROR () "~S invalid method combination order; | |
1825 | must be :BASE-FLAVOR-FIRST or :BASE-FLAVOR-LAST" | |
1826 | ORDERING-DECLARATION))) | |
1827 | METHODS) | |
1828 | ||
1829 | (DEFUN SPECIALLY-COMBINED-METHODS-PRESENT (MLE) | |
1830 | (LOOP FOR (TYPE) IN (CDDDR MLE) | |
1831 | THEREIS (ASSQ TYPE *SPECIALLY-COMBINED-METHOD-TYPES*))) | |
1832 | ||
1833 | ;; It is up to the caller to decide that a combined-method is called for at all. | |
1834 | ;; If one is, this function decides whether it already exists OK or needs | |
1835 | ;; to be recompiled. Returns the symbol for the combined method if it is | |
1836 | ;; still valid, otherwise returns NIL. | |
1837 | ;; Always canonicalizes the magic-list-entry, since it will be needed | |
1838 | ;; canonicalized later. | |
1839 | (DEFUN HAVE-COMBINED-METHOD (FL MAGIC-LIST-ENTRY | |
1840 | &AUX OPERATION-NAME CMS MTE OLD-MLE OLD-CMS TEM OMETH) | |
1841 | ;; Canonicalize the magic-list-entry so can compare with EQUAL | |
1842 | (SETF (CDDDR MAGIC-LIST-ENTRY) ;Canonicalize before comparing | |
1843 | (SORTCAR (CDDDR MAGIC-LIST-ENTRY) #'ALPHALESSP)) ;Sort by method-type | |
1844 | (SETQ OPERATION-NAME (CAR MAGIC-LIST-ENTRY)) | |
1845 | ;; See if we can inherit one in either the current or future (being-compiled) world, | |
1846 | ;; or use an existing combined method of this flavor. | |
1847 | ;; Get the :COMBINED method function spec for this flavor. Note that if a suitable | |
1848 | ;; one can be inherited, we will do so. | |
1849 | ;; *USE-OLD-COMBINED-METHODS* controls whether we reuse an existing one for this | |
1850 | ;; flavor; if we inherit one it will always be up-to-date already. | |
1851 | ;; If all OK, return the function spec, else return NIL if new combined method must be made. | |
1852 | (OR (DOLIST (FFL (FLAVOR-DEPENDS-ON-ALL FL)) | |
1853 | (LET ((FLAVOR1 (GET-FLAVOR FFL))) | |
1854 | (AND (OR (NEQ FLAVOR1 FL) *USE-OLD-COMBINED-METHODS*) | |
1855 | ;; ^ Combined methods of this flavor can be used only if permitted. | |
1856 | (SETQ MTE (ASSQ OPERATION-NAME (FLAVOR-METHOD-TABLE FLAVOR1))) | |
1857 | (SETQ OMETH (METH-LOOKUP ':COMBINED (CDDDR MTE))) | |
1858 | (METH-DEFINEDP OMETH) | |
1859 | (METH-DEFINITION OMETH) | |
1860 | (SETQ CMS (METH-FUNCTION-SPEC OMETH)) | |
1861 | (EQUAL MAGIC-LIST-ENTRY | |
1862 | (SETQ TEM (GET (METH-PLIST OMETH) 'COMBINED-METHOD-DERIVATION))) | |
1863 | (RETURN CMS))) | |
1864 | ;Save first combined-method seen for tracing, it's the one we would | |
1865 | ;have been most likely to inherit | |
1866 | (OR OLD-CMS (NULL CMS) (NULL TEM) | |
1867 | (SETQ OLD-CMS CMS OLD-MLE TEM))) | |
1868 | ||
1869 | ;; Have to make a new combined method. Trace if desired, but return NIL in any case. | |
1870 | (PROGN | |
1871 | (COND (*FLAVOR-COMPILE-TRACE* | |
1872 | (FORMAT *FLAVOR-COMPILE-TRACE* | |
1873 | "~&~S's ~S combined method needs to be recompiled~%to come from " | |
1874 | (FLAVOR-NAME FL) OPERATION-NAME) | |
1875 | (PRINT-COMBINED-METHOD-DERIVATION MAGIC-LIST-ENTRY *FLAVOR-COMPILE-TRACE*) | |
1876 | (COND (OLD-CMS | |
1877 | (FORMAT *FLAVOR-COMPILE-TRACE* | |
1878 | "~%rather than using ~S which comes from " OLD-CMS) | |
1879 | (PRINT-COMBINED-METHOD-DERIVATION OLD-MLE *FLAVOR-COMPILE-TRACE*)) | |
1880 | ((NOT *USE-OLD-COMBINED-METHODS*) | |
1881 | (FORMAT *FLAVOR-COMPILE-TRACE* "~%because of forced recompilation."))))) | |
1882 | NIL))) | |
1883 | ||
1884 | ||
1885 | (DEFUN PRINT-COMBINED-METHOD-DERIVATION (MLE STREAM) | |
1886 | (LOOP FOR (TYPE . FUNCTION-SPECS) IN (CDDDR MLE) | |
1887 | DO (LOOP FOR FUNCTION-SPEC IN FUNCTION-SPECS DO (FORMAT STREAM "~S " FUNCTION-SPEC))) | |
1888 | (IF (OR (CADR MLE) (CADDR MLE)) | |
1889 | (FORMAT STREAM "with method-combination ~S ~S" (CADR MLE) (CADDR MLE)))) | |
1890 | \f | |
1891 | ;; This function creates a combined-method, and returns the appropriate function spec. | |
1892 | ;; Its main job in life is to take care of wrappers. Note the combined method | |
1893 | ;; always takes a single &REST argument named .DAEMON-CALLER-ARGS. | |
1894 | ;; FORM is a single form to be used as the body. | |
1895 | (DEFUN MAKE-COMBINED-METHOD (FL MAGIC-LIST-ENTRY FORM &AUX FSPEC WRAPPERS) | |
1896 | ;; Get the function spec which will name the combined-method | |
1897 | (SETQ FSPEC `(:METHOD ,(FLAVOR-NAME FL) :COMBINED ,(CAR MAGIC-LIST-ENTRY))) | |
1898 | ;; Put the wrappers around the form. The base-flavor wrapper goes on the inside. | |
1899 | (SETQ WRAPPERS (GET-SPECIALLY-COMBINED-METHODS MAGIC-LIST-ENTRY FL)) | |
1900 | (DOLIST (METHOD WRAPPERS) | |
1901 | (SETQ FORM (FUNCALL (CADR (ASSQ (CADDR METHOD) *SPECIALLY-COMBINED-METHOD-TYPES*)) | |
1902 | METHOD FORM))) | |
1903 | ;; Remember that it's going to be there, for HAVE-COMBINED-METHOD | |
1904 | (FLAVOR-NOTICE-METHOD FSPEC) | |
1905 | ;; Compile the function. It will be inserted into the flavor's tables either | |
1906 | ;; now or when the QFASL file is loaded. | |
1907 | (COMPILE-AT-APPROPRIATE-TIME | |
1908 | FL | |
1909 | FSPEC | |
1910 | `(LAMBDA (&REST .DAEMON-CALLER-ARGS.) | |
1911 | .DAEMON-CALLER-ARGS. | |
1912 | ,FORM) | |
1913 | `(FUNCTION-SPEC-PUTPROP ',FSPEC | |
1914 | ',MAGIC-LIST-ENTRY | |
1915 | 'COMBINED-METHOD-DERIVATION)) | |
1916 | FSPEC) | |
1917 | ||
1918 | ||
1919 | (LOCAL-DECLARE ((SPECIAL *FL*)) | |
1920 | (DEFUN GET-SPECIALLY-COMBINED-METHODS (MLE *FL*) | |
1921 | (SORT (LOOP FOR (TYPE . FSPECS) IN (CDDDR MLE) | |
1922 | WHEN (ASSQ TYPE *SPECIALLY-COMBINED-METHOD-TYPES*) | |
1923 | APPEND FSPECS) | |
1924 | #'(LAMBDA (FS1 FS2) | |
1925 | (LOOP WITH FL1 = (CADR FS1) AND FL2 = (CADR FS2) | |
1926 | FOR SUP IN (FLAVOR-DEPENDS-ON-ALL *FL*) | |
1927 | WHEN (EQ SUP FL2) RETURN T ;Base flavor earlier in list | |
1928 | WHEN (EQ SUP FL1) RETURN NIL))))) | |
1929 | ||
1930 | (DEFUN PUT-WRAPPER-INTO-COMBINED-METHOD (WRAPPER-NAME FORM) | |
1931 | (LET ((DEF (COND #-Franz ((DECLARED-DEFINITION WRAPPER-NAME)) | |
1932 | ;; What would the above mean in Franz? | |
1933 | ((getd (method-function-name WRAPPER-NAME))) | |
1934 | (T (FERROR () "~S supposed to be a wrapper macro, but missing!" | |
1935 | WRAPPER-NAME))))) | |
1936 | (COND ((not (and (dtpr DEF) | |
1937 | (eq (CAR DEF) 'MACRO))) | |
1938 | (FERROR () "~S, supposed to be a wrapper macro, is poorly formed. Definiton is ~s" | |
1939 | WRAPPER-NAME DEF))) | |
1940 | ;; Here we just put the wrapper in as a macro. It will be expanded by the compiler. | |
1941 | `(MACROCALL ,WRAPPER-NAME .DAEMON-CALLER-ARGS. ,FORM))) | |
1942 | ||
1943 | ;Sort of a macro version of funcall, for wrappers | |
1944 | (DEFMACRO MACROCALL (&REST X) | |
1945 | (LET ((MACRO (COND #-Franz ((DECLARED-DEFINITION (CAR X))) | |
1946 | ((method-function-name (CAR X))) | |
1947 | (T (FERROR () "Unable to find definition of wrapper ~s at expand time" | |
1948 | (CAR X)))))) | |
1949 | (IF (AND (LISTP MACRO) (EQ (CAR MACRO) 'MACRO)) | |
1950 | (FUNCALL (cons 'lambda (CDR MACRO)) X) | |
1951 | ;--- Temporary code so I can test things in the kludge environment | |
1952 | (IF (AND (SYMBOLP MACRO) (LISTP (getd MACRO)) | |
1953 | (EQ (CAR (getd MACRO)) 'MACRO)) | |
1954 | (FUNCALL (cons 'lambda (CDR (getd MACRO))) X) | |
1955 | (FERROR () "~S evaluated to ~S, which is not a macro" | |
1956 | (CAR X) MACRO))))) | |
1957 | \f | |
1958 | ;; Given a functional object, return its subfunction to do the given | |
1959 | ;; operation or NIL. Returns NIL if it does not reduce to a select-method | |
1960 | ;; or if it does not handle that." | |
1961 | (DEFUN GET-HANDLER-FOR (FUNCTION OPERATION &OPTIONAL (SUPERIORS-P T) &AUX TEM) | |
1962 | (COND ((SYMBOLP FUNCTION) | |
1963 | (COND ((SETQ TEM (GET FUNCTION 'FLAVOR)) | |
1964 | (GET-FLAVOR-HANDLER-FOR TEM OPERATION)))) | |
1965 | ((:TYPEP FUNCTION 'FLAVOR) | |
1966 | (GET-FLAVOR-HANDLER-FOR (FLAVOR-NAME FUNCTION) OPERATION)) | |
1967 | ((INSTANCEP FUNCTION) | |
1968 | ; SMH@EMS VVV | |
1969 | ; (GET-FLAVOR-HANDLER-FOR (FLAVOR-NAME (VREF FUNCTION 6)) | |
1970 | ; OPERATION) | |
1971 | (GET-FLAVOR-HANDLER-FOR | |
1972 | (FLAVOR-NAME (INT:FCLOSURE-STACK-STUFF (VREF FUNCTION 2))) | |
1973 | OPERATION) | |
1974 | ; SMH@EMS ^^^ | |
1975 | ))) | |
1976 | ||
1977 | ;;; Get the function that would handle an operation for a flavor | |
1978 | (DEFUN GET-FLAVOR-HANDLER-FOR (FLAVOR-NAME OPERATION &AUX FL) | |
1979 | (CHECK-ARG FLAVOR-NAME (SETQ FL (GET FLAVOR-NAME 'FLAVOR)) | |
1980 | "the name of a flavor") | |
1981 | ;; Do any composition (compilation) of combined stuff, if not done already | |
1982 | (OR (FLAVOR-DEPENDS-ON-ALL FL) (COMPOSE-FLAVOR-COMBINATION FL)) | |
1983 | (OR (FLAVOR-METHOD-HASH-TABLE FL) (COMPOSE-METHOD-COMBINATION FL)) | |
1984 | (GETHASH OPERATION (FLAVOR-METHOD-HASH-TABLE FL))) | |
1985 | ||
1986 | (DEFUN SYMEVAL-IN-INSTANCE (INSTANCE VAR) | |
1987 | (CHECK-ARG INSTANCE INSTANCEP "an instance") | |
1988 | (SYMEVAL-IN-FCLOSURE INSTANCE VAR)) | |
1989 | ||
1990 | (DEFSETF SYMEVAL-IN-INSTANCE (E V) `(SET-IN-INSTANCE ,(CADR E) ,(CADDR E) ,V)) | |
1991 | ||
1992 | (DEFUN SET-IN-INSTANCE (INSTANCE VAR VAL) | |
1993 | (CHECK-ARG INSTANCE INSTANCEP "an instance") | |
1994 | (SET-IN-FCLOSURE INSTANCE VAR VAL)) | |
1995 | ||
1996 | ;Interface to the compiler. | |
1997 | (DEFUN COMPILE-AT-APPROPRIATE-TIME (FL NAME LAMBDA-EXP &OPTIONAL FORM-TO-EVAL) | |
1998 | (PUTD (METHOD-FUNCTION-NAME NAME) | |
1999 | (LAMBDACVT (CDR LAMBDA-EXP)))) | |
2000 | ||
2001 | ;This macro takes flavor names as "arguments". It causes the compiler | |
2002 | ;to include the appropriate methods in the qfasl file, provided all the | |
2003 | ;component flavors are defined. | |
2004 | (DEFMACRO COMPILE-FLAVOR-METHODS (&REST FLAVOR-NAMES) | |
2005 | `(PROGN 'COMPILE | |
2006 | (EVAL-WHEN (COMPILE) | |
2007 | . ,(MAPCAN #'(LAMBDA (FLAVOR-NAME) | |
2008 | (NCONC (AND (GET FLAVOR-NAME 'FLAVOR) | |
2009 | (NCONS `(PUTPROP (FLAVOR-PLIST | |
2010 | (GET ',FLAVOR-NAME 'FLAVOR)) | |
2011 | T | |
2012 | 'COMPILE-FLAVOR-METHODS))) | |
2013 | (NCONS `(COMPILE-FLAVOR-METHODS-1 ',FLAVOR-NAME)))) | |
2014 | FLAVOR-NAMES)) | |
2015 | (EVAL-WHEN (LOAD EVAL) | |
2016 | . ,(MAPCAR #'(LAMBDA (FLAVOR-NAME) `(COMPILE-FLAVOR-METHODS-2 ',FLAVOR-NAME)) | |
2017 | FLAVOR-NAMES)))) | |
2018 | ||
2019 | ;; Cause the combined-methods to get compiled. | |
2020 | ;; Executed only from the compiler, and does something | |
2021 | ;; only if compiling to a file. | |
2022 | (DEFUN COMPILE-FLAVOR-METHODS-1 (FLAVOR-NAME &AUX FL) | |
2023 | (IF (JUST-COMPILING) | |
2024 | (LET ((*JUST-COMPILING* T) | |
2025 | (*USE-OLD-COMBINED-METHODS* NIL)) | |
2026 | (COND ((FLAVOR-COMPONENTS-DEFINED-P FLAVOR-NAME 'COMPILE-FLAVOR-METHODS) | |
2027 | (SETQ FL (GET-FLAVOR FLAVOR-NAME)) | |
2028 | ;; Make sure we are not hacking the installed flavor object, | |
2029 | ;; in case there is no defflavor or defmethod for the flavor in this file. | |
2030 | (AND (EQ FL (GET FLAVOR-NAME 'FLAVOR)) | |
2031 | (COMPILATION-DEFINE-FLAVOR | |
2032 | FLAVOR-NAME | |
2033 | (SETQ FL (FLAVOR-REDEFINITION-FOR-COMPILATION FL NIL)))) | |
2034 | (OR (FLAVOR-DEPENDS-ON-ALL FL) | |
2035 | (COMPOSE-FLAVOR-COMBINATION FL)) | |
2036 | (COMPOSE-METHOD-COMBINATION FL NIL)))))) | |
2037 | ||
2038 | ;; Do the composition now. This should normally just generate data-structure | |
2039 | ;; as the methods should already all have been compiled, unless something has changed. | |
2040 | (DEFUN COMPILE-FLAVOR-METHODS-2 (FLAVOR-NAME &AUX FL) | |
2041 | (CHECK-ARG FLAVOR-NAME (SETQ FL (GET FLAVOR-NAME 'FLAVOR)) "the name of a flavor") | |
2042 | (PUTPROP (FLAVOR-PLIST FL) T 'COMPILE-FLAVOR-METHODS) | |
2043 | (COND ((FLAVOR-COMPONENTS-DEFINED-P FLAVOR-NAME) | |
2044 | (OR (FLAVOR-DEPENDS-ON-ALL FL) (COMPOSE-FLAVOR-COMBINATION FL)) | |
2045 | (OR (FLAVOR-METHOD-HASH-TABLE FL) | |
2046 | (COMPOSE-METHOD-COMBINATION FL)))) | |
2047 | FLAVOR-NAME) | |
2048 | ||
2049 | ;Returns T if all components of this flavor are defined | |
2050 | (DEFUN FLAVOR-COMPONENTS-DEFINED-P (FLAVOR-NAME &OPTIONAL COMPLAINT &AUX FL) | |
2051 | (COND ((SETQ FL (GET-FLAVOR FLAVOR-NAME)) | |
2052 | (OR (NOT (NULL (FLAVOR-DEPENDS-ON-ALL FL))) ;Already composed, be fast | |
2053 | (AND (DO ((L (FLAVOR-DEPENDS-ON FL) (CDR L))) ((NULL L) T) | |
2054 | (OR (FLAVOR-COMPONENTS-DEFINED-P (CAR L)) (RETURN NIL))) | |
2055 | (DO ((L (FLAVOR-INCLUDES FL) (CDR L))) ((NULL L) T) | |
2056 | (OR (FLAVOR-COMPONENTS-DEFINED-P (CAR L)) (RETURN NIL)))))) | |
2057 | (COMPLAINT (FORMAT ERRPORT "~&~A - ~S undefined flavor" COMPLAINT FLAVOR-NAME) | |
2058 | NIL) | |
2059 | (T NIL))) | |
2060 | ||
2061 | (EVAL-WHEN (EVAL LOAD) (LOAD 'VANILLA)) | |
2062 | ||
2063 | ;; Local Modes: | |
2064 | ;; Mode: Lisp | |
2065 | ;; Case Search: 1 | |
2066 | ;; End: |