![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to flavors.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib|
Return to flavors.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib |
1.1 root 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:
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:
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:
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:
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:
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:
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:
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:
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:
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:
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:
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:
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:
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:
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:
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:
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:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.