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