Return to flavors.l CVS log

Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / lisplib

Annotation of 43BSDTahoe/ucb/lisp/lisplib/flavors.l, revision 1.1

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.