;;; -*- Mode:Common-Lisp; Package:TICLOS; Base:10; Patch-file:T; Fonts:(CPTFONT CPTFONTB HL12BI HL12) -*-

;;; Reason: Fix to uncache inherited methods that may have been obsoleted by a class
;;; redefinition that changes the class precedence list.  [SPR 9798]


;;;                           RESTRICTED RIGHTS LEGEND
;;;
;;; Use, duplication, or disclosure by the Government is subject to
;;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;; Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;   TEXAS INSTRUMENTS INCORPORATED      
;;;   P.O. BOX 149149, M/S 2151             
;;;   AUSTIN, TEXAS 78714
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Patch file for TI-CLOS version 6.15
;;; Written 07/06/89 15:21:04 by GRAY,
;;; while running on Kelvin from band LOD2
;;; With SYSTEM 6.10, VIRTUAL-MEMORY 6.1, EH 6.3, MAKE-SYSTEM 6.0, MICRONET 6.0, LOCAL-FILE 6.0,
;;;  BASIC-PATHNAME 6.0, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.1, NETWORK-NAMESPACE 6.0,
;;;  DISK-IO 6.0, DISK-LABEL 6.0, BASIC-FILE 6.2, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0,
;;;  Inconsistent COMPILER 6.7, TV 6.12, DATALINK 6.0, CHAOSNET 6.0, GC 6.3, MEMORY-AUX 6.0,
;;;  NVRAM 6.1, SYSLOG 6.1, STREAMER-TAPE 6.3, UCL 6.0, INPUT-EDITOR 6.0, Inconsistent METER 6.1,
;;;  ZWEI 6.3, DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.1, DATALINK-DISPLAYS 6.0,
;;;  FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.2, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.0,
;;;  IMAGEN 6.0, SUGGESTIONS 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.0, TELNET 6.0, VT100 6.0,
;;;  NAMESPACE-EDITOR 6.0, PROFILE 6.1, VISIDOC 6.2, Inconsistent TI-CLOS 6.14, CLEH 6.4,
;;;  IP 3.47, Experimental BUG 11.10, Experimental CLX 6.2, CLUE 6.7, X11M 6.1, Experimental DOCUMENTER 619.0,
;;;  Experimental GRAPHICS-WINDOW 6.0, Inconsistent GED 6.2,  microcode 429, Band Name: 6.0 SLE 6/5 + u429 6/8

;;; BUG REPORT NUMBER:  9798
;;;
;;; PROBLEM: 	Redefining a flavor or class with a different set of 
;;;	superclasses does not update the method hash table of any CLOS generic 
;;;	functions that have methods specialized on superclasses that were added or 
;;;	removed.  For example:
;;;	      
;;;	  (defflavor fa () ())
;;;	  (defflavor fb () ())
;;;	  (defmethod goo ((x fa)) 'a)
;;;	  (defmethod goo ((x t)) 't)
;;;	  (goo (make-instance 'fb)) => t
;;;	      
;;;	all as expected.  But now redefine the flavor like this:
;;;	      
;;;	  (defflavor fb () (fa))
;;;	      
;;;	and we still get
;;;	      
;;;	  (goo (make-instance 'fb)) => t
;;;	      
;;;	but it should be returning A now.
;;;
;;; SOLUTION:
;;;	Updated functions TICLOS::RE-INIT-CLASS and SYS::DEFFLAVOR1 to
;;;	call the new function UNCACHE-INHERITED-METHODS to remove from the
;;;	method hash tables any entries which may have become obsolete as
;;;	the result of a change in the class precedence list.
;;;
;;;	For flavors, it was also necessary to add recording of direct
;;;	generic functions in the flavor structure.  This required
;;;	replacing the dummy methods for :ADD-METHOD-ON-SPECIALIZER and
;;;	:REMOVE-METHOD-ON-SPECIALIZER with the same code that was used for 
;;;	STANDARD-CLASS.

#!C
; From file CLASS.LISP#> CLOS; MR-X:
#10R TICLOS#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "TICLOS"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* SYS:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: CLOS; CLASS.#"


1;;  7/06/89 DNG - Add uncaching of methods inherited from classes whose 
;;*		1position in the class precedence list has changed.  [SPR 9798]
;;*		1Also use MAP-SPECIALIZER-DIRECT-GENERIC-FUNCTIONS instead of 
;;*		1SPECIALIZER-DIRECT-GENERIC-FUNCTIONS to avoid consing.*
(defun re-init-class (class temp-class-description )
  (declare (special temp-class-description))
  (let* ((temp-class (sys:make-flavor-instance (class-name (class-of class))
					       :class-description temp-class-description))
	 (old-cpl (internal-class-precedence-list class))
	 (old-class-description (class-description class))
	 (environment (class-description-environment old-class-description))
	 (new-cpl (loop for super in (compute-class-precedence-list temp-class environment)
			collect (class-named super nil environment))))
    ;;check if the class need to be made obsolete
    (setf (class-description-class-precedence-list temp-class-description) new-cpl)
    (let ((new-slots (collect-slot-descriptions temp-class)))
      (flet ((instance-slot-names (slots)
		(collect-body (dolist (s slots)
				(when (eq :instance (slot-allocation s))
				  (collect (slot-name s)))))))
	(if (set-exclusive-or (instance-slot-names (class-all-slots class))
			      (instance-slot-names  new-slots))
	    
	    (progn
	      ;;the class needs to be made obsolete
	      (make-instances-obsolete class)
	      (setf (class-all-slots class) nil))
	    (progn
	      (setf (class-all-slots class)
		    (reinit-effective-slots class new-slots temp-class))))
	(setf (class-description-class-precedence-list (class-description class))
	      (cons class (cdr new-cpl)))
	(unless (equal (cdr old-cpl) (cdr new-cpl))
	  ;;All the combined method are to be recomputed
	  ;;However, how can we make sure it is not done more than it needs to be?
	  (1map-specializer-direct-generic-functions*
	1     #'(lambda (gf)*
		1  (declare (si:downward-function))*
		  (uncache-effective-methods gf class))
	     class)
	  1;; Need to also uncache any methods that were or will be inherited from *
	1  ;; classes that are either added to or removed from the class precedence *
	1  ;; list, or are even just in a different order.  [SPR 9798]*
	1  (uncache-inherited-methods class old-cpl new-cpl)*
	  )
	class))))

1;;  7/06/89 DNG - Original.
(defun uncache-inherited-methods (class old-cpl new-cpl)
  ;; First find any superclasss that are not in the same relative position in 
  ;; both the old and new class precedence lists.
  (let ((diff '())*				1; the list of changed supers.*
	1(common nil))
    (do ((tail (cdr new-cpl) (cdr tail)))*
	1((null tail))
      (let ((old-tail (member (car tail) (cdr old-cpl) :test #'eq)))*
	1(when (equal tail old-tail)*
	1  (setq common old-tail)*
	1  (return)))
      (pushnew (car tail) diff :test #'eq))
    (do ((tail (cdr old-cpl) (cdr tail)))*
	1((eq tail common))
      (pushnew (car tail) diff :test #'eq))
    (unless (null diff)
      ;; Now, for each generic function that is specialized on one of those 
      ;; classes, uncache any method for instance class CLASS in order to force 
      ;; recomputing which method should be inherited.
      (let ((key (class-hash-key class)))*
	1(flet ((uncache (gfun)*
			1(let ((ht (generic-function-method-hash-table gfun)))*
			1  (unless (null ht)*
			1    ;;(format *debug-io* "~&[Removing ~S from ~S.]" key gfun)*
			1    (remhash key ht)))))*
	1  (dolist (super diff)*
	1    (block map*
	1      (when (symbolp super)*		1; when called from DEFFLAVOR1*
		1(unless (setq super (class-named super t (class-environment class)))*
		1  (return-from map)))*
	1      (map-specializer-direct-generic-functions #'uncache super)))))))
  (values))*
))

#!C
; From file GENERIC.LISP#> CLOS; MR-X:
#10R TICLOS#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "TICLOS"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* SYS:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: CLOS; GENERIC.#"

1;; 7/6/89 DNG - Changed from STANDARD-CLASS to CLASS as part of fix for SPR 9798.*
(defmethod (class :add-method-on-specializer) (method)
  (let* ((gfunc (*method-generic-function method))
	 (df (getf (class-description-plist (class-description self)) 'direct-generic-functions))
	 (acons (assoc gfunc
		      df)))
    (if  acons
	 (incf (cdr acons))
	 (setf (getf (class-description-plist (class-description self)) 'direct-generic-functions)
	       (cons (cons gfunc 1) df)))))
))

#!C
; From file GENERIC.LISP#> CLOS; MR-X:
#10R TICLOS#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "TICLOS"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* SYS:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: CLOS; GENERIC.#"

1;; 7/6/89 DNG - Changed from STANDARD-CLASS to CLASS as part of fix for SPR 9798.*
(defmethod (class :remove-method-on-specializer) (method)
  (let* ((gfunc (*method-generic-function method))
	 (df (getf (class-description-plist (class-description self)) 'direct-generic-functions))
	 (acons (assoc gfunc
		      df)))
    (when  acons
      (if (> (cdr acons) 1)
	  (decf (cdr acons))
	  (setf (getf (class-description-plist (class-description self)) 'direct-generic-functions)
		(delete acons df :count 1 :test #'eq))))))
))

1;; Remove the old dummy methods for FLAVOR-CLASS so that the new method on 
;; CLASS will be inherited.
(when (fdefinedp '(:method flavor-class :add-method-on-specializer))
  (undefmethod (flavor-class :add-method-on-specializer)))
(when (fdefinedp '(:method flavor-class :remove-method-on-specializer))
  (undefmethod (flavor-class :remove-method-on-specializer)))*

#!C
; From file FLAVOR.LISP#> KERNEL; MR-X:
#8R SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; FLAVOR.#"


1;;  7/06/89 DNG - Add use of TICLOS:UNCACHE-INHERITED-METHODS to fix SPR 9798.*
(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*)))
  (unless (or *just-compiling* (record-source-file-name flavor-name 'defflavor))
    (return-from defflavor1 nil))
  (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))))
1    (when (and (eq fl already-exists)*
	1       (not identical-components)*
	1       (flavor-depends-on-all fl)*
	1       (flavor-method-hash-table fl)*
	1       (fboundp 'ticlos:uncache-inherited-methods))
      ;; This is not completely correct [won't catch all cases where uncaching 
      ;; is needed], but we don't have access to both the old and new class 
      ;; precedence lists at the same time.
      (ticlos:uncache-inherited-methods (flavor-class-object fl)*
					1(cons flavor-name (append (flavor-includes already-exists)*
								1  (flavor-depends-on fl)))*
					1(cons flavor-name (append includes component-flavors))))*
    (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)))
    (setf (flavor-definition-package fl) *package*)
    
    (let* ((env (and *just-compiling* compiler:*compile-file-environment*))
	   (old (ticlos:class-named flavor-name t env)))
      (unless (or (and old (eq fl (ticlos:class-description old)))
		  (not (get-flavor 'ticlos:flavor-class)))   ;; clm 03/31/89 make sure it's defined
	(if (and old (typep-structure-or-flavor old 'ticlos:hybrid-class))
	    ;; These classes have separate class-description and flavor description objects.
	    (setf (flavor-class-object fl) old)
	  (progn
	     (unless (or (null old) (typep-structure-or-flavor old 'ticlos:flavor-class))
	        (cerror "Discard the old class ~S and proceed with installation of the flavor."
			 "Class ~S was defined as a ~S, but is being redefined as a flavor."
			 flavor-name (type-of old)))
	     (set-class-named flavor-name env
			      (setf (flavor-class-object fl)
				    (sys:make-flavor-instance 'ticlos:flavor-class :class-description fl)))
	     ))
	(unless (null env)
	  (setf (ticlos:class-description-environment fl) env))
	) )

    (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))
))