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