LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031415. :SYSTEM-TYPE :LOGICAL :VERSION 13. :TYPE "LISP" :NAME "FLAVOR" :DIRECTORY ("REL3-SOURCE" "KERNEL") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758639716. :AUTHOR "REL3" :LENGTH-IN-BYTES 218346. :LENGTH-IN-BLOCKS 214. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            ; Tasteful Flavors-*- cold-load:t; Mode: common-Lisp; Package: SI; Base:8-*-;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in;;;Technical Data and Computer Software clause at 52.227-7013.;;;                     TEXAS INSTRUMENTS INCORPORATED.;;;                              P.O. BOX 2909;;;                           AUSTIN, TEXAS 78769;;;                                 MS 2151;;; Copyright (C) 1985,1987 Texas Instruments Incorporated. All rights reserved.; A flavor-name is a symbol which names a type of objects defined; by the combination of several flavors.  The SI:FLAVOR; property is a data-structure (of type FLAVOR) defining the; nature of the flavor, as defined below.; Flavors come in essentially three kinds.  The first kind defines a class; of flavors, and provides the basic instance variables and methods for; that class.  This kind typically includes only VANILLA-FLAVOR as a; component, and uses the :REQUIRED-INSTANCE-VARIABLES and; :REQUIRED-METHODS options.  The second kind of flavor represents a; particular option that may be combined in (a "mix-in").  The third; kind of flavor is the kind that can usefully be instantiated; it is; a combination of one of the first kind and several of the second kind,; to achieve the behavior desired for a particular application.; The following symbols are interesting to outsiders:; DEFFLAVOR - macro for defining a flavor; DEFMETHOD - macro for defining a method; DEFWRAPPER - macro for defining a flavor-wrapper; INSTANTIATE-FLAVOR - create an object of a specified flavor; MAKE-INSTANCE - easier to call version of INSTANTIATE-FLAVOR; COMPILE-FLAVOR-METHODS - macro which does the right thing in the compiler; RECOMPILE-FLAVOR - function to recompile a flavor and maybe any flavors;that depend on it.  Usually this happens automatically.; DECLARE-FLAVOR-INSTANCE-VARIABLES - macro to put around a function;that will be called by methods and wants to access instance;variables.; FUNCALL-SELF - a macro which, assuming you are a flavor instance, will;call yourself without bothering about rebinding the;variables.  Will do something totally random if SELF;isn't a flavor instance.; LEXPR-FUNCALL-SELF - LEXPR-FUNCALL version of above; *ALL-FLAVOR-NAMES* - list of all symbols which have been used as the name of a flavor; *ALL-FLAVOR-NAMES-AARRAY* - completion aarray of flavor names to flavors.;Each flavor is included twice, once with and once without its package prefix.; *FLAVOR-COMPILATIONS* - list of all methods which had to be compiled;this is useful for finding flavors which weren't compiled in qfasl files;or which need to be recompiled to bring them up to date.; *FLAVOR-COMPILE-TRACE* - if non-NIL, a FORMAT destination for messages about;recompilation of combined methods; *USE-OLD-FLAVOR-INFO* - if NIL, re-DEFFLAVORing a flavor always makes a new one.;For debugging weird screws.;Also makes it possible to redefine a flavor and leave old;instances with the old methods, even if the flavor instance variables;are not being changed.; FLAVOR-ALLOWS-INIT-KEYWORD-P - determine whether a certain flavor allows;a certain keyword in its init-plist.; FLAVOR-ALLOWED-INIT-KEYWORDS - returns all the init keywords a flavor handles.; Roads not taken:;  o Changing the size of all extant instances of a flavor.;  o Nothing to stop you from instantiating a flavor of the first or;    second kind.  In practice you will usually get an error if you try it.; Philosophy with respect to multiple processes;  Interrupts are inhibited such that multiple processes munging unrelated;  flavors should work.  Multiple processes instantiating related flavors;  will work, however multiple processes defining methods for the same;  flavor at the same time, and things like that, will not.(defvar *integrate-combined-methods* ()   "When compiling a combined method, should the component methods be expanded inline?")  ;;; Phd 10/4/85 add this new flag to allow more that 120 settable instance variables.(defvar *flavor-enable-case-set-methods* t   "Enable generation of :case :set methods on settable instance variables")  ; This macro is used to define a flavor.  Use DEFMETHOD to define; methods (responses to messages sent to an instance of a flavor.(defmacro defflavor (name instance-variables component-flavors &rest options) "INSTANCE-VARIABLES can be symbols, or lists of symbol and initialization. COMPONENT-FLAVORS are searched from left to right for methods,  and contribute their instance variables. OPTIONS are:  (:GETTABLE-INSTANCE-VARIABLES v1 v2...)   (:SETTABLE-INSTANCE-VARIABLES v1 v2...)  (:REQUIRED-INSTANCE-VARIABLES v1 v2...)  (:REQUIRED-METHODS m1 m2...)  (:REQUIRED-FLAVORS f1 f2...)  (:INITTABLE-INSTANCE-VARIABLES v1 v2...)  (:INIT-KEYWORDS k1 k2...)  (:DEFAULT-INIT-PLIST k1 v1 k2 v2...)  (:DEFAULT-HANDLER function)  (:INCLUDED-FLAVORS f1 f2...)  :NO-VANILLA-FLAVOR  (:ORDERED-INSTANCE-VARIABLES v1 v2...)  (:OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES v1 v2...)  (:ACCESSOR-PREFIX sym)  (:METHOD-ORDER m1 m2...)  (:METHOD-COMBINATION (type order operation1 operation2...)...)  (:DOCUMENTATION <args>...)  (:SPECIAL-INSTANCE-VARIABLES <variables>)  :ABSTRACT-FLAVOR   :ALIAS-FLAVOR"  ;There may be more.  (let ((copied-options (copy-list options)))    `(progn       (eval-when (load eval)  (defflavor2 ',name ',instance-variables ',component-flavors ',copied-options))       (eval-when (compile)  (if (just-compiling)    (let ((*just-compiling* t))      (defflavor2 ',name ',instance-variables ',component-flavors ',copied-options)      (compose-automatic-methods (compilation-flavor ',name)))    (compose-automatic-methods (get ',name 'flavor))))       (eval-when (eval) (compose-automatic-methods (get ',name 'flavor)))       (eval-when (load eval)  ,@(do ((vs  (do ((opts options (cdr opts)))      ((null opts)       nil)    (and (consp (car opts))       (eq (caar opts) :outside-accessible-instance-variables)       (return (cdar opts)))    (and (eq (car opts) :outside-accessible-instance-variables)       (return(mapcar #'(lambda (x)    (if (atom x)      x      (car x)))instance-variables))))  (cdr vs)) (prefix  (or (cadr (assq-careful :accessor-prefix options)) (string-append name "-"))) (ords  (do ((opts options (cdr opts)))      ((null opts)       nil)    (and (consp (car opts)) (eq (caar opts) :ordered-instance-variables)       (return (cdar opts)))    (and (eq (car opts) :ordered-instance-variables)       (return(mapcar #'(lambda (x)    (if (atom x)      x      (car x)))instance-variables))))) (res nil  (cons   `(defsubst ,(intern1 (string-append prefix (car vs))) (,name)      (declare (function-parent ,name))      ,(if (member (car vs) ords :test #'eq) `(%instance-ref ,name ,(1+ (position (car vs) (the list ords) :test #'eq))) `(symeval-in-instance ,name ',(car vs))))   res)))((null vs) res)))       ,@(make-run-time-alternative-defflavors name       (or(cdr (assq-careful :run-time-alternatives options))(cdr (assq-careful :mixture options))))       ',name)))  (defprop defflavor2 t qfasl-dont-record)  (defun defflavor2 (name instance-variables component-flavors copied-options)  (cond    ((and (variable-boundp file-warnings-datum) file-warnings-datum)     (object-operation-with-warnings (name)(compiler:warn-on-errors ('flavor-definition-error "Error in flavor definition")   (defflavor1 name instance-variables component-flavors copied-options))))    (t (defflavor1 name instance-variables component-flavors copied-options))))  (defun undefflavor (flavor-name &aux fl)  "Make the flavor named FLAVOR-NAME cease to be defined."  (check-arg flavor-name     (typep (setq fl (if (symbolp flavor-name)       (get flavor-name 'flavor)       flavor-name)) 'flavor)     "a flavor or the name of one")  (dolist (dependent (flavor-depended-on-by fl))    (push (cons (flavor-name fl) dependent) *flavor-pending-depends*))  (perform-flavor-redefinition (flavor-name fl) t)  (remprop (flavor-name fl) 'flavor))  ; This wraps a local-declare special of the instance variables around its body.; It's good for things like defining functions that deal with a flavor but; are not methods (generally they are called by methods.)(defmacro zlc:declare-flavor-instance-variables ((flavor-name map-set-by-caller) &body body)  "Enable the BODY to access instance variables of SELF, being an instance of FLAVOR-NAME.The instance variables of SELF are made accessible under the assumptionthat, when this code is executed, SELF's flavor will include FLAVOR-NAMEas a component flavor.This macro may go around expressions in a function, or aroundentire function definitions.  In the latter case, it is equivalentto writing (DECLARE (:SELF-FLAVOR flavor-name)) inside the functions."  (let ((flavor-declaration (if (eq flavor-name 'vanilla-flavor)   '(:self-flavor vanilla-flavor nil)   (let ((*just-compiling* (just-compiling)))     (flavor-declaration flavor-name))))decls)    (or map-set-by-caller (setq body (list `(with-self-accessible ,flavor-name ,@body))))    (if flavor-declaration      (push flavor-declaration decls))    `(local-declare ,decls(compiler-let ((self-flavor-declaration ',(cdr flavor-declaration))) ,@body))))  ;Interpreted definition.  Only works compiled.(defun with-self-variables-bound (&rest body)  "Execute the body with all instance variables of SELF bound as specials.This means that the body can use SYMEVAL, BOUNDP, etc. on them."  (with-self-variables-bound (apply 'progn body)))  ;This produces a list suitable for %USING-BINDING-INSTANCES.;It provides run-time support for the compiled code for WITH-SELF-VARIABLES-BOUND.(defun self-binding-instances ()  (and (typep self 'instance)     (do ((index 1 (1+ index))  (ivars (flavor-all-instance-variables (instance-flavor self)) (cdr ivars))  (bindings)  (normal-bindings-left (flavor-bindings (instance-flavor self)))  (next-normal-binding)) ((null ivars) bindings)  ;; Figure out whether the next ivar is bound as special by message sending.       (or (and (numberp next-normal-binding) (plusp next-normal-binding))  (setq next-normal-binding (pop normal-bindings-left)))       (if (numberp next-normal-binding) (decf next-normal-binding))       ;; If it isn't, we must put it on our binding list to be bound now.       (or (locativep next-normal-binding)  (setq bindings(list* (locf (symbol-value (car ivars))) (%instance-loc self index) bindings))))))  ;Interpreted definition, which binds all instance variables as specials.(defun with-self-accessible (&quote flavor-name &rest body)  flavor-name  (with-self-variables-bound (apply 'progn body)))    ;; These two for compatibility with the new Symbolics system.(defmacro defun-method (fspec flavor-name arglist &body body)  `(defun ,fspec ,arglist     (declare (:self-flavor ,flavor-name))     ,@body)) (defmacro instance-variable-boundp (x)  `(boundp ',x))  (defmacro defwhopper ((flavor-name operation) arglist &body body)  "sugar coating of :`(defmethod (,flavor-name :around ,operation) (.continuation. .mapping-table. .around-args. ,@arglist)     ,@body),used for other LISP MACHINES compatibility"  `(defmethod (,flavor-name :around ,operation) (.continuation. .mapping-table. .around-args. ,@arglist)     ,@body))  (defmacro continue-whopper (&rest arguments)  `(funcall-with-mapping-table .continuation. .mapping-table. (car .around-args.) ,@arguments))  (defmacro lexpr-continue-whopper (&rest arguments)  `(lexpr-funcall-with-mapping-table .continuation. .mapping-table. (car .around-args.)      ,@arguments))  (defvar *all-flavor-names* ())  ;List of names of all flavors (mostly for editor)(defvar *all-flavor-names-aarray*;For editor's completing reader   (make-array 2400;736 flavors in system 75       :type 'art-q-list :leader-list '(0 nil)))  (defun sort-aarray (aarray)  (cond ((not (array-leader aarray 1));If not sorted right now (sort aarray #'string-lessp :key #'car) (setf (array-leader aarray 1) t))));(add-initialization "Condense Flavor Name Tables";    '(progn;       (sort-aarray *all-flavor-names-aarray*);       (if (= (%p-cdr-code *all-flavor-names*) cdr-normal); (setq *all-flavor-names* (copylist *all-flavor-names*))));    '(:before-cold))  ;Don't let these get left bound losingly after a warm boot.(add-initialization "Reinit possibly bound flavor globals"    '(setq *use-old-combined-methods* t   *just-compiling* ()) '(:warm))  (defvar *use-old-flavor-info* t)    ;T means DEFFLAVOR1 only "unhooks" if the flavor;has changed incompatibly, NIL means always unhook;if flavor already existed.(defvar *use-old-combined-methods* t)  ;T means recycle old, NIL means generate new.; This is an implicit argument to certain routines.(defvar *flavor-pending-depends* ())  ;Used by DEFFLAVOR1(defvar *flavor-compilations* ())  ;List of methods compiled(defvar *flavor-compile-trace* ())  (defvar *just-compiling* ())  ;T means putting combined methods into qfasl file,; not updating the current flavor data-structure;T if we are inside a compilation going to a binary file.;We do not simply call this function wherever we want to check,;but instead bind *JUST-COMPILING* at various points;and check that.  The reason is that those points are all;inside (EVAL-WHEN (COMPILE) ..)'s; as a result, any flavor;hacking done randomly inside the compiler's execution;finds *JUST-COMPILING* is NIL, as it should.(defun just-compiling ()  (and (boundp 'compiler::qc-file-in-progress) compiler::qc-file-in-progress     (not compiler::qc-file-load-flag)))  ;This is an area in which to cons data internal to the flavor system.  It is used;rather than default-cons-area as a hedge against temporary area lossage which can;happen if you do things from an error in a compilation, or if you make instances;in a temporary area and that requires composing flavors or methods.#-elroy(defvar *flavor-area* working-storage-area)  ; These two functions are used when sending a message to yourself, for extra efficiency.(defmacro zlc:funcall-self (&rest args)  "Like FUNCALL of SELF, but a little faster,"  `(funcall self ,@args))  (defmacro zlc:lexpr-funcall-self (&rest args)  "Like LEXPR-FUNCALL of SELF, but a little faster."  `(apply self ,@args))  (defsubst instance-flavor (instance)  "Returns the flavor-object of a given flavor instance."  (%make-pointer dtp-array-pointer (%p-contents-as-locative-offset instance 0)))  (defsubst instance-function (instance)  "Returns the handler-function of the flavor of INSTANCE."  (%p-contents-offset (%p-contents-as-locative-offset instance 0) %instance-descriptor-function))  ;When compiling files, we make a new flavor object for each flavor;defined in the file.  That way we win if the definition in the file;does not match the one loaded.  These flavors live in a FILE-LOCAL-DECLARATION;element which looks like (FLAVORS name flavor name flavor ...);This function, given a flavor name or flavor object,;gives the right flavor object to use.  If compiling a file,;it uses the compilation flavor if any; otherwise, it uses the installed flavor.(defun compilation-flavor (flavor-or-name &optional (use-compilation-flavors *just-compiling*))  "Returns the appropriate flavor object for the specified flavor.If compiling, it returns the compilation-time flavor object correspondingto the specified flavor or flavor name.  If not compiling, returns theactual installed flavor object.  USE-COMPILATION-FLAVORS specifies whetherto assume we are compiling or not; it defaults to the truth."  (or   (and use-compilation-flavors      (let* ((name (if (symbolp flavor-or-name)     flavor-or-name     (flavor-name flavor-or-name))))(get (assoc 'flavors file-local-declarations :test #'eq) name)))   (if (symbolp flavor-or-name)     (get flavor-or-name 'flavor)     flavor-or-name)))  ; The data-structure on the FLAVOR property of a flavor-name; This must agree with INSTANCE-DESCRIPTOR-OFFSETS in LISPM;QCOM#-elroy(defstruct (flavor :named :array (:constructor make-flavor) (:alterant nil)  (:make-array (:area permanent-storage-area)) (:conc-name nil) (:callable-constructors nil)  (:predicate nil) (:copier nil))  flavor-instance-size;1+ the number of instance variables  flavor-bindings;List of locatives to instance variable  ; internal value cells.  MUST BE CDR-CODED!!  ;Fixnums can also appear.  They say to skip  ;whatever number of instance variable slots.  flavor-method-hash-table;The hash table for methods of this flavor.  ; NIL means method-combination not composed yet.  ; T means abstract flavor with COMPILE-FLAVOR-METHODS done.  flavor-name;Symbol which is the name of the flavor.  ; This is returned by TYPEP.  flavor-component-mapping-table-alist;Alist of component flavor names vs.  ;locatives into vector containing mapping tables.  ;; End of magic locations known in microcode and QCOM.  flavor-local-instance-variables;Names and initializations,  ; does not include inherited ones.  flavor-all-instance-variables;Just names, only valid when flavor-combination composed.  ; Corresponds directly to FLAVOR-BINDINGS and the instances.  flavor-method-table;Defined below.  ;; End of locations depended on in many other files.  flavor-depends-on;List of names of flavors incorporated into this flavor.  flavor-depended-on-by;List of names of flavors which incorporate this one.  ;The above are only immediate dependencies.  flavor-includes;List of names of flavors to include at the end  ; rather than as immediate depends-on's.  flavor-package;Package in which the DEFFLAVOR was done.  flavor-depends-on-all;Names of all flavors depended on, to all levels, including  ; this flavor itself.  NIL means flavor-combination not  ; composed yet.  This is used by TYPEP of 2 arguments.  (flavor-which-operations ());List of operations handled, created when needed.  ; This is NIL if it has not been computed yet.  ;;This is the list of instance variables accessable from this flavor  ;;which are mapped by mapping tables with this flavor as the method-flavor.  (flavor-mapped-instance-variables ())  ;; Redundant copy of :DEFAULT-HANDLER property, for speed in calling it.  (flavor-default-handler ())  (flavor-inittable-instance-variables ());Alist from init keyword to name of variable  (flavor-init-keywords ());option  (flavor-plist ());Esoteric things stored here as properties  ;Known: :ORDERED-INSTANCE-VARIABLES, :DEFAULT-HANDLER  ; :OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES, :ACCESSOR-PREFIX,  ; :REQUIRED-INSTANCE-VARIABLES, :REQUIRED-METHODS,  ; :REQUIRED-FLAVORS, :SELECT-METHOD-ORDER,  ; :DEFAULT-INIT-PLIST, :DOCUMENTATION, :NO-VANILLA-FLAVOR  ; :GETTABLE-INSTANCE-VARIABLES :SETTABLE-INSTANCE-VARIABLES  ; :SPECIAL-INSTANCE-VARIABLES  ; :ABSTRACT-FLAVOR, :ALIAS-FLAVOR  ; :INSTANTIATION-FLAVOR-FUNCTION  ; :RUN-TIME-ALTERNATIVES or :MIXTURE  ; RUN-TIME-ALTERNATIVE-ALIST  ;   -- is the alist of lists of flavors vs  ;      names we constructed for those combinations.  ; ADDITIONAL-INSTANCE-VARIABLES  ; COMPILE-FLAVOR-METHODS  ; UNMAPPED-INSTANCE-VARIABLES  ; MAPPED-COMPONENT-FLAVORS  ; ALL-INSTANCE-VARIABLES-SPECIAL  ; INSTANCE-VARIABLE-INITIALIZATIONS  ; ALL-INITTABLE-INSTANCE-VARIABLES  ; REMAINING-DEFAULT-PLIST  ; REMAINING-INIT-KEYWORDS  ; :INSTANCE-AREA-FUNCTION - the one specified for this fl.  ; INSTANCE-AREA-FUNCTION - the one to be used (maybe inherited)  ; :REQUIRED-INIT-KEYWORDS - the ones specified for this fl.  ; REQUIRED-INIT-KEYWORDS - all required ones incl. inherited.  ;The convention on these is supposed to be that  ;ones in the keyword packages are allowed to be  ;used by users.  ;Some of these are not used by the flavor system, they are  ;just remembered on the plist in case anyone cares.  The  ;flavor system does all its handling of them during the  ;expansion of the DEFFLAVOR macro.)  ;Named-structure handler for above structure, to make it print nicer#-elroy(defun (:property flavor named-structure-invoke) (operation &optional self &rest args)  (case operation    (:which-operations '(:print-self :describe))    ((:print-self)     (printing-random-object (self (car args))(format (car args) "FLAVOR ~S" (flavor-name self))))    (:describe (describe-flavor self))    (otherwise (ferror () "~S unknown" operation))))  ;These properties are not discarded by redoing a DEFFLAVOR.(defparameter defflavor1-preserved-properties   '(additional-instance-variables all-instance-variables-special compile-flavor-methods     unmapped-instance-variables mapped-component-flavors instance-variable-initializations     all-special-instance-variables all-inittable-instance-variables remaining-default-plist     remaining-init-keywords required-init-keywords instance-area-function :obsolete-flavor))  ;A little slower, but eliminates compile-time dependency on details of flavor defstruct.(defun flavor-all-instance-variables-slow (flavor)  (flavor-all-instance-variables flavor))  ;Used by other files to avoid compile-time dependency on our defstruct.#-elroy(defun flavor-get (flavor prop)  (getf (flavor-plist flavor) prop))  (defsubst flavor-gettable-instance-variables (flavor)  (getf (flavor-plist flavor) :gettable-instance-variables))  (defsubst flavor-settable-instance-variables (flavor)  (getf (flavor-plist flavor) :settable-instance-variables))  (defsubst flavor-special-instance-variables (flavor)  (getf (flavor-plist flavor) :special-instance-variables))  (defsubst flavor-all-instance-variables-special (flavor)  "T if all instance variables of FLAVOR must be special due to old compiled methods."  (getf (flavor-plist flavor) 'all-instance-variables-special))  (defsubst flavor-all-special-instance-variables (flavor)  "Return a list of all the special instance variables of FLAVOR (a flavor object)."  (getf (flavor-plist flavor) 'all-special-instance-variables))  ;These are instance variables that don't belong to this flavor or its components;but can be accessed by methods of this flavor.(defsubst flavor-additional-instance-variables (flavor)  (getf (flavor-plist flavor) 'additional-instance-variables))  ;The next four are distillations of info taken from this flavor and its components,;used for instantiating this flavor.  See COMPOSE-FLAVOR-INITIALIZATIONS.(defsubst flavor-instance-variable-initializations (flavor)  (getf (flavor-plist flavor) 'instance-variable-initializations))  (defsubst flavor-remaining-default-plist (flavor)  (getf (flavor-plist flavor) 'remaining-default-plist))  (defsubst flavor-remaining-init-keywords (flavor)  (getf (flavor-plist flavor) 'remaining-init-keywords))  (defsubst flavor-all-inittable-instance-variables (flavor)  (getf (flavor-plist flavor) 'all-inittable-instance-variables))  ;This is a vector in which the mapping table locations in the alist point.(defsubst flavor-component-mapping-table-vector (flavor)  (getf (flavor-plist flavor) 'component-mapping-table-vector))  ;This is a list of flavors we depend on whose methods are referred;to by our combined methods.(defsubst flavor-mapped-component-flavors (flavor)  (getf (flavor-plist flavor) 'mapped-component-flavors))  ;This is a list of instance variables which are ordered;because of an :ORDERED-INSTANCE-VARIABLES declaration in some flavor we depend on.;They do not need to be mapped in mapping tables.(defsubst flavor-unmapped-instance-variables (flavor)  (getf (flavor-plist flavor) 'unmapped-instance-variables))  (defsubst flavor-unhandled-init-keywords (flavor)  (getf (flavor-plist flavor) 'unhandled-init-keywords))  ;Called by open-compiled TYPEP if second arg is a flavor name.(defun typep-flavor (x type &aux fl)  (cond    ((and (= (%data-type x) dtp-instance)(= (%p-data-type (setq fl (%p-contents-as-locative-offset x 0))) dtp-array-header)(eq (aref (setq fl (%make-pointer dtp-array-pointer fl)) 0) 'flavor))     (not (null (member type (flavor-depends-on-all fl) :test #'eq))))    ((get type 'flavor) nil)    (t (typep x type))))  ;Optimization turned out to be wrong#-elroy(defvar flavor-data-area   (make-area :name 'flavor-data-area :region-size 100000 :representation :list)   "Area for flavor plists and other lists associated with a flavor definition.")  (defun linearize-flavor-plists ()  "Recopy all flavor plists (and other things) so that they are linear and compact."  (dolist (name *all-flavor-names*)    (let ((fl (get name 'flavor)))      (unless (symbolp (flavor-method-hash-table fl))       ;; Cause rehash now if necessary.(gethash () (flavor-method-hash-table fl)))      (let ((default-cons-area flavor-data-area))(unless (= (%area-number (flavor-bindings fl)) flavor-data-area)  (setf (flavor-bindings fl) (copy-list (flavor-bindings fl))))(unless (= (%area-number (flavor-component-mapping-table-alist fl)) flavor-data-area)  (setf (flavor-component-mapping-table-alist fl)(copy-alist (flavor-component-mapping-table-alist fl))))(unless (= (%area-number (flavor-all-instance-variables fl)) flavor-data-area)  (setf (flavor-all-instance-variables fl)(copy-list (flavor-all-instance-variables fl))))(unless (= (%area-number (flavor-mapped-instance-variables fl)) flavor-data-area)  (setf (flavor-mapped-instance-variables fl)(copy-list (flavor-mapped-instance-variables fl))))(unless (= (%area-number (flavor-plist fl)) flavor-data-area)  (setf (flavor-plist fl) (copy-tree (flavor-plist fl)))))      ;; In any case force transport of all these lists to newspace now.      (nsubst '(nil) '(nil) (flavor-bindings fl))      (nsubst '(nil) '(nil) (flavor-component-mapping-table-alist fl))      (nsubst '(nil) '(nil) (flavor-all-instance-variables fl))      (nsubst '(nil) '(nil) (flavor-mapped-instance-variables fl))      (nsubst '(nil) '(nil) (flavor-plist fl)))))  ;;;(add-initialization "Linearize flavor plists" '(linearize-flavor-plists) '(:after-full-gc))  ;Format of flavor-method-table:; New format of a flavor-method-table entry is:;   (message combination-type combination-order meth...); A meth is:;   (function-spec definition plist); Thus the second element of a meth is actually a function-cell.; The meth's are stored in permanent-storage-area so that they will be compact.;    [That might not be the best area, the select-methods, and component;     lists, and instanc-variable lists, and which-operations's, are also there.]; A magic-list entry is:;   (message combination-type combination-order (method-type function-spec...)...); In the magic-list, there can be more than one method listed under a method-type,; the base flavor always comes first.  The :COMBINED methods are elided from; the magic-list.;; Special method-types:;   NIL - no type specified;   :DEFAULT - like NIL but only taken if there are no type-NIL methods;   :WRAPPER - wrappers are remembered this way;   :COMBINED - a combined method; it has a debug info entry;(COMBINED-METHOD-DERIVATION derivation) or else the function spec;has a property COMBINED-METHOD-DERIVATION whose value is the derivation.;The derivation is the magic list entry used to make the combined method.;The CDDDR is canonicalized; each contained list of method symbols is;of course ordered by the order in which flavors are combined (base;flavor first).  Canonical order is alphabetical by method-type.; Non-special method-types:;   :BEFORE, :AFTER - these are used by the default combination-type, :DAEMON;; Special hair for wrappers: changing a wrapper can invalidate the combined method; without changing anything in the flavor-method-table entry.  Rather than having; it automatically recompile, which turns out to be a pain when the wrapper was; just reloaded or changed trivially, it will fail to recompile and you must use; RECOMPILE-FLAVOR with a 3rd argument of NIL.;; A combination-type of NIL means it has not been explicitly specified.; Method-combination functions.  Found on the SI:METHOD-COMBINATION property; of the combination-type.  These are passed the flavor structure, and the; magic-list entry, and must return the function spec to use as the handler.; It should also define or compile thew definition for that function spec if nec.; This function interprets combination-type-arg,; which for many combination-types is either :BASE-FLAVOR-FIRST or :BASE-FLAVOR-LAST.;This is an a-list from method type to function to write the code to go;in the combined method.  Users can add to this.;These types of method are added to the combined method;in the order they are listed here.;So if one flavor defines a wrapper and an :around method,;the wrapper goes outside.(defparameter *specially-combined-method-types*   '((:around put-around-method-into-combined-method)     (:wrapper put-wrapper-into-combined-method)))  ;These specially combined method types go in with base flavor outermost.(defparameter *inverse-specially-combined-method-types*   '((:inverse-around put-around-method-into-combined-method)     (:inverse-wrapper put-wrapper-into-combined-method)))  ;Definitions of a meth (the datum which stands for a method)(defstruct (meth (:type :list) (:constructor nil) (:alterant nil) (:conc-name "METH-")  (:callable-constructors nil) (:predicate nil) (:copier nil));No constructor because defstruct doesn't let me specify the area  function-spec  definition  (plist ()))  ; If there is no definition, it contains DTP-NULL and a pointer to the meth; Extract the method-type of a meth(defsubst meth-method-type (meth)  (and (cdddr (meth-function-spec meth)) (third (meth-function-spec meth))))  (defsubst meth-method-subtype (meth)  (fifth (meth-function-spec meth)))  ; Return a meth of specified type from a list of meth's.(defun meth-lookup (meth-list method-type &optional method-subtype)  (loop for meth in meth-list when     (and (eq (meth-method-type meth) method-type)(or (not method-subtype) (eq (meth-method-subtype meth) method-subtype)))     return meth))  (defun nullify-method-definition (meth)  (let ((p (locf (meth-definition meth))))    (without-interrupts;; TGC (%p-store-pointer p meth) (%p-store-data-type p dtp-null)      (%p-store-data-type-and-pointer p dtp-null meth))))  (defun meth-definedp (meth)  (and (location-boundp (locf (meth-definition meth)))     (neq (meth-definition meth) 'undefinition-in-progress)))  (defun method-plist (function-spec);For debugging ease only  (meth-plist (flavor-method-entry function-spec t)))  ;; Obsolete flavor feature, will warn user during compilation if he includes (in any way);; a flavor marked as obsolete.(DEFVAR ENABLE-OBSOLETE-FLAVOR-CHECK T  "Used to turn off the obsolete flavor checking when one doesn't care to see it.")(defun check-obsolete-flavors (flavor-list option-category &aux fl)  "Check the list to see if there are any flavors there which are designated as being obsolete.FLAVOR-LIST is a list of flavors to check.OPTION-CATEGORY is a string that indicates what kind of option is being checked."  ;; Check only when we compile, not at load time or runtime.  (when (and compiler::qc-file-in-progress compiler::qcompile-temporary-area     enable-obsolete-flavor-check)    (dolist (flavor flavor-list)      (when (and (setf fl (compilation-flavor flavor)) (getf (flavor-plist fl) :obsolete-flavor))(flavor-warn flavor () :obsolete "the ~A flavor ~:S is obsolete, ~A." option-category     flavor (getf (flavor-plist fl) :obsolete-flavor)))))) (defun compiler::make-obsolete-flavor (flavor reason)  "Mark a flavor as being obsolete."  (setf (getf (flavor-plist (compilation-flavor flavor)) :obsolete-flavor) reason)) (defprop defflavor "Flavor" definition-type-name)  ;Function to define or redefine a flavor (used by DEFFLAVOR macro).;Note that to ease initialization problems, the flavors depended upon need;not be defined yet.  You will get an error the first time you try to create;an instance of this flavor if a flavor it depends on is still undefined.;When redefining a flavor, we reuse the same FLAVOR defstruct so that;old instances continue to get the latest methods, unless you change;something incompatibly, in which case you will get a warning.(defprop defflavor1 t qfasl-dont-record)  (defun defflavor1 (flavor-name instance-variables component-flavors options &aux ffl already-exists instv      identical-components gettable settable inittable special-ivs old-special-ivs      old-default-handler old-default-init-plist old-local-ivs old-inittable-ivs      old-init-kwds old-instance-area-function old-required-init-keywords init-keywords      includes meth-comb new-plist (pl (locf new-plist))      (default-cons-area (if *just-compiling*   default-cons-area   *flavor-area*)))  (or *just-compiling* (record-source-file-name flavor-name 'defflavor))  (without-interrupts   (cond     ((and (not *just-compiling*) (not (member flavor-name *all-flavor-names* :test #'eq)))      (push flavor-name *all-flavor-names*)      ;; Push on the name without the package prefix.      (vector-push-extend (cons (symbol-name flavor-name) flavor-name) *all-flavor-names-aarray*)      ;; Push on the name with the package prefix.      (vector-push-extend       (cons (string-append (package-name *package*) ":" (symbol-name flavor-name)) flavor-name)       *all-flavor-names-aarray*)      ;; Array is no longer sorted.      (store-array-leader () *all-flavor-names-aarray* 1))))  ;; Analyze and error check the instance-variable and component-flavor lists  (setq instv (mapcar #'(lambda (x)  (if (atom x)    x    (car x)))      instance-variables))  (dolist (iv instv)    (if (or (null iv) (not (symbolp iv)))      (ferror () "~:S, which is not a symbol, was specified as an instance variable" iv)))  (dolist (cf component-flavors)    (if (or (null cf) (not (symbolp cf)))      (ferror () "~:S, which is not a symbol, was specified as a component flavor" cf)))  ;;Check for obsolete component flavors here  (check-obsolete-flavors component-flavors "component")  ;; Certain properties are inherited from the old property list, while  ;; others are generated afresh each time from the defflavor-options.  (cond    ((and (setq already-exists (compilation-flavor flavor-name)) *use-old-flavor-info*)     (dolist (prop defflavor1-preserved-properties)       (setf (get pl prop) (getf (flavor-plist already-exists) prop)))))  ;; First, parse all the defflavor options into local variables so we can see  ;; whether the flavor is being redefined incompatibly.  (do ((l options (cdr l))       (option)       (args))      ((null l))    (if (atom (car l))      (setq option (car l)    args ())      (setq option (caar l)    args (cdar l)))    (case option      (:gettable-instance-variables       (validate-instance-variables-spec args instv flavor-name option)       (setq gettable (union gettable (or args instv) :test #'eq)))      (:settable-instance-variables       (validate-instance-variables-spec args instv flavor-name option)       (setq settable (union settable (or args instv) :test #'eq)))      ((:inittable-instance-variables :initable-instance-variables)       (validate-instance-variables-spec args instv flavor-name option)       (setq inittable (union inittable (or args instv) :test #'eq)))      (:special-instance-variables       (validate-instance-variables-spec args instv flavor-name option)       (setq special-ivs (union special-ivs (or args instv) :test #'eq)))      (:init-keywords (setq init-keywords (union init-keywords args :test #'eq)))      (:included-flavors (setq includes (union includes args :test #'eq)) (check-obsolete-flavors args "included"))      (:no-vanilla-flavor (setf (get pl option) t))      (:ordered-instance-variables       ;;Don't validate.  User may reasonably want to specify non-local instance       ;;variables, and any bogus names here will get detected by COMPOSE-FLAVOR-COMBINATION       ;;(VALIDATE-INSTANCE-VARIABLES-SPEC ARGS INSTV FLAVOR-NAME OPTION)       (setf (get pl :ordered-instance-variables) (or args instv)))      (:outside-accessible-instance-variables       (validate-instance-variables-spec args instv flavor-name option)       (setf (get pl :outside-accessible-instance-variables)     (union (get pl :outside-accessible-instance-variables) (or args instv) :test #'eq)))      (:method-combination (setq meth-comb (nunion meth-comb args :test #'equal) ))      (:default-handler (setf (get pl option) (car args)))      ((:required-instance-variables :required-methods :required-flavors :required-init-keywords)       (setf (get pl option) (union args (get pl option) :test #'eq))       (when (eq option :required-flavors)         (check-obsolete-flavors (get pl ':required-flavors) "required")))      ((:documentation :default-init-plist :select-method-order :accessor-prefix)       (setf (get pl option) args))      (:alias-flavor (setf (get pl :alias-flavor) t))      (:abstract-flavor (setf (get pl :abstract-flavor) t))      (:instance-area-function (setf (get pl :instance-area-function) (car args)))      (:instantiation-flavor-function (setf (get pl :instantiation-flavor-function) (car args)))      ((:run-time-alternatives :mixture) (setf (get pl :run-time-alternatives) args)       (setf (get pl :instantiation-flavor-function) 'choose-run-time-alternative)       (setf (get pl 'run-time-alternative-alist)     (make-run-time-alternative-alist flavor-name args)))      (otherwise (ferror () "~S is not a known DEFFLAVOR option." option))))  ;; All settable instance variables should also be gettable and inittable.  (dolist (v settable)    (or (member v gettable :test #'eq) (push v gettable))    (or (member v inittable :test #'eq) (push v inittable)))  ;; See whether there are any changes in component flavor structure from last time  (setq identical-components(and already-exists *use-old-flavor-info*   (equal component-flavors (flavor-depends-on already-exists))   (equal includes (flavor-includes already-exists))   (equal (get pl :required-flavors)  (getf (flavor-plist already-exists) :required-flavors))))  (and already-exists     (setq old-special-ivs (flavor-special-instance-variables already-exists)   old-default-handler (getf (flavor-plist already-exists) :default-handler)   old-default-init-plist (getf (flavor-plist already-exists) :default-init-plist)   old-local-ivs (flavor-local-instance-variables already-exists)   old-inittable-ivs (flavor-inittable-instance-variables already-exists)   old-instance-area-function (flavor-get already-exists :instance-area-function)   old-required-init-keywords (flavor-get already-exists :required-init-keywords)   old-init-kwds (flavor-init-keywords already-exists)))  ;; If the flavor is being redefined, and the number or order of instance$variables  ;; is being changed, and this flavor or any that depends on it  ;; has a select-method table (i.e. has probably been instantiated), give a warning  ;; and disconnect from the old FLAVOR defstruct so that old instances will  ;; retain the old information.  The instance variables can get changed either  ;; locally or by rearrangement of the component flavors.  (and already-exists     (if (and *use-old-flavor-info* (equal (get pl :ordered-instance-variables)(getf (flavor-plist already-exists) :ordered-instance-variables)) (or (equal (flavor-local-instance-variables already-exists) instance-variables)    (equal     (mapcar #'(lambda (x) (if (atom x)   x   (car x)))     (flavor-local-instance-variables already-exists))     instv)) (eq (get pl :alias-flavor) (flavor-get already-exists :alias-flavor)) (or identical-components    (equal (flavor-relevant-components already-exists component-flavors includes)   (flavor-relevant-components already-exists (flavor-depends-on already-exists)       (flavor-includes already-exists)))))       (if *just-compiling* (setq already-exists (flavor-redefinition-for-compilation already-exists ())))       (if *just-compiling* (setq already-exists (flavor-redefinition-for-compilation already-exists t)) (setq already-exists (perform-flavor-redefinition flavor-name)))))  (when (get pl :alias-flavor)    (if (cdr component-flavors)      (flavor-warn flavor-name 'alias-flavor-multiple-components :impossible   "This alias flavor has more than one component."))    (unless component-flavors      (flavor-warn flavor-name 'alias-flavor-multiple-components :impossible   "This alias flavor has no component to be the alias of."))    (if instance-variables      (flavor-warn flavor-name 'alias-flavor-multiple-components :impossible   "This alias flavor has instance variables; they will be ignored.")))  ;; Make the information structure unless the flavor already exists.  (let ((fl (or already-exists (and (not *just-compiling*) (get flavor-name 'undefined-flavor))    (make-flavor flavor-name flavor-name))))    (setf (flavor-package fl) *package*)    (setf (flavor-local-instance-variables fl) instance-variables)    (setf (flavor-depends-on fl) component-flavors)    (let ((ovec (flavor-component-mapping-table-vector fl)))      (setf (flavor-plist fl) new-plist)      (if ovec(setf (flavor-component-mapping-table-vector fl) ovec)))    (if gettable      (setf (flavor-gettable-instance-variables fl) gettable))    (if settable      (setf (flavor-settable-instance-variables fl) settable))    (if special-ivs      (setf (flavor-special-instance-variables fl) special-ivs))    (setf (flavor-inittable-instance-variables fl)  (loop for v in inittable collect (cons (corresponding-keyword v) v)))    (setf (flavor-init-keywords fl) init-keywords)    (setf (flavor-includes fl) includes)    ;; This can't be computed for real until flavor composition,    ;; but this at least contains some of the right ones.    (setf (flavor-unmapped-instance-variables fl) (flavor-known-unmapped-instance-variables fl))    ;; First remove old method-combination declarations, then add new ones    (dolist (mte (flavor-method-table fl))      (cond((loop for decl in meth-comb never (member (car mte) (cddr decl) :test #'eq)) (setf (second mte) ()) (setf (third mte) ()))))    (dolist (decl meth-comb)      (let ((type (car decl)) (order (cadr decl)) elem)    ;; Don't error-check TYPE now, its definition might not be loaded yet(dolist (msg (cddr decl))  (or (setq elem (assoc msg (flavor-method-table fl) :test #'eq))     (push (setq elem (list* msg () () ())) (flavor-method-table fl)))  (setf (second elem) type)  (setf (third elem) order))))    (if *just-compiling*      (compilation-define-flavor flavor-name fl)      ;; Make this a depended-on-by of its depends-on, or remember to do it later in      ;; the case of depends-on's not yet defined.      (progn(dolist (component-flavor component-flavors)  (without-interrupts   (cond     ((setq ffl (get component-flavor 'flavor))      (or (member flavor-name (flavor-depended-on-by ffl) :test #'eq) (push flavor-name (flavor-depended-on-by ffl))))     (t (push (cons component-flavor flavor-name) *flavor-pending-depends*)))))(dolist (included-flavor (flavor-includes fl))  (without-interrupts   (cond     ((setq ffl (get included-flavor 'flavor))      (or (member flavor-name (flavor-depended-on-by ffl) :test #'eq) (push flavor-name (flavor-depended-on-by ffl))))     (t (push (cons included-flavor flavor-name) *flavor-pending-depends*)))))(without-interrupts (dolist (x *flavor-pending-depends*)   (cond     ((eq (car x) flavor-name)      (or (member (cdr x) (flavor-depended-on-by fl) :test #'eq) (push (cdr x) (flavor-depended-on-by fl)))      (setq *flavor-pending-depends*    (delete x (the list *flavor-pending-depends*) :test #'eq))))))(setf (get flavor-name 'flavor) fl)(remprop flavor-name 'undefined-flavor)(if (and already-exists (not identical-components))  (perform-flavor-method-only-redefinition flavor-name)  ;; If the methods and instances are ok but other things have changed, notice that too.  (or   (and (equal old-special-ivs (flavor-special-instance-variables fl))      (equal old-default-init-plist (getf (flavor-plist fl) :default-init-plist))      (equal old-local-ivs (flavor-local-instance-variables fl))      ;; Get a warning every time, if there is a variable      ;; that is globally special but not in a :SPECIAL-INSTANCE-VARIABLES      (not       (dolist (iv (flavor-local-instance-variables fl));; Elements can be lists (var init) (if (consp iv)   (setq iv (car iv))) (and (get iv 'special)    (not (member iv (flavor-special-instance-variables fl) :test #'eq))    (return t))))      (equal old-inittable-ivs (flavor-inittable-instance-variables fl))      (equal old-default-handler (getf (flavor-plist fl) :default-handler))      (equal old-instance-area-function (flavor-get fl :instance-area-function))      (equal old-required-init-keywords (flavor-get fl :required-init-keywords))      (equal old-init-kwds (flavor-init-keywords fl)))   (perform-flavor-bindings-redefinition flavor-name)))(flavor-hack-documentation flavor-name))      ;; Now, if the flavor was redefined in a way that changes the methods but doesn't      ;; invalidate old instances, we have to propagate some changes.      ;; If someone depends on this flavor, which wasn't defined until now, link them up.      ;; If that flavor was flavor-composed, recompose it now.      ;; Likewise for its includes)    flavor-name))  ;; Determine as many as we can of FL's ordered instance variables;; at a time when FL's components need not all be defined.;; This is used to init FL's unmapped instance variables list at defflavor time.;; That list's final value will be computed when FL is composed.;; This is so that methods of FL loaded before FL is composed;; will not need to make mapping table entries for these ivars.(defun flavor-known-unmapped-instance-variables (fl)  (let ((fls (append (flavor-depends-on fl) (flavor-get fl :required-flavors)))(ords (flavor-get fl :ordered-instance-variables)))    (dolist (f fls)      (setq f (compilation-flavor f ))      (when f(let ((ord (flavor-unmapped-instance-variables f)))      ;; Merge into existing order requirement.  Shorter of the two must be      ;; a prefix of the longer, and we take the longer.  (do ((l1 ord (cdr l1))       (l2 ords (cdr l2)))      (nil)    (cond      ((null l1) (return ()))      ((null l2) (return (setq ords ord)))      ((neq (car l1) (car l2))       (ferror () ":ORDERED-INSTANCE-VARIABLES conflict, ~S vs ~S." (car l1) (car l2))))))))    ords))  ;Check for typos in user-specified lists of instance variables.;This assumes that only locally-specified (not inherited) instance variables;may be mentioned in DEFFLAVOR declaration clauses.(defun validate-instance-variables-spec (vars-specd vars-allowed flavor-name option)  (dolist (var vars-specd)    (or (member var vars-allowed :test #'eq)       (flavor-warn flavor-name 'nonexistent-instance-variable :impossible    "~S includes instance variable ~S, which this flavor lacks." option var))))  (defun flavor-warn (flavor-name type severity format-string &rest format-args)  (if object-warnings-object-name    (apply 'compiler::warn type severity format-string format-args)    (progn      (format *error-output* "~&In the definition of flavor ~S,~%" flavor-name)      (apply 'format *error-output* format-string format-args))))  ;List of those components which affect the names, number, and ordering of the;instance variables.  Don't worry about undefined components, by definition;they must be different from the already-existing flavor, so the right;thing will happen.  (I wonder what that comment means?  Undefined components;will not even appear in the list.)(defun flavor-relevant-components (fl component-flavors included-flavors)  (bind (locf (flavor-depends-on fl)) component-flavors)  (bind (locf (flavor-includes fl)) included-flavors)  (delete-if-not   #'(lambda (flavor);Splice out the uninteresting ones       (let ((tem (compilation-flavor flavor))) (or (null tem) (flavor-local-instance-variables tem))))   (compose-flavor-inclusion (flavor-name fl) ())))  (defun flavor-redefinition-for-compilation (old-flavor new-components-p)  "Prepare for compile-time redefinition of a flavor.Copies the flavor, but installs the copy only for the current compilation."  new-components-p  (let ((new-flavor (make-flavor flavor-name (flavor-name old-flavor))))    (copy-array-contents old-flavor new-flavor)    ;; Do copy any combined methods.  If we have dependents also in this file    ;; and they have COMPILE-FLAVOR-METHODS in this file,    ;; they will want to see our combined methods in case they can use them.    (copy-method-table old-flavor new-flavor ())    (setf (flavor-instance-size new-flavor) ());Defuse error check    (setf (flavor-depends-on-all new-flavor) ());Will need to be flavor-composed again    ;; Cause an error if these are looked at before they are valid.    (setf (flavor-all-instance-variables new-flavor) 'not-computed)    (setf (flavor-depended-on-by new-flavor) 'compilation)    (setf (flavor-method-hash-table new-flavor) ());Will need to be method-composed again    (setf (flavor-which-operations new-flavor) ())    new-flavor))  (defun copy-method-table (old-flavor new-flavor discard-combined-methods)  (let ((l (copy-list (flavor-method-table old-flavor)))(meth-area (if *just-compiling*     default-cons-area     permanent-storage-area)))    (do ((tail l (cdr tail)))((null tail)) ;; Copy the method-table element, including the list of METH's.      (setf (car tail) (copy-list (car tail)))      (if discard-combined-methods       ;; Flush from the copy all combined methods.(do ((tail2 (cdddr (car tail)) (cdr tail2)))    ((null tail2))  (and (eq (meth-method-type (car tail2)) :combined)     (setf (cdddar tail) (delete (car tail2) (the list (cdddar tail)) :test #'eq)))))      ;; Now copy each METH that we didn't delete.      ;; Copying a METH is not trivial because it can contain a DTP-NULL.      (do ((tail2 (cdddr (car tail)) (cdr tail2)))  ((null tail2))(let ((new-meth       (list-in-area meth-area (first (car tail2)) () (copy-list (third (car tail2))))))  (if (meth-definedp (car tail2))    (setf (meth-definition new-meth) (meth-definition (car tail2)))    (nullify-method-definition new-meth))  (setf (car tail2) new-meth))))    (setf (flavor-method-table new-flavor) l)))  ;Record a flavor definition, during compiling a file.;Instead of setting the name's FLAVOR property, we put an entry on the;FLAVORS element in the FILE-LOCAL-DECLARATIONS, where COMPILATION-FLAVOR looks.(defun compilation-define-flavor (flavor-name fl)  (let ((fll (assoc 'flavors file-local-declarations :test #'eq)))    (cond      ((null fll) (push (cons 'flavors ()) file-local-declarations)       (setq fll (car file-local-declarations))))    (setf (get fll flavor-name) fl)))  ;Call here when a flavor has been changed in a way that is not compatible;with old instances of this flavor or its dependents.;Arranges for those old instances to keep the old flavor structures and methods.;Return new copy of the FLAVOR defstruct, and propagate to those that depend on it.;Note that we tell copy-method-table to discard our combined methods.;This is because they point to METHs in our method table,;so we must make new combined methods that point at our new method table.(defun perform-flavor-redefinition (flavor-name &optional for-undefflavor-p &aux fl nfl)  (setq fl (get flavor-name 'flavor))  (cond    ((flavor-method-hash-table fl) (setq nfl (make-flavor)) (copy-array-contents fl nfl)     (copy-method-table fl nfl t);Copy, but discard combined methods     (setq fl nfl) (setf (flavor-plist fl) (copy-list (flavor-plist fl) property-list-area))     (setf (flavor-mapped-instance-variables fl)   (copy-list (flavor-mapped-instance-variables fl)))     (remprop (locf (flavor-plist fl)) 'mapped-component-flavors);They are used only by the combined     ;methods, which we just flushed.     (setf (flavor-component-mapping-table-alist fl) ())     (setf (flavor-component-mapping-table-vector fl) ()) (setf (get flavor-name 'flavor) fl)     (format *error-output*     (if for-undefflavor-p       "~&Flavor ~S no longer instantiable; old instances are not affected.~%"       "~&Flavor ~S changed incompatibly; old instances will not get the new version.~%")     flavor-name))    ;; Even if this flavor wasn't instantiated,    ;; probably some of its dependents were,    ;; and their hash tables and combined methods point to our method table.    (t (copy-method-table fl fl t)))  (setf (flavor-instance-size fl) ());Defuse error check  (setf (flavor-depends-on-all fl) ());Will need to be flavor-composed again  (setf (flavor-method-hash-table fl) ());Will need to be method-composed again  (setf (flavor-which-operations fl) ())  (dolist (fn (flavor-depended-on-by fl))    (perform-flavor-redefinition fn for-undefflavor-p))  fl)  ;This one is when the old instances don't have to be discarded, but recomposition;does have to occur because something was changed in the order of flavor combination(defun perform-flavor-method-only-redefinition (flavor-name) ;; If we define any combined methods, they don't "belong" to any file ;; that happens to be being loaded when this is called.  (let ((fdefine-file-pathname nil) (inhibit-fdefine-warnings t));Don't give warnings for combined methods;; Reverse the list so that this flavor comes first, followed by directest descendents.    (dolist (fn (reverse (flavor-depended-on-by-all (get flavor-name 'flavor) (list flavor-name))))      (let ((fl (get fn 'flavor)))(if (flavor-depends-on-all fl)  (compose-flavor-combination fl))(if (flavor-method-hash-table fl)  (compose-method-combination fl))))))  ;This one is when the old instances don't have to be discarded,;and methods have not changed, just to check whether specialness;of instance variables has changed.(defun perform-flavor-bindings-redefinition (flavor-name)  (dolist (fl1 (flavor-depended-on-by-all (get flavor-name 'flavor) (list flavor-name)))    (setq fl1 (get fl1 'flavor))    (cond      ((flavor-method-hash-table fl1) (compose-flavor-bindings fl1)       (compose-flavor-initializations fl1)))))  (defun make-flavor-all-special (flavor)  (if (symbolp flavor)    (setq flavor (get flavor 'flavor)))  (cond    ((not (flavor-all-instance-variables-special flavor))     (or      (fquery format:y-or-n-p-options      "~&Loading old compiled methods for flavor ~S.  Make that flavor all-special? "      (flavor-name flavor))      (ferror ()      "Loading old compiled methods which require all instance variablesto be special, for flavor ~S"      (flavor-name flavor)))     (setf (flavor-all-instance-variables-special flavor) (or fdefine-file-pathname t))     (perform-flavor-bindings-redefinition (flavor-name flavor)))))  (defun describe-flavor (flavor-name &aux fl)  (check-arg flavor-name     (typep (setq fl (if (symbolp flavor-name)       (get flavor-name 'flavor)       flavor-name)) 'flavor)     "a flavor or the name of one")  (format t "~&Flavor ~S directly depends on flavors: ~:[none~;~:*~{~<~%   ~3:;~S~>~^, ~}~]~%"  flavor-name (flavor-depends-on fl))  (and (flavor-includes fl)     (format t " and directly includes ~{~<~%   ~3:;~S~>~^, ~}~%" (flavor-includes fl)))  (and (flavor-depended-on-by fl)     (format t " and is directly depended on by ~{~<~%   ~3:;~S~>~^, ~}~%"     (flavor-depended-on-by fl)))  (and (flavor-depends-on-all fl);If this has been computed, show it     (format t " and directly or indirectly depends on ~{~<~%   ~3:;~S~>~^, ~}~%"     (flavor-depends-on-all fl)))  (cond    ((not (null (flavor-method-table fl)))     (format t "Not counting inherited methods, the methods for ~S are:~%" flavor-name)     (dolist (m (flavor-method-table fl))       (let ((methods (remove-if-not 'meth-definedp (cdddr m)))) (format t "   ") (do ((tpl methods (cdr tpl)))     ((null tpl))   (if (meth-method-type (car tpl))     (format t ":~A " (meth-method-type (car tpl))))   (format t ":~A" (car m))   (let ((subop (fifth (meth-function-spec (car tpl)))))     (when subop       (format t " :~A" subop)))   (if (cdr tpl)     (princ ", "))) ;; Print the method combination type if there is any. (and (cadr m) (format t "    :~A~@[ :~A~]" (cadr m) (caddr m))) (terpri)))))  (and (flavor-instance-size fl);If has been composed     (format t "Flavor ~S has instance size ~D, " flavor-name (flavor-instance-size fl)))  (when (flavor-all-instance-variables fl)    (or (flavor-instance-size fl) (format t "Flavor ~s has " flavor-name))    (format t "Instance variables: ~{~<~%   ~3:;~S~>~^, ~}~%" (flavor-all-instance-variables fl)))  (and (flavor-gettable-instance-variables fl)     (format t     "Automatically-generated methods to get instance variables: ~{~<~%   ~3:;~S~>~^, ~}~%"     (flavor-gettable-instance-variables fl)))  (and (flavor-settable-instance-variables fl)     (format t     "Automatically-generated methods to set instance variables: ~{~<~%   ~3:;~S~>~^, ~}~%"     (flavor-settable-instance-variables fl)))  (and (flavor-inittable-instance-variables fl)     (format t "Instance variables that may be set by initialization: ~{~<~%   ~3:;~S~>~^, ~}~%"     (mapcar #'cdr (flavor-inittable-instance-variables fl))))  (and (flavor-init-keywords fl)     (format t "Keywords in the :INIT message handled by this flavor: ~{~<~%   ~3:;~S~>~^, ~}~%"     (flavor-init-keywords fl)))  (format t "Defined in package ~A~%" (flavor-package fl))  (cond    ((flavor-plist fl) (format t "Properties:~%")     (do ((l (flavor-plist fl) (cddr l))) ((null l)  nil)       (format t "     ~S:~S~%" (car l) (cadr l)))))  (cond    ((null (flavor-method-hash-table fl))     (format t "Flavor ~S does not yet have a method hash table~%" flavor-name))    ((eq t (flavor-method-hash-table fl))     (format t     "Flavor ~S has been method-composed but has no hash table since it is an :ABSTRACT-FLAVOR.~%"     flavor-name))    (t (format t "Flavor ~S has method hash table:~%" flavor-name)     (describe (flavor-method-hash-table fl)))))  (defun flavor-hack-documentation (flavor-name)  (let* ((doc (getf (flavor-plist (get flavor-name 'flavor)) :documentation)) (strings nil) foo)    (if doc      (progn(dolist (tem doc)  (and (stringp tem) (setq strings (nconc strings (cons tem ())))))(dolist (tem doc)  (unless (stringp tem)    (setq strings  (nconc strings (list* (if (and strings (not foo))  #\Newline  "")(if foo  ""  (setq foo "A "))tem #\Space ())))))(if foo  (nconc strings (list "Flavor.")))(setf (documentation flavor-name 'defflavor) (apply 'string-append strings)))      (if (documentation flavor-name 'defflavor)(setf (documentation flavor-name 'defflavor) ())))))  ;; This is the standard way of defining a method of a class,;; so that the code will be compiled.  Note that DEFMETHOD works for;; both Class methods and Flavor methods.;; If in place of the lambda-list you have a symbol, and the body;; is null, that symbol is a function which stands in for the method.(defmacro defmethod (spec lambda-list . body)  "(DEFMETHOD (flavor-name [daemon-type] operation [:case-sub-operation]) lambda-list . body)Defines the method for flavor: flavor-name for the message operation,Daemon-type can be one of: :BEFORE :AFTER :AROUND :INVERSE-AROUND :CASE :DEFAULT :OR :AND :OVERRIDE:PROGN :LIST :INVERSE-LIST :PASS-ON :APPEND :NCONC.:case-sub-operation must be provided for :CASE deamon-type,it is illegal otherwise."  (let ((class-name (car spec))(function-spec (cons :method spec))fl)    `(progn       ,(and (just-compiling) (compilation-flavor class-name t)     (neq class-name 'vanilla-flavor);This kludge avoids bootstrapping problems!   `(eval-when (compile)       (let ((*just-compiling* t)) (flavor-notice-method ',function-spec))))       ,(cond  ((and (symbolp lambda-list) (not (null lambda-list)) (null body))   `(fdefine-for-defmethod ',function-spec ',lambda-list t))  ((setq fl (compilation-flavor class-name t))   (if (flavor-get fl :alias-flavor)     (ferror () "Attempt to define ~S; the flavor is an alias flavor."     (cons :method spec)))   `(defun ,function-spec ,(method-argument-list lambda-list function-spec)      (declare (:self-flavor ,class-name))      ,@body))  (t     (ferror () "~S is not a flavor" (car spec))))))) (defprop .operation. t compiler:ignorable-variable)  (defprop .suboperation. t compiler:ignorable-variable)  (defprop .daemon-caller-args. t compiler:ignorable-variable)  (defprop .daemon-mapping-table. t compiler:ignorable-variable)  (deff fdefine-for-defmethod #'fdefine)  (defprop fdefine-for-defmethod t qfasl-dont-record)  (defun method-argument-list (specified-lambda-list function-spec)  "Given an arglist specified in DEFMETHOD, return an arglist for the actual method.This involves adding OPERATION to the front, and sometimes other thingsdepending on the method type"  (cons '.operation.(append (if (cdddr function-spec)   (get (caddr function-spec) 'implicit-method-arguments)) specified-lambda-list)))  (defprop :case (.suboperation.) implicit-method-arguments)  ; This lets you specify code to be wrapped around the invocation of the; various methods for an operation.  For example,; (DEFWRAPPER (FOO-FLAVOR :OPERATION) ((ARG1 ARG2) . BODY);   `(WITH-FOO-LOCKED (SELF);      (PRE-FROBULATE SELF ARG1 ARG2);      ,@BODY;      (POST-FROBULATE SELF ARG2 ARG1)));Note that the wrapper needs to be defined at both compile and run times;so that compiling combined methods as part of the qfasl file works.(defmacro defwrapper ((flavor-name operation) (defmacro-lambda . guts) &body body)  (let ((function-spec `(:method ,flavor-name :wrapper ,operation)))    `(progn       ,(and (compilation-flavor flavor-name t) (just-compiling)   `(eval-when (compile)       (let ((*just-compiling* t)) (flavor-notice-method ',function-spec))))       ,(if (and (symbolp defmacro-lambda) (string-equal defmacro-lambda 'ignore))  `(defmacro ,function-spec (ignore . ,guts)     ,@body)  `(defmacro ,function-spec (arglistname . ,guts)     `(destructuring-bind ,',defmacro-lambda (cdr ,arglistname) ,,@body))))))  ;This just exists to be called at compile-time from the DEFMETHOD macro,;so that any combined methods generated by COMPILE-FLAVOR-METHODS will;know that this method will be around at run time and should be called.;Returns non-NIL if the method is really defined (not just noticed).(defun flavor-notice-method (function-spec)  (if (fboundp 'compiler:compilation-define)    (compiler:compilation-define function-spec))  (condition-case ()     (let ((meth (flavor-method-entry function-spec () t)))       (if (meth-definedp meth) (meth-definition meth) (progn   (setf (meth-definition meth) ())   ())))     (invalid-function-spec nil)))  ;Find or create a method-table entry for the specified method.;DONT-CREATE is NIL if method is to be created if necessary.;The flavor is "created" too, as an UNDEFINED-FLAVOR property;of the flavor name, just to record any properties of methods.;COPY-FLAVOR-IF-UNDEFINED-METH says we are going to alter the METH;for compilation if it is not defined, so the flavor should be copied in that case.(defun flavor-method-entry (function-spec dont-create &optional copy-flavor-if-undefined-meth)  (let ((default-cons-area background-cons-area)(flavor-name (second function-spec))(type (third function-spec))(subtype (fifth function-spec))(message (fourth function-spec)))    (if (null message)      (setq message type    type ()));If no type    (if (or (null message) (neq (first function-spec) :method) (> (length function-spec) 5)(not (symbolp flavor-name)) (not (symbolp type)) (not (symbolp message))(not (symbolp subtype)))      (ferror 'invalid-function-spec "~S is not a valid :METHOD function spec." function-spec))    (let* ((fl    (or (compilation-flavor flavor-name)       (unless *just-compiling* (get flavor-name 'undefined-flavor))       (and (not dont-create)  (if *just-compiling*    (compilation-define-flavor flavor-name (make-flavor flavor-name flavor-name))    (setf (get flavor-name 'undefined-flavor)  (make-flavor flavor-name flavor-name))))))   (mte (and fl (assoc message (flavor-method-table fl) :test #'eq)))   (meth (meth-lookup (cdddr mte) type subtype)))   ;; If we are compiling a file, don't modify an installed flavor.   ;; Make a new flavor object just for compilation and modify it instead.      (and       (or (and (not dont-create) (null meth))  (and meth copy-flavor-if-undefined-meth (not (meth-definedp meth))))       *just-compiling* fl (eq fl (get flavor-name 'flavor)) (compilation-define-flavor flavor-name    (setq fl (flavor-redefinition-for-compilation fl ()))))      (and (null mte) (not dont-create)      ;; Message not previously known about, put into table fl (push (setq mte (list* message () () ())) (flavor-method-table fl)))      ;; Message known, search for the type entry      (cond(meth);Known by flavor(dont-create nil);Not to be created((null fl) nil);Create, but no flavor defined(t ;; Type not known, create a new meth with an unbound definition cell (let ((meth(list-in-area (if *just-compiling*default-cons-areapermanent-storage-area)      ;; Copy the function spec for paging efficiency.      (if *just-compiling*function-spec(copy-list function-spec permanent-storage-area))      () ())))   (nullify-method-definition meth)   (push meth (cdddr mte))   meth))))))  (defun flavor-method-function-specs (flavor &aux methods)  "Return a list of function specs for all the methods (except combined) of FLAVOR."  (if (symbolp flavor)    (setq flavor (compilation-flavor flavor)))  (dolist (mte (flavor-method-table flavor))    (dolist (meth (cdddr mte))      (or (eq (meth-method-type meth) :combined) (not (meth-definedp meth)) (push (meth-function-spec meth) methods))))  methods)  (defun delete-flavor-method-table-entry (flavor method)  "Delete the specified METHOD entry in the FLAVOR's flavor-method-table"  (let ((tempvar (get flavor 'flavor)))    (and tempvar       (setf (flavor-method-table tempvar)     (delete (assoc method (flavor-method-table tempvar) :test #'eq)     (the list (flavor-method-table tempvar)) :test #'eq)))    t))  (defmacro undefmethod (method-spec)  "Forcibly remove a method definition from a flavor's method table.Syntax is identical to the beginning of a defmethod for the same method."  `(progn     (fundefine '(:method . ,method-spec))     (delete-flavor-method-table-entry ',(first method-spec) ',(second method-spec))))  ;;; Interface to function-spec system;; (:METHOD class-name operation) refers to the method in that class for;;   that operation; this works for Flavor methods.;;   The specification may also be of the form;;   (:METHOD flavor-name method-type operation).(defvar last-fasload-combined-method-spec ())  (defvar last-fasload-combined-method-def)  (defprop :method method-function-spec-handler function-spec-handler)  (defun method-function-spec-handler (function function-spec &optional arg1 arg2 &aux fl) ;; 10/03/85 DNG - For FDEFINE of a :FASLOAD-COMBINED method, go ahead and replace ;;                the previous definition if the new one is not FEF-EQUAL to it. ;; 6/16/86 PHD Removed support for classes.  (let ((flavor (second function-spec))(method-type (third function-spec))(message (fourth function-spec))(default-cons-area background-cons-area))    (if (null (cdddr function-spec))      (setq message (third function-spec)    method-type ()))    (cond      ((not(and (symbolp flavor) (symbolp method-type) (symbolp message)   (<= 3 (length function-spec) 5)))       (unless (eq function 'validate-function-spec) (ferror 'invalid-function-spec "The function spec ~S is invalid." function-spec)))      ((eq t (setq fl (compilation-flavor flavor)))       ;; Silly pseudo-flavor for cold-load stream       (if (eq function 'validate-function-spec) t ;;The property-list operations need to work for the editor (function-spec-default-handler function function-spec arg1 arg2)))      (t       (if (eq function 'validate-function-spec) t ;; Ignore FASLOAD-COMBINED methods if flavor methods composed already. (if (and fl (flavor-method-hash-table fl) (eq (third function-spec) 'fasload-combined)     (if (eq function 'fdefine)       (fef-equal arg1 (fdefinition-safe function-spec))       (equal function-spec last-fasload-combined-method-spec)))  ;; This hair makes defining (INTERNAL (:METHOD FOO FASLOAD-COMBINED ...) ...)  ;; get ignored properly and not get an error.   (case function     (fdefinition last-fasload-combined-method-def)     (fdefinedp t)     (fdefine (setq last-fasload-combined-method-spec function-spec)      (setq last-fasload-combined-method-def arg1))     (fdefinition-location (locf last-fasload-combined-method-def))     (t nil))   ;; Otherwise refer to or define the :COMBINED method.   (progn     (if (eq method-type 'fasload-combined)       (setq function-spec     (list* (first function-spec) flavor :combined (cdddr function-spec))     method-type :combined))     (let ((meth    (flavor-method-entry function-spec (case function   ((putprop push-property fdefinition-location fdefine)    nil);Create.   (otherwise t)))));Don't create       (or (and meth (meth-definedp meth))  (member function  '(fdefinedp compiler-fdefinedp putprop push-property      fdefinition-location fdefine get function-parent dwimify)  :test #'eq)  (if fl    (ferror () "~S is not a defined method; it is not possible to ~S it"    function-spec function)    (ferror ()    "~S is neither the name of a flavor nor the name ~      of a class;~% it is not possible to ~S ~S."    flavor function function-spec)))       (case function (fdefine  (or fl     (ferror ()     "~S is neither the name of a flavor nor the name ~      of a class;~% it is not possible to ~S ~S."     flavor function function-spec))  (let ((definition-new (not (meth-definedp meth)))(old-definition (and (meth-definedp meth) (meth-definition meth))))    (setf (meth-definition meth) arg1)    ;; If we load a method compiled before system 83,    ;; that expects instance variables to be bound,    ;; make it work by forcing this flavor to bind all variables.;    (if (and (typep arg1 :compiled-function);(zerop (%p-ldb %%fefh-get-self-mapping-table arg1));    (not (assoc 'encapsulated-definition (debugging-info arg1) :test #'eq)));      (make-flavor-all-special fl))    ;; Incrementally recompile the flavor if this is a new method, unless    ;; it is a :COMBINED method, which is the result of compilation,    ;; not a client of it.    (cond      ((member method-type '(:wrapper :inverse-wrapper) :test #'eq)       (or(and (consp old-definition) (fef-equal (cdr arg1) (cdr old-definition)));; Wrapper is really changed; must recompile flavors.;; Arrange that if we abort, the definition is set;; to the symbol ABORTED-DEFINITION.  This is a no-op,;; and redefining or undefining the wrapper will recompile.(let (success)  (unwind-protect (progn   (recompile-flavor flavor message ())   (setq success t))    (or success (setf (meth-definition meth) 'aborted-definition))))))      ((eq method-type :combined)       ;;;phd 3/6/84 update the macro-expanded-into debug info field       ;;; of the daemons, so when a daemon is gettting redefined, we can recompose       ;;; this combined method.       (let ((remove       (set-difference (and  old-definition       #-elroy       (cadr (assoc       :macros-expanded       (debugging-info  old-definition t)       :test #'eq))       #+elroy (get-debug-info-field (get-debug-info-struct  old-definition t) :macros-expanded))       #-elroy (cadr (assoc :macros-expanded (debugging-info (meth-definition meth) t) :test #'eq)) #+elroy (get-debug-info-field   (get-debug-info-struct (meth-definition meth) t)   :macros-expanded) :test #'equal :key #'(lambda (x) (if (consp x) (car x) x))))     (add   #-elroy    (cadr (assoc    :macros-expanded    (debugging-info (meth-definition meth) t)    :test #'eq))    #+elroy (get-debug-info-field      (get-debug-info-struct (meth-definition meth) t)      :macros-expanded)    )) (when remove   (dolist (fn  remove)     (let ((fn (if (consp fn) (car fn) fn)))       (when (and (consp fn ) (eq :method (car fn))) (remove-method-reference fn (function-name old-definition)))))) (when add   (dolist (fn add)     (let ((fn (if (consp fn) (car fn) fn)))       (when (and (consp fn ) (eq :method (car fn ))) (add-method-reference fn (meth-function-spec meth))))))))      (definition-new       ;; This SETF, by virtue of the preceding clause,       ;; arranges that if we abort out before finishing recompilation       ;; then the recompilation will be done again if the user       ;; either redoes the defmethod or does undefmethod.       (setf (meth-definition meth) 'aborted-definition)       (recompile-flavor flavor message) (setf (meth-definition meth) arg1))      ;; If method defined as a random symbol,      ;; must fix up hash table each time it changes.      ((or (symbolp old-definition) (symbolp arg1))       (recompile-flavor flavor message))      ;; phd 2/15/86 if the old method is expanded in a combined method      ;; then rebuild it for that we use meth as third arg for recompile-flavor      ((and  #- elroy (cdr (assoc :macros-expanded-into (debugging-info  old-definition t)     :test #'eq)) #+ elroy (get-debug-info-field (get-debug-info-struct  old-definition t)       :macros-expanded-into ) (not (fef-equal old-definition (meth-definition meth))))       (recompile-flavor flavor message meth))))) (fdefinition (meth-definition meth)) (fdefinedp  (and meth     (values (meth-definedp meth)     (and (meth-definedp meth) (meth-definition meth))))) (fdefinition-location (locf (meth-definition meth))) (fundefine (setf (meth-definition meth) 'undefinition-in-progress)    (recompile-flavor (flavor-name fl) message);Propagate the change    (nullify-method-definition meth));Say propagation is complete. (compiler-fdefinedp meth) (get (and meth (getf (meth-plist meth) arg1))) (putprop  (let ((default-cons-area background-cons-area))    (setf (getf (meth-plist meth) arg2) arg1))) (push-property  (let ((default-cons-area background-cons-area))    (setf (getf (meth-plist meth) arg2)  (cons arg1 (getf (meth-plist meth) arg2))))) (dwimify  (catch-continuation 'dwimify-package #'(lambda (new-spec)   new-spec)     #'(lambda () ())     (dolist (component       (or (flavor-depends-on-all fl) (compose-flavor-combination fl ())))       (let ((flavor (compilation-flavor component))     (meths)) (and flavor    (setq meths  (cdddr (assoc message (flavor-method-table flavor) :test #'eq)))) (dolist (meth meths)   (and (meth-definedp meth)      (dwimify-package-2 (meth-function-spec meth) arg1 arg2 t))))))) (otherwise (function-spec-default-handler function function-spec arg1 arg2)))))))))))  (defun add-method-reference (fn combined-method)  ;; add the reference to combined-method from the debug-info :macros-expanded-into of fn  (let((default-cons-area background-cons-area)       (sys:%inhibit-read-only t)       #-elroy       (debug-info (debugging-info (fdefinition fn ) t))       #+elroy       (debug-info (get-debug-info-struct (fdefinition fn ) t))       prop)    #+elroy    (if debug-info(unless (member combined-method(setf prop (get-debug-info-field     debug-info :macros-expanded-into)):test #'equal)  (put-debug-info-field debug-info :macros-expanded-into  (nconc prop (list combined-method))))nil );(foo (make-debug-info-struct :macros-expanded-into combined-method)))    #-elroy    (and debug-info (if (setf prop (assoc :macros-expanded-into debug-info :test #'eq))     (unless (member combined-method (cdr prop) :test #'equal)       (nconc prop (list combined-method)))     (setf (cdr debug-info ) (cons `(:macros-expanded-into ,combined-method)(cdr debug-info ))))))) (defun remove-method-reference (fn combined-method)  ;; remove the reference to combined-method from the debug-info :macros-expanded-into of fn  (let((default-cons-area background-cons-area)       (sys:%inhibit-read-only t)       #-elroy       (debug-info (debugging-info (fdefinition fn ) t))       #+elroy       (debug-info (get-debug-info-struct (fdefinition fn ) t))       #-elroy       prop)    #+elroy    (when debug-info(put-debug-info-field debug-info :macros-expanded-into      (delete combined-method (get-debug-info-field  debug-info :macros-expanded-into)      :test #'equal :count 1)))    #-elroy    (and debug-info (setf prop (assoc :macros-expanded-into debug-info :test #'eq)) (setf (cdr prop) (delete combined-method (cdr prop) :test #'equal :count 1)))))#-elroy(defun fix-references (flavor-name )  (let ((flavor (compilation-flavor flavor-name nil)))    (unless flavor      (error "~S is not a valid flavor name" flavor-name))    (dolist (m (flavor-method-table flavor))(dolist (meth (cdddr m))  (when (and (meth-definedp meth)     (eq :combined (meth-method-type meth)))    (dolist (fn (cadr (assoc :macros-expanded    (debugging-info (meth-definition meth) t )    :test #'eq)))      (when (and (consp fn ) (eq :method (car fn )))(add-method-reference fn (meth-function-spec meth)))))))    (dolist (super (flavor-depended-on-by flavor))      (fix-references super))));Like EQUAL, but compares the contents of FEFs.;;PHD 1/5/86, Replaced equal by equalp so debug-info-structure are;;Compared for their values and not for eqness.(defun fef-equal (fef1 fef2 &aux dt)  (or (equal fef1 fef2)      (and (= (%structure-total-size fef1) (%structure-total-size fef2))   (= (%structure-boxed-size fef1) (%structure-boxed-size fef2))   (let ((boxed (%structure-boxed-size fef1)) (total (%structure-total-size fef1)))     (and (= (%p-pointer fef1) (%p-pointer fef2));; TGC     (and (= (%p-ldb %%q-pointer fef1) (%p-ldb %%q-pointer fef2))  (do ((i 1 (1+ i)))      ((= i boxed)       t)    (or      (and(= (setq dt (%p-data-type-offset fef1 i))   (%p-data-type-offset fef2 i));; TGC                (= (%p-ldb-offset %%q-data-type fef1 i) (%p-ldb-offset %%q-data-type fef2 i))(OR  ;; Check for self ref pointer.  They're "same" if same pointer field.  ;; Never try to get "contents" of SRP. 3-19-87, -ab  (WHEN (= dt dtp-self-ref-pointer)    (IF (eq (%p-pointer-offset fef1 i) (%p-pointer-offset fef2 i))t(RETURN nil)))  (equal (%p-safe-contents-offset fef1 i) (%p-safe-contents-offset fef2 i))  (eql i %fef-debugging-info-word)))      (return ())))  (do ((i boxed (1+ i)))      ((= i total)       t)    (or      (and (= (%p-ldb-offset %%q-low-half fef1 i) (%p-ldb-offset %%q-low-half fef2 i))   (= (%p-ldb-offset %%q-high-half fef1 i) (%p-ldb-offset %%q-high-half fef2 i)))      (return ()))))))))  ;This is left as the method definition if you abort out of the recompilation;caused by defining a previously undefined method.(deff aborted-definition 'prog1)  ;This is what the method definition is while the method is being FUNDEFINEd.(deff undefinition-in-progress 'prog1)  ;; Run-time alternative flavors.(defun get-run-time-alternative-flavor-names (flavor)  (mapcar 'cdr (flavor-get flavor 'run-time-alternative-alist)))  (defun make-run-time-alternative-defflavors (flavor-name specs)  "Return a list of defflavor forms for the run-time alternatives of FLAVOR-NAME.These are the flavors generated automatically by defining FLAVOR-NAMEand one of which you get when you instantiate FLAVOR-NAME.SPECS should be the value of the :RUN-TIME-ALTERNATIVES option in its definition;this function can be called before the definition is really in effect."  (loop for alt in (make-run-time-alternative-combinations-1 flavor-name specs) when     (and (not (member-if 'stringp alt)) (> (length alt) 1)) collect     `(defflavor ,(intern (combination-flavor-name alt)) () ,alt)))  (defun make-run-time-alternative-alist (flavor-name specs)  (mapcar   #'(lambda (combination)       (cons combination (intern (combination-flavor-name combination))))   (make-run-time-alternative-combinations-1 flavor-name specs)))  (defun combination-flavor-name (flavor-list &aux combined-name)  (dolist (name (remove-duplicates flavor-list))    (if (string-equal name "-FLAVOR" (- (length name) 7))      (setq name (SUBSEQ NAME 0 (- (length name) 7))))    (if (string-equal name "-MIXIN" (- (length name) 6))      (setq name (SUBSEQ name 0 (- (length name) 6))))    (if combined-name      (setq combined-name (string-append combined-name "-" name))      (setq combined-name name)))  combined-name)    (defun make-run-time-alternative-combinations (flavor)  "Return a list of flavor combinations which are run-time alternatives of FLAVOR-NAME.Each combination is a list of the flavor names to be combined."  (let ((specs (flavor-get flavor :run-time-alternatives)))    (make-run-time-alternative-combinations-1 flavor specs)))  (defun make-run-time-alternative-combinations-1 (flavor-name specs)  (if (null specs)    (if flavor-name      `((,flavor-name))      '(nil))    (let ((remaining-specs-alternatives   (make-run-time-alternative-combinations-1 flavor-name (cdr specs)))  (this-spec-alternatives (make-run-time-alternatives (car specs))))      (loop for this-spec in this-spec-alternatives nconc (loop for remaining in remaining-specs-alternatives collect    (append this-spec remaining))))))  (defun make-run-time-alternatives (spec)  (if (consp (cadr spec))    (loop for alternative in (cdr spec) append       (make-run-time-alternative-combinations-1 (cadr alternative) (cddr alternative)))    `(nil . ,(make-run-time-alternative-combinations-1 (cadr spec) (cddr spec)))))  ;; Note that it is vital that the combination to be used;; be consed up in the same order as the combination was made by;; MAKE-RUN-TIME-ALTERNATIVE-COMBINATIONS, or it will not be recognized;; in the RUN-TIME-ALTERNATIVE-ALIST.(defun choose-run-time-alternative (flavor init-plist)  "This is the :INSTANTIATION-FLAVOR-FUNCTION used for run-time alternative flavors."  (let* ((specs (flavor-get flavor :run-time-alternatives)) (combination (choose-run-time-alternative-1 specs init-plist (flavor-name flavor))))    (or     (cdr      (assoc (append combination (list (flavor-name flavor)))     (flavor-get flavor 'run-time-alternative-alist) :test #'equal))     (if (member-if 'stringp combination)       (ferror () (car (member-if 'stringp combination)))       (ferror () "Bug in :RUN-TIME-ALTERNATIVE processing:~%Flavor ~S, combination ~S." flavor       combination)))))  (defun choose-run-time-alternative-1 (specs init-plist flavor-name)  (loop for spec in specs append (choose-run-time-alternative-2 spec init-plist flavor-name)))  (defun choose-run-time-alternative-2 (spec init-plist flavor-name)  (let ((value (get init-plist (car spec)))tem)    (if (consp (cadr spec))      (setq tem (assoc value (cdr spec) :test #'eq))      (case value((t) (setq tem spec))((nil) (setq tem '(foo)))))    (unless tem      (ferror () "Keyword ~S with value ~S is not legitimate for flavor ~S." (car spec) value      flavor-name))    (when (stringp (cadr tem))      (ferror () (cadr tem) (car spec) value flavor-name))    (let ((subs (choose-run-time-alternative-1 (cddr tem) init-plist flavor-name)))      (if (cadr tem)(append subs (list (cadr tem)))subs))))  (defun assure-flavor-composed (flavor-name &aux fl)  "Compose flavor FLAVOR-NAME and its methods if that has not already been done."  (check-arg flavor-name (setq fl (get-flavor-tracing-aliases flavor-name))     "the name of an instantiable flavor, or alias thereof")  ;; Do any composition (compilation) of combined stuff, if not done already  (or (flavor-depends-on-all fl) (compose-flavor-combination fl))  (or (flavor-method-hash-table fl) (compose-method-combination fl)))  #-elroy(defun make-instance (flavor &rest init-options)  "Create and return an instance of FLAVOR.  INIT-OPTIONS is an alternatinglist of init keywords and their values.  The new instance is sent an :INIT message.FLAVOR may also be a flavor instance, instead of a flavor name.  In this casethe instance is used instead of creating a new instance.  It is initializedusing the INIT-OPTIONS and is sent an :INIT message.  The instance is returned."  (instantiate-flavor flavor (locf init-options) t))  ;Make an object of a particular flavor (the usual use), or reinitialize a flavor instance.;In the first case, if the flavor hasn't been composed yet, must do so now.; Delaying it until the first time it is needed aids initialization,; e.g. up until now we haven't depended on the depended-on flavors being defined yet.;Note that INIT-PLIST can be modified, if the :DEFAULT-INIT-PLIST option was; used or the init methods modify it.;;****** phd 9/2/85: changed INSTANTIATE-FLAVOR to use a specialized miscop to create the instance;;****** This requires microcode 213 of newer.#-elroy(defsubst fast-eval (form)  "for internal use only"  (typecase form    (symbol (symbol-value form))    (atom form)    (list (if (eq (first form) 'quote)    (second form)    (eval form)))    (t (eval form)))) ;;;#+elroy ;;;(defun make-method-hash-table (fl);;;  ;; makes the hash table from a list of (key . value) stored in the flavor-hash-table of fl.;;;  (let* ((entry-list (flavor-method-hash-table fl));;;(ht (make-flavor-hash-array permanent-storage-area;;;    (1+ (ceiling (/ (length entry-list ) 0.8s0)))));;;(*create-mapping-tables* t));;;    (dolist (entry entry-list);;;      (puthash-array (car entry ) (second entry) ht;;;     (third entry) ));;;    (setf (flavor-method-hash-table fl) ht)));;;#+elroy;;;(defun instantiate-flavor (flavor init-plist &optional send-init-message-p return-unhandled-keywords-p;as second value;;;  area-to-cons-instance-in &aux fl  unhandled-keywords instance vars new-plist plist);;;  "Create and return an instance of the specified FLAVOR, low level.;;;INIT-PLIST's CDR is the list of init keywords and their values.;;;This list will be modified destructively so that any default init plist;;;keywords (except those that just set instance variables) are on it.;;;We send a :INIT message only if SEND-INIT-MESSAGE-P is non-nil.;;;That may further modify the INIT-PLIST.;;;If RETURN-UNHANDLED-KEYWORDS-P is non-nil, our second value is an;;;alternating list of keywords and values for those keywords specified in;;;INIT-PLIST (or in the default init plist) which the flavor doesn't handle.;;;If RETURN-UNHANDLED-KEYWORDS-P is nil, it is an error if there are any such.;;;FLAVOR may also be a flavor instance, instead of a flavor name.  In this case;;;the instance is reinitialized using INIT-PLIST, and a new flavor instance is NOT created.";;;  ;;If user supplied first arg a flavor instance, use it instead of creating a new instance.;;;  (if (typep flavor 'instance);;;    (progn;;;      (setq instance flavor;;;    flavor (type-of instance);;;    fl (get-flavor-tracing-aliases flavor);;;    vars (flavor-all-instance-variables fl));;;      ;; Default all instance variables to unbound;;;      (do ((v vars (cdr v));;;   (i 1 (1+ i)));;;  ((null v));;;(%p-store-tag-and-pointer (%make-pointer-offset dtp-locative instance i) dtp-null;;;  (car v))));;;    ;; Trace any chain of alias flavors to a non-alias flavor.;;;    (progn;;;      (check-arg flavor (setq fl (get-flavor-tracing-aliases flavor));;; "the name of an instantiable flavor, or alias thereof, or a flavor instance to be reinitialized.");;;      (setf plist (flavor-plist fl));;;      (let ((tem (getf plist :instantiation-flavor-function)));;;(when tem;;;  (setq tem (funcall tem fl init-plist));;;  (unless (and (symbolp tem) (get tem 'flavor));;;    (ferror ();;;    "The INSTANTIATION-FLAVOR-FUNCTION for flavor ~S;;;returned an invalid value, ~S, not a flavor name.";;;    flavor));;;  (setq flavor tem;;;fl (get-flavor-tracing-aliases flavor))));;;      (when (getf plist :abstract-flavor);;;(ferror () "~S is an abstract flavor (or alias of one) and may not be instantiated.";;;flavor));;;      (or (flavor-depends-on-all fl) (compose-flavor-combination fl));;;      (typecase (flavor-method-hash-table fl);;;(array nil);;;(cons(make-method-hash-table fl));;;(null (compose-method-combination fl));;;(t nil));;;      (unless area-to-cons-instance-in;;;(setq area-to-cons-instance-in;;;      (and (getf plist 'instance-area-function);;; (funcall (getf plist 'instance-area-function) init-plist))));;;      (let ((missing-keywords;;;     (remove-if #'(lambda (keyword);;;    (get-location-or-nil init-plist keyword));;;(getf plist 'required-init-keywords))));;;(when missing-keywords;;;  (ferror () "Flavor ~S requires init keywords ~S that are missing." flavor;;;  missing-keywords)));;;      (setq instance;;;    (%allocate-and-initialize-instance;;;;     fl area-to-cons-instance-in (flavor-instance-size fl))));;;    ;; Make the instance object, then fill in its various fields;;;    ;    (FUNCALL (OR (GETF PLIST 'INSTANCE-AREA-FUNCTION) 'IGNORE);;;    ;     INIT-PLIST)));;;    ;; Do any composition (compilation) of combined stuff, if not done already;;;);    (SETQ VARS (FLAVOR-ALL-INSTANCE-VARIABLES FL)));;;  ;; Default all instance variables to unbound;;;  ;  (DO ((V VARS (CDR V));;;  ;       (I 1 (1+ I)));;;  ;      ((NULL V));;;  ;    (%P-STORE-TAG-AND-POINTER (%MAKE-POINTER-OFFSET DTP-LOCATIVE INSTANCE I);;;  ;      DTP-NULL (CAR V)));;;  (setq unhandled-keywords (flavor-unhandled-init-keywords fl));;;  (let ((var-keywords (flavor-all-inittable-instance-variables fl));;;(remaining-keywords (flavor-remaining-init-keywords fl)));;;;; First, process any user-specified init keywords that;;;;; set instance variables.  When we process the defaults,;;;;; we will see that these are already set, and will;;;;; refrain from evaluating the default forms.;;;;; At the same time, we record any init keywords that this flavor doesn't handle.;;;    (do ((pl (cdr init-plist) (cddr pl)));;;((null pl));;;      (let ((index (position (car pl) (the list var-keywords) :test #'eq)));;;(cond;;;  (index;;;   (or (/= dtp-null (%p-data-type (%instance-loc instance (1+ index))));;;      (setf (%instance-ref instance (1+ index)) (cadr pl))));;;  ((not (member (car pl) remaining-keywords :test #'eq));;;   (pushnew (car pl) unhandled-keywords)))));;;    ;; Now do all the default initializations, of one sort or other,;;;    ;; that have not been overridden.;;;    (let ((self instance));;;      (dolist (d (flavor-instance-variable-initializations fl));;;(or (/= dtp-null (%p-data-type (%instance-loc instance (1+ (car d)))));;;   (setf (%instance-ref instance (1+ (car d))) (fast-eval (cadr d)))));;;      ;; Now stick any default init plist items that aren't handled by that;;;      ;; onto the actual init plist.;;;      (do ((pl (flavor-remaining-default-plist fl) (cddr pl)));;;  ((null pl));;;(or (memq-alternated (car pl) (cdr init-plist));;;   (progn;;;     (unless (eq init-plist (locf new-plist));;;       (setq new-plist (cdr init-plist);;;     init-plist (locf new-plist)));;;     (setq new-plist (list* (car pl) (fast-eval (cadr pl)) new-plist)))))));;;  ;; Complain if any keywords weren't handled, unless our caller;;;  ;; said it wanted to take care of this.;;;  (and (not return-unhandled-keywords-p) unhandled-keywords;;;     (not (get init-plist :allow-other-keys));;;     (ferror () "Flavor ~S does not handle the init keyword~P ~{~S~^, ~}" flavor;;;     (length unhandled-keywords) unhandled-keywords));;;  (if send-init-message-p;;;    (send instance :init init-plist));;;  (values instance unhandled-keywords))    #-elroy(defun instantiate-flavor (flavor init-plist &optional send-init-message-p return-unhandled-keywords-p;as second value  area-to-cons-instance-in &aux fl unhandled-keywords instance vars new-plist plist)  "Create and return an instance of the specified FLAVOR, low level.INIT-PLIST's CDR is the list of init keywords and their values.This list will be modified destructively so that any default init plistkeywords (except those that just set instance variables) are on it.We send a :INIT message only if SEND-INIT-MESSAGE-P is non-nil.That may further modify the INIT-PLIST.If RETURN-UNHANDLED-KEYWORDS-P is non-nil, our second value is analternating list of keywords and values for those keywords specified inINIT-PLIST (or in the default init plist) which the flavor doesn't handle.If RETURN-UNHANDLED-KEYWORDS-P is nil, it is an error if there are any such.FLAVOR may also be a flavor instance, instead of a flavor name.  In this casethe instance is reinitialized using INIT-PLIST, and a new flavor instance is NOT created."  ;;If user supplied first arg a flavor instance, use it instead of creating a new instance.  (if (typep flavor 'instance)    (progn      (setq instance flavor    flavor (type-of instance)    fl (get-flavor-tracing-aliases flavor)    vars (flavor-all-instance-variables fl))      ;; Default all instance variables to unbound      (do ((v vars (cdr v))   (i 1 (1+ i)))  ((null v))(%p-store-tag-and-pointer (%make-pointer-offset dtp-locative instance i) dtp-null  (car v))))    ;; Trace any chain of alias flavors to a non-alias flavor.    (progn      (check-arg flavor (setq fl (get-flavor-tracing-aliases flavor)) "the name of an instantiable flavor, or alias thereof, or a flavor instance to be reinitialized.")      (setf plist (flavor-plist fl))      (let ((tem (getf plist :instantiation-flavor-function)))(when tem  (setq tem (funcall tem fl init-plist))  (unless (and (symbolp tem) (get tem 'flavor))    (ferror ()    "The INSTANTIATION-FLAVOR-FUNCTION for flavor ~Sreturned an invalid value, ~S, not a flavor name."    flavor))  (setq flavor temfl (get-flavor-tracing-aliases flavor))))      (when (getf plist :abstract-flavor)(ferror () "~S is an abstract flavor (or alias of one) and may not be instantiated."flavor))      (or (flavor-depends-on-all fl) (compose-flavor-combination fl))      (or (flavor-method-hash-table fl) (compose-method-combination fl))      (unless area-to-cons-instance-in(setq area-to-cons-instance-in      (and (getf plist 'instance-area-function) (funcall (getf plist 'instance-area-function) init-plist))))      (let ((missing-keywords     (remove-if #'(lambda (keyword)    (get-location-or-nil init-plist keyword))(getf plist 'required-init-keywords))))(when missing-keywords  (ferror () "Flavor ~S requires init keywords ~S that are missing." flavor  missing-keywords)))      (setq instance    (%allocate-and-initialize-instance;     fl area-to-cons-instance-in (flavor-instance-size fl))))    ;; Make the instance object, then fill in its various fields    ;    (FUNCALL (OR (GETF PLIST 'INSTANCE-AREA-FUNCTION) 'IGNORE)    ;     INIT-PLIST)))    ;; Do any composition (compilation) of combined stuff, if not done already);    (SETQ VARS (FLAVOR-ALL-INSTANCE-VARIABLES FL)))  ;; Default all instance variables to unbound  ;  (DO ((V VARS (CDR V))  ;       (I 1 (1+ I)))  ;      ((NULL V))  ;    (%P-STORE-TAG-AND-POINTER (%MAKE-POINTER-OFFSET DTP-LOCATIVE INSTANCE I)  ;      DTP-NULL (CAR V)))  (setq unhandled-keywords (flavor-unhandled-init-keywords fl))  (let ((var-keywords (flavor-all-inittable-instance-variables fl))(remaining-keywords (flavor-remaining-init-keywords fl)));; First, process any user-specified init keywords that;; set instance variables.  When we process the defaults,;; we will see that these are already set, and will;; refrain from evaluating the default forms.;; At the same time, we record any init keywords that this flavor doesn't handle.    (do ((pl (cdr init-plist) (cddr pl)))((null pl))      (let ((index (position (car pl) (the list var-keywords) :test #'eq)))(cond  (index   (or (/= dtp-null (%p-data-type (%instance-loc instance (1+ index))))      (setf (%instance-ref instance (1+ index)) (cadr pl))))  ((not (member (car pl) remaining-keywords :test #'eq))   (pushnew (car pl) unhandled-keywords)))))    ;; Now do all the default initializations, of one sort or other,    ;; that have not been overridden.    (let ((self instance))      (dolist (d (flavor-instance-variable-initializations fl))(or (/= dtp-null (%p-data-type (%instance-loc instance (1+ (car d)))))   (setf (%instance-ref instance (1+ (car d))) (fast-eval (cadr d)))))      ;; Now stick any default init plist items that aren't handled by that      ;; onto the actual init plist.      (do ((pl (flavor-remaining-default-plist fl) (cddr pl)))  ((null pl))(or (memq-alternated (car pl) (cdr init-plist))   (progn     (unless (eq init-plist (locf new-plist))       (setq new-plist (cdr init-plist)     init-plist (locf new-plist)))     (setq new-plist (list* (car pl) (fast-eval (cadr pl)) new-plist)))))))  ;; Complain if any keywords weren't handled, unless our caller  ;; said it wanted to take care of this.  (and (not return-unhandled-keywords-p) unhandled-keywords     (not (get init-plist :allow-other-keys))     (ferror () "Flavor ~S does not handle the init keyword~P ~{~S~^, ~}" flavor     (length unhandled-keywords) unhandled-keywords))  (if send-init-message-p    (send instance :init init-plist))  (values instance unhandled-keywords))  ;;;#+elroy;;;(defun %make-instance (flavor-name &rest contents &aux fl instance);;;  "Create an instance of flavor FLAVOR-NAME and init all slots from CONTENTS.;;;This ignores completely the default initializations,;;;and dos not send the :INIT message.  But it is very fast.;;;CONTENTS must have exactly the right number of elements,;;; and must be a cdr-coded list.";;;  (check-arg flavor-name (setq fl (get flavor-name 'flavor)) "the name of a flavor");;;  (or (flavor-depends-on-all fl) (compose-flavor-combination fl));;;  (typecase (flavor-method-hash-table fl);;;    (array nil);;;    (cons (make-method-hash-table fl));;;    (null (compose-method-combination fl));;;    (t nil));;;  (setq instance;;;(%allocate-and-initialize-instance fl default-cons-area (flavor-instance-size fl)));;;  (when contents;;;    (%blt-typed contents (%instance-loc instance 1) (1- (flavor-instance-size fl)) 1));;;  instance)  ;The old code is below:#-elroy(defun %make-instance (flavor-name &rest contents &aux fl instance)  "Create an instance of flavor FLAVOR-NAME and init all slots from CONTENTS.This ignores completely the default initializations,and dos not send the :INIT message.  But it is very fast.CONTENTS must have exactly the right number of elements, and must be a cdr-coded list."  (check-arg flavor-name (setq fl (get flavor-name 'flavor)) "the name of a flavor")  (or (flavor-depends-on-all fl) (compose-flavor-combination fl))  (or (flavor-method-hash-table fl) (compose-method-combination fl))  (setq instance(%allocate-and-initialize dtp-instance dtp-instance-header fl () default-cons-area  (flavor-instance-size fl)))  (%blt-typed contents (%instance-loc instance 1) (1- (flavor-instance-size fl)) 1)  instance)  (defun memq-alternated (elt list)  (do ((l list (cddr l)))      ((null l)       nil)    (if (eq (car l) elt)      (return l))))  (defun flavor-default-init-plist (flavor-name &optional (init-plist (cons () ())) &aux fl)  "Returns the default init plist for FLAVOR-NAME.If INIT-PLIST is specified, it is modified to contain anydefault init plist entries which it does not override."  (check-arg flavor-name (setq fl (get flavor-name 'flavor)) "the name of a flavor")  ;; Do any composition (compilation) of combined stuff, if not done already  (or (flavor-depends-on-all fl) (compose-flavor-combination fl))  (dolist (ffl (flavor-depends-on-all fl))    (setq ffl (get ffl 'flavor))    (do ((l (getf (flavor-plist ffl) :default-init-plist) (cddr l)))((null l) nil)      (do ((m (cdr init-plist) (cddr m)))  ((null m)   (setf (get init-plist (car l)) (eval (cadr l))))(and (eq (car m) (car l)) (return)))))  init-plist)  (defun flavor-allows-init-keyword-p (flavor-name keyword)  "Return non-nil if flavor FLAVOR-NAME handles init keyword KEYWORD.The actual value is the particular component flavor which handles it."  (map-over-component-flavors 0 t t      #'(lambda (fl ignore keyword)  (and   (or    (assoc keyword (flavor-inittable-instance-variables fl)   :test #'eq)    (member keyword (flavor-init-keywords fl) :test #'eq))   (flavor-name fl)))      flavor-name () keyword))  (defun flavor-allowed-init-keywords (flavor-name)  "Return a list of all init keywords handled by flavor FLAVOR-NAME."  (let ((init-keywords nil))    (map-over-component-flavors 0 t ()#'(lambda (flavor ignore)    (setq init-keywords  (append   (mapcar    #'(lambda (kwd)(if (consp kwd)  (car kwd)  kwd))    (flavor-local-init-keywords flavor))   init-keywords)))flavor-name ())    (sort (delete-duplicates (the list init-keywords) :test #'eq) #'alphalessp)))(defun flavor-local-init-keywords (flavor)  (append (flavor-inittable-instance-variables flavor) (flavor-init-keywords flavor)))  (defun flavor-default-init-putprop (flavor form init-keyword &aux fl)  "Add or change an entry in FLAVOR's default init plist.The entry is for init keyword INIT-KEYWORD, and the valuewill be computed by evaluating FORM."  (setq fl (if (symbolp flavor)     (compilation-flavor flavor)     flavor))  (unless (flavor-allows-init-keyword-p flavor init-keyword)    (ferror () "Init keyword ~S invalid for flavor ~S." init-keyword flavor))  (setf (getf (getf (flavor-plist fl) :default-init-plist) init-keyword) form)  (perform-flavor-bindings-redefinition flavor))  (defprop flavor-default-init-get   ((flavor-default-init-get fl kwd) flavor-default-init-putprop fl val kwd) setf)  (defun flavor-default-init-remprop (flavor init-keyword &aux fl)  "Remove any entry for INIT-KEYWORD from FLAVOR's default init plist."  (setq fl (if (symbolp flavor)     (compilation-flavor flavor)     flavor))  (remprop (locf (get (locf (flavor-plist fl)) :default-init-plist)) init-keyword)  (perform-flavor-bindings-redefinition flavor))  (defun flavor-default-init-get (flavor init-keyword &aux fl)  "Return the form for INIT-KEYWORD in FLAVOR's default init plist, or NIL."  (setq fl (if (symbolp flavor)     (compilation-flavor flavor)     flavor))  (getf (getf (flavor-plist fl) :default-init-plist) init-keyword))  ; Function to map over all components of a specified flavor.  We must do the;  DEPENDS-ON's to all levels first, then the INCLUDES's at all levels and;  what they depend on.; Note that it does the specified flavor itself as well as all its components.; Note well: if there are included flavors, this does not do them in the;  right order.  Also note well: if there are multiple paths to a component,;  it will be done more than once.; RECURSION-STATE is 0 except when recursively calling itself.; ERROR-P is T if not-yet-defflavored flavors are to be complained about,;  NIL if they are to be ignored.  This exists to get rid of certain;  bootstrapping problems.; RETURN-FIRST-NON-NIL is T if the iteration should terminate as soon;  as FUNCTION returns a non-null result.; At each stage FUNCTION is applied to the flavor (not the name), the;  STATE, and any ARGS.  STATE is updated to whatever the function returns.; The final STATE is the final result of this function.; RECURSION-STATE is:;  0top-level;  1first-pass over just depends-on's;  6  second-pass, this flavor reached via depends-on's so don't do it again;  2second-pass, this flavor reached via includes's so do it.(defvar some-component-undefined ())     ;If we find an undefined component, we put its name here.(defun map-over-component-flavors (recursion-state error-p return-first-non-nil function flavor-name state &rest args)  (block map-over-component-flavors    (prog (fl)      (cond((or error-p (compilation-flavor flavor-name)) (check-arg flavor-name (setq fl (compilation-flavor flavor-name)) "a defined flavor") ;; First do this flavor, unless this is the second pass and it shouldn't be done (or (logtest 4 recursion-state) (setq state (apply function fl state args))) ;; After each call to the function, see if we're supposed to be done now (and return-first-non-nil (not (null state)) (return-from map-over-component-flavors)) ;; Now do the depends-on's. (dolist (component-flavor (flavor-depends-on fl))   (setq state (apply #'map-over-component-flavors(if (zerop recursion-state)  1  recursion-state)error-p return-first-non-nil function component-flavor state args))   (and return-first-non-nil (not (null state)) (return-from map-over-component-flavors))) ;; Unless this is the first pass, do the includes. (or (logtest 1 recursion-state)    (dolist (component-flavor (flavor-includes fl))      (setq state    (apply #'map-over-component-flavors 2 error-p return-first-non-nil function   component-flavor state args))      (and return-first-non-nil (not (null state)) (return-from map-over-component-flavors)))) ;; If this is the top-level, run the second pass on its depends-on's ;; which doesn't do them but does do what they include. (or (not (zerop recursion-state))    (dolist (component-flavor (flavor-depends-on fl))      (setq state    (apply #'map-over-component-flavors 6 error-p return-first-non-nil function   component-flavor state args))      (and return-first-non-nil (not (null state)) (return-from map-over-component-flavors)))))((null some-component-undefined) (setq some-component-undefined flavor-name)))))  state)  (defparameter *dont-recompile-flavors* ()   "T means RECOMPILE-FLAVOR does nothing.Used to speed up multiple redefinitions on flavors.Turn this on for the redefinitions, turn this off, then recompile by hand.It can be a <meth structure>, in that case the combined methods will be recompiledif they contain (meth-function-spec <neth structure> in line") (defun recompile-flavor (flavor-name &optional (single-operation nil) (*use-old-combined-methods* t) (do-dependents t)      &aux fl)  "Recompute some or all combined methods for flavor FLAVOR-NAME and dependents.If SINGLE-OPERATION is NIL, all operations are done;otherwise that specifies which operation to do.If DO-DEPENDENTS is specified as NIL, the dependents are not done.If *USE-OLD-COMBINED-METHODS* is specified as NIL, existing combinedmethods are replaced even if they appear to be valid when checked.Do this to correct for a bug in a combined method creation functionor a change in a macro that a wrapper expands into."  ;; If this is called during file compilation, the output goes to the QFASL file.  (check-arg flavor-name (setq fl (get flavor-name 'flavor)) "the name of a flavor")  (unless *dont-recompile-flavors*   ;; Only update the method combination if it has been done before, else doesn't matter    (cond      ((flavor-method-hash-table fl)       (or (flavor-depends-on-all fl) (compose-flavor-combination fl))       (compose-method-combination fl single-operation)))    (when do-dependents      (let ((inhibit-fdefine-warnings t);Don't give warnings for combined methods    (fdefine-file-pathname nil));And they don't "belong" to a file that calls this.(dolist (fn (flavor-depended-on-by-all fl))  (if (flavor-method-hash-table (get fn 'flavor))    (recompile-flavor fn single-operation *use-old-combined-methods* ())))))))  (defun flavor-depended-on-by-all (fl &optional list-so-far &aux scan-pointer tail ffl)  "Return a list of the names of all flavors that depend on the flavor FL.Values are in breadth-first order, a good though not perfect order for doing redefinitions."  (push fl list-so-far)  (setq tail (last list-so-far))  (setq scan-pointer list-so-far)  (do ()      ((null scan-pointer)       (cdr list-so-far))    (let* ((fn (car scan-pointer))   (fl (if (symbolp fn) (compilation-flavor fn) fn)))      (dolist (fn1 (flavor-depended-on-by fl))(or (member fn1 list-so-far :test #'eq) (not (setq ffl (compilation-flavor fn1 )))   (rplacd tail (setq tail (cons fn1 ()))))))    (pop scan-pointer)))  ;This function takes care of flavor-combination.  It sets up the list;of all component flavors, in appropriate order, and the list of all;instance variables.  It generally needs to be called only once for a;flavor, and must be called before method-combination can be dealt with.(defvar flavors-being-composed ())  ;;;PHD 3/9/87 Be carefull with nunion that destruct more than they used to do.(defun compose-flavor-combination (fl &optional (error-p t) &aux fls vars ords reqs specs size (some-component-undefined nil)  (flavors-being-composed (cons fl flavors-being-composed))  (perm-area (if *just-compiling*       default-cons-area       permanent-storage-area))  (default-cons-area (if *just-compiling*       default-cons-area       *flavor-area*)))  "Find and record component flavors of flavor object FL.ERROR-P says whether to get error on undefined components.We return a list of all known components;if they are all defined, then they are really all the components,and the flavor is marked as composed by setting its FLAVOR-DEPENDS-ON-ALL to that list."  ;; Make list of all component flavors' names.  ;; This list is in outermost-first order.  ;; Would be nice for this not to have to search to all levels, but for  ;; the moment that is hard, so I won't do it.  ;; Included-flavors are hairy: if not otherwise in the list of components, they  ;; are stuck in after the rightmost component that includes them, along with  ;; any components of their own not otherwise in the list.  (setq fls (copy-list (compose-flavor-inclusion (flavor-name fl) error-p) perm-area))  ;; Vanilla-flavor may have been put in by magic, so maintain the dependencies  ;; in case new methods get added to it later.  (let ((van (compilation-flavor 'vanilla-flavor))(flav (flavor-name fl)))    (and (not (null van)) (neq flav 'vanilla-flavor) (member 'vanilla-flavor fls :test #'eq)       (not *just-compiling*) (not (member flav (flavor-depended-on-by van) :test #'eq))       (push flav (flavor-depended-on-by van))))  ;; Compute what the instance variables will be, and in what order.  ;; Also collect the required but not present instance variables, which go onto the  ;; ADDITIONAL-INSTANCE-VARIABLES property.  The instance variables of the  ;; :REQUIRED-FLAVORS work the same way.  Such instance variables are ok  ;; for our methods to access.  (dolist (f fls)    (setq f (compilation-flavor f))    (dolist (v (flavor-local-instance-variables f))      (or (atom v) (setq v (car v)))      (or (member v vars :test #'eq) (push v vars)))    (setq specs (nunion specs (copylist* (flavor-special-instance-variables f)) :test #'eq))    (setq reqs (nunion reqs (copylist* (getf (flavor-plist f) :required-instance-variables)) :test #'eq))    ;; Any variables our required flavors have or require, we require.    (dolist (ff (getf (flavor-plist f) :required-flavors))      (cond((and (not (member ff fls :test #'eq)) (setq ff (compilation-flavor ff))    (not (member ff (cdr flavors-being-composed) :test #'eq))) (or (flavor-depends-on-all ff) (compose-flavor-combination ff ())) (setq specs (nunion specs (copylist* (flavor-all-special-instance-variables ff)) :test #'eq)) (setq reqs       (nunion (nunion reqs (copylist* (flavor-all-instance-variables ff)) :test #'eq)       (copylist* (getf (flavor-plist ff) 'additional-instance-variables)) :test #'eq)))))    (let ((ord (getf (flavor-plist f) :ordered-instance-variables)))  ;; Merge into existing order requirement.  Shorter of the two must be  ;; a prefix of the longer, and we take the longer.      (do ((l1 ord (cdr l1))   (l2 ords (cdr l2)))  (nil)(cond  ((null l1) (return ()))  ((null l2) (return (setq ords ord)))  ((neq (car l1) (car l2))   (ferror () ":ORDERED-INSTANCE-VARIABLES conflict, ~S vs ~S" (car l1) (car l2)))))))  ;; Must not merge this with the previous loop,  ;; to avoid altering order of instance variables  ;; if a DEFFLAVOR is redone.  (dolist (f fls)    (setq f (compilation-flavor f)));    ;; Any variables our components's methods reference, we must keep having.  ;    (SETQ VARS (UNION VARS (FLAVOR-MAPPED-INSTANCE-VARIABLES F))))  ;; This NREVERSE makes it compatible with the old code.  There is no other reason for it.  (setq vars (nreverse vars))  ;; Apply ordering requirement by moving those variables to the front.  (dolist (v ords)    (or (member v vars :test #'eq)       (ferror () "Flavor ~S lacks instance variable ~S which has an order requirement"       (flavor-name fl) v))    (setq vars (delete v (the list vars) :test #'eq)))  (setq vars (append ords vars))  (setf (flavor-all-instance-variables fl) (copy-list vars perm-area))  (if (or ords (flavor-unmapped-instance-variables fl))    (setf (flavor-unmapped-instance-variables fl) ords))  ;; Instance size must be at least 2 or microcode blows out - fix some day?  (setq size (max (1+ (length vars)) 2))  (and (flavor-instance-size fl) (/= (flavor-instance-size fl) size)     (format *error-output*     "~&Warning: changing the size of an instance of ~S from ~S to ~SThis may cause you problems.~%";* This should perhaps do something about it *     (flavor-name fl) (flavor-instance-size fl) size))  (setf (flavor-instance-size fl) size)  ;; If there are any instance variables required but not present, save them  ;; so that they can be accessed in methods.  (dolist (v vars)    (setq reqs (delete v (the list reqs) :test #'eq)))  (and reqs (setf (getf (flavor-plist fl) 'additional-instance-variables) reqs))  (and specs (setf (flavor-all-special-instance-variables fl) specs))  ;; Don't mark this flavor as "composed" if there were errors.  (or some-component-undefined (setf (flavor-depends-on-all fl) fls))  fls)  (defun compose-flavor-inclusion (flavor error-p)  (multiple-value-bind (fls additions)    (compose-flavor-inclusion-1 flavor () error-p)    ;; The new additions may themselves imply more components    (do ((l additions (cdr l)))((null l) nil)      (let ((more-fls (compose-flavor-inclusion-1 (car l) fls error-p)))(dolist (f more-fls) ;; This hair inserts F before (after) the thing that indirectly included it ;; and then puts that next on ADDITIONS so it gets composed also  (let ((ll (member (car l) fls :test #'eq)))    (rplaca (rplacd ll (cons (car ll) (cdr ll))) f)    (rplacd l (cons f (cdr l)))))))    ;; Now attach vanilla-flavor if desired    (or     (loop for flavor in fls thereis(let ((tem (compilation-flavor flavor)))  (and tem (getf (flavor-plist tem) :no-vanilla-flavor))))     (push 'vanilla-flavor fls))    (nreverse fls)))  (defun compose-flavor-inclusion-1 (flavor other-components error-p &aux flavor-1) ;; First, make a backwards list of all the normal (non-included) components  (declare (special other-components))  (let ((fls (map-over-component-flavors 1 error-p ()     #'(lambda (fl list) (setq fl (flavor-name fl)) (or (member fl list :test #'eq)    (member fl other-components :test #'eq)    (push fl list)) list)     flavor ()))(additions nil));; If there are any inclusions that aren't in the list, plug;; them in right after (before in backwards list) their last (first) includer    (do ((l fls (cdr l)))((null l) nil)      (dolist (fl (flavor-includes (compilation-flavor (car l))))(or (member fl fls :test #'eq) (member fl other-components :test #'eq)   (push (car (rplaca (rplacd l (cons (car l) (cdr l))) fl)) additions))))    (or (member flavor fls :test #'eq);; Avoid error if FLAVOR is undefined and ERROR-P is NIL.       (not (or (setq flavor-1 (compilation-flavor flavor)) error-p))       (setq fls     (nconc fls    (nreverse     (loop for fl in (flavor-includes flavor-1) unless(or (member fl fls :test #'eq) (member fl other-components :test #'eq))collect fl and do (push fl additions))))))    (values fls additions)))  ;Mapping tables.;Each mapping table relates a method-flavor to an instance-flavor.;It maps several of the instance vars accessible from the method-flavor;to slot positions in the instances of the instance flavor.;Ths instance variables mapped are those in the (FLAVOR-MAPPED-INSTANCE-VARIABLES ...);of the method flavor.  Those conprise all the instance variables actually;referred to by compiled code of methods of the method flavor,;except for ordered instance variables, which are not mapped at all.;Note that "method-flavor" simply means a flavor on which a method has been defined;and "instance-flavor" simply means a flavor which depends on the method-flavor;and has been instantiated.;Pointers to the mapping tables for one instance-flavor (and various method-flavors);are stored in an art-q-list array called;(FLAVOR-COMPONENT-MAPPING-TABLE-VECTOR instance-flavor).;But they are found thru an alist, (FLAVOR-COMPONENT-MAPPING-TABLE-ALIST instance-flavor).;The CDRs of alist elements are locatives into the vector.;When a new method-flavor is seen to need a mapping table,;the entire alist is recopied so it will be compact;;and a previously unused slot in the vector is used.;This way, we keep the alist maximally short and compact,;while keeping the vector short but avoiding forwarding it;unless the flavor gets recomposed with new mixins.;Methods called by message passing get their mapping tables;from the method hash table.;Methods called from combined methods are given mapping tables;by the combined method.  This does not search the alist.;Instead, the combined method looks in its own mapping table,;in the array leader, to find the mapping table to supply for the;method it is calling.;Given a list (FLAVOR-NAME VAR-NAME), return the number of the slot;in mapping tables from that flavor as the method flavor;for the specified variable.;If necessary, add this variable to the flavor's mapped variables;and update all the flavor's mapping tables.;Given instead a list (FLAVOR-NAME T COMPONENT-FLAVOR-NAME),;we pass it on to FLAVOR-COMPONENT-FLAVOR-SELF-REF-INDEX.(defun flavor-var-self-ref-index (flavor-and-varname) ;;  4/19/85 DNG - Use COMPILATION-FLAVOR instead of GET.  (let ((flavor (compilation-flavor (car flavor-and-varname))))    (or flavor       (ferror () "Loading a method for flavor ~S which is not defined" (car flavor-and-varname)))    (if (and (CDDR flavor-and-varname) (eq (second flavor-and-varname) t))      (flavor-component-flavor-self-ref-index flavor-and-varname)      (let* ((varname (cadr flavor-and-varname))     (pos      (position varname (the list (flavor-mapped-instance-variables flavor)) :test #'eq))     (opos      (position varname (the list (flavor-unmapped-instance-variables flavor)) :test#'eq)))(cond  (opos)  ((and (eq (third flavor-and-varname) :unmapped);; Unmapped reference requested by COMPILER:TRY-REF-SELF      (position varname (the list (flavor-all-instance-variables flavor)) :test #'eq)))  (pos (dpb 1 %%self-ref-relocate-flag pos))  (t   (setf (flavor-mapped-instance-variables flavor) (nconc (flavor-mapped-instance-variables flavor)(cons-in-area varname () working-storage-area)))   (remake-mapping-tables flavor flavor)   (dpb 1 %%self-ref-relocate-flag(position varname (the list (flavor-mapped-instance-variables flavor)) :test  #'eq))))))))  ;Don't record evaluations of this function in QFASL files.(defprop flavor-var-self-ref-index t qfasl-dont-record)  ;Given a list (FLAVOR-NAME T COMPONENT-FLAVOR-NAME), return the number of the slot;in the array leader of a mapping table between any-flavor and FLAVOR-NAME;which contains the locative to the ptr to the mapping table between;any-flavor and COMPONENT-FLAVOR-NAME.  Adds such an array leader slot if none yet.(defun flavor-component-flavor-self-ref-index (flavor-and-component-flavor-name) ;; 3/28/85 DNG - Use COMPILATION-FLAVOR instead of GET.  (let* ((flavor (compilation-flavor (car flavor-and-component-flavor-name))) (component-flavor-name (caddr flavor-and-component-flavor-name)) (pos  (position component-flavor-name (the list (flavor-mapped-component-flavors flavor))    :test #'eq)))    (or pos       (setq pos     (progn       (let ((default-cons-area background-cons-area))     ;; Note that the SETF does a PUTPROP which can cons. (setf (flavor-mapped-component-flavors flavor)       (nconc (flavor-mapped-component-flavors flavor)      (cons component-flavor-name ()))))       (remake-mapping-tables flavor flavor)       (position component-flavor-name (the list (flavor-mapped-component-flavors flavor)) :test #'eq))))    (dpb 1 %%self-ref-relocate-flag (dpb 1 %%self-ref-map-leader-flag (+ pos 3)))))  (defun flavor-decode-self-ref-pointer (flavor-name pointer-number)  "Decode the pointer field of a DTP-SELF-REF-POINTER.Assumes that it is used with flavor FLAVOR-NAME.Values are an instance variable name and NIL,or a component flavor name and T."  (declare (values instance-var-or-component-flavor t-if-component-flavor))  (let ((flavor (get flavor-name 'flavor)))    (cond      ((null flavor) nil)      ((ldb-test %%self-ref-map-leader-flag pointer-number)       (values(nth (- (ldb %%self-ref-index pointer-number) 3)     (flavor-mapped-component-flavors flavor))t))      ((ldb-test %%self-ref-relocate-flag pointer-number)       (nth (ldb %%self-ref-index pointer-number) (flavor-mapped-instance-variables flavor)))      ((nth (ldb %%self-ref-index pointer-number) (flavor-unmapped-instance-variables flavor)))      (t (nth (ldb %%self-ref-index pointer-number) (flavor-all-instance-variables flavor))))))  (defun flavor-inherit-mapping-table-flavors (fl)  "Return a list of component flavor objects of FL from which FL can inherit mapping tables."  (if (symbolp fl)    (setq fl (get fl 'flavor)))  (loop for fn1 in (cdr (flavor-depends-on-all fl)) as fl1 = (get fn1 'flavor) when     (and (flavor-all-instance-variables fl1) (flavor-method-hash-table fl1)(do ((vs (flavor-all-instance-variables fl) (cdr vs))     (v1s (flavor-all-instance-variables fl1) (cdr v1s)))    ((null v1s)     t)  (if (or (null vs) (neq (car vs) (car v1s)))    (return ()))))     collect fl1))  ;Update the mapping tables from method-flavor to instance-flavor;and all flavors that depend on instance-flavor.;Don't create any new mapping tables; only update those that exist.;We take short cuts that assume that this is being done because a new mapped instance var;or mapped component-flavor has been added, and that the goal is to make the maps longer.(defun remake-mapping-tables (instance-flavor method-flavor) ;; 3/28/85 DNG - Use COMPILATION-FLAVOR instead of GET.  (and instance-flavor     (let ((loc    (assoc (flavor-name method-flavor)   (flavor-component-mapping-table-alist instance-flavor) :test #'eq)))   ;; If this instance-flavor's mapping table already maps as many variables   ;; as need to be mapped, it must have been reached by a different path,   ;; so don't bother with it or its dependants again.       (if (and (cddr loc)   (eq (array-leader (cddr loc) 0)       (length (flavor-mapped-instance-variables method-flavor)))   (= (array-leader-length (cddr loc))      (+ 3 (length (flavor-mapped-component-flavors method-flavor))))) () (progn   (cond     ((cddr loc)      (let ((omap (cddr loc)))(setf (cddr loc) (update-mapping-table instance-flavor method-flavor (cddr loc)))(and (arrayp (flavor-method-hash-table instance-flavor))   (replace-through-hash-table (flavor-method-hash-table instance-flavor) omap       (cddr loc))))))   (dolist (subflavor (flavor-depended-on-by instance-flavor))     (remake-mapping-tables      (if (symbolp subflavor)(compilation-flavor subflavor)subflavor)      method-flavor)))))))  (defun replace-through-hash-table (hash-table old new)  (let ((len (array-total-size hash-table)))    (do ((i 2 (+ 3 i)))((>= i len))      (if (eq (aref hash-table i) old)(setf (aref hash-table i) new)))))  (defvar trace-mapping-table-growth ()   "T => print a message every time an existing flavor mapping table is made bigger.")  ;Construct a new map for a pair of flavors, or reuse an old map if it is long enough.;If we construct a new map, we make it a little bigger than necessary;so that if only a couple more mapped vars are needed we can reuse it.(defun update-mapping-table (instance-flavor method-flavor &optional old-map) ;; 3/28/85 DNG - Use COMPILATION-FLAVOR instead of GET.  (if (symbolp method-flavor)    (setq method-flavor (compilation-flavor method-flavor)))  (let ((mapvars (flavor-mapped-instance-variables method-flavor))(mapflavs (flavor-mapped-component-flavors method-flavor))(ivars (flavor-all-instance-variables instance-flavor)))    (let ((map old-map))      (when (or (null map) (> (length mapvars) (array-total-size map))  (> (length mapflavs) (- (array-leader-length map) 3)))(and map trace-mapping-table-growth   (format t "~&Growing mapping table for method flavor ~S, instance flavor ~S."   (flavor-name method-flavor)   (if (symbolp instance-flavor)     instance-flavor     (flavor-name instance-flavor))))(setq map      (make-array (+ 4 (length mapvars)) :type art-16b :leader-length  (+ 3 (length mapflavs)) :area permanent-storage-area)))      ;; Fill in the extra leader slots with mapping table locatives      ;; for this instance flavor and the method flavor's mapped component-flavors      ;; as method flavors.      (do ((i 3 (1+ i))   (flavs mapflavs (cdr flavs)))  ((null flavs))(setf (array-leader map i) (get-mapping-table-location instance-flavor (car flavs))))      ;; Fill in the array elements of the mapping table      ;; with indices in the instance flavor of the method flavor's mapped variables.      (do ((i 0 (1+ i))   (vars mapvars (cdr vars)))  ((null vars)   (setf (array-leader map 0) i))(setf (aref map i) (or (position (car vars) (the list ivars) :test #'eq)       #-Elroy #o7771       #+Elroy #XFFFFFF)))      ;; The 7771 or #XFFFFFFis recognize by the microcode, when somebody tries to get that offset      ;; into an instance the microcode traps (> #-Elroy 7770 #+Elroy #XFFFFFE)      (setf (array-leader map 1) method-flavor)      (setf (array-leader map 2) instance-flavor)      map)))  (defvar *create-mapping-tables* ()   "T while method-composing; create any mapping table a method wants to use.")  ;Get a cell whose CDR is or will be the mapping table for a pair of flavors.;If the instance flavor has been instantiated, we also create a mapping table;if there isn't one.  Otherwise, we just make a slot in the alist and leave it nil.;The mapping tables will be created when the flavor is instantiated.(defun get-mapping-table-location (instance-flavor method-flavor)  (if (symbolp instance-flavor)    (setq instance-flavor (compilation-flavor instance-flavor )))  (or (symbolp method-flavor) (setq method-flavor (flavor-name method-flavor)))  (or   (cdr (assoc method-flavor (flavor-component-mapping-table-alist instance-flavor) :test #'eq))   ;; If the method-flavor is no longer a component of the instance-flavor,   ;; it must be someone's mapped-component-flavor that is no longer used.   ;; Just ignore it.   (and (member method-flavor (flavor-depends-on-all instance-flavor) :test #'eq);; This method flavor is not in the alist, so make a slot for its mapping table.      (let ((vector (flavor-component-mapping-table-vector instance-flavor)) vector-index)    ;; Make sure vector exists and is long enough for all our component flavors.(let ((len (length (flavor-depends-on-all instance-flavor))))  (or vector     (setf (flavor-component-mapping-table-vector instance-flavor)   (setq vector (make-array len :type 'art-q-list :area permanent-storage-area     :leader-list '(0)))))  (if (or (> len (array-total-size vector))      (= (array-active-length vector) (array-total-size vector)))    (adjust-array vector (max len (1+ (length vector))))));; Add a slot for the new mapping table to the vector.(setq vector-index (vector-push () vector));; Add an entry to the alist, pointing at newly added vector slot.(let ((default-cons-area background-cons-area))  (push (cons method-flavor (locf (aref vector vector-index)))     (flavor-component-mapping-table-alist instance-flavor)));; Now fill in the slot in the vector with a mapping table;; if the instance flavor may have been instantiated already.(and (or *create-mapping-tables* (flavor-method-hash-table instance-flavor))   (setf (aref vector vector-index) (update-mapping-table instance-flavor method-flavor)))(locf (aref vector vector-index))))))  (defun fef-flavor-name (fef)  "Return the flavor which the compiled function FEF assumes SELF is an instance of."  #- Elroy (and (typep fef :compiled-function) (not (zerop (%p-ldb %%fefh-get-self-mapping-table fef)))     (%p-contents-offset fef (1- (%p-ldb-offset %%fefhi-ms-arg-desc-org fef %fefhi-misc))))  #+ Elroy  (and (typep fef 'compiled-function)       (not (zerop (%p-ldb %%FEF-HEADER-Self-Mapping-Table fef)))       (%p-contents-offset fef   (if (= (%p-ldb si::%%fef-header-call-type  fef)  %fef-call-long)       %fef-second-optional-word       %fef-first-optional-word))))(defun get-handler-mapping-table (flavor handler definition-location)  (or   (cdr    (get-mapping-table-location flavor(or (and (= dtp-symbol (%p-data-type definition-location))    (fboundp (car definition-location))    (fef-flavor-name (symbol-function (car definition-location)))) (cadr handler))))   (ferror () "No mapping table for method ~S in flavor ~S" handler flavor)))  (defvar total-inherited-mapping-table-size 0)  ;Update all the mapping tables for INSTANCE-FLAVOR and various method-flavors.;Creates a mapping table for each slot which is empty.;If REPLACE-ALL is set, creates a new mapping table for every slot,;throwing away the old mapping tables.  That is used when a flavor has;changed incompatibly.(defun make-component-mapping-tables (instance-flavor &optional replace-all &aux  (inherit-mapping-table-flavors   (flavor-inherit-mapping-table-flavors instance-flavor))) ;; Make sure vector exists and is long enough for all our component flavors.  (let ((len (length (flavor-depends-on-all instance-flavor))))    (or (flavor-component-mapping-table-vector instance-flavor)       (setf (flavor-component-mapping-table-vector instance-flavor)     (make-array len :type 'art-q-list :area permanent-storage-area :leader-list '(0))))    (if (> len (array-total-size (flavor-component-mapping-table-vector instance-flavor)))      (adjust-array (flavor-component-mapping-table-vector instance-flavor) len)))  ;; Make sure all components are in the vector and alist.  (dolist (mf (flavor-depends-on-all instance-flavor))    (get-mapping-table-location instance-flavor mf))  ;; Copy the alist now so it is compact, if it has changed.  ;; It is now copied by LINEARIZE-FLAVOR-PLISTS after full-gc.  ;  (OR (EQ OALIST (FLAVOR-COMPONENT-MAPPING-TABLE-ALIST INSTANCE-FLAVOR))  ;      (SETF (FLAVOR-COMPONENT-MAPPING-TABLE-ALIST INSTANCE-FLAVOR)  ;    (COPYALIST (FLAVOR-COMPONENT-MAPPING-TABLE-ALIST INSTANCE-FLAVOR)  ;       PERMANENT-STORAGE-AREA)))  ;; Make sure all mapping tables exist and are up to date.  (dolist (elt (flavor-component-mapping-table-alist instance-flavor))    (when (or replace-all (null (cddr elt)))     ;; Inherit mapping tables when possible.      (dolist (ifl inherit-mapping-table-flavors)(when (member (car elt) (flavor-depends-on-all ifl) :test #'eq)  (setf (cddr elt) (car (get-mapping-table-location ifl (car elt))))  (incf total-inherited-mapping-table-size (%structure-total-size (cddr elt)))))      (setf (cddr elt) (update-mapping-table instance-flavor (car elt))))))  ;Once the flavor-combination stuff has been done, do the method-combination stuff.;The above function usually only gets called once, but this function gets called;when a new method is added.;Specify SINGLE-OPERATION to do this for just one operation, for incremental update.;This function should not be called for a single operation until it has;been called at least once to do all operations.;NOTE WELL: If a meth is in the method-table at all, it is considered to be defined; for purposes of compose-method-combination.  Thus merely putprop'ing a method,; or calling flavor-notice-method, will make the flavor think that method exists; when it is next composed.  This is necessary to make compile-flavor-methods work.; (Putprop must create the meth because loading does putprop before fdefine.)(defun compose-method-combination (fl &optional (single-operation nil) &aux tem magic-list order msg elem handlers ffl pl  (default-cons-area *flavor-area*))  (if (flavor-get fl :alias-flavor)    (ferror () "Attempt to compose methods of ~S, an alias flavor." (flavor-name fl)))  ;; If we are doing wholesale method composition,  ;; compose the flavor bindings list also.  ;; This way it is done often enough, but not at every defmethod.  (or single-operation *just-compiling* (flavor-get fl :abstract-flavor)     (progn       (compose-flavor-bindings fl)       (compose-flavor-initializations fl)))  ;; Look through all the flavors depended upon and collect the following:  ;; A list of all the operations handled and all the methods for each, called MAGIC-LIST.  ;; The default handler for unknown operations.  ;; The declared order of entries in the select-method alist.  ;; Also generate any automatically-created methods not already present.  ;; MAGIC-LIST is roughly the same format as the flavor-method-table, see its comments.  ;; Each magic-list entry is (message comb-type comb-order (type function-spec...)...)  (do ((ffls (flavor-depends-on-all fl) (cdr ffls)))      ((null ffls))    (setq ffl (compilation-flavor (car ffls))  pl (locf (flavor-plist ffl)))    (cond      ((not single-operation)       (and (setq tem (get pl :select-method-order)) (setq order (nconc order (copy-list tem))))))    ;; Add data from flavor method-table to magic-list    ;; But skip over combined methods, they are not relevant here    (dolist (mte (flavor-method-table ffl))      (setq msg (car mte))      (cond((or (not single-operation) (eq msg single-operation)) ;; Well, we're supposed to concern ourselves with this operation (setq elem (assoc msg magic-list :test #'eq));What we already know about it (cond   ((dolist (meth (cdddr mte))      (or (eq (meth-method-type meth) :combined) (not (meth-definedp meth)) (return t)))    ;; OK, this flavor really contributes to handling this operation    (or elem (push (setq elem (list* msg () () ())) magic-list))    ;; For each non-combined method for this operation, add it to the front    ;; of the magic-list element, thus they are in base-flavor-first order.    (dolist (meth (cdddr mte))      (let ((type (meth-method-type meth)))(cond  ((eq type :combined))  ((not (meth-definedp meth)))  ((not (setq tem (assoc type (cdddr elem) :test #'eq)))   (push (list type (meth-function-spec meth)) (cdddr elem)))  ;; Don't let the same method get in twice (how could it?)  ((not (member (meth-function-spec meth) (cdr tem) :test #'eq))   (push (meth-function-spec meth) (cdr tem)))))))) ;; Pick up method-combination declarations (and (cadr mte)    (cadr elem);If both specify combination-type, check    ;;;PHD 2/11/86 Fixed bug about some method-combinations being equal but    ;;; not eq, changed neq to not equal .    (or (neq (cadr mte) (cadr elem)) (not (equal (caddr mte) (caddr elem))))    (ferror () "Method-combination mismatch ~S-~S vs. ~S-~S, check your DEFFLAVOR's"    (cadr mte) (caddr mte) (cadr elem) (caddr elem))) (cond   ((cadr mte);Save combination-type when specified    (or elem (push (setq elem (list* msg () () ())) magic-list))    (setf (cadr elem) (cadr mte)) (setf (caddr elem) (caddr mte))))))))  ;; This NREVERSE tends to put base-flavor methods last  (setq magic-list (nreverse magic-list))  ;; Re-order the magic-list according to any declared required order  (dolist (msg (nreverse order))    (and (setq tem (assoc msg magic-list :test #'eq))       (setq magic-list (cons tem (delete tem (the list magic-list) :count 1 :test #'eq)))))  ;; Map over the magic-list.  For each entry call the appropriate method-combining  ;; routine, which will return a function spec for the handler to use for this operation.  (dolist (mte magic-list)   ;; Punt if there are no methods at all (just a method-combination declaration)    (cond      ((cdddr mte)       ;; Process the :DEFAULT methods; if there are any untyped methods the       ;; default methods go away, otherwise they become untyped methods.       (and (setq tem (assoc :default (cdddr mte) :test #'eq))  (if (assoc () (cdddr mte) :test #'eq)    (setf (cdddr mte) (delete tem (the list (cdddr mte)) :test #'eq))    (rplaca tem ())))       (or (setq tem (get (or (cadr mte) :daemon) 'method-combination))  (ferror () "~S unknown method combination type for ~S operation" (cadr mte) (car mte)))       (push (funcall tem fl mte) handlers))      (t (setq magic-list (delete mte (the list magic-list) :count 1 :test #'eq)))))  (or *just-compiling* (flavor-get fl :abstract-flavor)     (progn      ;; Make sure that the required variables and methods are present.      (unless single-operation(verify-required-flavors-methods-and-ivars fl magic-list))      ;; If the flavor does not have mapping tables yet, make some.      (make-component-mapping-tables fl)))  ;; Get back into declared order.  We now have a list of function specs for handlers.  (setq handlers (nreverse handlers))  (cond    (*just-compiling*);If just compiling, don't affect hash table.    ((flavor-get fl :abstract-flavor) (setf (flavor-method-hash-table fl) t))    (single-operation     ;; If doing SINGLE-OPERATION, put it into the hash table.     ;; If the operation is becoming defined and wasn't, or vice versa,     ;; must recompute the which-operations list.     (without-interrupts;SWAPHASH or REMHASH might rehash.      (cond((null handlers);Deleting method ;; Remove entry from the which-operations list. (and (member single-operation (flavor-which-operations fl) :test #'eq)    (setf (flavor-which-operations fl)  (delete single-operation (the list (flavor-which-operations fl)) :test #'eq))) (remhash single-operation  (flavor-method-hash-table fl)))(t ;; Add an entry to the which-operations list. (unless (member single-operation (flavor-which-operations fl) :test #'eq)   (when (flavor-which-operations fl)     (setf (flavor-which-operations fl)   (copy-list (cons single-operation (flavor-which-operations fl)))))) ;; Add one to the hash table. (let (def)   (swaphash single-operation (setq def (fdefinition-location (car handlers)))     (flavor-method-hash-table fl)     (get-handler-mapping-table fl (car handlers) def))))))     (setf (flavor-method-hash-table fl)   (FOLLOW-STRUCTURE-FORWARDING (flavor-method-hash-table fl))))    ;; Working on all operations at once.    (t     (let ((ht    (make-flavor-hash-array permanent-storage-area    (1+ (ceiling (/ (length magic-list) 0.8s0)))))   def)       (do ((handlers handlers (cdr handlers))    (*create-mapping-tables* t)    (ml magic-list (cdr ml)))   ((null ml)) (puthash-array (caar ml) (setq def (fdefinition-location (car handlers))) ht(get-handler-mapping-table fl (car handlers) def)))       (setf (flavor-method-hash-table fl) ht)       (setf (flavor-which-operations fl) ());This will have to be recomputed       (let ((hash-instance (flavor-method-hash-table fl)))     ;; If a hash-instance exists, make sure SEND will use the latest     ;; version of the hash array of that hash instance. (when hash-instance   (setf (flavor-method-hash-table fl) (follow-structure-forwarding  hash-instance )))))))  (unless (or *just-compiling* (flavor-which-operations fl) (flavor-get fl :abstract-flavor))   ;; Make the :WHICH-OPERATIONS list.    (let ((ht (flavor-method-hash-table fl))  list)      (declare (special list))      (maphash-array #'(lambda (op &rest ignore) (push op list))     ht)      (setq list (sort list 'alphalessp))      (unless (equal list (flavor-which-operations fl))(setf (flavor-which-operations fl) (copy-list list)))))  ())  (defun flavor-all-inheritable-methods (flavor-name operation &aux fl)  "Return a list of function specs of all methods used by OPERATION on FLAVOR-NAME.This may include some that are shadowed by others in the list."  (check-arg flavor-name (setq fl (get flavor-name 'flavor)) "a flavor name")  (do ((ffls (flavor-depends-on-all fl) (cdr ffls))       mte       list)      ((null ffls)       (nreverse list))    (setq mte (assoc operation (flavor-method-table (compilation-flavor (car ffls))) :test #'eq))    (when mte     ;; For each non-combined method for this operation, add it to the front     ;; of the list, thus they are in base-flavor-first order.      (dolist (meth (cdddr mte))(let ((type (meth-method-type meth)))  (cond    ((eq type :combined))    ((not (meth-definedp meth)))    (t (push (meth-function-spec meth) list))))))))  (defun verify-required-flavors-methods-and-ivars (fl magic-list)  (do ((ffls (flavor-depends-on-all fl) (cdr ffls))       (missing-methods nil)       (missing-instance-variables nil)       (missing-flavors nil)       (requiring-flavor-alist nil))      ((null ffls)       (and (or missing-instance-variables missing-methods missing-flavors)  (ferror ()  "Flavor ~S is missing ~~:[~2*~;instance variable~P ~{~S~^, ~} ~]~~:[~3*~;~:[~;and ~]method~P ~{~S~^, ~}~]~~:[~3*~;~:[~;and ~]component flavor~P ~{~S~^, ~}~]Requiring Flavor alist: ~S"  (flavor-name fl) missing-instance-variables  (length missing-instance-variables) missing-instance-variables missing-methods  missing-instance-variables (length missing-methods) missing-methods  missing-flavors (or missing-instance-variables missing-methods)  (length missing-flavors) missing-flavors requiring-flavor-alist)))    (let ((pl (locf (flavor-plist (get (car ffls) 'flavor)))))      (dolist (reqm (get pl :required-methods))(or (assoc reqm magic-list :test #'eq) (member reqm missing-methods :test #'eq)   (progn     (push reqm missing-methods)     (push (cons (first ffls) reqm) requiring-flavor-alist))))      (dolist (reqv (get pl :required-instance-variables))(or (member reqv (flavor-all-instance-variables fl) :test #'eq)   (member reqv missing-instance-variables :test #'eq)   (progn     (push reqv missing-instance-variables)     (push (cons (first ffls) reqv) requiring-flavor-alist))))      (dolist (reqf (get pl :required-flavors))(or (member reqf (flavor-depends-on-all fl) :test #'eq)   (member reqf missing-flavors :test #'eq)   (progn     (push reqf missing-flavors)     (push (cons (first ffls) reqf) requiring-flavor-alist)))))))  ;This function is called whenever the microcode fails to find an operation;in the flavor's hash table.;It could be because it is really undefined.;Or maybe a GC has taken place and the method hash table must be rehashed.;Or maybe the hash table has been forwarded.  The ucode doesn't follow the;forwarding, but rather gives up, so that we can un-forward it permanently.;note: instance-hash-failure is called from the microcode via the;support vector#-elroy(defun instance-hash-failure (op &rest args &aux (ht (%function-inside-self)) fn-location func)  (cond    ((/= (dont-optimize (hash-table-gc-generation-number ht)) %gc-generation-number)     (let ((newht (funcall (dont-optimize (hash-table-rehash-function ht)) ht ())))   ;; Some %POINTER's may have changed, try rehashing       (set-in-instance (dont-optimize (hash-table-instance ht)) 'hash-array newht)       (setf (instance-function self) newht))))  ;; In case a GC has happened or the hash table has been rehashed and forwarded,  ;; search it again using GETHASH to find out if the operation is really there.  (setq fn-location;; GETHASH does follow forwarding, and rehashes if nec.(gethash op  ht))  (cond    (fn-location     ;; In case GETHASH rehashed, snap out forwarding.      (setf (instance-function self)   (symeval-in-instance (dont-optimize (hash-table-instance ht)) 'hash-array))))  (cond    ((setq func (or (car fn-location);Found a definition   (flavor-default-handler (instance-flavor self))))     (apply func op args))    ((setq func (and (neq op :unclaimed-message);user defined handler   (get-handler-for self :unclaimed-message)))     (apply func :unclaimed-message op args))    (t (apply 'flavor-unclaimed-message op args))))  ;default handler;;;#+elroy;;;(defun instance-hash-failure (op &rest args &aux (ht (%function-inside-self)) fn-location func);;;  (cond;;;    ((/= (dont-optimize (hash-table-gc-generation-number ht)) %gc-generation-number);;;     (let ((newht (funcall (dont-optimize (hash-table-rehash-function ht)) ht ())));;;   ;; Some %POINTER's may have changed, try rehashing;;;       (setf (instance-function self) (FOLLOW-STRUCTURE-FORWARDING newht)))));;;  ;; In case a GC has happened or the hash table has been rehashed and forwarded,;;;  ;; search it again using GETHASH to find out if the operation is really there.;;;  (setq fn-location;;;;; GETHASH does follow forwarding, and rehashes if nec.;;;(gethash op ht ));;;  (when     fn-location;;;    ;; In case GETHASH rehashed, snap out forwarding. ;;;    (setf (instance-function self);;;  (FOLLOW-STRUCTURE-FORWARDING (instance-function self))));;;  (cond;;;    ((setq func (or (car fn-location);Found a definition;;;   (flavor-default-handler (instance-flavor self))));;;     (apply func op args));;;    ((setq func (and (neq op :unclaimed-message);user defined handler;;;   (get-handler-for self :unclaimed-message)));;;     (apply func :unclaimed-message op args));;;    (t (apply 'flavor-unclaimed-message op args))));This is the default handler for flavors.#-elroy(defun flavor-unclaimed-message (&rest message)  (report-unclaimed-message (%stack-frame-pointer) message))  #-elroy(defprop report-unclaimed-message t :error-reporter)  #-elroy(defun report-unclaimed-message (frame-pointer message) ;; Make this frame be a call to SELF so retrying it works.  (rplaca frame-pointer self)  (let ((new-operation (cerror :new-operation () 'unclaimed-message "The object ~S received a ~S message, which went unclaimed.The rest of the message was ~S." self (car message) (cdr message))))    (apply self new-operation (cdr message))))  (defun flavor-method-alist (fl)  "Return an alist of operations and their handlers, for flavor FL."  (if (symbolp fl)    (setq fl (compilation-flavor fl)))  (if fl    (let ((ht (flavor-method-hash-table fl))  alist)      (and (arrayp ht) (maphash  #'(lambda (op meth-locative &rest ignore)      (push (cons op (car meth-locative)) alist))  (flavor-method-hash-table fl)))      alist)));; Make the instance-variable getting and setting methods(defprop compose-automatic-methods t qfasl-dont-record)  ;;;??? This needs to get changed so that the methods are always compiled;;; once most files are compiled so that this is not called at load time.(defun compose-automatic-methods (fl &aux (settable-instance-variables    (flavor-settable-instance-variables fl))) ;;phd 7/8/86 changed the generation of accessor method so that if the instance is settable  ;; the accessor method is of type :default instead of untyped. This allows the user to  ;; provide his/her own accessor method. ;;Phd 1/2/87 Previous change turned to be wrong, because inherited method will  ;; override the accessor method. ;; Phd 10/4/85 add new flag to allow more that 120 settable instance variables. ;; This will prevent the generation of :case :set methods for the instance variables. ;; Avoid lossage on PROPERTY-LIST-MIXIN while reading this file into the cold load.  (when (fboundp 'compile-at-appropriate-time)    (dolist (v (flavor-gettable-instance-variables fl))      (let* ((vv (corresponding-keyword v))     (meth `(:method ,(flavor-name fl)  ,vv)))(if (or (not (flavor-notice-method meth)) *just-compiling*)  (compile-at-appropriate-time fl meth       `(named-lambda (,meth) (ignore)  (declare (function-parent ,(flavor-name fl) defflavor)     (:self-flavor ,(flavor-name fl)))  ,v))  (record-source-file-name meth))))    (dolist (v (flavor-settable-instance-variables fl))      (let* ((sv (intern1 (string-append "SET-" (symbol-name v)) pkg-keyword-package))     (meth `(:method ,(flavor-name fl) ,sv)))(if (or (not (flavor-notice-method meth)) *just-compiling*)  (compile-at-appropriate-time fl meth       `(named-lambda (,meth) (ignore .newvalue.)  (declare (function-parent ,(flavor-name fl) defflavor)     (:self-flavor ,(flavor-name fl)))  (setq ,v .newvalue.)))  (record-source-file-name meth)))      (when *flavor-enable-case-set-methods*(let* ((vv (corresponding-keyword v))       (meth `(:method ,(flavor-name fl) :case :set ,vv)))  (if (or (not (flavor-notice-method meth)) *just-compiling*)    (compile-at-appropriate-time fl meth `(named-lambda (,meth) (ignore ignore .newvalue.)    (declare     (function-parent ,(flavor-name fl) defflavor)     (:self-flavor ,(flavor-name fl)))    (setq ,v .newvalue.)))    (record-source-file-name meth)))))))  ;INTERN but always return-storage the print-name argument(defun intern1 (pname &optional (pkg *package*))  (prog1    (intern pname pkg)    (return-storage (prog1      pname      (setq pname ())))))  ;Given a symbol return the corresponding one in the keyword package(defun corresponding-keyword (symbol)  (intern (symbol-name symbol) pkg-keyword-package))  ;Make sure that the flavor bindings are up to date;;see which instance variables are supposed to be special.;We assume that the flavor has been composed.(defun compose-flavor-bindings (fl)  (let ((fls (flavor-depends-on-all fl))(specials (flavor-special-instance-variables fl)))    (dolist (f fls)      (setq f (compilation-flavor f ))      (setq specials (union specials (flavor-special-instance-variables f) :test #'eq))      (cond((flavor-all-instance-variables-special f) (or (flavor-depends-on-all f) (compose-flavor-combination f)) (setq specials       (union (union specials (flavor-all-instance-variables f) :test #'eq)      (flavor-additional-instance-variables f) :test #'eq)))))    ;; Any instance variables which the user has declared special elsewhere    ;; ought to be special.    (dolist (v (flavor-all-instance-variables fl))      (cond((and (not (member v specials :test #'eq)) (fboundp 'compiler::specialp)    (compiler::specialp v)) (format *error-output* "~&Instance variable ~S of ~S being made specialbecause that variable is globally special~%" v (flavor-name fl)) (push v specials))))    ;; Tell microcode about the instance variables    (let ((b   (mapcar #'(lambda (v)       (if (member v specials :test #'eq) (locf (symbol-value v))))   (flavor-all-instance-variables fl))))      (do ((bb b (cdr bb))   (prev (locf b) bb))  ((null bb))(if (null (car bb))  (do ((bbb bb (cdr bbb))       (i 0 (1+ i)))      ((car bbb)       (rplaca bb i)       (rplacd bb bbb))    (if (null bbb)      (progn(rplacd prev ())(rplacd bb ())(return ()))))))      (setf (flavor-bindings fl) (copy-list b)))))  ;Figure out the information needed to instantiate a flavor quickly.;We store these three properties on the flavor:;INSTANCE-VARIABLE-INITIALIZATIONS - alist of (ivar-index . init-form);REMAINING-DEFAULT-PLIST - a default plist from which kwds that init ivars have been removed.;ALL-INITTABLE-INSTANCE-VARIABLES - a list parallel to FLAVOR-ALL-INSTANCE-VARIABLES;   which has either the keyword to init with or NIL.;REMAINING-INIT-KEYWORDS - the init keywords that are handled and dont just init ivars.;We also set up the FLAVOR-DEFAULT-HANDLER of the flavor.(defun compose-flavor-initializations (fl &aux alist remaining-default-plist all-inittable-ivars area-function required-init-keywords  remaining-init-keywords unhandled-init-keywords)  (setq all-inittable-ivars(make-list (length (flavor-all-instance-variables fl)) :area   (if *just-compiling*     default-cons-area     background-cons-area)))  ;; First make the mask saying which ivars can be initted by init kywords.  (dolist (ffl (flavor-depends-on-all fl))    (let ((ffl (compilation-flavor ffl)))      (or area-function (setq area-function (flavor-get ffl :instance-area-function)))      (setq required-init-keywords    (union required-init-keywords (flavor-get ffl :required-init-keywords) :test #'eq))      (or (flavor-default-handler fl) (setf (flavor-default-handler fl) (getf (flavor-plist ffl) :default-handler)))      (dolist (iiv (flavor-inittable-instance-variables ffl))(let ((index       (position (cdr iiv) (the list (flavor-all-instance-variables fl)) :test #'eq)))  (and index (setf (nth index all-inittable-ivars) (car iiv)))))))  (setq remaining-init-keywords(mapcan #'(lambda (x)    (if (member x all-inittable-ivars :test #'eq)      ()      (list x)))(flavor-allowed-init-keywords fl)));(subset-not #'MEMQ (FLAVOR-ALLOWED-INIT-KEYWORDS FL) (CIRCULAR-LIST ALL-INITTABLE-IVARS)))  (pushnew :allow-other-keys remaining-init-keywords)  (setf (flavor-remaining-init-keywords fl) remaining-init-keywords)  ;; Then look at all the default init plists, for anything there  ;; that initializes an instance variable.  If it does, make an entry on ALIST.  ;; Any that doesn't initialize a variable, put on the "remaining" list.  (dolist (ffl (flavor-depends-on-all fl))    (setq ffl (compilation-flavor ffl))    (do ((l (getf (flavor-plist ffl) :default-init-plist) (cddr l)))((null l))      (let* ((keyword (car l)) (arg (cadr l))     (index (position keyword (the list all-inittable-ivars) :test #'eq)))     ;; Remove this keyword from the list of required ones,     ;; since it is cannot ever be missing.(setq required-init-keywords      (delete keyword (the list required-init-keywords) :test #'eq))(if index ;; This keyword initializes an instance variable, ;; so record an initialization of that variable if none found yet.  (or (assoc index alist :test #'eq) (push (list index arg) alist))  ;; This keyword does not just initialize an instance variable.  (progn    (unless (getf remaining-default-plist keyword)      (setf (getf remaining-default-plist keyword) arg))    (unless (member keyword remaining-init-keywords :test #'eq)      (pushnew keyword unhandled-init-keywords)))  ;;(IF (MEMQ KEYWORD (FLAVOR-REMAINING-INIT-KEYWORDS FL))  ;;    (OR (GET (LOCF REMAINING-DEFAULT-PLIST) KEYWORD)  ;;        (PUTPROP (LOCF REMAINING-DEFAULT-PLIST) ARG KEYWORD))  ;;  (FERROR NIL "The flavor ~S has keyword ~S in its default init plist, but doesn't handle it" (FLAVOR-NAME FL) KEYWORD))))))  (setf (flavor-unhandled-init-keywords fl) unhandled-init-keywords)  ;; Then, look for default values provided in list of instance vars.  (dolist (ffl (flavor-depends-on-all fl))    (setq ffl (compilation-flavor ffl))    (dolist (v (flavor-local-instance-variables ffl))      (and (not (atom v))   ;; When we find one, put it in if there is no init for that variable yet. (let ((index(position (car v) (the list (flavor-all-instance-variables fl)) :test #'eq)))   (and (not (assoc index alist :test #'eq)) (push (list index (cadr v)) alist))))))  (if area-function    (setf (getf (flavor-plist fl) 'instance-area-function) area-function)    (remprop (locf (flavor-plist fl)) 'instance-area-function))  (if required-init-keywords    (setf (getf (flavor-plist fl) 'required-init-keywords) required-init-keywords)    (remprop (locf (flavor-plist fl)) 'required-init-keywords))  (setf (flavor-instance-variable-initializations fl) alist)  (setf (flavor-remaining-default-plist fl) remaining-default-plist)  (setf (flavor-all-inittable-instance-variables fl) all-inittable-ivars))  ; Method-combination functions.  Found on the SI:METHOD-COMBINATION property; of the combination-type.  These are passed the flavor structure, and the; magic-list entry, and must return the function-spec for the handler; to go into the select-method, defining any necessary functions.; This function interprets combination-type-arg,; which for many combination-types is either :BASE-FLAVOR-FIRST or :BASE-FLAVOR-LAST.; :DAEMON combination; The primary method is the outermost untyped-method (or :DEFAULT).; The :BEFORE methods are called base-flavor-last, the :AFTER methods are called; base-flavor-first.  An important optimization is not to generate a combined-method; if there is only a primary method.  You are allowed to omit the primary method; if there are any daemons (I'm not convinced this is really a good idea) in which; case the method's returned value will be NIL.(defun (:property :daemon method-combination) (fl magic-list-entry)  (let ((primary-method (car (get-certain-methods magic-list-entry () '(:before :after) t :base-flavor-last)))(before-methods (get-certain-methods magic-list-entry :before t t :base-flavor-last))(after-methods (get-certain-methods magic-list-entry :after t t :base-flavor-first))(wrappers-p (specially-combined-methods-present magic-list-entry)));; Remove shadowed primary methods from the magic-list-entry so that it won't look like;; we depend on them (which could cause extraneous combined-method recompilation).    (let ((mle (assoc () (cdddr magic-list-entry) :test #'eq)))      (and (cddr mle) (setf (cdr mle) (list primary-method))))    (or (and (not wrappers-p) (null before-methods) (null after-methods) primary-method)       (have-combined-method fl magic-list-entry)       (make-combined-method fl magic-list-entry     (daemon-combination primary-method before-methods after-methods)))))  (defun daemon-combination (primary-method before-methods after-methods &optional or-methods and-methods)  (let ((inner-call (and primary-method (method-call primary-method))))    (and or-methods (setq inner-call `(or ,@(mapcar 'method-call or-methods) ,inner-call)))    (and and-methods (setq inner-call `(and ,@(mapcar 'method-call and-methods) ,inner-call)))    `(progn       ,@(mapcar 'method-call before-methods)       ,(if after-methods  `(multiple-value-prog1 ,inner-call ,@(mapcar 'method-call after-methods))  ;; You are allowed to not have a primary method  inner-call))))  (defun method-call (method)  `(lexpr-funcall-with-mapping-table-internal (function ,method) (method-mapping-table ,method)      .daemon-caller-args.))  ; :DAEMON-WITH-OVERRIDE combination; This is the same as :DAEMON (the default), except that :OVERRIDE type methods; are combined with the :BEFORE-primary-:AFTER methods in an OR.  This allows; overriding of the main methods function.  For example, a combined method as follows; might be generated: (OR (FOO-OVERRIDE-BAR-METHOD) (PROGN (FOO-BEFORE-BAR-METHOD)))(defun (:property :daemon-with-override method-combination) (fl magic-list-entry)  (let ((primary-method (car  (get-certain-methods magic-list-entry () '(:before :after :override) t       :base-flavor-last)))(before-methods (get-certain-methods magic-list-entry :before t t :base-flavor-last))(after-methods (get-certain-methods magic-list-entry :after t t :base-flavor-first))(wrappers-p (specially-combined-methods-present magic-list-entry))(override-methods (get-certain-methods magic-list-entry :override t t ())));; Remove shadowed primary methods from the magic-list-entry so that it won't look like;; we depend on them (which could cause extraneous combined-method recompilation).    (let ((mle (assoc () (cdddr magic-list-entry) :test #'eq)))      (and (cddr mle) (setf (cdr mle) (list primary-method))))    (or     (and (not wrappers-p) (null before-methods) (null after-methods) (null override-methods)primary-method)     (have-combined-method fl magic-list-entry)     (make-combined-method fl magic-list-entry   `(or ,@(mapcar 'method-call override-methods)       ,(daemon-combination primary-method before-methods after-methods))))))  ; :DAEMON-WITH-OR combination; This is the same as :DAEMON (the default), except that :OR type methods; are combined with the primary methods inside an OR, and used in place of; the primary method in :DAEMON type combination.; For example, the following combined method might be generated:; (PROGN (FOO-BEFORE-BAR-METHOD); (OR (FOO-OR-BAR-METHOD);     (BAZ-OR-BAR-METHOD);     (MULTIPLE-VALUE-PROG1;       (BUZZ-PRIMARY-METHOD);       (FOO-AFTER-BAR-METHOD)))(defun (:property :daemon-with-or method-combination) (fl magic-list-entry)  (let ((primary-method (car  (get-certain-methods magic-list-entry () '(:before :after :or) t :base-flavor-last)))(before-methods (get-certain-methods magic-list-entry :before t t :base-flavor-last))(after-methods (get-certain-methods magic-list-entry :after t t :base-flavor-first))(wrappers-p (specially-combined-methods-present magic-list-entry))(or-methods (get-certain-methods magic-list-entry :or t t ())));; Remove shadowed primary methods from the magic-list-entry so that it won't look like;; we depend on them (which could cause extraneous combined-method recompilation).    (let ((mle (assoc () (cdddr magic-list-entry) :test #'eq)))      (and (cddr mle) (setf (cdr mle) (list primary-method))))    (or     (and (not wrappers-p) (null before-methods) (null after-methods) (null or-methods)primary-method)     (have-combined-method fl magic-list-entry)     (make-combined-method fl magic-list-entry   (daemon-combination primary-method before-methods after-methods       or-methods)))))  ; :DAEMON-WITH-AND combination; This is the same as :DAEMON (the default), except that :AND type methods; are combined with the primary methods inside an AND, and used in place of; the primary method in :DAEMON type combination.; For example, the following combined method might be generated:; (PROGN (FOO-BEFORE-BAR-METHOD); (AND (FOO-AND-BAR-METHOD);      (BAZ-AND-BAR-METHOD);      (MULTIPLE-VALUE-PROG1;        (BUZZ-PRIMARY-METHOD);        (FOO-AFTER-BAR-METHOD)))(defun (:property :daemon-with-and method-combination) (fl magic-list-entry)  (let ((primary-method (car  (get-certain-methods magic-list-entry () '(:before :after :and) t :base-flavor-last)))(before-methods (get-certain-methods magic-list-entry :before t t :base-flavor-last))(after-methods (get-certain-methods magic-list-entry :after t t :base-flavor-first))(wrappers-p (specially-combined-methods-present magic-list-entry))(and-methods (get-certain-methods magic-list-entry :and t t ())));; Remove shadowed primary methods from the magic-list-entry so that it won't look like;; we depend on them (which could cause extraneous combined-method recompilation).    (let ((mle (assoc () (cdddr magic-list-entry) :test #'eq)))      (and (cddr mle) (setf (cdr mle) (list primary-method))))    (or     (and (not wrappers-p) (null before-methods) (null after-methods) (null and-methods)primary-method)     (have-combined-method fl magic-list-entry)     (make-combined-method fl magic-list-entry   (daemon-combination primary-method before-methods after-methods ()       and-methods)))))  ; :LIST combination; No typed-methods allowed.  Returns a list of the results of all the methods.; There will always be a combined-method, even if only one method to be called.(defun (:property :list method-combination) (fl magic-list-entry)  (or (have-combined-method fl magic-list-entry)     (make-combined-method fl magic-list-entry   `(list     . ,(mapcar 'method-call(append (get-certain-methods magic-list-entry :list '(nil) t ()) (get-certain-methods magic-list-entry () '(:list) () ())))))))  ; :INVERSE-LIST combination; No typed-methods allowed.  Apply each method to an element of the list.  Given; the result of a :LIST-combined method with the same ordering, and corresponding; method definitions, the result that emerged from each component flavor gets handed; back to that same flavor.  The combined-method returns no particular value.(defun (:property :inverse-list method-combination) (fl magic-list-entry)  (or (have-combined-method fl magic-list-entry)     (make-combined-method fl magic-list-entry   `(let ((.foo. (cadr .daemon-caller-args.)))      ,@(do ((ml      (append       (get-certain-methods magic-list-entry :inverse-list    '(nil) t ())       (get-certain-methods magic-list-entry () '(:inverse-list)    () ()))      (cdr ml))     (r nil))    ((null ml)     (nreverse r))  (push   `(funcall-with-mapping-table-internal (function ,(car ml))       (method-mapping-table ,(car ml))       (car .daemon-caller-args.) (car .foo.))   r)  (and (cdr ml) (push '(setq .foo. (cdr .foo.)) r)))))))  ; Combination types PROGN, AND, OR, MAX, MIN, +, APPEND, NCONC; These just call all their typed methods then the untyped methods,; inside the indicated special form or function.; As an optimization, if there is only one method it is simply called.(defprop :progn simple-method-combination method-combination)  (defprop :and simple-method-combination method-combination)  (defprop :or simple-method-combination method-combination)  (defprop :max simple-method-combination method-combination)  (defprop :min simple-method-combination method-combination)  (defprop :+ simple-method-combination method-combination)  (defprop :append simple-method-combination method-combination)  (defprop :nconc simple-method-combination method-combination)  (defprop :progn progn simple-method-combination)  (defprop :and and simple-method-combination)  (defprop :or or simple-method-combination)  (defprop :max max simple-method-combination)  (defprop :min min simple-method-combination)  (defprop :+ + simple-method-combination)  (defprop :append append simple-method-combination)  (defprop :nconc nconc simple-method-combination)  ;;PHD 12/28/86 Fixed bug, a primary method is no longer necessary.;;This allows for better compatibility with Symbolics.(defun simple-method-combination (fl magic-list-entry)  (let ((methods (append (get-certain-methods magic-list-entry (cadr magic-list-entry) '(nil) t ()) (get-certain-methods magic-list-entry () (list (cadr magic-list-entry)) t ())))(wrappers-p (specially-combined-methods-present magic-list-entry)))    (or (and (not wrappers-p) (null (cdr methods)) (car methods))       (have-combined-method fl magic-list-entry)       (make-combined-method fl magic-list-entry     (cons (get (cadr magic-list-entry) 'simple-method-combination)   (mapcar 'method-call methods))))))  (defun (:property :case method-combination) (fl magic-list-entry) ;;  9/16/85 DNG - Invoke CASE-METHOD-DEFAULT-HANDLER with FUNCALL instead ;;                of LEXPR-FUNCALL to allow combined method integration.  (let* ((primary-method  (car    (get-certain-methods magic-list-entry () '(:case :or :otherwise :before :after) t:base-flavor-last))) (otherwise-method  (or (car (get-certain-methods magic-list-entry :otherwise t t :base-flavor-last))     primary-method)) (before-methods (get-certain-methods magic-list-entry :before t t :base-flavor-last)) (after-methods (get-certain-methods magic-list-entry :after t t :base-flavor-first)) (or-methods (get-certain-methods magic-list-entry :or t t :base-flavor-last)) (methods (get-certain-methods magic-list-entry :case t t ()))) ;; Remove shadowed :otherwise methods from the magic-list-entry so that it won't look like ;; we depend on them (which could cause extraneous combined-method recompilation).    (let ((mle (assoc :otherwise (cdddr magic-list-entry) :test #'eq)))      (and (cddr mle) (setf (cdr mle) (list otherwise-method))))    ;; Remove shadowed primary methods too.    (let ((mle (assoc () (cdddr magic-list-entry) :test #'eq)))      (if (eq otherwise-method primary-method)(and (cddr mle) (setf (cdr mle) (list primary-method)));; If there is a :OTHERWISE method, all the primary ones are shadowed.(and mle (delete mle (the list magic-list-entry) :test #'eq))))    (or (have-combined-method fl magic-list-entry)       (make-combined-method fl magic-list-entry     (let ((inner-call    `(progn       ,@(mapcar 'method-call before-methods)       (case (cadr .daemon-caller-args.)  ,@(mapcar     #'(lambda (method) `(,(fifth method) ,(method-call method)))     methods)  ((:get-handler-for :operation-handled-p    :case-documentation)   (funcall 'case-method-default-handler    ',(flavor-name fl) ',(car magic-list-entry)    ',methods (cadr .daemon-caller-args.)    (caddr .daemon-caller-args.)))  (:which-operations   ',(mapcar #'(lambda (x) (car (cddddr x)))     methods))  (t   (or ,@(mapcar 'method-call or-methods)      ,(and otherwise-method  (method-call otherwise-method))))))))   ;; Copied from DAEMON-COMBINATION.       (if after-methods `(multiple-value-prog1 ,inner-call     ,@(mapcar 'method-call after-methods)) ;; No :AFTER methods, hair not required ;; You are allowed to not have a primary method inner-call))))))  (defun case-method-default-handler (flavor operation case-methods suboperation &rest args)  flavor  operation  (dolist (cm case-methods)    (if (eq (fifth cm) (car args))      (return       (case suboperation (:get-handler-for (fdefinition cm)) (:operation-handled-p t) (:case-documentation (documentation cm)))))))  ; :PASS-ON combination; The values from the individual methods are the arguments to the next one;; the values from the last method are the values returned by the combined; method.  Format is (:METHOD-COMBINATION (:PASS-ON (ORDERING . ARGLIST) . OPERATION-NAMES); ORDERING is :BASE-FLAVOR-FIRST or :BASE-FLAVOR-LAST.  ARGLIST can have &AUX and &OPTIONAL.(defun (:property :pass-on method-combination) (fl magic-list-entry)  (let ((methods (append  (get-certain-methods magic-list-entry :pass-on '(nil) t (caaddr magic-list-entry))  (get-certain-methods magic-list-entry () '(:pass-on) () (caaddr magic-list-entry))))(arglist (cdaddr magic-list-entry))argsrest-arg-p)    (do ((l arglist (cdr l)) (arg) (nl nil))((null l) (setq args (nreverse nl)))      (setq arg (car l))      (and (consp arg) (setq arg (car arg)))      (cond((eq arg '&rest) (setq rest-arg-p t))((eq arg '&aux))((eq arg '&optional))(t (push arg nl))))    (or (have-combined-method fl magic-list-entry)       (make-combined-method fl magic-list-entry     `(destructuring-bind (.operation. . ,arglist) .daemon-caller-args. ,@(do ((meths methods (cdr meths))(list ())(meth))       ((null meths)(nreverse list))     (setq meth   `(,(if rest-arg-p'lexpr-funcall-with-mapping-table-internal'funcall-with-mapping-table-internal)     (function ,(car meths))     (method-mapping-table ,(car meths)) .operation.     ,@args))     (and (cdr meths)(setq meth      (if (null (cdr args))`(setq ,(car args) ,meth)`(multiple-value-setq ,args ,meth))))     (push meth list)))))))  ; This function does most of the analysis of the magic-list-entry needed by; method-combination functions, including most error checking.(defun get-certain-methods (magic-list-entry method-type other-methods-allowed no-methods-ok ordering-declaration &aux  methods default-methods)  "Perform analysis needed by method-combination functions.   Returns a list of the method symbols for METHOD-TYPE extracted from MAGIC-LIST-ENTRY.   This value is shared with the data structure, don't bash it.   OTHER-METHODS-ALLOWED is a list of method types not to complain about (T = allow all).   NO-METHODS-OK = NIL means to complain if the returned value would be NIL.   ORDERING-DECLARATION is :BASE-FLAVOR-FIRST, :BASE-FLAVOR-LAST, or NIL meaning     take one of those symbols from the MAGIC-LIST-ENTRY."  ;; Find the methods of the desired type, and barf at any extraneous methods  (dolist (x (cdddr magic-list-entry))    (cond      ((eq (car x) method-type) (setq methods (cdr x)))      ((assoc (car x) *specially-combined-method-types* :test #'eq)) ;Wrappers ignored at this level      ((assoc (car x) *inverse-specially-combined-method-types* :test #'eq)) ;Wrappers ignored at this level      ((eq (car x) :default) (setq default-methods (cdr x)))      ((or (eq other-methods-allowed t) (member (car x) other-methods-allowed :test #'eq)))      (t       (ferror () "~S ~S method(s) illegal when using :~A method-combination" (car x)       (car magic-list-entry) (or (cadr magic-list-entry) :daemon)))))  ;; If we were looking for primary methods and there are none, use the :DEFAULT methods.  (and (null method-type) (null methods) (setq methods default-methods))  ;; Complain if no methods supplied  (and (null methods) (not no-methods-ok)     (ferror () "No ~S ~S method(s) supplied to :~A method-combination" method-type     (car magic-list-entry) (cadr magic-list-entry)))  ;; Get methods into proper order.  Don't use NREVERSE!  (case (or ordering-declaration (setq ordering-declaration (caddr magic-list-entry)))    (:base-flavor-first)    (:base-flavor-last (setq methods (reverse methods)))    (otherwise     (ferror ()     "~S invalid method combination order; must be :BASE-FLAVOR-FIRST or :BASE-FLAVOR-LAST"     ordering-declaration)))  methods)  (defun specially-combined-methods-present (mle)  (loop for (type) in (cdddr mle) thereis     (assoc type *specially-combined-method-types* :test #'eq)))  ;; It is up to the caller to decide that a combined-method is called for at all.;; If one is, this function decides whether it already exists OK or needs;; to be recompiled.  Returns the symbol for the combined method if it is;; still valid, otherwise returns NIL.;; Always canonicalizes the magic-list-entry, since it will be needed;; canonicalized later.(defun have-combined-method (fl magic-list-entry &aux operation-name cms mte old-mle old-cms tem ometh) ;; Canonicalize the magic-list-entry so can compare with EQUAL  (setf (cdddr magic-list-entry);Canonicalize before comparing(sort (cdddr magic-list-entry) #'string-lessp :key #'car));Sort by method-type  (setq operation-name (car magic-list-entry))  ;; See if we can inherit one in either the current or future (being-compiled) world,  ;; or use an existing combined method of this flavor.  ;; Get the :COMBINED method function spec for this flavor.  Note that if a suitable  ;; one can be inherited, we will do so.  ;; *USE-OLD-COMBINED-METHODS* controls whether we reuse an existing one for this  ;; flavor; if we inherit one it will always be up-to-date already.  ;; If all OK, return the function spec, else return NIL if new combined method must be made.  (or   (dolist (ffl (flavor-depends-on-all fl))     (let ((flavor1 (compilation-flavor ffl)))       (and (or (neq flavor1 fl) *use-old-combined-methods*)    ;; ^ Combined methods of this flavor can be used only if permitted.  (setq mte (assoc operation-name (flavor-method-table flavor1) :test #'eq))  (setq ometh (meth-lookup (cdddr mte) :combined))  (meth-definedp ometh)  ;; Check that  *use-old-combined-methods* has not been expanded in line  ;; in the combined method  (null   (and (neq t *use-old-combined-methods*)(meth-definition ometh)      (member (meth-function-spec *use-old-combined-methods*)      #-Elroy      (cadr       (assoc :macros-expanded (debugging-info (meth-definition ometh) t) :test      #'eq))      #+Elroy      (get-debug-info-field (get-debug-info-struct (meth-definition ometh) t)    :macros-expanded )      :test #'equal      :key #'(lambda (x) (if (consp x) (car x) x)))))  (or (meth-definition ometh) (and *just-compiling* (neq fl flavor1)))  (setq cms (meth-function-spec ometh))  (equal magic-list-entry (setq tem       (or#-Elroy(cadr (assoc 'combined-method-derivation(and (meth-definition ometh)   (debugging-info (meth-definition ometh) t)):test #'eq))#+Elroy(and (meth-definition ometh)     (get-debug-info-field (get-debug-info-struct (meth-definition ometh) t)   'combined-method-derivation ))(getf (meth-plist ometh) 'combined-method-derivation))))  (or (not (fboundp 'compiler:expr-sxhash))     (dolist (elt       #-Elroy       (cdr (assoc 'wrapper-sxhashes(and (meth-definition ometh) (debugging-info (meth-definition ometh) t)):test #'eq))       #+Elroy       (and (meth-definition ometh)    (get-debug-info-field (get-debug-info-struct (meth-definition ometh) t)  'wrapper-sxhashes ))       t);Return T if get thru whole list without mismatch.      ;; If any wrappers were used, make sure their definitions now      ;; match the definitions that were used to make the combined method.       (unless (eql (compiler:expr-sxhash (car elt)) (cadr elt)) (return ()))));Return NIL if mismatch.  (return cms)));Save first combined-method seen for tracing, it's the one we would     ;have been most likely to inherit     (or old-cms (null cms) (setq old-cms cms  old-mle tem)))   ;; Have to make a new combined method.  Trace if desired, but return NIL in any case.   (progn     (cond       (*flavor-compile-trace*(format *flavor-compile-trace*"~&~S's ~S combined method needs to be recompiled~%to come from "(flavor-name fl) operation-name)(print-combined-method-derivation magic-list-entry *flavor-compile-trace*)(cond  (old-cms   (format *flavor-compile-trace* "~%rather than using ~S which comes from " old-cms)   (print-combined-method-derivation old-mle *flavor-compile-trace*))  ((not *use-old-combined-methods*)   (format *flavor-compile-trace* "~%because of forced recompilation.")))))     ())))  (defun print-combined-method-derivation (mle stream)  (loop for (type . function-specs) in (cdddr mle) do     (loop for function-spec in function-specs do (format stream "~S " function-spec)))  (if (or (cadr mle) (caddr mle))    (format stream "with method-combination ~S ~S" (cadr mle) (caddr mle))))  (defun optimize-method-body-and-args (form) ;;  9/16/85 DNG - Original version, separated from MAKE-COMBINED-METHOD.  (declare (values body arglist))  (let (ll)    (let ((number-of-method-args nil)  (minimum-number-of-method-args 0)  (method-arg-list '(operation .method-arg-1. .method-arg-2. .method-arg-3.)))      (declare (special number-of-method-args minimum-number-of-method-args method-arg-list))      (if (and *integrate-combined-methods*  (catch 'out    (setq form (substitute-funcall-in-expression form))))(if (null number-of-method-args)  (setq ll(append (firstn minimum-number-of-method-args method-arg-list) '(&rest ignore)))  (setq ll method-arg-list))(setq ll '(&rest .daemon-caller-args.))))    (values form ll)))  ;; This function creates a combined-method, and returns the appropriate function spec.;; Its main job in life is to take care of wrappers.  Note the combined method;; always takes a single &REST argument named .DAEMON-CALLER-ARGS.;; FORM is a single form to be used as the body.(defun make-combined-method (fl magic-list-entry form &aux fspec wrappers wrapper-sxhashes) ;;  9/16/85 DNG - Modified to use new function OPTIMIZE-METHOD-BODY-AND-ARGS.  (setq form `(compile-time-remember-mapping-table ,(flavor-name fl) ,form))  ;; Get the function spec which will name the combined-method  (setq fspec `(:method ,(flavor-name fl) :combined ,(car magic-list-entry)))  ;; Put the wrappers and :AROUND methods around the form.  ;; The base-flavor wrapper goes on the inside.  (setq wrappers(append (get-specially-combined-methods magic-list-entry fl)(get-inverse-specially-combined-methods magic-list-entry fl)))  (do ((wr wrappers (cdr wr))       (last-method-type nil))      ((null wr))    (let ((method (car wr)))  ;; Record sxhash of each wrapper that goes in.  ;; This way we can tell if the combined method is obsolete when fasloaded.      (when (and (member (caddr method) '(:wrapper :inverse-wrapper) :test #'eq)  (fboundp 'compiler:expr-sxhash))(push (list method (compiler:expr-sxhash method)) wrapper-sxhashes))      (setq form    (funcall     (cadr      (or (assoc (caddr method) *specially-combined-method-types* :test #'eq) (assoc (caddr method) *inverse-specially-combined-method-types* :test #'eq)))     fl last-method-type method form))      (setq last-method-type (caddr method))))  ;; Remember that it's going to be there, for HAVE-COMBINED-METHOD  (flavor-notice-method fspec)  (when *just-compiling*    (function-spec-putprop fspec magic-list-entry 'combined-method-derivation))  ;; Compile the function.  It will be inserted into the flavor's tables either  ;; now or when the QFASL file is loaded.  (multiple-value-bind (body ll)    (optimize-method-body-and-args form)    #-elroy    (compile-at-appropriate-time fl fspec `(named-lambda (,fspec ,@(if wrapper-sxhashes     `((wrapper-sxhashes . ,wrapper-sxhashes))) (combined-method-derivation ,magic-list-entry)) ,ll    (let ((.daemon-mapping-table. self-mapping-table))      ,body)) () )    #+elroy    (compile-at-appropriate-time fl fspec `(named-lambda (,fspec) ,ll,@(if wrapper-sxhashes      `((declare (wrapper-sxhashes  ,@wrapper-sxhashes))))(declare (combined-method-derivation ,@magic-list-entry))    (let ((.daemon-mapping-table. self-mapping-table))      ,body)) () ))  fspec)  (defun substitute-funcall-in-expression (form)  ;; In order to prepare a combined method function body for the  ;; compiler to do inline expansion of method calls, try to replace  ;; all LEXPR-FUNCALL-WITH-MAPPING-TABLE-INTERNAL forms which were  ;; created by METHOD-CALL with equivalent FUNCALL-WITH-MAPPING-TABLE  ;; forms.  This requires making sure that all of the calls will  ;; use the same number of arguments.  ;; A THROW is done to OUT if a consistent transformation is not  ;; possible.  ;;  8/03/85 DNG - Fixed to handle &REST args correctly.  [SPR 249]  ;;  9/16/85 DNG - Save time by not looking at argument of METHOD-MAPPING-TABLE.  ;;  4/07/86 DNG - Modified for VM2 to use ARGS-DESC instead of ARGS-INFO.  (declare (special number-of-method-args minimum-number-of-method-args method-arg-list))  (if (atom form)      (if (eq form '.daemon-caller-args.)  ;; A reference to the combined method's &REST argument  ;;  which was not removed by one of the special cases  ;;  below.  Give up on optimization.  (throw 'out nil)form)    (let ((f (first form)))      (cond((null (REST form)) (if (atom f)     form   (cons (substitute-funcall-in-expression f) nil)))((member f '(quote function method-mapping-table) :test #'eq) form)((and (eq (second form) '.daemon-caller-args.)      (member f '(car cadr caddr first second third) :test #'eq)) (let ((new (funcall f method-arg-list))       (min (funcall f '(1 2 3))))   (when (null new)     (throw 'out nil))   (when (> min minimum-number-of-method-args)     (setq minimum-number-of-method-args min))   new))((and (member f '(lexpr-funcall-with-mapping-table  lexpr-funcall-with-mapping-table-internal)      :test #'eq)      (eq (fourth form) '.daemon-caller-args.)      (null (NTHCDR 4 form))      (consp (second form))      (eq (first (second form)) 'function)) #-Elroy (let* ((args-info  (args-info (or (declared-definition (second (second form))) (throw 'out nil))))(min (ldb %%arg-desc-min-args args-info))(max (ldb %%arg-desc-max-args args-info)))   (cond     ((or (/= min max)  (> max 3)  (< min minimum-number-of-method-args)  (logtest    (logior %arg-desc-evaled-rest %arg-desc-quoted-rest    %arg-desc-fef-quote-hair %arg-desc-interpreted)    args-info))      (throw 'out nil))     ((null number-of-method-args)      (setq number-of-method-args min)      (setq method-arg-list (firstn min method-arg-list)))     ((/= min number-of-method-args) (throw 'out nil)))   (list* 'funcall-with-mapping-table (second form) (third form) method-arg-list)) #+Elroy (multiple-value-bind (min max rest)     (args-desc (or (declared-definition (second (second form)))    (throw 'out nil)))   (cond     ((or (/= min max)  (> max 3)  (< min minimum-number-of-method-args)  rest)      (throw 'out nil))     ((null number-of-method-args)      (setq number-of-method-args min)      (setq method-arg-list (firstn min method-arg-list)))     ((/= min number-of-method-args) (throw 'out nil)))   (list* 'funcall-with-mapping-table (second form) (third form) method-arg-list)))((and (atom f) (null (CDDR form))) (let ((new (substitute-funcall-in-expression (second form))))   (if (eq (second form) new)       form     (list f new))))(t (loop for x in form collecting (substitute-funcall-in-expression x)))))))    ;; These macros are used in combined methods to compile the appropriate code;; to set the self mapping table from time to time.;; COMPILE-TIME-REMEMBER-MAPPING-TABLE goes around the entire method combination;; and METHOD-MAPPING-TABLE goes at each place where a specific mapping table;; is wanted.  METHOD-MAPPING-TABLE takes a method function spec as quoted arg;; and turns into code to return the appropriate mapping table.(defvar compiler-flavor)  (defmacro compile-time-remember-mapping-table (flavor &body body)  `(compiler-let ((compiler-flavor ',flavor)) ,@body))  (defmacro method-mapping-table (method-function-spec)  (or (eq (car method-function-spec) :method) (ferror () "METHOD-FUNCTION-SPEC is not one"))  (let ((flavor (cadr method-function-spec)))    (if (eq flavor compiler-flavor)      '.daemon-mapping-table.      `(self-ref ,compiler-flavor t ,flavor))))  (defun get-specially-combined-methods (mle *fl*)  (declare (special *fl*))  ;; First get all :AROUNDs followed by all :WRAPPERs,  ;; then reorder by flavor but preserve the order of things for a given flavor.  (stable-sort   (mapcan    #'(lambda (method-type-cons)(copy-list (cdr (assoc (car method-type-cons) (cdddr mle) :test #'eq))))    *specially-combined-method-types*)   #'(lambda (fs1 fs2)      ;; Return T if FS1's flavor comes later      ;; in our list of dependents than FS2's flavor.       (member (cadr fs1) (cdr (member (cadr fs2) (flavor-depends-on-all *fl*) :test #'eq))       :test #'eq))))  (defun get-inverse-specially-combined-methods (mle *fl*)  (declare (special *fl*))  ;; First get all :INVERSE-AROUNDs followed by all :INVERSE-WRAPPERs,  ;; then reorder by flavor but preserve the order of things for a given flavor.  (stable-sort   (mapcan    #'(lambda (method-type-cons)(copy-list (cdr (assoc (car method-type-cons) (cdddr mle) :test #'eq))))    *inverse-specially-combined-method-types*)   #'(lambda (fs1 fs2)      ;; Return T if FS2's flavor comes later      ;; in our list of dependents than FS1's flavor.       (member (cadr fs2) (cdr (member (cadr fs1) (flavor-depends-on-all *fl*) :test #'eq))       :test #'eq))))  (defun put-wrapper-into-combined-method (flavor previous-method-type wrapper-name form)  flavor  ;; Before any sequence of wrappers, stick on a binding of SELF-MAPPING-TABLE  ;; because the body, a typical combined method, clobbers it,  ;; but the code expanded by the wrapper itself may assume it is preserved.  ;; If the last thing done was another wrapper, this is not necessary.  (and (not (member previous-method-type '(:wrapper :inverse-wrapper) :test #'eq))     (setq form `(let ((self-mapping-table self-mapping-table))   ,form)))  (let ((def (cond   ((declared-definition wrapper-name))   ((fdefinedp wrapper-name) (fdefinition wrapper-name))   (t (ferror () "~S supposed to be a wrapper macro, but missing!" wrapper-name)))))    (if (eq def 'aborted-definition)      form      (progn(cond  ((or (atom def) (neq (car def) 'macro))   (ferror () "~S, supposed to be a wrapper macro, is poorly formed. Definiton is ~s"   wrapper-name def)))`(macrocall ,wrapper-name .daemon-caller-args. ,form))      ;; Here we just put the wrapper in as a macro.  It will be expanded by the compiler.)))  ;Sort of a macro version of funcall, for wrappers(defmacro macrocall (&rest x)  (let ((macro (cond ((declared-definition (car x))) ((fdefinedp (car x)) (fdefinition (car x))) (t (ferror () "Unable to find definition of wrapper ~s at expand time" (car x))))))    (if (and (consp macro) (eq (car macro) 'macro))      (call (cdr macro) () x :optional *macroexpand-environment*)      ;;--- Temporary code so I can test things in the kludge environment      (if (and (symbolp macro) (consp (symbol-function macro))  (eq (car (symbol-function macro)) 'macro))(call (cdr (symbol-function macro)) () x :optional *macroexpand-environment*)(ferror () "~S evaluated to ~S, which is not a macro" (car x) macro)))))  (defun put-around-method-into-combined-method (flavor previous-method-type method-function-spec form) ;;  9/16/85 DNG - Use function OPTIMIZE-METHOD-BODY-AND-ARGS to enable ;;                inline expansion of method calls in the continuation function.  (declare (ignore previous-method-type))  (multiple-value-bind (body ll)    (optimize-method-body-and-args form)    `(compile-time-remember-mapping-table ,(flavor-name flavor)(lexpr-funcall-with-mapping-table-internal (function ,method-function-spec)   (method-mapping-table ,method-function-spec) (car .daemon-caller-args.)   #'(named-lambda continuation ,ll       (let ((.daemon-mapping-table. self-mapping-table)) ,body))   .daemon-mapping-table. .daemon-caller-args. (cdr .daemon-caller-args.)))))  ;Use this inside an :AROUND method, to call the continuation.;Pass the first three args that the :AROUND method received.(defsubst around-method-continue (continuation mapping-table args)  (lexpr-funcall-with-mapping-table continuation mapping-table args))  ;Return the FLAVOR declaration for use in methods, DECLARE-FLAVOR-INSTANCE-VARIABLES, etc.;Declares all the instance variables of the flavor, as well as the flavor name.;(EVAL-WHEN (COMPILE EVAL LOAD)(defun flavor-declaration (flavor-name &aux fl)  (let ((*just-compiling* (just-compiling)))   (labels ((internal-function (fl vl)       (dolist (x (flavor-local-instance-variables fl)) (or (atom x) (setq x (car x))) (or (member x vl :test #'eq) (push x vl)))       (append vl       (getf (flavor-plist fl)     :required-instance-variables)       (loop for flname in (getf (flavor-plist fl) :required-flavors)     nconc (get-instance-variables flname))))     (get-instance-variables (name)       (let ((fl (compilation-flavor name))) (and fl (map-over-component-flavors 0 () ()        #'internal-functionname ())))))    (when (setq fl (compilation-flavor flavor-name))      (cond((flavor-components-defined-p flavor-name) (unless (flavor-depends-on-all fl)   (let ((default-cons-area working-storage-area))     (compose-flavor-combination fl nil))) (let ((vars (flavor-all-instance-variables fl))       (more-vars (getf (flavor-plist fl) 'additional-instance-variables)))   `(:self-flavor ,flavor-name ,(flavor-get-all-special-instance-variables fl)  ,@more-vars ,@vars)))(t;Try to get as many variables as we can. `(:self-flavor ,flavor-name ,(flavor-special-instance-variables fl),@(get-instance-variables flavor-name))))))))(defun flavor-get-all-special-instance-variables (flavor)  "Return a list of all the special instance variables of FLAVOR (a flavor object or name).This function is for compatibility with flavors composed beforethe ALL-SPECIAL-INSTANCE-VARIABLES property started being used."  (if (symbolp flavor)    (setq flavor (compilation-flavor flavor)))  (or (flavor-all-special-instance-variables flavor)     (do ((ivars (flavor-all-instance-variables flavor) (cdr ivars))  (specials)  (normal-bindings-left (flavor-bindings flavor))  (next-normal-binding)) ((null ivars) specials)  ;; Figure out whether the next ivar is bound as special by message sending.       (or (and (numberp next-normal-binding) (plusp next-normal-binding))  (setq next-normal-binding (pop normal-bindings-left)))       (if (numberp next-normal-binding) (decf next-normal-binding))       ;; If it isn't, we must put it on our binding list to be bound now.       (if (locativep next-normal-binding) (push (car ivars) specials)))))  ;This is a flavor which is automatically made a component of nearly all;other flavors.  It provides some basic facilities such as PRINT;and DESCRIBE.#-elroy(eval-when (load eval);Allow this file to compile if it isn't loaded   (defflavor vanilla-flavor () () :no-vanilla-flavor;No instance variables, no other flavors      (:method-combination (:case :base-flavor-last :set))      (:documentation :mixin       "The default base flavor.This flavor provides the normal handlers for the :PRINT, :DESCRIBE, and :WHICH-OPERATIONSoperations.  Only esoteric hacks should give the :NO-VANILLA-FLAVOR option to DEFFLAVOR toprevent this inclusion.")))  #-elroy(defmethod (vanilla-flavor :default :init) (ignore)  ())  #-elroy(defmethod (vanilla-flavor :print-self) (stream &rest ignore)  (printing-random-object (self stream :typep)))  #-elroy(defmethod (vanilla-flavor :describe) ()  (format t "~&~S, an object of flavor ~S,~% has instance variable values:~%" self  (type-of self))  (do ((ivars (flavor-all-instance-variables (instance-flavor self)) (cdr ivars))       (i 1 (1+ i)))      ((null ivars))    (format t "~S:~27T " (car ivars))    (cond      ((= (%p-ldb-offset %%q-data-type self i) dtp-null) (format t "unbound~%"))      (t (format t "~S~%" (%instance-ref self i))))))  #-elroy(defmethod (vanilla-flavor :which-operations) ()  (flavor-which-operations (instance-flavor self)))  ;;;#+elroy;;;(defmethod (vanilla-flavor :operation-handled-p) (op);;;  (let ((fl (instance-flavor self)));;;    (if (arrayp (flavor-method-hash-table fl));;;      (multiple-value-bind (nil definedp);;;(without-interrupts;;; (gethash op (flavor-method-hash-table fl)));;;definedp);;;      (let ((wo (or (flavor-which-operations fl) (funcall self :which-operations))));;;(not (not (member op wo :test #'eq)))))))  ;;;#+elroy;;;(defmethod (vanilla-flavor :send-if-handles) (op &rest to-send);;;  (let ((fl (instance-flavor self)));;;    (if (arrayp (flavor-method-hash-table fl));;;      (multiple-value-bind (fn-location definedp);;;(without-interrupts;;; (gethash op (flavor-method-hash-table fl)));;;(if definedp;;;  (apply (car fn-location) op to-send)));;;      (let ((wo (or (flavor-which-operations fl) (funcall self :which-operations))));;;(and (member op wo :test #'eq) (apply self op to-send))))))  #-elroy(defmethod (vanilla-flavor :operation-handled-p) (op)  (let ((fl (instance-flavor self)))    (if (arrayp (flavor-method-hash-table fl))      (multiple-value-bind (nil definedp)(without-interrupts (gethash op (dont-optimize (hash-table-instance (flavor-method-hash-table fl)))))definedp)      (let ((wo (or (flavor-which-operations fl) (funcall self :which-operations))))(not (not (member op wo :test #'eq)))))))  #-elroy(defmethod (vanilla-flavor :send-if-handles) (op &rest to-send)  (let ((fl (instance-flavor self)))    (if (arrayp (flavor-method-hash-table fl))      (multiple-value-bind (fn-location definedp)(without-interrupts (gethash op (dont-optimize (hash-table-instance (flavor-method-hash-table fl)))))(if definedp  (apply (car fn-location) op to-send)))      (let ((wo (or (flavor-which-operations fl) (funcall self :which-operations))))(and (member op wo :test #'eq) (apply self op to-send))))))  #-elroy(defmethod (vanilla-flavor :get-handler-for) (op)  (get-handler-for self op))  ;Useful methods for debugging.;They all cause the instance variables of SELF to be bound as specials.#-elroy(defmethod (vanilla-flavor :eval-inside-yourself) (form)  (with-self-variables-bound (eval form))) #-elroy(defmethod (vanilla-flavor :funcall-inside-yourself) (function &rest args)  (with-self-variables-bound (apply function args)))  #-elroy(defmethod (vanilla-flavor :break) ()  (with-self-variables-bound (break "~S" self)))  ;;; This flavor is a useful mixin that provides messages for a property list protocol.#-elroy(defflavor property-list-mixin ((property-list nil)) () :settable-instance-variables   (:documentation :mixin "A mixin that provides property list messages."))  #-elroy(defmethod (property-list-mixin :get) (indicator &optional default)  (getf property-list indicator default))  #-elroy(defmethod (property-list-mixin :case :set :get) (indicator &rest property)  (declare (arglist indicator property))  ;; use car last is to ignore optional default eg from "(push zap (send foo :get bar))"  (setf (getf property-list indicator) (car (last property))))  #-elroy(defmethod (property-list-mixin :get-location-or-nil) (indicator)  (get-location-or-nil (locf property-list) indicator))  #-elroy(defmethod (property-list-mixin :get-location) (indicator)  (locf (get (locf property-list) indicator))) #-elroy(defmethod (property-list-mixin :getl) (indicator-list)  (getl (locf property-list) indicator-list))  #-elroy(defmethod (property-list-mixin :putprop) (property indicator)  (setf (getf property-list indicator) property))  #-elroy(defmethod (property-list-mixin :remprop) (indicator)  (remprop (locf property-list) indicator))  #-elroy(defmethod (property-list-mixin :push-property) (property indicator)  (push property (getf property-list indicator)))  #-elroy(defmethod (property-list-mixin :plist) ()  property-list)  #-elroy(defmethod (property-list-mixin :plist-location) ()  (locf property-list))  #-elroy(defmethod (property-list-mixin :property-list-location) ()  (locf property-list))  #-elroy(defmethod (property-list-mixin :setplist) (new-plist)  (setq property-list new-plist))  #-elroy(defparameter instance-invoke-vector-contents   '(:get :getl :get-location-or-nil :car :cdr :set-car :set-cdr)   "A list of elements to copy into the value of INSTANCE-INVOKE-VECTOR.")  #-elroy(defvar instance-invoke-vector :unbound   "A vector of operations that the microcode wants to perform on instances.Indices in this vector are defined in SYS:UCODE;UC-PARAMETERS LISP.The vector may not be forwarded.")  #-elroy(defun init-instance-invoke-vector ()  (let ((vector (make-array (length instance-invoke-vector-contents))))    (fillarray vector instance-invoke-vector-contents)    (setq instance-invoke-vector vector)))  #-elroy(add-initialization 'init-instance-invoke-vector '(init-instance-invoke-vector) '(once))  ;; This flavor makes your instance print out using horseshoes, and read back in.#-elroy(defflavor print-readably-mixin () () (:required-methods :reconstruction-init-plist))  #-elroy(defmethod (print-readably-mixin :print-self) (stream &rest ignore)  (send stream :string-out "#")  (let ((*package* pkg-user-package))    (prin1 (type-of self) stream))  (send stream :tyo #\Space)  (do ((init-options (send self :reconstruction-init-plist) (cddr init-options)))      ((null init-options))    (prin1 (car init-options) stream)    (send stream :tyo #\Space)    (prin1 (cadr init-options) stream)    (if (cddr init-options)      (send stream :tyo #\Space)))  (send stream :tyo #\))  #-elroy(defmethod (print-readably-mixin :read-instance) (flavor stream)  (do (ch       init-options)      (nil)       ;; Skip past spaces.    (do ()((not (= (setq ch (send stream :tyi)) #\Space)) (send stream :untyi ch)))    (if (= ch #\)      (return (apply 'make-instance flavor init-options)))    (setq init-options (list* (read stream  t nil t) (read stream t nil t) init-options))))  #-elroy(defun get-handler-for (function operation &optional (superiors-p t) &aux tem)  "Given a functional object, return its subfunction to do the given operation or NIL.   Returns NIL if it does not reduce to a select-method or if it does not handle that."  (block get-handler-for    (do ()(nil)      (select (%data-type function) (dtp-array-pointer;Set function to NIL or Named-structure handler  (setq function (get (named-structure-p function) 'named-structure-invoke))) (dtp-symbol (or (fboundp function) (return ()))  (setq function (symbol-function function))) ((dtp-entity dtp-closure) (setq function (car (%make-pointer dtp-list function)))) (dtp-select-method (setq function (%make-pointer dtp-list function))  (do ()      (nil);Iterate down select-method, then continue with tail    (cond      ((symbolp (car function));One level subroutine call       (and superiors-p (setq tem (get-handler-for function operation ()))  (return-from get-handler-for tem)))      ((if (consp (caar function)) (member operation (caar function) :test #'eq) (eq operation (caar function)))       (return-from get-handler-for (cdar function))))    (setq function (cdr function))    (or (consp function) (return ())))) (dtp-instance (setq function (instance-function function))  (if (arrayp function)    (return-from get-handler-for       (car(without-interrupts (gethash operation  function)))))) (otherwise (return-from get-handler-for ()))));Repeat until reduced to a select-method (if possible)))  #-elroy(defun get-flavor-tracing-aliases (flavor-name &aux fl)  "Return the flavor object for FLAVOR-NAME, or the one it is an alias for ..."  (do ((name flavor-name))      (nil)    (setq fl (get name 'flavor))    (unless fl      (return ()))    (if (flavor-get fl :alias-flavor)      (setq name (car (flavor-depends-on fl)))      (return fl))))  ;;; Get the function that would handle an operation for a flavor(defun get-flavor-handler-for (flavor-name operation &aux fl)  (check-arg flavor-name (setq fl (get-flavor-tracing-aliases flavor-name))     "the name of a flavor")  ;; Do any composition (compilation) of combined stuff, if not done already  (or (flavor-depends-on-all fl) (compose-flavor-combination fl))  (or (flavor-method-hash-table fl) (compose-method-combination fl))  (if (eq (flavor-method-hash-table fl) t)    (ferror () "The flavor ~S is an :ABSTRACT-FLAVOR." flavor-name))  (car   (without-interrupts    (gethash operation (flavor-method-hash-table fl)))));; (:HANDLER flavor operation) refers to the function that is called when;;   an object of flavor FLAVOR is sent the message OPERATION.;; Storing into this changes the value in the method table for that specific flavor;;  which should make it possible to trace and so forth.(defprop :handler handler-function-spec-handler function-spec-handler)  (defun handler-function-spec-handler (function function-spec &optional arg1 arg2)  (let ((flavor (second function-spec)) (operation (third function-spec)));; Checking structure like :INTERNAL    (and (symbolp flavor)       (let ((fl (get-flavor-tracing-aliases flavor))) (or fl    (ferror 'invalid-function-spec    "In the function spec ~S, ~S is not the name of a flavor" function-spec    flavor)) ;; Do any composition (compilation) of combined stuff, if not done already (or (flavor-depends-on-all fl) (compose-flavor-combination fl)) (or (flavor-method-hash-table fl) (compose-method-combination fl)) (if (eq (flavor-method-hash-table fl) t)   (ferror () "The flavor ~S is an :ABSTRACT-FLAVOR." flavor)) (let ((loc(without-interrupts;Location of method (gethash operation  (flavor-method-hash-table fl)))))   (or (not (null loc)) (member function '(validate-function-spec fdefinedp) :test #'eq)      (ferror () "The flavor ~S does not handle the ~S operation." flavor operation))   (case function     (validate-function-spec t)     (fdefine (rplacd loc arg1))     (fdefinition (cdr loc))     (fdefinedp loc)     (fdefinition-location loc)     (fundefine (ferror () "FUNDEFINE is not implemented for :HANDLER"))     (otherwise (function-spec-default-handler function function-spec arg1 arg2))))))))  (defprop %instance-ref ((%instance-ref instance index) set-%instance-ref instance index val)   setf)  (defprop %instance-ref ((%instance-ref instance index) %instance-loc instance index) locf)  ;This is in LMWIN;COLD now, and no longer defined this way.;(DEFUN SYMEVAL-IN-INSTANCE (INSTANCE PTR);  (CHECK-ARG INSTANCE (TYPEP INSTANCE ':INSTANCE) "an instance");  (OR (SYMBOLP PTR) (SETQ PTR (%FIND-STRUCTURE-HEADER PTR)));  (LET ((N (FIND-POSITION-IN-LIST PTR (FLAVOR-ALL-INSTANCE-VARIABLES;(INSTANCE-FLAVOR INSTANCE)))));    (IF N;(%INSTANCE-REF INSTANCE (1+ N));(FERROR NIL "The variable ~S is not an instance variable of ~S";PTR INSTANCE))));(DEFPROP SYMEVAL-IN-INSTANCE ((SYMEVAL-IN-INSTANCE INSTANCE PTR);      SET-IN-INSTANCE INSTANCE PTR VAL) SETF); SYMEVAL-IN-INSTANCE is now a DEFSUBST so this is not needed.;; This definition is not patched in system 91.#-elroy(defun set-in-instance (instance ptr val)  "Set the value of instance variable PTR in INSTANCE to VAL.PTR can also be a locative pointer to a value cell."  (setf (contents (locate-in-instance instance ptr)) val)  val)  #-elroy(defprop symeval-in-instance   ((symeval-in-instance instance ptr) locate-in-instance instance ptr) locf)  ;; LOCATE-IN-INSTANCE is now microcoded.#-elroy(defun symeval-maybe-in-instance (instance ptr)  "Try SYMEVAL-IN-INSTANCE; if not an instance variable of INSTANCE, then do SYMEVAL"  (check-arg instance (typep instance :instance) "an instance")  (or (symbolp ptr) (setq ptr (%find-structure-header ptr)))  (let ((n (position ptr (the list (flavor-all-instance-variables (instance-flavor instance)))   :test #'eq)))    (if n      (%instance-ref instance (1+ n))      (symbol-value ptr))))  ;Interface to the compiler.;If called in *JUST-COMPILING* mode, during a QC-FILE, sends its output into the QFASL file.;If called during a compilation to core, for instance from;the editor c-t-C command, compiles to core as part of the compilation;in progress (assuming you are in the top level macro-expanding part of the;compiler rather than deep inside its guts).  If called at a random time,;simply compiles to core.;Note that if LOCAL-DECLARATIONS is bound when this is called it will be obeyed.;;;Added fix for compilation of flavors that occurs when a file containing them is;;;loaded as the result of the evaluation of a LOAD form in an edit buffer.  Done;;;by Ellen for David Gray.(defun compile-at-appropriate-time (fl name lambda-exp &optional form-to-eval) ;; Switch to the appropriate package so gensyms get defined in that package and ;; and error messages about wrong package defining a function are avoided.  But ;; if compiling, don't mess with the package, so that symbols in the qfasl file ;; get interned in the proper place.  (let ((*package* (if compiler::qc-file-in-progress     *package*     (flavor-package fl)));; Declare the instance variables for the code being compiled.(local-declarations (list* (flavor-declaration (flavor-name fl)) local-declarations)))    (if (and compiler::qc-file-in-progress compiler::qcompile-temporary-area)     ;; This case if in QC-FILE or editor-compile      (if *just-compiling*       ;; Here if QC-FILE.  If it's a combined method,       ;; actually FDEFINE a FASLOAD-COMBINED method when we load,       ;; but make the FEF's name say :COMBINED.(compiler::qc-translate-function (if (and (= 4 (length name)) (eq (third name) :combined))   (list* (first name) (second name) 'fasload-combined (cdddr name))   name) lambda-exp 'compiler:macro-compile 'compiler:qfasl name);; Here for compiling from editor buffer, or QC-FILE to core.(compiler::locking-resources-no-qfasl (let ((inhibit-fdefine-warnings t))   (push (list name fdefine-file-pathname) *flavor-compilations*)   (compiler::qc-translate-function name lambda-exp 'compiler:macro-compile    'compiler:compile-to-core))))      ;; This case if not doing anything special      (progn(push (list name fdefine-file-pathname) *flavor-compilations*)(let ((fdefine-file-pathname nil) (inhibit-fdefine-warnings t))      ;; If the compiler is not loaded, try to limp through with interpreted methods  (funcall (if (fboundp 'compile)     'compile     'fdefine)   name lambda-exp))))    ;; Evaluate form now or send it over in the qfasl file    (and form-to-eval       (if *just-compiling* (compiler::fasd-form form-to-eval) (eval form-to-eval))))) (defmacro compile-flavor-methods (&rest flavor-names)  "In a file being compiled, put combined methods of flavors into the QFASL file."  `(progn     (eval-when (compile),@(mapcan   #'(lambda (flavor-name)       (nconc(and (get flavor-name 'flavor)   (cons    `(putprop (locf (flavor-plist (get ',flavor-name 'flavor))) t      'compile-flavor-methods)    ()))(cons `(compile-flavor-methods-1 ',flavor-name) ())))   flavor-names))     (eval-when (load eval),@(mapcar #'(lambda (flavor-name)      `(compile-flavor-methods-2 ',flavor-name))  flavor-names))))  ;; Cause the combined-methods to get compiled.;; Executed only from the compiler, and does something;; only if compiling to a file.(defun compile-flavor-methods-1 (flavor-name)  (let ((*integrate-combined-methods* (or *integrate-combined-methods*    (and (fboundp 'compiler:speed-over-safety-p)       (dont-optimize (compiler:speed-over-safety-p))))))    (cond      ((just-compiling)       (let ((*just-compiling* t)     (*use-old-combined-methods* nil)     fl) (cond   ((flavor-components-defined-p flavor-name 'compile-flavor-methods)    (setq fl (compilation-flavor flavor-name))    ;; Make sure we are not hacking the installed flavor object,    ;; in case there is no defflavor or defmethod for the flavor in this file.    (and (eq fl (get flavor-name 'flavor))       (compilation-define-flavor flavor-name  (setq fl (flavor-redefinition-for-compilation fl ()))))    (or (flavor-depends-on-all fl) (compose-flavor-combination fl))    (compose-method-combination fl ())    (dolist (alternative (get-run-time-alternative-flavor-names fl))      (compile-flavor-methods-1 alternative))))))      (*integrate-combined-methods* (integrate-flavor-methods flavor-name)))))  ;; Do the composition now.  This should normally just generate data-structure;; as the methods should already all have been compiled, unless something has changed.(defprop compile-flavor-methods-2 t qfasl-dont-record)  (defun compile-flavor-methods-2 (flavor-name &aux fl)  (check-arg flavor-name (setq fl (get flavor-name 'flavor)) "the name of a flavor")  (setf (getf (flavor-plist fl) 'compile-flavor-methods) (or fdefine-file-pathname t))  (cond    ((flavor-components-defined-p flavor-name)     (or (flavor-depends-on-all fl) (compose-flavor-combination fl))     (or (flavor-method-hash-table fl) (compose-method-combination fl))     (dolist (alternative (get-run-time-alternative-flavor-names fl))       (compile-flavor-methods-2 alternative))))  flavor-name)  (defun integrate-flavor-methods (flavor-name)  "Compile any combined methods, using inline expansion for component methods."  ;;phd 1/16/86 added compose-flavor-combination to fix a bug.  (let ((fl (get flavor-name 'flavor))(*integrate-combined-methods* t)(*dont-recompile-flavors* nil))    (or (flavor-depends-on-all fl) (compose-flavor-combination fl))    (if (flavor-method-hash-table fl)      (recompile-flavor flavor-name () ())      (compose-method-combination fl))))  (defun flavor-components-defined-p (flavor-name &optional complaint &aux fl)  "Returns T if all components of this flavor are defined.If COMPLAINT is non-NIL, a message containing it is printedif not all components are defined."  (cond    ((setq fl (compilation-flavor flavor-name))     (or (flavor-depends-on-all fl);Already composed, be fast(and (do ((l (flavor-depends-on fl) (cdr l)))     ((null l)      t)   (or (flavor-components-defined-p (car l)) (return ()))) (do ((l (flavor-includes fl) (cdr l)))     ((null l)      t)   (or (flavor-components-defined-p (car l)) (return ()))) (do ((l (getf (flavor-plist fl) :required-flavors) (cdr l)))     ((null l)      t)   (or (flavor-components-defined-p (car l)) (return ()))))))    (complaint (format *error-output* "~&~A - ~S undefined flavor" complaint flavor-name) nil)    (t nil)))  (defun flavor-undefined-components (flavor-name )  "Returns the list of the undefined components or required flavors"  (let ((*just-compiling* (just-compiling)))    (labels ((flavor-undefined-components-internal (flavor-name)       (let ((fl (compilation-flavor flavor-name (just-compiling)))     (l nil)) (if fl     (and (null (flavor-depends-on-all fl));Already composed, be fast  (progn     (dolist (comp (flavor-depends-on fl) nil)      (setf l (nconc (flavor-undefined-components-internal comp) l)))    (dolist (inc (flavor-includes fl) nil)      (setf l (nconc (flavor-undefined-components-internal inc) l)))    (dolist (req (getf (flavor-plist fl) :required-flavors) nil)      (setf l (nconc (flavor-undefined-components-internal req) l)))    l))     (cons flavor-name nil)))))      (flavor-undefined-components-internal flavor-name))));;;PHD 11/4/86 Fix up method lists generated by Genasys to hash table (defun fixup-method-hash-tables ()  (dolist (fl-name *all-flavor-names*)    (let* ((fl  (get fl-name 'flavor))   (ht (flavor-method-hash-table fl)))      (when (consp ht)(make-method-hash-table fl)))))(add-initialization "Fix Up Flavor Method Hashtables" '(fixup-method-hash-tables) :once)e-size fl) (/= (flavor-instance-size fl) size)     (format *error-output*     "~&Warning: changing the size of an instance of ~S from ~S to ~SThis may cause you problems.~%";* This should perhaps do something about it *     (flavor-name fl) (flavor-instance-size fl) size))  (setf (flavor-instance-size fl) size)  ;; If there are any instance variables required but not present, save them  ;; so that they can be accessed in methods.  (dolist (v vars)    (setq reqs (delete v (the list reqs) :test #'eq)))  (and reqs (setf (getf (flavor-plist fl) 'additional-instance-variables) reqs))  (and specs (setf (flavor-all-special-instance-variables fl) specs))  ;; Don't mark this flavor as "composed" if there were errors.  (or some-component-undefined (setf (flavor-depends-on-all fl) fls))  fls)  (defun compose-flavor-inclusion (flavor error-p)  (multiple-value-bind (fls additions)    (compose-flavor-inclusion-1 flavor () error-p)    ;; The new additions may themselves imply more components    (do ((l additions (cdr l)))((null l) nil)      (let ((more-fls (compose-flavor-inclusion-1 (car l) fls error-p)))(dolist (f more-fls) ;; This hair inserts F before (after) the thing that indirectly included it ;; and then puts that next on ADDITIONS so it gets composed also  (let ((ll (member (car l) fls :test #'eq)))    (rplaca (rplacd ll (cons (car ll) (cdr ll))) f)    (rplacd l (cons f (cdr l)))))))    ;; Now attach vanilla-flavor if desired    (or     (loop for flavor in fls thereis(let ((tem (compilation-flavor flavor)))  (and tem (getf (flavor-plist tem) :no-vanilla-flavor))))     (push 'vanilla-flavor fls))    (nreverse fls)))  (defun compose-flavor-inclusion-1 (flavor other-components error-p &aux flavor-1) ;; First, make a backwards list of all the normal (non-included) components  (declare (special other-components))  (let ((fls (map-over-component-flavors 1 error-p ()     #'(lambda (fl list) (setq fl (flavor-name fl)) (or (member fl list :test #'eq)    (member fl other-components :test #'eq)    (push fl list)) list)     flavor ()))(additions nil));; If there are any inclusions that aren't in the list, plug;; them in right after (before in backwards list) their last (first) includer    (do ((l fls (cdr l)))((null l) nil)      (dolist (fl (flavor-includes (compilation-flavor (car l))))(or (member fl fls :test #'eq) (member fl other-components :test #'eq)   (push (car (rplaca (rplacd l (cons (car l) (cdr l))) fl)) additions))))    (or (member flavor fls :test #'eq);; Avoid error if FLAVOR is undefined and ERROR-P is NIL.       (not (or (setq flavor-1 (compilation-flavor flavor)) error-p))       (setq fls     (nconc fls    (nreverse     (loop for fl in (flavor-includes flavor-1) unless(or (member fl fls :test #'eq) (member fl other-components :test #'eq))collect fl and do (push fl additions))))))    (values fls additions)))  ;Mapping tables.;Each mapping table relates a method-flavor to an instance-flavor.;It maps several of the instance vars accessible from the method-flavor;to slot positions in the instances of the instance flavor.;Ths instance variables mapped are those in the (FLAVOR-MAPPED-INSTANCE-VARIABLES ...);of the method flavor.  Those conprise all the instance variables actually;referred to by compiled code of methods of the method flavor,;except for ordered instance variables, which are not mapped at all.;Note that "method-flavor" simply means a flavor on which a method has been defined;and "instance-flavor" simply means a flavor which depends on the method-flavor;and has been instantiated.;Pointers to the mapping tables for one instance-flavor (and various method-flavors);are stored in an art-q-list array called;(FLAVOR-COMPONENT-MAPPING-TABLE-VECTOR instance-flavor).;But they are found thru an alist, (FLAVOR-COMPONENT-MAPPING-TABLE-ALIST instance-flavor).;The CDRs of alist elements are locatives into the vector.;When a new method-flavor is seen to need a mapping table,;the entire alist is recopied so it will be compact;;and a previously unused slot in the vector is used.;This way, we keep the alist maximally short and compact,;while keeping the vector short but avoiding forwarding it;unless the flavor gets recomposed with new mixins.;Methods called by message passing get their mapping tables;from the method hash table.;Methods called from combined methods are given mapping tables;by the combined method.  This does not search the alist.;Instead, the combined method looks in its own mapping table,;in the array leader, to find the mapping table to supply for the;method it is calling.;Given a list (FLAVOR-NAME VAR-NAME), return the number of the slot;in mapping tables from that flavor as the method flavor;for the specified variable.;If necessary, add this variable to the flavor's mapped variables;and update all the flavor's mapping tables.;Given instead a list (FLAVOR-NAME T COMPONENT-FLAVOR-NAME),;we pass it on to FLAVOR-COMPONENT-FLAVOR-SELF-REF-INDEX.(defun flavor-var-self-ref-index (flavor-and-varname) ;;  4/19/85 DNG - Use COMPILATION-FLAVOR instead of GET.  (let ((flavor (compilation-flavor (car flavor-and-varname))))    (or flavor       (ferror () "Loading a method for flavor ~S which is not defined" (car flavor-and-varname)))    (if (and (CDDR flavor-and-varname) (eq (second flavor-and-varname) t))      (flavor-component-flavor-self-ref-index flavor-and-varname)      (let* ((varname (cadr flavor-and-varname))     (pos      (position varname (the list (flavor-mapped-instance-variables flavor)) :test #'eq))     (opos      (position varname (the list (flavor-unmapped-instance-variables flavor)) :test#'eq)))(cond  (opos)  ((and (eq (third flavor-and-varname) :unmapped);; Unmapped reference requested by COMPILER:TRY-REF-SELF      (position varname (the list (flavor-all-instance-variables flavor)) :test #'eq)))  (pos (dpb 1 %%self-ref-relocate-flag pos))  (t   (setf (flavor-mapped-instance-variables flavor) (nconc (flavor-mapped-instance-variables flavor)(cons-in-area varname () working-storage-area)))   (remake-mapping-tables flavor flavor)   (dpb 1 %%self-ref-relocate-flag(position varname (the list (flavor-mapped-instance-variables flavor)) :test  #'eq))))))))  ;Don't record evaluations of this function in QFASL files.(defprop flavor-var-self-ref-index t qfasl-dont-record)  ;Given a list (FLAVOR-NAME T COMPONENT-FLAVOR-NAME), return the number of the slot;in the array leader of a mapping table between any-flavor and FLAVOR-NAME;which contains the locative to the ptr to the mapping table between;any-flavor and COMPONENT-FLAVOR-NAME.  Adds such an array leader slot if none yet.(defun flavor-component-flavor-self-ref-index (flavor-and-component-flavor-name) ;; 3/28/85 DNG - Use COMPILATION-FLAVOR instead of GET.  (let* ((flavor (compilation-flavor (car flavor-and-component-flavor-name))) (component-flavor-name (caddr flavor-and-component-flavor-name)) (pos  (position component-flavor-name (the list (flavor-mapped-component-flavors flavor))    :test #'eq)))    (or pos       (setq pos     (progn       (let ((default-cons-area background-cons-area))     ;; Note that the SETF does a PUTPROP which can cons. (setf (flavor-mapped-component-flavors flavor)       (nconc (flavor-mapped-component-flavors flavor)      (cons component-flavor-name ()))))       (remake-mapping-tables flavor flavor)       (position component-flavor-name (the list (flavor-mapped-component-flavors flavor)) :test #'eq))))    (dpb 1 %%self-ref-relocate-flag (dpb 1 %%self-ref-map-leader-flag (+ pos 3)))))  (defun flavor-decode-self-ref-pointer (flavor-name pointer-number)  "Decode the pointer field of a DTP-SELF-REF-POINTER.Assumes that it is used with flavor FLAVOR-NAME.Values are an instance variable name and NIL,or a component flavor name and T."  (declare (values instance-var-or-component-flavor t-if-component-flavor))  (let ((flavor (get flavor-name 'flavor)))    (cond      ((null flavor) nil)      ((ldb-test %%self-ref-map-leader-flag pointer-number)       (values(nth (- (ldb %%self-ref-index pointer-number) 3)     (flavor-mapped-component-flavors flavor))t))      ((ldb-test %%self-ref-relocate-flag pointer-number)       (nth (ldb %%self-ref-index pointer-number) (flavor-mapped-instance-variables flavor)))      ((nth (ldb %%self-ref-index pointer-number) (flavor-unmapped-instance-variables flavor)))      (t (nth (ldb %%self-ref-index pointer-number) (flavor-all-instance-variables flavor))))))  (defun flavor-inherit-mapping-table-flavors (fl)  "Return a list of component flavor objects of FL from which FL can inherit mapping tables."  (if (symbolp fl)    (setq fl (get fl 'flavor)))  (loop for fn1 in (cdr (flavor-depends-on-all fl)) as fl1 = (get fn1 'flavor) when     (and (flavor-all-instance-variables fl1) (flavor-method-hash-table fl1)(do ((vs (flavor-all-instance-variables fl) (cdr vs))     (v1s (flavor-all-instance-variables fl1) (cdr v1s)))    ((null v1s)     t)  (if (or (null vs) (neq (car vs) (car v1s)))    (return ()))))     collect fl1))  ;Update the mapping tables from method-flavor to instance-flavor;and all flavors that depend on instance-flavor.;Don't create any new mapping tables; only update those that exist.;We take short cuts that assume that this is being done because a new mapped instance var;or mapped component-flavor has been added, and that the goal is to make the maps longer.(defun remake-mapping-tables (instance-flavor method-flavor) ;; 3/28/85 DNG - Use COMPILATION-FLAVOR instead of GET.  (and instance-flavor     (let ((loc    (assoc (flavor-name method-flavor)   (flavor-component-mapping-table-alist instance-flavor) :test #'eq)))   ;; If this instance-flavor's mapping table already maps as many variables   ;; as need to be mapped, it must have been reached by a different path,   ;; so don't bother with it or its dependants again.       (if (and (cddr loc)   (eq (array-leader (cddr loc) 0)       (length (flavor-mapped-instance-variables method-flavor)))   (= (array-leader-length (cddr loc))      (+ 3 (length (flavor-mapped-component-flavors method-flavor))))) () (progn   (cond     ((cddr loc)      (let ((omap (cddr loc)))(setf (cddr loc) (update-mapping-table instance-flavor method-flavor (cddr loc)))(and (arrayp (flavor-method-hash-table instance-flavor))   (replace-through-hash-table (flavor-method-hash-table instance-flavor) omap       (cddr loc))))))   (dolist (subflavor (flavor-depended-on-by instance-flavor))     (remake-mapping-tables      (if (symbolp subflavor)(compilation-flavor subflavor)subflavor)      method-flavor)))))))  (defun replace-through-hash-table (hash-table old new)  (let ((len (array-total-size hash-table)))    (do ((i 2 (+ 3 i)))((>= i len))      (if (eq (aref hash-table i) old)(setf (aref hash-table i) new)))))  (defvar trace-mapping-table-growth ()   "T => print a message every time an existing flavor mapping table is made bigger.")  ;Construct a new map for a pair of flavors, or reuse an old map if it is long enough.;If we construct a new map, we make it a little bigger than necessary;so that if only a couple more mapped vars are needed we can reuse it.(defun update-mapping-table (instance-flavor method-flavor &optional old-map) ;; 3/28/85 DNG - Use COMPILATION-FLAVOR instead of GET.  (if (symbolp method-flavor)    (setq method-flavor (compilation-flavor method-flavor)))  (let ((mapvars (flavor-mapped-instance-variables method-flavor))(mapflavs (flavor-mapped-component-flavors method-flavor))(ivars (flavor-all-instance-variables instance-flavor)))    (let ((map old-map))      (when (or (null map) (> (length mapvars) (array-total-size map))  (> (length mapflavs) (- (array-leader-length map) 3)))(and map trace-mapping-table-growth   (format t "~&Growing mapping table for method flavor ~S, instance flavor ~S."   (flavor-name method-flavor)   (if (symbolp instance-flavor)     instance-flavor     (flavor-name instance-flavor))))(setq map      (make-array (+ 4 (length mapvars)) :type art-16b :leader-length  (+ 3 (length mapflavs)) :area permanent-storage-area)))      ;; Fill in the extra leader slots with mapping table locatives      ;; for this instance flavor and the method flavor's mapped component-flavors      ;; as method flavors.      (do ((i 3 (1+ i))   (flavs mapflavs (cdr flavs)))  ((null flavs))(setf (array-leader map i) (get-mapping-table-location instance-flavor (car flavs))))      ;; Fill in the array elements of the mapping table      ;; with indices in the instance flavor of the method flavor's mapped variables.      (do ((i 0 (1+ i))   (vars mapvars (cdr vars)))  ((null vars)   (setf (array-leader map 0) i))(setf (aref map i) (or (position (car vars) (the list ivars) :test #'eq)       #-Elroy #o7771       #+Elroy #XFFFFFF)))      ;; The 7771 or #XFFFFFFis recognize by the microcode, when somebody tries to get that offset      ;; into an instance the microcode traps (> #-Elroy 7770 #+Elroy #XFFFFFE)      (setf (array-leader map 1) method-flavor)      (setf (array-leader map 2) instance-flavor)      map)))  (defvar *create-mapping-tables* ()   "T while method-composing; create any mapping table a method wants to use.")  ;Get a cell whose CDR is or will be the mapping table for a pair of flavors.;If the instance flavor has been instantiated, we also create a mapping table;if there isn't one.  Otherwise, we just make a slot in the alist and leave it nil.;The mapping tables will be created when the flavor is instantiated.(defun get-mapping-table-location (instance-flavor method-flavor)  (if (symbolp instance-flavor)    (setq instance-flavor (compilation-flavor instance-flavor )))  (or (symbolp method-flavor) (setq method-flavor (flavor-name method-flavor)))  (or   (cdr (assoc method-flavor (flavor-component-mapping-table-alist instance-flavor) :test #'eq))   ;; If the method-flavor is no longer a component of the instance-flavor,   ;; it must be someone's mapped-component-flavor that is no longer used.   ;; Just ignore it.   (and (member method-flavor (flavor-depends-on-all instance-flavor) :test #'eq);; This method flavor is not in the alist, so make a slot for its mapping table.      (let ((vector (flavor-component-mapping-table-vector instance-flavor)) vector-index)    ;; Make sure vector exists and is long enough for all our component flavors.(let ((len (length (flavor-depends-on-all instance-flavor))))  (or vector     (setf (flavor-component-mapping-table-vector instance-flavor)   (setq vector (make-array len :type 'art-q-list :area permanent-storage-area     :leader-list '(0)))))  (if (or (> len (array-total-size vector))      (= (array-active-length vector) (array-total-size vector)))    (adjust-array vector (max len (1+ (length vector))))));; Add a slot for the new mapping table to the vector.(setq vector-index (vector-push () vector));; Add an entry to the alist, pointing at newly added vector slot.(let ((default-cons-area background-cons-area))  (push (cons method-flavor (locf (aref vector vector-index)))     (flavor-component-mapping-table-alist instance-flavor)));; Now fill in the slot in the vector with a mapping table;; if the instance flavor may have been instantiated already.(and (or *create-mapping-tables* (flavor-method-hash-table instance-flavor))   (setf (aref vector vector-index) (update-mapping-table instance-flavor method-flavor)))(locf (aref vector vector-index))))))  (defun fef-flavor-name (fef)  "Return the flavor which the compiled function FEF assumes SELF is an instance of."  #- Elroy (and (typep fef :compiled-function) (not (zerop (%p-ldb %%fefh-get-self-mapping-table fef)))     (%p-contents-offset fef (1- (%p-ldb-offset %%fefhi-ms-arg-desc-org fef %fefhi-misc))))  #+ Elroy  (and (typep fef 'compiled-function)       (not (zerop (%p-ldb %%FEF-HEADER-Self-Mapping-Table fef)))       (%p-contents-offset fef   (if (= (%p-ldb si::%%fef-header-call-type  fef)  %fef-call-long)       %fef-second-optional-word       %fef-first-optional-word))))(defun get-handler-mapping-table (flavor handler definition-location)  (or   (cdr    (get-mapping-table-location flavor(or (and (= dtp-symbol (%p-data-type definition-location))    (fboundp (car definition-location))    (fef-flavor-name (symbol-function (car definition-location)))) (cadr handler))))   (ferror () "No mapping table for method ~S in flavor ~S" handler flavor)))  (defvar total-inherited-mapping-table-size 0)  ;Update all the mapping tables for INSTANCE-FLAVOR and various method-flavors.;Creates a mapping table for each slot which is empty.;If REPLACE-ALL is set, creates a new mapping table for every slot,;throwing away the old mapping tables.  That is used when a flavor has;changed incompatibly.(defun make-component-mapping-tables (instance-flavor &optional replace-all &aux  (inherit-mapping-table-flavors   (flavor-inherit-mapping-table-flavors instance-flavor))) ;; Make sure vector exists and is long enough for all our component flavors.  (let ((len (length (flavor-depends-on-all instance-flavor))))    (or (flavor-component-mapping-table-vector instance-flavor)       (setf (flavor-component-mapping-table-vector instance-flavor)     (make-array len :type 'art-q-list :area permanent-storage-area :leader-list '(0))))    (if (> len (array-total-size (flavor-component-mapping-table-vector instance-flavor)))      (adjust-array (flavor-component-mapping-table-vector instance-flavor) len)))  ;; Make sure all components are in the vector and alist.  (dolist (mf (flavor-depends-on-all instance-flavor))    (get-mapping-table-location instance-flavor mf))  ;; Copy the alist now so it is compact, if it has changed.  ;; It is now copied by LINEARIZE-FLAVOR-PLISTS after full-gc.  ;  (OR (EQ OALIST (FLAVOR-COMPONENT-MAPPING-TABLE-ALIST INSTANCE-FLAVOR))  ;      (SETF (FLAVOR-COMPONENT-MAPPING-TABLE-ALIST INSTANCE-FLAVOR)  ;    (COPYALIST (FLAVOR-COMPONENT-MAPPING-TABLE-ALIST INSTANCE-FLAVOR)  ;       PERMANENT-STORAGE-AREA)))  ;; Make sure all mapping tables exist and are up to date.  (dolist (elt (flavor-component-mapping-table-alist instance-flavor))    (when (or replace-all (null (cddr elt)))     ;; Inherit mapping tables when possible.      (dolist (ifl inherit-mapping-table-flavors)(when (member (car elt) (flavor-depends-on-all ifl) :test #'eq)  (setf (cddr elt) (car (get-mapping-table-location ifl (car elt))))  (incf total-inherited-mapping-table-size (%structure-total-size (cddr elt)))))      (setf (cddr elt) (update-mapping-table instance-flavor (car elt))))))  ;Once the flavor-combination stuff has been done, do the method-combination stuff.;The above function usually only gets called once, but this function gets called;when a new method is added.;Specify SINGLE-OPERATION to do this for just one operation, for incremental update.;This function should not be called for a single operation until it has;been called at least once to do all operations.;NOTE WELL: If a meth is in the method-table at all, it is considered to be defined; for purposes of compose-method-combination.  Thus merely putprop'ing a method,; or calling flavor-notice-method, will make the flavor think that method exists; when it is next composed.  This is necessary to make compile-flavor-methods work.; (Putprop must create the meth because loading does putprop before fdefine.)(defun compose-method-combination (fl &optional (single-operation nil) &aux tem magic-list order msg elem handlers ffl pl  (default-cons-area *flavor-area*))  (if (flavor-get fl :alias-flavor)    (ferror () "Attempt to compose methods of ~S, an alias flavor." (flavor-name fl)))  ;; If we are doing wholesale method composition,  ;; compose the flavor bindings list also.  ;; This way it is done often enough, but not at every defmethod.  (or single-operation *just-compiling* (flavor-get fl :abstract-flavor)     (progn       (compose-flavor-bindings fl)       (compose-flavor-initializations fl)))  ;; Look through all the flavors depended upon and collect the following:  ;; A list of all the operations handled and all the methods for each, called MAGIC-LIST.  ;; The default handler for unknown operations.  ;; The declared order of entries in the select-method alist.  ;; Also generate any automatically-created methods not already present.  ;; MAGIC-LIST is roughly the same format as the flavor-method-table, see its comments.  ;; Each magic-list entry is (message comb-type comb-order (type function-spec...)...)  (do ((ffls (flavor-depends-on-all fl) (cdr ffls)))      ((null ffls))    (setq ffl (compilation-flavor (car ffls))  pl (locf (flavor-plist ffl)))    (cond      ((not single-operation)       (and (setq tem (get pl :select-method-order)) (setq order (nconc order (copy-list tem))))))    ;; Add data from flavor method-table to magic-list    ;; But skip over combined methods, they are not relevant here    (dolist (mte (flavor-method-table ffl))      (setq msg (car mte))      (cond((or (not single-operation) (eq msg single-operation)) ;; Well, we're supposed to concern ourselves with this operation (setq elem (assoc msg magic-list :test #'eq));What we already know about it (cond   ((dolist (meth (cdddr mte))      (or (eq (meth-method-type meth) :combined) (not (meth-definedp meth)) (return t)))    ;; OK, this flavor really contributes to handling this operation    (or elem (push (setq elem (list* msg () () ())) magic-list))    ;; For each non-combined method for this operation, add it to the front    ;; of the magic-list element, thus they are in base-flavor-first order.    (dolist (meth (cdddr mte))      (let ((type (meth-method-type meth)))(cond  ((eq type :combined))  ((not (meth-definedp meth)))  ((not (setq tem (assoc type (cdddr elem) :test #'eq)))   (push (list type (meth-function-spec meth)) (cdddr elem)))  ;; Don't let the same method get in twice (how could it?)  ((not (member (meth-function-spec meth) (cdr tem) :test #'eq))   (push (meth-function-spec meth) (cdr tem)))))))) ;; Pick up method-combination declarations (and (cadr mte)    (cadr elem);If both specify combination-type, check    ;;;PHD 2/11/86 Fixed bug about some method-combinations being equal but    ;;; not eq, changed neq to not equal .    (or (neq (cadr mte) (cadr elem)) (not (equal (caddr mte) (caddr elem))))    (ferror () "Method-combination mismatch ~S-~S vs. ~S-~S, check your DEFFLAVOR's"    (cadr mte) (caddr mte) (cadr elem) (caddr elem))) (cond   ((cadr mte);Save combination-type when specified    (or elem (push (setq elem (list* msg () () ())) magic-list))    (setf (cadr elem) (cadr mte)) (setf (caddr elem) (caddr mte))))))))  ;; This NREVERSE tends to put base-flavor methods last  (setq magic-list (nreverse magic-list))  ;; Re-order the magic-list according to any declared required order  (dolist (msg (nreverse order))    (and (setq tem (assoc msg magic-list :test #'eq))       (setq magic-list (cons tem (delete tem (the list magic-list) :count 1 :test #'eq)))))  ;; Map over the magic-list.  For each entry call the appropriate method-combining  ;; routine, which will return a function spec for the handler to use for this operation.  (dolist (mte magic-list)   ;; Punt if there are no methods at all (just a method-combination declaration)    (cond      ((cdddr mte)       ;; Process the :DEFAULT methods; if there are any untyped methods the       ;; default methods go away, otherwise they become untyped methods.       (and (setq tem (assoc :default (cdddr mte) :test #'eq))  (if (assoc () (cdddr mte) :test #'eq)    (setf (cdddr mte) (delete tem (the list (cdddr mte)) :test #'eq))    (rplaca tem ())))       (or (setq tem (get (or (cadr mte) :daemon) 'method-combination))  (ferror () "~S unknown method combination type for ~S operation" (cadr mte) (car mte)))       (push (funcall tem fl mte) handlers))      (t (setq magic-list (delete mte (the list magic-list) :count 1 :test #'eq)))))  (or *just-compiling* (flavor-get fl :abstract-flavor)     (progn      ;; Make sure that the required variables and methods are present.      (unless single-operation(verify-required-flavors-methods-and-ivars fl magic-list))      ;; If the flavor does not have mapping tables yet, make some.      (make-component-mapping-tables fl)))  ;; Get back into declared order.  We now have a list of function specs for handlers.  (setq handlers (nreverse handlers))  (cond    (*just-compiling*);If just compiling, don't affect hash table.    ((flavor-get fl :abstract-flavor) (setf (flavor-method-hash-table fl) t))    (single-operation     ;; If doing SINGLE-OPERATION, put it into the hash table.     ;; If the operation is becoming defined and wasn't, or vice versa,     ;; must recompute the which-operations list.     (without-interrupts;SWAPHASH or REMHASH might rehash.      (cond((null handlers);Deleting method ;; Remove entry from the which-operations list. (and (member single-operation (flavor-which-operations fl) :test #'eq)    (setf (flavor-which-operations fl)  (delete single-operation (the list (flavor-which-operations fl)) :test #'eq))) (remhash single-operation  (flavor-method-hash-table fl)))(t ;; Add an entry to the which-operations list. (unless (member single-operation (flavor-which-operations fl) :test #'eq)   (when (flavor-which-operations fl)     (setf (flavor-which-operations fl)   (copy-list (cons single-operation (flavor-which-operations fl)))))) ;; Add one to the hash table. (let (def)   (swaphash single-operation (setq def (fdefinition-location (car handlers)))     (flavor-method-hash-table fl)     (get-handler-mapping-table fl (car handlers) def))))))     (setf (flavor-method-hash-table fl)   (FOLLOW-STRUCTURE-FORWARDING (flavor-method-hash-table fl))))    ;; Working on all operations at once.    (t     (let ((ht    (make-flavor-hash-array permanent-storage-area    (1+ (ceiling (/ (length magic-list) 0.8s0)))))   def)       (do ((handlers handlers (cdr handlers))    (*create-mapping-tables* t)    (ml magic-list (cdr ml)))   ((null ml)) (puthash-array (caar ml) (setq def (fdefinition-location (car handlers))) ht(get-handler-mapping-table fl (car handlers) def)))       (setf (flavor-method-hash-table fl) ht)       (setf (flavor-which-operations fl) ());This will have to be recomputed       (let ((hash-instance (flavor-method-hash-table fl)))     ;; If a hash-instance exists, make sure SEND will use the latest     ;; version of the hash array of that hash instance. (when hash-instance   (setf (flavor-method-hash-table fl) (follow-structure-forwarding  hash-instance )))))))  (unless (or *just-compiling* (flavor-which-operations fl) (flavor-get fl :abstract-flavor))   ;; Make the :WHICH-OPERATIONS list.    (let ((ht (flavor-method-hash-table fl))  list)      (declare (special list))      (maphash-array #'(lambda (op &rest ignore) (push op list))     ht)      (setq list (sort list 'alphalessp))      (unless (equal list (flavor-which-operations fl))(setf (flavor-which-operations fl) (copy-list list)))))  ())  (defun flavor-all-inheritable-methods (flavor-name operation &aux fl)  "Return a list of function specs of all methods used by OPERATION on FLAVOR-NAME.This may include some that are shadowed by others in the list."  (check-arg flavor-name (setq fl (get flavor-name 'flavor)) "a flavor name")  (do ((ffls (flavor-depends-on-all fl) (cdr ffls))       mte       list)      ((null ffls)       (nreverse list))    (setq mte (assoc operation (flavor-method-table (compilation-flavor (car ffls))) :test #'eq))    (when mte     ;; For each non-combined method for this operation, add it to the front     ;; of the list, thus they are in base-flavor-first order.      (dolist (meth (cdddr mte))(let ((type (meth-method-type meth)))  (cond    ((eq type :combined))    ((not (meth-definedp meth)))    (t (push (meth-function-spec meth) list))))))))  (defun verify-required-flavors-methods-and-ivars (fl magic-list)  (do ((ffls (flavor-depends-on-all fl) (cdr ffls))       (missing-methods nil)       (missing-instance-variables nil)       (missing-flavors nil)       (requiring-flavor-alist nil))      ((null ffls)       (and (or missing-instance-variables missing-methods missing-flavors)  (ferror ()  "Flavor ~S is missing ~~:[~2*~;instance variable~P ~{~S~^, ~} ~]~~:[~3*~;~:[~;and ~]method~P ~{~S~^, ~}~]~~:[~3*~;~:[~;and ~]component flavor~P ~{~S~^, ~}~]Requiring Flavor alist: ~S"  (flavor-name fl) missing-instance-variables  (length missing-instance-variables) missing-instance-variables missing-methods  missing-instance-variables (length missing-methods) missing-methods  missing-flavors (or missing-instance-variables missing-methods)  (length missing-flavors) missing-flavors requiring-flavor-alist)))    (let ((pl (locf (flavor-plist (get (car ffls) 'flavor)))))      (dolist (reqm (get pl :required-methods))(or (assoc reqm magic-list :test #'eq) (member reqm missing-methods :test #'eq)   (progn     (push reqm missing-methods)     (push (cons (first ffls) reqm) requiring-flavor-alist))))      (dolist (reqv (get pl :required-instance-variables))(or (member reqv (flavor-all-instance-variables fl) :test #'eq)   (member reqv missing-instance-variables :test #'eq)   (progn     (push reqv missing-instance-variables)     (push (cons (first ffls) reqv) requiring-flavor-alist))))      (dolist (reqf (get pl :required-flavors))(or (member reqf (flavor-depends-on-all fl) :test #'eq)   (member reqf missing-flavors :test #'eq)   (progn     (push reqf missing-flavors)     (push (cons (first ffls) reqf) requiring-flavor-alist)))))))  ;This function is called whenever the microcode fails to find an operation;in the flavor's hash table.;It could be because it is really undefined.;Or maybe a GC has taken place and the method hash table must be rehashed.;Or maybe the hash table has been forwarded.  The ucode doesn't follow the;forwarding, but rather gives up, so that we can un-forward it permanently.;note: instance-hash-failure is called from the microcode via the;support vector#-elroy(defun instance-hash-failure (op &rest args &aux (ht (%function-inside-self)) fn-location func)  (cond    ((/= (dont-optimize (hash-table-gc-generation-number ht)) %gc-generation-number)     (let ((newht (funcall (dont-optimize (hash-table-rehash-function ht)) ht ())))   ;; Some %POINTER's may have changed, try rehashing       (set-in-instance (dont-optimize (hash-table-instance ht)) 'hash-array newht)       (setf (instance-function self) newht))))  ;; In case a GC has happened or the hash table has been rehashed and forwarded,  ;; search it again using GETHASH to find out if the operation is really there.  (setq fn-location;; GETHASH does follow forwarding, and rehashes if nec.(gethash op  ht))  (cond    (fn-location     ;; In case GETHASH rehashed, snap out forwarding.      (setf (instance-function self)   (symeval-in-instance (dont-optimize (hash-table-instance ht)) 'hash-array))))  (cond    ((setq func (or (car fn-location);Found a definition   (flavor-default-handler (instance-flavor self))))     (apply func op args))    ((setq func (and (neq op :unclaimed-message);user defined handler   (get-handler-for self :unclaimed-message)))     (apply func :unclaimed-message op args))    (t (apply 'flavor-unclaimed-message op args))))  ;default handler;;;#+elroy;;;(defun instance-hash-failure (op &rest args &aux (ht (%function-inside-self)) fn-location func);;;  (cond;;;    ((/= (dont-optimize (hash-table-gc-generation-number ht)) %gc-generation-number);;;     (let ((newht (funcall (dont-optimize (hash-table-rehash-function ht)) ht ())));;;   ;; Some %POINTER's may have changed, try rehashing;;;       (setf (instance-function self) (FOLLOW-STRUCTURE-FORWARDING newht)))));;;  ;; In case a GC has happened or the hash table has been rehashed and forwarded,;;;  ;; search it again using GETHASH to find out if the operation is really there.;;;  (setq fn-location;;;;; GETHASH does follow forwarding, and rehashes if nec.;;;(gethash op ht ));;;  (when     fn-location;;;    ;; In case GETHASH rehashed, snap out forwarding. ;;;    (setf (instance-function self);;;  (FOLLOW-STRUCTURE-FORWARDING (instance-function self))));;;  (cond;;;    ((setq func (or (car fn-location);Found a definition;;;   (flavor-default-handler (instance-flavor self))));;;     (apply func op args));;;    ((setq func (and (neq op :unclaimed-message);user defined handler;;;   (get-handler-for self :unclaimed-message)));;;     (apply func :unclaimed-message op args));;;    (t (apply 'flavor-unclaimed-message op args))));This is the default handler for flavors.#-elroy(defun flavor-unclaimed-message (&rest message)  (report-unclaimed-message (%stack-frame-pointer) message))  #-elroy(defprop report-unclaimed-message t :error-reporter)  #-elroy(defun report-unclaimed-message (frame-pointer message) ;; Make this frame be a call to SELF so retrying it works.  (rplaca frame-pointer self)  (let ((new-operation (cerror :new-operation () 'unclaimed-message "The object ~S received a ~S message, which went unclaimed.The rest of the message was ~S." self (car message) (cdr message))))    (apply self new-operation (cdr message))))  (defun flavor-method-alist (fl)  "Return an alist of operations and their handlers, for flavor FL."  (if (symbolp fl)    (setq fl (compilation-flavor fl)))  (if fl    (let ((ht (flavor-method-hash-table fl))  alist)      (and (arrayp ht) (maphash  #'(lambda (op meth-locative &rest ignore)      (push (cons op (car meth-locative)) alist))  (flavor-method-hash-table fl)))      alist)));; Make the instance-variable getting and setting methods(defprop compose-automatic-methods t qfasl-dont-record)  ;;;??? This needs to get changed so that the methods are always compiled;;; once most files are compiled so that this is not called at load time.(defun compose-automatic-methods (fl &aux (settable-instance-variables    (flavor-settable-instance-variables fl))) ;;phd 7/8/86 changed the generation of accessor method so that if the instance is settable  ;; the accessor method is of type :default instead of untyped. This allows the user to  ;; provide his/her own accessor method. ;;Phd 1/2/87 Previous change turned to be wrong, because inherited method will  ;; override the accessor method. ;; Phd 10/4/85 add new flag to allow more that 120 settable instance variables. ;; This will prevent the generation of :case :set methods for the instance variables. ;; Avoid lossage on PROPERTY-LIST-MIXIN while reading this file into the cold load.  (when (fboundp 'compile-at-appropriate-time)    (dolist (v (flavor-gettable-instance-variables fl))      (let* ((vv (corresponding-keyword v))     (meth `(:method ,(flavor-name fl)  ,vv)))(if (or (not (flavor-notice-method meth)) *just-compiling*)  (compile-at-appropriate-time fl meth       `(named-lambda (,meth) (ignore)  (declare (function-parent ,(flavor-name fl) defflavor)     (:self-flavor ,(flavor-name fl)))  ,v))  (record-source-file-name meth))))    (dolist (v (flavor-settable-instance-variables fl))      (let* ((sv (intern1 (string-append "SET-" (symbol-name v)) pkg-keyword-package))     (meth `(:method ,(flavor-name fl) ,sv)))(if (or (not (flavor-notice-method meth)) *just-compiling*)  (compile-at-appropriate-time fl meth       `(named-lambda (,meth) (ignore .newvalue.)  (declare (function-parent ,(flavor-name fl) defflavor)     (:self-flavor ,(flavor-name fl)))  (setq ,v .newvalue.)))  (record-source-file-name meth)))      (when *flavor-enable-case-set-methods*(let* ((vv (corresponding-keyword v))       (meth `(:method ,(flavor-name fl) :case :set ,vv)))  (if (or (not (flavor-notice-method meth)) *just-compiling*)    (compile-at-appropriate-time fl meth `(named-lambda (,meth) (ignore ignore .newvalue.)    (declare     (function-parent ,(flavor-name fl) defflavor)     (:self-flavor ,(flavor-name fl)))    (setq ,v .newvalue.)))    (record-source-file-name meth)))))))  ;INTERN but always return-storage the print-name argument(defun intern1 (pname &optional (pkg *package*))  (prog1    (intern pname pkg)    (return-storage (prog1      pname      (setq pname ())))))  ;Given a symbol return the corresponding one in the keyword package(defun corresponding-keyword (symbol)  (intern (symbol-name symbol) pkg-keyword-package))  ;Make sure that the flavor bindings are up to date;;see which instance variables are supposed to be special.;We assume that the flavor has been composed.(defun compose-flavor-bindings (fl)  (let ((fls (flavor-depends-on-all fl))(specials (flavor-special-instance-variables fl)))    (dolist (f fls)      (setq f (compilation-flavor f ))      (setq specials (union specials (flavor-special-instance-variables f) :test #'eq))      (cond((flavor-all-instance-variables-special f) (or (flavor-depends-on-all f) (compose-flavor-combination f)) (setq specials       (union (union specials (flavor-all-instance-variables f) :test #'eq)      (flavor-additional-instance-variables f) :test #'eq)))))    ;; Any instance variables which the user has declared special elsewhere    ;; ought to be special.    (dolist (v (flavor-all-instance-variables fl))      (cond((and (not (member v specials :test #'eq)) (fboundp 'compiler::specialp)    (compiler::specialp v)) (format *error-output* "~&Instance variable ~S of ~S being made specialbecause that variable is globally special~%" v (flavor-name fl)) (push v specials))))    ;; Tell microcode about the instance variables    (let ((b   (mapcar #'(lambda (v)       (if (member v specials :test #'eq) (locf (symbol-value v))))   (flavor-all-instance-variables fl))))      (do ((bb b (cdr bb))   (prev (locf b) bb))  ((null bb))(if (null (car bb))  (do ((bbb bb (cdr bbb))       (i 0 (1+ i)))      ((car bbb)       (rplaca bb i)       (rplacd bb bbb))    (if (null bbb)      (progn(rplacd prev ())(rplacd bb ())(return ()))))))      (setf (flavor-bindings fl) (copy-list b)))))  ;Figure out the information needed to instantiate a flavor quickly.;We store these three properties on the flavor:;INSTANCE-VARIABLE-INITIALIZATIONS - alist of (ivar-index . init-form);REMAINING-DEFAULT-PLIST - a default plist from which kwds that init ivars have been removed.;ALL-INITTABLE-INSTANCE-VARIABLES - a list parallel to FLAVOR-ALL-INSTANCE-VARIABLES;   which has either the keyword to init with or NIL.;REMAINING-INIT-KEYWORDS - the init keywords that are handled and dont just init ivars.;We also set up the FLAVOR-DEFAULT-HANDLER of the flavor.(defun compose-flavor-initializations (fl &aux alist remaining-default-plist all-inittable-ivars area-function required-init-keywords  remaining-init-keywords unhandled-init-keywords)  (setq all-inittable-ivars(make-list (length (flavor-all-instance-variables fl)) :area   (if *just-compiling*     default-cons-area     background-cons-area)))  ;; First make the mask saying which ivars can be initted by init kywords.  (dolist (ffl (flavor-depends-on-all fl))    (let ((ffl (compilation-flavor ffl)))      (or area-function (setq area-function (flavor-get ffl :instance-area-function)))      (setq required-init-keywords    (union required-init-keywords (flavor-get ffl :required-init-keywords) :test #'eq))      (or (flavor-default-handler fl) (setf (flavor-default-handler fl) (getf (flavor-plist ffl) :default-handler)))      (dolist (iiv (flavor-inittable-instance-variables ffl))(let ((index       (position (cdr iiv) (the list (flavor-all-instance-variables fl)) :test #'eq)))  (and index (setf (nth index all-inittable-ivars) (car iiv)))))))  (setq remaining-init-keywords(mapcan #'(lambda (x)    (if (member x all-inittable-ivars :test #'eq)      ()      (list x)))(flavor-allowed-init-keywords fl)));(subset-not #'MEMQ (FLAVOR-ALLOWED-INIT-KEYWORDS FL) (CIRCULAR-LIST ALL-INITTABLE-IVARS)))  (pushnew :allow-other-keys remaining-init-keywords)  (setf (flavor-remaining-init-keywords fl) remaining-init-keywords)  ;; Then look at all the default init plists, for anything there  ;; that initializes an instance variable.  If it does, make an entry on ALIST.  ;; Any that doesn't initialize a variable, put on the "remaining" list.  (dolist (ffl (flavor-depends-on-all fl))    (setq ffl (compilation-flavor ffl))    (do ((l (getf (flavor-plist ffl) :default-init-plist) (cddr l)))((null l))      (let* ((keyword (car l)) (arg (cadr l))     (index (position keyword (the list all-inittable-ivars) :test #'eq)))     ;; Remove this keyword from the list of required ones,     ;; since it is cannot ever be missing.(setq required-init-keywords      (delete keyword (the list required-init-keywords) :test #'eq))(if index ;; This keyword initializes an instance variable, ;; so record an initialization of that variable if none found yet.  (or (assoc index alist :test #'eq) (push (list index arg) alist))  ;; This keyword does not just initialize an instance variable.  (progn    (unless (getf remaining-default-plist keyword)      (setf (getf remaining-default-plist keyword) arg))    (unless (member keyword remaining-init-keywords :test #'eq)      (pushnew keyword unhandled-init-keywords)))  ;;(IF (MEMQ KEYWORD (FLAVOR-REMAINING-INIT-KEYWORDS FL))  ;;    (OR (GET (LOCF REMAINING-DEFAULT-PLIST) KEYWORD)  ;;        (PUTPROP (LOCF REMAINING-DEFAULT-PLIST) ARG KEYWORD))  ;;  (FERROR NIL "The flavor ~S has keyword ~S in its default init plist, but doesn't handle it" (FLAVOR-NAME FL) KEYWORD))))))  (setf (flavor-unhandled-init-keywords fl) unhandled-init-keywords)  ;; Then, look for default values provided in list of instance vars.  (dolist (ffl (flavor-depends-on-all fl))    (setq ffl (compilation-flavor ffl))    (dolist (v (flavor-local-instance-variables ffl))      (and (not (atom v))   ;; When we find one, put it in if there is no init for that variable yet. (let ((index(position (car v) (the list (flavor-all-instance-variables fl)) :test #'eq)))   (and (not (assoc index alist :test #'eq)) (push (list index (cadr v)) alist))))))  (if area-function    (setf (getf (flavor-plist fl) 'instance-area-function) area-function)    (remprop (locf (flavor-plist fl)) 'instance-area-function))  (if required-init-keywords    (setf (getf (flavor-plist fl) 'required-init-keywords) required-init-keywords)    (remprop (locf (flavor-plist fl)) 'required-init-keywords))  (setf (flavor-instance-variable-initializations fl) alist)  (setf (flavor-remaining-default-plist fl) remaining-default-plist)  (setf (flavor-all-inittable-instance-variables fl) all-inittable-ivars))  ; Method-combination functions.  Found on the SI:METHOD-COMBINATION property; of the combination-type.  These are passed the flavor structure, and the; magic-list entry, and must return the function-spec for the handler; to go into the select-method, defining any necessary functions.; This function interprets combination-type-arg,; which for many combination-types is either :BASE-FLAVOR-FIRST or :BASE-FLAVOR-LAST.; :DAEMON combination; The primary method is the outermost untyped-method (or :DEFAULT).; The :BEFORE methods are called base-flavor-last, the :AFTER methods are called; base-flavor-first.  An important optimization is not to generate a combined-method; if there is only a primary method.  You are allowed to omit the primary method; if there are any daemons (I'm not convinced this is really a good idea) in which; case the method's returned value will be NIL.(defun (:property :daemon method-combination) (fl magic-list-entry)  (let ((primary-method (car (get-certain-methods magic-list-entry () '(:before :after) t :base-flavor-last)))(before-methods (get-certain-methods magic-list-entry :before t t :base-flavor-last))(after-methods (get-certain-methods magic-list-entry :after t t :base-flavor-first))(wrappers-p (specially-combined-methods-present magic-list-entry)));; Remove shadowed primary methods from the magic-list-entry so that it won't look like;; we depend on them (which could cause extraneous combined-method recompilation).    (let ((mle (assoc () (cdddr magic-list-entry) :test #'eq)))      (and (cddr mle) (setf (cdr mle) (list primary-method))))    (or (and (not wrappers-p) (null before-methods) (null after-methods) primary-method)       (have-combined-method fl magic-list-entry)       (make-combined-method fl magic-list-entry     (daemon-combination primary-method before-methods after-methods)))))  (defun daemon-combination (primary-method before-methods after-methods &optional or-methods and-methods)  (let ((inner-call (and primary-method (method-call primary-method))))    (and or-methods (setq inner-call `(or ,@(mapcar 'method-call or-methods) ,inner-call)))    (and and-methods (setq inner-call `(and ,@(mapcar 'method-call and-methods) ,inner-call)))    `(progn       ,@(mapcar 'method-call before-methods)       ,(if after-methods  `(multiple-value-prog1 ,inner-call ,@(mapcar 'method-call after-methods))  ;; You are allowed to not have a primary method  inner-call))))  (defun method-call (method)  `(lexpr-funcall-with-mapping-table-internal (function ,method) (method-mapping-table ,method)      .daemon-caller-args.))  ; :DAEMON-WITH-OVERRIDE combination; This is the same as :DAEMON (the default), except that :OVERRIDE type methods; are combined with the :BEFORE-primary-:AFTER methods in an OR.  This allows; overriding of the main methods function.  For example, a combined method as follows; might be generated: (OR (FOO-OVERRIDE-BAR-METHOD) (PROGN (FOO-BEFORE-BAR-METHOD)))(defun (:property :daemon-with-override method-combination) (fl magic-list-entry)  (let ((primary-method (car  (get-certain-methods magic-list-entry () '(:before :after :override) t       :base-flavor-last)))(before-methods (get-certain-methods magic-list-entry :before t t :base-flavor-last))(after-methods (get-certain-methods magic-list-entry :after t t :base-flavor-first))(wrappers-p (specially-combined-methods-present magic-list-entry))(override-methods (get-certain-methods magic-list-entry :override t t ())));; Remove shadowed primary methods from the magic-list-entry so that it won't look like;; we depend on them (which could cause extraneous combined-method recompilation).    (let ((mle (assoc () (cdddr magic-list-entry) :test #'eq)))      (and (cddr mle) (setf (cdr mle) (list primary-method))))    (or     (and (not wrappers-p) (null before-methods) (null after-methods) (null override-methods)primary-method)     (have-combined-method fl magic-list-entry)     (make-combined-method fl magic-list-entry   `(or ,@(mapcar 'method-call override-methods)       ,(daemon-combination primary-method before-methods after-methods))))))  ; :DAEMON-WITH-OR combination; This is the same as :DAEMON (the default), except that :OR type methods; are combined with the primary methods inside an OR, and used in place of; the primary method in :DAEMON type combination.; For example, the following combined method might be generated:; (PROGN (FOO-BEFORE-BAR-METHOD); (OR (FOO-OR-BAR-METHOD);     (BAZ-OR-BAR-METHOD);     (MULTIPLE-VALUE-PROG1;       (BUZZ-PRIMARY-METHOD);       (FOO-AFTER-BAR-METHOD)))(defun (:property :daemon-with-or method-combination) (fl magic-list-entry)  (let ((primary-method (car  (get-certain-methods magic-list-entry () '(:before :after :or) t :base-flavor-last)))(before-methods (get-certain-methods magic-list-entry :before t t :base-flavor-last))(after-methods (get-certain-methods magic-list-entry :after t t :base-flavor-first))(wrappers-p (specially-combined-methods-present magic-list-entry))(or-methods (get-certain-methods magic-list-entry :or t t ())));; Remove shadowed primary methods from the magic-list-entry so that it won't look like;; we depend on them (which could cause extraneous combined-method recompilation).    (let ((mle (assoc () (cdddr magic-list-entry) :test #'eq)))      (and (cddr mle) (setf (cdr mle) (list primary-method))))    (or     (and (not wrappers-p) (null before-methods) (null after-methods) (null or-methods)primary-method)     (have-combined-method fl magic-list-entry)     (make-combined-method fl magic-list-entry   (daemon-combination primary-method before-methods after-methods       or-methods)))))  ; :DAEMON-WITH-AND combination; This is the same as :DAEMON (the default), except that :AND type methods; are combined with the primary methods inside an AND, and used in place of; the primary method in :DAEMON type combination.; For example, the following combined method might be generated:; (PROGN (FOO-BEFORE-BAR-METHOD); (AND (FOO-AND-BAR-METHOD);      (BAZ-AND-BAR-METHOD);      (MULTIPLE-VALUE-PROG1;        (BUZZ-PRIMARY-METHOD);        (FOO-AFTER-BAR-METHOD)))(defun (:property :daemon-with-and method-combination) (fl magic-list-entry)  (let ((primary-method (car  (get-certain-methods magic-list-entry () '(:before :after :and) t :base-flavor-last)))(before-methods (get-certain-methods magic-list-entry :before t t :base-flavor-last))(after-methods (get-certain-methods magic-list-entry :after t t :base-flavor-first))(wrappers-p (specially-combined-methods-present magic-list-entry))(and-methods (get-certain-methods magic-list-entry :and t t ())));; Remove shadowed primary methods from the magic-list-entry so that it won't look like;; we depend on them (which could cause extraneous combined-method recompilation).    (let ((mle (assoc () (cdddr magic-list-entry) :test #'eq)))      (and (cddr mle) (setf (cdr mle) (list primary-method))))    (or     (and (not wrappers-p) (null before-methods) (null after-methods) (null and-methods)primary-method)     (have-combined-method fl magic-list-entry)     (make-combined-method fl magic-list-entry   (daemon-combination primary-method before-methods after-methods ()       and-methods)))))  ; :LIST combination; No typed-methods allowed.  Returns a list of the results of all the methods.; There will always be a combined-method, even if only one method to be called.(defun (:property :list method-combination) (fl magic-list-entry)  (or (have-combined-method fl magic-list-entry)     (make-combined-method fl magic-list-entry   `(list     . ,(mapcar 'method-call(append (get-certain-methods magic-list-entry :list '(nil) t ()) (get-certain-methods magic-list-entry () '(:list) () ())))))))  ; :INVERSE-LIST combination; No typed-methods allowed.  Apply each method to an element of the list.  Given; the result of a :LIST-combined method with the same ordering, and corresponding; method definitions, the result that emerged from each component flavor gets handed; back to that same flavor.  The combined-method returns no particular value.(defun (:property :inverse-list method-combination) (fl magic-list-entry)  (or (have-combined-method fl magic-list-entry)     (make-combined-method fl magic-list-entry   `(let ((.foo. (cadr .daemon-caller-args.)))      ,@(do ((ml      (append       (get-certain-methods magic-list-entry :inverse-list    '(nil) t ())       (get-certain-methods magic-list-entry () '(:inverse-list)    () ()))      (cdr ml))     (r nil))    ((null ml)     (nreverse r))  (push   `(funcall-with-mapping-table-internal (function ,(car ml))       (method-mapping-table ,(car ml))       (car .daemon-caller-args.) (car .foo.))   r)  (and (cdr ml) (push '(setq .foo. (cdr .foo.)) r)))))))  ; Combination types PROGN, AND, OR, MAX, MIN, +, APPEND, NCONC; These just call all their typed methods then the untyped methods,; inside the indicated special form or function.; As an optimization, if there is only one method it is simply called.(defprop :progn simple-method-combination method-combination)  (defprop :and simple-method-combination method-combination)  (defprop :or simple-method-combination method-combination)  (defprop :max simple-method-combination method-combination)  (defprop :min simple-method-combination method-combination)  (defprop :+ simple-method-combination method-combination)  (defprop :append simple-method-combination method-combination)  (defprop :nconc simple-method-combination method-combination)  (defprop :progn progn simple-method-combination)  (defprop :and and simple-method-combination)  (defprop :or or simple-method-combination)  (defprop :max max simple-method-combination)  (defprop :min min simple-method-combination)  (defprop :+ + simple-method-combination)  (defprop :append append simple-method-combination)  (defprop :nconc nconc simple-method-combination)  ;;PHD 12/28/86 Fixed bug, a primary method is no longer necessary.;;This allows for better compatibility with Symbolics.(defun simple-method-combination (fl magic-list-entry)  (let ((methods (append (get-certain-methods magic-list-entry (cadr magic-list-entry) '(nil) t ()) (get-certain-methods magic-list-entry () (list (cadr magic-list-entry)) t ())))(wrappers-p (specially-combined-methods-present magic-list-entry)))    (or (and (not wrappers-p) (null (cdr methods)) (car methods))       (have-combined-method fl magic-list-entry)       (make-combined-method fl magic-list-entry     (cons (get (cadr magic-list-entry) 'simple-method-combination)   (mapcar 'method-call methods))))))  (defun (:property :case method-combination) (fl magic-list-entry) ;;  9/16/85 DNG - Invoke CASE-METHOD-DEFAULT-HANDLER with FUNCALL instead ;;                of LEXPR-FUNCALL to allow combined method integration.  (let* ((primary-method  (car    (get-certain-methods magic-list-entry () '(:case :or :otherwise :before :after) t:base-flavor-last))) (otherwise-method  (or (car (get-certain-methods magic-list-entry :otherwise t t :base-flavor-last))     primary-method)) (before-methods (get-certain-methods magic-list-entry :before t t :base-flavor-last)) (after-methods (get-certain-methods magic-list-entry :after t t :base-flavor-first)) (or-methods (get-certain-methods magic-list-entry :or t t :base-flavor-last)) (methods (get-certain-methods magic-list-entry :case t t ()))) ;; Remove shadowed :otherwise methods from the magic-list-entry so that it won't look like ;; we depend on them (which could cause extraneous combined-method recompilation).    (let ((mle (assoc :otherwise (cdddr magic-list-entry) :test #'eq)))      (and (cddr mle) (setf (cdr mle) (list otherwise-method))))    ;; Remove shadowed primary methods too.    (let ((mle (assoc () (cdddr magic-list-entry) :test #'eq)))      (if (eq otherwise-method primary-method)(and (cddr mle) (setf (cdr mle) (list primary-method)));; If there is a :OTHERWISE method, all the primary ones are shadowed.(and mle (delete mle (the list magic-list-entry) :test #'eq))))    (or (have-combined-method fl magic-list-entry)       (make-combined-method fl magic-list-entry     (let ((inner-call    `(progn       ,@(mapcar 'method-call before-methods)       (case (cadr .daemon-caller-args.)  ,@(mapcar     #'(lambda (method) `(,(fifth method) ,(method-call method)))     methods)  ((:get-handler-for :operation-handled-p    :case-documentation)   (funcall 'case-method-default-handler    ',(flavor-name fl) ',(car magic-list-entry)    ',methods (cadr .daemon-caller-args.)    (caddr .daemon-caller-args.)))  (:which-operations   ',(mapcar #'(lambda (x) (car (cddddr x)))     methods))  (t   (or ,@(mapcar 'method-call or-methods)      ,(and otherwise-method  (method-call otherwise-method))))))))   ;; Copied from DAEMON-COMBINATION.       (if after-methods `(multiple-value-prog1 ,inner-call     ,@(mapcar 'method-call after-methods)) ;; No :AFTER methods, hair not required ;; You are allowed to not have a primary method inner-call))))))  (defun case-method-default-handler (flavor operation case-methods suboperation &rest args)  flavor  operation  (dolist (cm case-methods)    (if (eq (fifth cm) (car args))      (return       (case suboperation (:get-handler-for (fdefinition cm)) (:operation-handled-p t) (:case-documentation (documentation cm)))))))  ; :PASS-ON combination; The values from the individual methods are the arguments to the next one;; the values from the last method are the values returned by the combined; method.  Format is (:METHOD-COMBINATION (:PASS-ON (ORDERING . ARGLIST) . OPERATION-NAMES); ORDERING is :BASE-FLAVOR-FIRST or :BASE-FLAVOR-LAST.  ARGLIST can have &AUX and &OPTIONAL.(defun (:property :pass-on method-combination) (fl magic-list-entry)  (let ((methods (append  (get-certain-methods magic-list-entry :pass-on '(nil) t (caaddr magic-list-entry))  (get-certain-methods magic-list-entry () '(:pass-on) () (caaddr magic-list-entry))))(arglist (cdaddr magic-list-entry))argsrest-arg-p)    (do ((l arglist (cdr l)) (arg) (nl nil))((null l) (setq args (nreverse nl)))      (setq arg (car l))      (and (consp arg) (setq arg (car arg)))      (cond((eq arg '&rest) (setq rest-arg-p t))((eq arg '&aux))((eq arg '&optional))(t (push arg nl))))    (or (have-combined-method fl magic-list-entry)       (make-combined-method fl magic-list-entry     `(destructuring-bind (.operation. . ,arglist) .daemon-caller-args. ,@(do ((meths methods (cdr meths))(list ())(meth))       ((null meths)(nreverse list))     (setq meth   `(,(if rest-arg-p'lexpr-funcall-with-mapping-table-internal'funcall-with-mapping-table-internal)     (function ,(car meths))     (method-mapping-table ,(car meths)) .operation.     ,@args))     (and (cdr meths)(setq meth      (if (null (cdr args))`(setq ,(car args) ,meth)`(multiple-value-setq ,args ,meth))))     (push meth list)))))))  ; This function does most of the analysis of the magic-list-entry needed by; method-combination functions, including most error checking.(defun get-certain-methods (magic-list-entry method-type other-methods-allowed no-methods-ok ordering-declaration &aux  methods default-methods)  "Perform analysis needed by method-combination functions.   Returns a list of the method symbols for METHOD-TYPE extracted from MAGIC-LIST-ENTRY.   This value is shared with the data structure, don't bash it.   OTHER-METHODS-ALLOWED is a list of method types not to complain about (T = allow all).   NO-METHODS-OK = NIL means to complain if the returned value would be NIL.   ORDERING-DECLARATION is :BASE-FLAVOR-FIRST, :BASE-FLAVOR-LAST, or NIL meaning     take one of those symbols from the MAGIC-LIST-ENTRY."  ;; Find the methods of the desired type, and barf at any extraneous methods  (dolist (x (cdddr magic-list-entry))    (cond      ((eq (car x) method-type) (setq methods (cdr x)))      ((assoc (car x) *specially-combined-method-types* :test #'eq)) ;Wrappers ignored at this level      ((assoc (car x) *inverse-specially-combined-method-types* :test #'eq)) ;Wrappers ignored at this level      ((eq (car x) :default) (setq default-methods (cdr x)))      ((or (eq other-methods-allowed t) (member (car x) other-methods-allowed :test #'eq)))      (t       (ferror () "~S ~S method(s) illegal when using :~A method-combination" (car x)       (car magic-list-entry) (or (cadr magic-list-entry) :daemon)))))  ;; If we were looking for primary methods and there are none, use the :DEFAULT methods.  (and (null method-type) (null methods) (setq methods default-methods))  ;; Complain if no methods supplied  (and (null methods) (not no-methods-ok)     (ferror () "No ~S ~S method(s) supplied to :~A method-combination" method-type     (car magic-list-entry) (cadr magic-list-entry)))  ;; Get methods into proper order.  Don't use NREVERSE!  (case (or ordering-declaration (setq ordering-declaration (caddr magic-list-entry)))    (:base-flavor-first)    (:base-flavor-last (setq methods (reverse methods)))    (otherwise     (ferror ()     "~S invalid method combination order; must be :BASE-FLAVOR-FIRST or :BASE-FLAVOR-LAST"     ordering-declaration)))  methods)  (defun specially-combined-methods-present (mle)  (loop for (type) in (cdddr mle) thereis     (assoc type *specially-combined-method-types* :test #'eq)))  ;; It is up to the caller to decide that a combined-method is called for at all.;; If one is, this function decides whether it already exists OK or needs;; to be recompiled.  Returns the symbol for the combined method if it is;; still valid, otherwise returns NIL.;; Always canonicalizes the magic-list-entry, since it will be needed;; canonicalized later.(defun have-combined-method (fl magic-list-entry &aux operation-name cms mte old-mle old-cms tem ometh) ;; Canonicalize the magic-list-entry so can compare with EQUAL  (setf (cdddr magic-list-entry);Canonicalize before comparing(sort (cdddr magic-list-entry) #'string-lessp :key #'car));Sort by method-type  (setq operation-name (car magic-list-entry))  ;; See if we can inherit one in either the current or future (being-compiled) world,  ;; or use an existing combined method of this flavor.  ;; Get the :COMBINED method function spec for this flavor.  Note that if a suitable  ;; one can be inherited, we will do so.  ;; *USE-OLD-COMBINED-METHODS* controls whether we reuse an existing one for this  ;; flavor; if we inherit one it will always be up-to-date already.  ;; If all OK, return the function spec, else return NIL if new combined method must be made.  (or   (dolist (ffl (flavor-depends-on-all fl))     (let ((flavor1 (compilation-flavor ffl)))       (and (or (neq flavor1 fl) *use-old-combined-methods*)    ;; ^ Combined methods of this flavor can be used only if permitted.  (setq mte (assoc operation-name (flavor-method-table flavor1) :test #'eq))  (setq ometh (meth-lookup (cdddr mte) :combined))  (meth-definedp ometh)  ;; Check that  *use-old-combined-methods* has not been expanded in line  ;; in the combined method  (null   (and (neq t *use-old-combined-methods*)(meth-definition ometh)      (member (meth-function-spec *use-old-combined-methods*)      #-Elroy      (cadr       (assoc :macros-expanded (debugging-info (meth-definition ometh) t) :test      #'eq))      #+Elroy      (get-debug-info-field (get-debug-info-struct (meth-definition ometh) t)    :macros-expanded )      :test #'equal      :key #'(lambda (x) (if (consp x) (car x) x)))))  (or (meth-definition ometh) (and *just-compiling* (neq fl flavor1)))  (setq cms (meth-function-spec ometh))  (equal magic-list-entry (setq tem       (or#-Elroy(cadr (assoc 'combined-method-derivation(and (meth-definition ometh)   (debugging-info (meth-definition ometh) t)):test #'eq))#+Elroy(and (meth-definition ometh)     (get-debug-info-field (get-debug-info-struct (meth-definition ometh) t)   'combined-method-derivation ))(getf (meth-plist ometh) 'combined-method-derivation))))  (or (not (fboundp 'compiler:expr-sxhash))     (dolist (elt       #-Elroy       (cdr (assoc 'wrapper-sxhashes(and (meth-definition ometh) (debugging-info (meth-definition ometh) t)):test #'eq))       #+Elroy       (and (meth-definition ometh)    (get-debug-info-field (get-debug-info-struct (meth-definition ometh) t)  'wrapper-sxhashes ))       t);Return T if get thru whole list without mismatch.      ;; If any wrappers were used, make sure their definitions now      ;; match the definitions that were used to make the combined method.       (unless (eql (compiler:expr-sxhash (car elt)) (cadr elt)) (return ()))));Return NIL if mismatch.  (return cms)));Save first combined-method seen for tracing, it's the one we would     ;have been most likely to inherit     (or old-cms (null cms) (setq old-cms cms  old-mle tem)))   ;; Have to make a new combined method.  Trace if desired, but return NIL in any case.   (progn     (cond       (*flavor-compile-trace*(format *flavor-compile-trace*"~&~S's ~S combined method needs to be recompiled~%to come from "(flavor-name fl) operation-name)(print-combined-method-derivation magic-list-entry *flavor-compile-trace*)(cond  (old-cms   (format *flavor-compile-trace* "~%rather than using ~S which comes from " old-cms)   (print-combined-method-derivation old-mle *flavor-compile-trace*))  ((not *use-old-combined-methods*)   (format *flavor-compile-trace* "~%because of forced recompilation.")))))     ())))  (defun print-combined-method-derivation (mle stream)  (loop for (type . function-specs) in (cdddr mle) do     (loop for function-spec in function-specs do (format stream "~S " function-spec)))  (if (or (cadr mle) (caddr mle))    (format stream "with method-combination ~S ~S" (cadr mle) (caddr mle))))  (defun optimize-method-body-and-args (form) ;;  9/16/85 DNG - Original version, separated from MAKE-COMBINED-METHOD.  (declare (values body arglist))  (let (ll)    (let ((number-of-method-args nil)  (minimum-number-of-method-args 0)  (method-arg-list '(operation .method-arg-1. .method-arg-2. .method-arg-3.)))      (declare (special number-of-method-args minimum-number-of-method-args method-arg-list))      (if (and *integrate-combined-methods*  (catch 'out    (setq form (substitute-funcall-in-expression form))))(if (null number-of-method-args)  (setq ll(append (firstn minimum-number-of-method-args method-arg-list) '(&rest ignore)))  (setq ll method-arg-list))(setq ll '(&rest .daemon-caller-args.))))    (values form ll)))  ;; This function creates a combined-method, and returns the appropriate function spec.;; Its main job in life is to take care of wrappers.  Note the combined method;; always takes a single &REST argument named .DAEMON-CALLER-ARGS.;; FORM is a single form to be used as the body.(defun make-combined-method (fl magic-list-entry form &aux fspec wrappers wrapper-sxhashes) ;;  9/16/85 DNG - Modified to use new function OPTIMIZE-METHOD-BODY-AND-ARGS.  (setq form `(compile-time-remember-mapping-table ,(flavor-name fl) ,form))  ;; Get the function spec which will name the combined-method  (setq fspec `(:method ,(flavor-name fl) :combined ,(car magic-list-entry)))  ;; Put the wrappers and :AROUND methods around the form.  ;; The base-flavor wrapper goes on the inside.  (setq wrappers(append (get-specially-combined-methods magic-list-entry fl)(get-inverse-specially-combined-methods magic-list-entry fl)))  (do ((wr wrappers (cdr wr))       (last-method-type nil))      ((null wr))    (let ((method (car wr)))  ;; Record sxhash of each wrapper that goes in.  ;; This way we can tell if the combined method is obsolete when fasloaded.      (when (and (member (caddr method) '(:wrapper :inverse-wrapper) :test #'eq)  (fboundp 'compiler:expr-sxhash))(push (list method (compiler:expr-sxhash method)) wrapper-sxhashes))      (setq form    (funcall     (cadr      (or (assoc (caddr method) *specially-combined-method-types* :test #'eq) (assoc (caddr method) *inverse-specially-combined-method-types* :test #'eq)))     fl last-method-type method form))      (setq last-method-type (caddr method))))  ;; Remember that it's going to be there, for HAVE-COMBINED-METHOD  (flavor-notice-method fspec)  (when *just-compiling*    (function-spec-putprop fspec magic-list-entry 'combined-method-derivation))  ;; Compile the function.  It will be inserted into the flavor's tables either  ;; now or when the QFASL file is loaded.  (multiple-value-bind (body ll)    (optimize-method-body-and-args form)    #-elroy    (compile-at-appropriate-time fl fspec `(named-lambda (,fspec ,@(if wrapper-sxhashes     `((wrapper-sxhashes . ,wrapper-sxhashes))) (combined-method-derivation ,magic-list-entry)) ,ll    (let ((.daemon-mapping-table. self-mapping-table))      ,body)) () )    #+elroy    (compile-at-appropriate-time fl fspec `(named-lambda (,fspec) ,ll,@(if wrapper-sxhashes      `((declare (wrapper-sxhashes  ,@wrapper-sxhashes))))(declare (combined-method-derivation ,@magic-list-entry))    (let ((.daemon-mapping-table. self-mapping-table))      ,body)) () ))  fspec)  (defun substitute-funcall-in-expression (form)  ;; In order to prepare a combined method function body for the  ;; compiler to do inline expansion of method calls, try to replace  ;; all LEXPR-FUNCALL-WITH-MAPPING-TABLE-INTERNAL forms which were  ;; created by METHOD-CALL with equivalent FUNCALL-WITH-MAPPING-TABLE  ;; forms.  This requires making sure that all of the calls will  ;; use the same number of arguments.  ;; A THROW is done to OUT if a consistent transformation is not  ;; possible.  ;;  8/03/85 DNG - Fixed to handle &REST args correctly.  [SPR 249]  ;;  9/16/85 DNG - Save time by not looking at argument of METHOD-MAPPING-TABLE.  ;;  4/07/86 DNG - Modified for VM2 to use ARGS-DESC instead of ARGS-INFO.  (declare (special number-of-method-args minimum-number-of-method-args method-arg-list))  (if (atom form)      (if (eq form '.daemon-caller-args.)  ;; A reference to the combined method's &REST argument  ;;  which was not removed by one of the special cases  ;;  below.  Give up on optimization.  (throw 'out nil)form)    (let ((f (first form)))      (cond((null (REST form)) (if (atom f)     form   (cons (substitute-funcall-in-expression f) nil)))((member f '(quote function method-mapping-table) :test #'eq) form)((and (eq (second form) '.daemon-caller-args.)      (member f '(car cadr caddr first second third) :test #'eq)) (let ((new (funcall f method-arg-list))       (min (funcall f '(1 2 3))))   (when (null new)     (throw 'out nil))   (when (> min minimum-number-of-method-args)     (setq minimum-number-of-method-args min))   new))((and (member f '(lexpr-funcall-with-mapping-table  lexpr-funcall-with-mapping-table-internal)      :test #'eq)      (eq (fourth form) '.daemon-caller-args.)      (null (NTHCDR 4 form))      (consp (second form))      (eq (first (second form)) 'function)) #-Elroy (let* ((args-info  (args-info (or (declared-definition (second (second form))) (throw 'out nil))))(min (ldb %%arg-desc-min-args args-info))(max (ldb %%arg-desc-max-args args-info)))   (cond     ((or (/= min max)  (> max 3)  (< min minimum-number-of-method-args)  (logtest    (logior %arg-desc-evaled-rest %arg-desc-quoted-rest    %arg-desc-fef-quote-hair %arg-desc-interpreted)    args-info))      (throw 'out nil))     ((null number-of-method-args)      (setq number-of-method-args min)      (setq method-arg-list (firstn min method-arg-list)))     ((/= min number-of-method-args) (throw 'out nil)))   (list* 'funcall-with-mapping-table (second form) (third form) method-arg-list)) #+Elroy (multiple-value-bind (min max rest)     (args-desc (or (declared-definition (second (second form)))    (throw 'out nil)))   (cond     ((or (/= min max)  (> max 3)  (< min minimum-number-of-method-args)  rest)      (throw 'out nil))     ((null number-of-method-args)      (setq number-of-method-args min)      (setq method-arg-list (firstn min method-arg-list)))     ((/= min number-of-method-args) (throw 'out nil)))   (list* 'funcall-with-mapping-table (second form) (third form) method-arg-list)))((and (atom f) (null (CDDR form))) (let ((new (substitute-funcall-in-expression (second form))))   (if (eq (second form) new)       form     (list f new))))(t (loop for x in form collecting (substitute-funcall-in-expression x)))))))    ;; These macros are used in combined methods to compile the appropriate code;; to set the self mapping table from time to time.;; COMPILE-TIME-REMEMBER-MAPPING-TABLE goes around the entire method combination;; and METHOD-MAPPING-TABLE goes at each place where a specific mapping table;; is wanted.  METHOD-MAPPING-TABLE takes a method function spec as quoted arg;; and turns into code to return the appropriate mapping table.(defvar compiler-flavor)  (defmacro compile-time-remember-mapping-table (flavor &body body)  `(compiler-let ((compiler-flavor ',flavor)) ,@body))  (defmacro method-mapping-table (method-function-spec)  (or (eq (car method-function-spec) :method) (ferror () "METHOD-FUNCTION-SPEC is not one"))  (let ((flavor (cadr method-function-spec)))    (if (eq flavor compiler-flavor)      '.daemon-mapping-table.      `(self-ref ,compiler-flavor t ,flavor))))  (defun get-specially-combined-methods (mle *fl*)  (declare (special *fl*))  ;; First get all :AROUNDs followed by all :WRAPPERs,  ;; then reorder by flavor but preserve the order of things for a given flavor.  (stable-sort   (mapcan    #'(lambda (method-type-cons)(copy-list (cdr (assoc (car method-type-cons) (cdddr mle) :test #'eq))))    *specially-combined-method-types*)   #'(lambda (fs1 fs2)      ;; Return T if FS1's flavor comes later      ;; in our list of dependents than FS2's flavor.       (member (cadr fs1) (cdr (member (cadr fs2) (flavor-depends-on-all *fl*) :test #'eq))       :test #'eq))))  (defun get-inverse-specially-combined-methods (mle *fl*)  (declare (special *fl*))  ;; First get all :INVERSE-AROUNDs followed by all :INVERSE-WRAPPERs,  ;; then reorder by flavor but preserve the order of things for a given flavor.  (stable-sort   (mapcan    #'(lambda (method-type-cons)(copy-list (cdr (assoc (car method-type-cons) (cdddr mle) :test #'eq))))    *inverse-specially-combined-method-types*)   #'(lambda (fs1 fs2)      ;; Return T if FS2's flavor comes later      ;; in our list of dependents than FS1's flavor.       (member (cadr fs2) (cdr (member (cadr fs1) (flavor-depends-on-all *fl*) :test #'eq))       :test #'eq))))  (defun put-wrapper-into-combined-method (flavor previous-method-type wrapper-name form)  flavor  ;; Before any sequence of wrappers, stick on a binding of SELF-MAPPING-TABLE  ;; because the body, a typical combined method, clobbers it,  ;; but the code expanded by the wrapper itself may assume it is preserved.  ;; If the last thing done was another wrapper, this is not necessary.  (and (not (member previous-method-type '(:wrapper :inverse-wrapper) :test #'eq))     (setq form `(let ((self-mapping-table self-mapping-table))   ,form)))  (let ((def (cond   ((declared-definition wrapper-name))   ((fdefinedp wrapper-name) (fdefinition wrapper-name))   (t (ferror () "~S supposed to be a wrapper macro, but missing!" wrapper-name)))))    (if (eq def 'aborted-definition)      form      (progn(cond  ((or (atom def) (neq (car def) 'macro))   (ferror () "~S, supposed to be a wrapper macro, is poorly formed. Definiton is ~s"   wrapper-name def)))`(macrocall ,wrapper-name .daemon-caller-args. ,form))      ;; Here we just put the wrapper in as a macro.  It will be expanded by the compiler.)))  ;Sort of a macro version of funcall, for wrappers(defmacro macrocall (&rest x)  (let ((macro (cond ((declared-definition (car x))) ((fdefinedp (car x)) (fdefinition (car x))) (t (ferror () "Unable to find definition of wrapper ~s at expand time" (car x))))))    (if (and (consp macro) (eq (car macro) 'macro))      (call (cdr macro) () x :optional *macroexpand-environment*)      ;;--- Temporary code so I can test things in the kludge environment      (if (and (symbolp macro) (consp (symbol-function macro))  (eq (car (symbol-function macro)) 'macro))(call (cdr (symbol-function macro)) () x :optional *macroexpand-environment*)(ferror () "~S evaluated to ~S, which is not a macro" (car x) macro)))))  (defun put-around-method-into-combined-method (flavor previous-method-type method-function-spec form) ;;  9/16/85 DNG - Use function OPTIMIZE-METHOD-BODY-AND-ARGS to enable ;;                inline expansion of method calls in the continuation function.  (declare (ignore previous-method-type))  (multiple-value-bind (body ll)    (optimize-method-body-and-args form)    `(compile-time-remember-mapping-table ,(flavor-name flavor)(lexpr-funcall-with-mapping-table-internal (function ,method-function-spec)   (method-mapping-table ,method-function-spec) (car .daemon-caller-args.)   #'(named-lambda continuation ,ll       (let ((.daemon-mapping-table. self-mapping-table)) ,body))   .daemon-mapping-table. .daemon-caller-args. (cdr .daemon-caller-args.)))))  ;Use this inside an :AROUND method, to call the continuation.;Pass the first three args that the :AROUND method received.(defsubst around-method-continue (continuation mapping-table args)  (lexpr-funcall-with-mapping-table continuation mapping-table args))  ;Return the FLAVOR declaration for use in methods, DECLARE-FLAVOR-INSTANCE-VARIABLES, etc.;Declares all the instance variables of the flavor, as well as the flavor name.;(EVAL-WHEN (COMPILE EVAL LOAD)(defun flavor-declaration (flavor-name &aux fl)  (let ((*just-compiling* (just-compiling)))   (labels ((internal-function (fl vl)       (dolist (x (flavor-local-instance-variables fl)) (or (atom x) (setq x (car x))) (or (member x vl :test #'eq) (push x vl)))       (append vl       (getf (flavor-plist fl)     :required-instance-variables)       (loop for flname in (getf (flavor-plist fl) :required-flavors)     nconc (get-instance-variables flname))))     (get-instance-variables (name)       (let ((fl (compilation-flavor name))) (and fl (map-over-component-flavors 0 () ()        #'internal-functionname ())))))    (when (setq fl (compilation-flavor flavor-name))      (cond((flavor-components-defined-p flavor-name) (unless (flavor-depends-on-all fl)   (let ((default-cons-area working-storage-area))     (compose-flavor-combination fl nil))) (let ((vars (flavor-all-instance-variables fl))       (more-vars (getf (flavor-plist fl) 'additional-instance-variables)))   `(:self-flavor ,flavor-name ,(flavor-get-all-special-instance-variables fl)  ,@more-vars ,@vars)))(t;Try to get as many variables as we can. `(:self-flavor ,flavor-name ,(flavor-special-instance-variables fl),@(get-instance-variables flavor-name))))))))(defun flavor-get-all-special-instance-variables (flavor)  "Return a list of all the special instance variables of FLAVOR (a flavor object or name).This function is for compatibility with flavors composed beforethe ALL-SPECIAL-INSTANCE-VARIABLES property started being used."  (if (symbolp flavor)    (setq flavor (compilation-flavor flavor)))  (or (flavor-all-special-instance-variables flavor)     (do ((ivars (flavor-all-instance-variables flavor) (cdr ivars))  (specials)  (normal-bindings-left (flavor-bindings flavor))  (next-normal-binding)) ((null ivars) specials)  ;; Figure out whether the next ivar is bound as special by message sending.       (or (and (numberp next-normal-binding) (plusp next-normal-binding))  (setq next-normal-binding (pop normal-bindings-left)))       (if (numberp next-normal-binding) (decf next-normal-binding))       ;; If it isn't, we must put it on our binding list to be bound now.       (if (locativep next-normal-binding) (push (car ivars) specials)))))  ;This is a flavor which is automatically made a component of nearly all;other flavors.  It provides some basic facilities such as PRINT;and DESCRIBE.#-elroy(eval-when (load eval);Allow this file to compile if it isn't loaded   (defflavor vanilla-flavor () () :no-vanilla-flavor;No instance variables, no other flavors      (:method-combination (:case :base-flavor-last :set))      (:documentation :mixin       "The default base flavor.This flavor provides the normal handlers for the :PRINT, :DESCRIBE, and :WHICH-OPERATIONSoperations.  Only esoteric hacks should give the :NO-VANILLA-FLAVOR option to DEFFLAVOR toprevent this inclusion.")))  #-elroy(defmethod (vanilla-flavor :default :init) (ignore)  ())  #-elroy(defmethod (vanilla-flavor :print-self) (stream &rest ignore)  (printing-random-object (self stream :typep)))  #-elroy(defmethod (vanilla-flavor :describe) ()  (format t "~&~S, an object of flavor ~S,~% has instance variable values:~%" self  (type-of self))  (do ((ivars (flavor-all-instance-variables (instance-flavor self)) (cdr ivars))       (i 1 (1+ i)))      ((null ivars))    (format t "~S:~27T " (car ivars))    (cond      ((= (%p-ldb-offset %%q-data-type self i) dtp-null) (format t "unbound~%"))      (t (format t "~S~%" (%instance-ref self i))))))  #-elroy(defmethod (vanilla-flavor :which-operations) ()  (flavor-which-operations (instance-flavor self)))  ;;;#+elroy;;;(defmethod (vanilla-flavor :operation-handled-p) (op);;;  (let ((fl (instance-flavor self)));;;    (if (arrayp (flavor-method-hash-table fl));;;      (multiple-value-bind (nil definedp);;;(without-interrupts;;; (gethash op (flavor-method-hash-table fl)));;;definedp);;;      (let ((wo (or (flavor-which-operations fl) (funcall self :which-operations))));;;(not (not (member op wo :test #'eq)))))))  ;;;#+elroy;;;(defmethod (vanilla-flavor :send-if-handles) (op &rest to-send);;;  (let ((fl (instance-flavor self)));;;    (if (arrayp (flavor-method-hash-table fl));;;      (multiple-value-bind (fn-location definedp);;;(without-interrupts;;; (gethash op (flavor-method-hash-table fl)));;;(if definedp;;;  (apply (car fn-location) op to-send)));;;      (let ((wo (or (flavor-which-operations fl) (funcall self :which-operations))));;;(and (member op wo :test #'eq) (apply self op to-send))))))  #-elroy(defmethod (vanilla-flavor :operation-handled-p) (op)  (let ((fl (instance-flavor self)))    (if (arrayp (flavor-method-hash-table fl))      (multiple-value-bind (nil definedp)(without-interrupts (gethash op (dont-optimize (hash-table-instance (flavor-method-hash-table fl)))))definedp)      (let ((wo (or (flavor-which-operations fl) (funcall self :which-operations))))(not (not (member op wo :test #'eq)))))))  #-elroy(defmethod (vanilla-flavor :send-if-handles) (op &rest to-send)  (let ((fl (instance-flavor self)))    (if (arrayp (flavor-method-hash-table fl))      (multiple-value-bind (fn-location definedp)(without-interrupts (gethash op (dont-optimize (hash-table-instance (flavor-method-hash-table fl)))))(if definedp  (apply (car fn-location) op to-send)))      (let ((wo (or (flavor-which-operations fl) (funcall self :which-operations))))(and (member op wo :test #'eq) (apply self op to-send))))))  #-elroy(defmethod (vanilla-flavor :get-handler-for) (op)  (get-handler-for self op))  ;Useful methods for debugging.;They all cause the instance variables of SELF to be bound as specials.#-elroy(defmethod (vanilla-flavor :eval-inside-yourself) (form)  (with-self-variables-bound (eval form))) #-elroy(defmethod (vanilla-flavor :funcall-inside-yourself) (function &rest args)  (with-self-variables-bound (apply function args)))  #-elroy(defmethod (vanilla-flavor :break) ()  (with-self-variables-bound (break "~S" self)))  ;;; This flavor is a useful mixin that provides messages for a property list protocol.#-elroy(defflavor property-list-mixin ((property-list nil)) () :settable-instance-variables   (:documentation :mixin "A mixin that provides property list messages."))  #-elroy(defmethod (property-list-mixin :get) (indicator &optional default)  (getf property-list indicator default))  #-elroy(defmethod (property-list-mixin :case :set :get) (indicator &rest property)  (declare (arglist indicator property))  ;; use car last is to ignore optional default eg from "(push zap (send foo :get bar))"  (setf (getf property-list indicator) (car (last property))))  #-elroy(defmethod (property-list-mixin :get-location-or-nil) (indicator)  (get-location-or-nil (locf property-list) indicator))  #-elroy(defmethod (property-list-mixin :get-location) (indicator)  (locf (get (locf property-list) indicator))) #-elroy(defmethod (property-list-mixin :getl) (indicator-list)  (getl (locf property-list) indicator-list))  #-elroy(defmethod (property-list-mixin :putprop) (property indicator)  (setf (getf property-list indicator) property))  #-elroy(defmethod (property-list-mixin :remprop) (indicator)  (remprop (locf property-list) indicator))  #-elroy(defmethod (property-list-mixin :push-property) (property indicator)  (push property (getf property-list indicator)))  #-elroy(defmethod (property-list-mixin :plist) ()  property-list)  #-elroy(defmethod (property-list-mixin :plist-location) ()  (locf property-list))  #-elroy(defmethod (property-list-mixin :property-list-location) ()  (locf property-list))  #-elroy(defmethod (property-list-mixin :setplist) (new-plist)  (setq property-list new-plist))  #-elroy(defparameter instance-invoke-vector-contents   '(:get :getl :get-location-or-nil :car :cdr :set-car :set-cdr)   "A list of elements to copy into the value of INSTANCE-INVOKE-VECTOR.")  #-elroy(defvar instance-invoke-vector :unbound   "A vector of operations that the microcode wants to perform on instances.Indices in this vector are defined in SYS:UCODE;UC-PARAMETERS LISP.The vector may not be forwarded.")  #-elroy(defun init-instance-invoke-vector ()  (let ((vector (make-array (length instance-invoke-vector-contents))))    (fillarray vector instance-invoke-vector-contents)    (setq instance-invoke-vector vector)))  #-elroy(add-initialization 'init-instance-invoke-vector '(init-instance-invoke-vector) '(once))  ;; This flavor makes your instance print out using horseshoes, and read back in.#-elroy(defflavor print-readably-mixin () () (:required-methods :reconstruction-init-plist))  #-elroy(defmethod (print-readably-mixin :print-self) (stream &rest ignore)  (send stream :string-out "#")  (let ((*package* pkg-user-package))    (prin1 (type-of self) stream))  (send stream :tyo #\Space)  (do ((init-options (send self :reconstruction-init-plist) (cddr init-options)))      ((null init-options))    (prin1 (car init-options) stream)    (send stream :tyo #\Space)    (prin1 (cadr init-options) stream)    (if (cddr init-options)      (send stream :tyo #\Space)))  (send stream :tyo #\))  #-elroy(defmethod (print-readably-mixin :read-instance) (flavor stream)  (do (ch       init-options)      (nil)       ;; Skip past spaces.    (do ()((not (= (setq ch (send stream :tyi)) #\Space)) (send stream :untyi ch)))    (if (= ch #\)      (return (apply 'make-instance flavor init-options)))    (setq init-options (list* (read stream  t nil t) (read stream t nil t) init-options))))  #-elroy(defun get-handler-for (function operation &optional (superiors-p t) &aux tem)  "Given a functional object, return its subfunction to do the given operation or NIL.   Returns NIL if it does not reduce to a select-method or if it does not handle that."  (block get-handler-for    (do ()(nil)      (select (%data-type function) (dtp-array-pointer;Set function to NIL or Named-structure handler  (setq function (get (named-structure-p function) 'named-stru