;;; -*- Mode:Common-Lisp; Package:TICLOS; Base:10; Patch-file:T -*-

;;; Reason: Fix more problems with method hash tables, including SPR 10315, 10446, 
;;; 10571, 10572, and 10573.


;;;                           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.24
;;; Written 09/26/89 17:35:07 by GRAY,
;;; while running on Kelvin from band LOD2
;;; With SYSTEM 6.15, VIRTUAL-MEMORY 6.1, EH 6.4, MAKE-SYSTEM 6.0, MICRONET 6.0, LOCAL-FILE 6.0,
;;;  BASIC-PATHNAME 6.1, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.2, NETWORK-NAMESPACE 6.0,
;;;  DISK-IO 6.1, DISK-LABEL 6.0, BASIC-FILE 6.2, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0,
;;;  Inconsistent COMPILER 6.11, TV 6.15, DATALINK 6.0, CHAOSNET 6.0, GC 6.3, MEMORY-AUX 6.0,
;;;  NVRAM 6.1, SYSLOG 6.1, STREAMER-TAPE 6.4, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1,
;;;  ZWEI 6.5, 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.3, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.1,
;;;  IMAGEN 6.0, SUGGESTIONS 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.2, TELNET 6.0, VT100 6.0,
;;;  NAMESPACE-EDITOR 6.0, PROFILE 6.1, VISIDOC 6.4, Inconsistent TI-CLOS 6.23, CLEH 6.5,
;;;  IP 3.48, Experimental CLX 6.2, CLUE 6.10, X11M 6.13, Experimental BUG 11.15,
;;;  Experimental DOCUMENTER 701.0,  microcode 429, Band Name: 6.0+Scribe,&c,u430 9/6


;;; BUG REPORT NUMBER:  10315, 10446, 10571, 10572, 10573
;;;	plus several additional problems that are demonstrated in file
;;;	"TEST:CLOS;METHOD-TESTS" but haven't been entered as SPRs.
;;;
;;; PROBLEM:  Many problems with constructing and updating the method hash 
;;;	tables used by generic function dispatch.
;;;
;;; SOLUTION:  The major change here is that functions COMBINE-METHODS and 
;;;	RECOMBINE-METHODS have been completely re-designed so that 
;;;	PUT-METHOD-IN-HASH-TABLE will be called for all of the right combinations 
;;;	of arguments.  This relieves PUT-METHOD-IN-HASH-TABLE of the difficult and 
;;;	error-prone job of trying to update other paths that need to inherit the 
;;;	method.
;;;
;;;	Several other smaller fixes related to method hash tables are also included.
;;;
;;; DEPENDENCIES: 
;;;
;;; CODEREAD:


#!C
; From file METHOD-COMBINATION.LISP#> SYS6.CLOS; Kelvin:
#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; METHOD-COMBINATION.#"


;;  9/05/89 DNG - For use by COMBINE-METHODS, return second value of T when a new combined method has been made.
(defun combine-method  (gen-function arg-types &optional dont-reuse-old-combined-methods-p)
  ;;Arg-types is supposed to be ordered as arguments-precedence-order
  (let ((default-cons-area sys:background-cons-area))
    (multiple-value-bind (handler code derivation methods)
	(find-handler gen-function  arg-types #'get-sorted-alists dont-reuse-old-combined-methods-p)
      (when (and handler (generic-function-method-hash-table gen-function))
	(put-method-in-hash-table  gen-function  handler arg-types))
      (or handler
	  (if methods
	      (values (make-combined-method gen-function
					    (order-parameter-specializers gen-function arg-types)
					    code derivation methods)
		      t)
	    ;; Else there aren't any applicable methods, so remove any existing combined method.
	    (let ((m (*find-method gen-function '(:combined) (REORDER-PARAMETER-SPECIALIZERS gen-function arg-types) nil)))
	      (when m (remove-method gen-function m))
	      (when (generic-function-method-hash-table gen-function)
		(remove-method-in-hash-table gen-function arg-types))
	      nil))))))


;;  8/12/88 DNG - Use CATCH-ERROR-RESTART instead of IGNORE-ERRORS.
;;  9/20/88 DNG - Use IGNORE-METHOD-COMBINATION-ERROR instead of CATCH-ERROR-RESTART.
;;  9/05/89 DNG - Completely re-written [old version was missing some 
;;		combinations and was too slow].  Add use of INSERT-IN-METHOD-LIST.  
;;  9/06/89 DNG - Merged function RECOMBINE-METHODS with this one to avoid duplication of code.
;;  9/13/89 DNG - For RECOMBINE-METHODS, make sure that 
;;		(first arg-specializers) is included in augmented-method-list.
;;  9/15/89 DNG - Add code to find classes which don't have a method defined 
;;		for them directly, but inherit methods from more than one path.
;;  9/18/89 DNG - Added check of COMBINED-EFFECTIVE-METHOD-P before calling INSERT-IN-METHOD-LIST.
;;  9/19/89 DNG - Fix merger of multiple paths on class T.
(defun combine-methods (generic-function &optional arg-specializers arg-values dont-reuse-old-combined-methods-p)
  ;; Invoke COMBINE-METHOD for each set of argument specializers for which a 
  ;; combined method or handler will be needed.  For example, given
  ;;	(defmethod ex ((x (eql 'a)) (y t)) 1)
  ;;	(defmethod ex ((x t) (y t)) 2)
  ;;	(defmethod ex ((x integer) (y character)) 3)
  ;;	(defmethod ex ((x fixnum) (y symbol)) 4)
  ;; then COMBINE-METHOD will be called for:
  ;;  * Each set of specializers with a defined method, namely (EQL A),T ; 
  ;;	T,T; INTEGER,CHARACTER; and FIXNUM,SYMBOL.
  ;;  * The default entry for an EQL hash table:  SYMBOL,T.
  ;;  * Paths consisting of a defined specializer for one argument followed by 
  ;;	the specializers for the remaining arguments of methods defined on 
  ;;	superclasses of the first specializer.  In this example:  FIXNUM,CHARACTER; 
  ;;	FIXNUM,T; and INTEGER,T.  There may not actually be distinct combined 
  ;;	methods generated for these, depending on whether the most applicable 
  ;;	method is qualified or uses CALL-NEXT-METHOD.
  ;;  * Any classes which inherit independently from more than one of the 
  ;;    classes for which methods are defined.  There aren't any in the 
  ;;	example above, but if there were methods defined on ARRAY and SEQUENCE, 
  ;;	then a combined method would be needed for VECTOR because it is a 
  ;;	subclass of both.  STRING would inherit the handler for VECTOR.
  ;; Optional argument ARG-SPECIALIZERS is supplied when this is invoked when 
  ;;  adding or removing a method, in which case we only generate those 
  ;;  combined methods that could depend on the method indicated by the specializers.
  ;; Optional argument ARG-VALUES is supplied when invoked from a hash failure 
  ;;  in generic function dispatch, in which case we only process the methods 
  ;;  that could be applicable to those arguments.
  ;; Note that METHOD-LIST, ARG-SPECIALIZERS, and ARG-VALUES are all given in 
  ;;  argument precedence order.
  (let ((combination-specs '()))		; list of reversed specializer lists.
    (labels ((combine-tree (previous-specializers method-list n-args-remaining arg-specializers arg-values)
	       (declare (list previous-specializers method-list))
	       (if (zerop n-args-remaining)
		   ;; Then METHOD-LIST is a list of method specs.
		   ;; If there is any method defined here, then make the associated combined method.
		   (when (some #'method-spec-object-method method-list)
		     (pushnew previous-specializers combination-specs :test #'equal))
		 ;; Else METHOD-LIST is an a-list with specializers as the keys [with possible duplicates].
		 (let ((nn (- n-args-remaining 1))
		       (augmented-method-list method-list)
		       (method-classes '()))
		   (declare (list augmented-method-list method-classes))
		   (let ((end '()))
		      (dolist (elt method-list)
			(let ((specializer (car elt)))
			  (if (individual-typep specializer)
			       ;; Make sure that we have a handler for the default value of an individual hash table.
			       (let ((class (class-of (individual-type specializer))))
				 (unless (assoc class augmented-method-list :test #'eq)
				   (push (cons class nil) augmented-method-list)))
			    (unless (eq specializer *t-class*)
			       (if (not (send specializer :has-slots-p))
				    ;; Put classes such as STANDARD-OBJECT and SI:VANILLA-FLAVOR at the 
				    ;; end of the list to try to avoid having to descend their subclass trees.
				    (push specializer end)
				  (push specializer method-classes))) )))
		      (setq method-classes (nconc method-classes end)))
		   ;; Search for classes which inherit from more than one of the method 
		   ;; classes and add them to the classes for which method combination is needed.
		   (do ((tail method-classes (rest tail)))
		        ((atom tail))
		      (let ((specializer (first tail)))
			 (when (dolist (other (rest tail) nil)
				  (when (possible-common-subclass other specializer)
				     ;; There may be some class that inherits from both of these classes.
				     (return t)))
			    (let ((subclasses (class-direct-subclasses specializer)))
			       (unless (null subclasses)
				  (let ((spec-cpl (class-precedence-list specializer))
					 (checked '()))
				     (labels ((check-subs (subclasses) ; breadth-first tree search
					(dolist (subc subclasses)
					   (unless (or (assoc subc augmented-method-list :test #'eq)
							 (member subc checked :test #'eq))
					      (block process-subc
						 (unless (null (rest (class-direct-superclasses subc)))
						    (unless (class-composed-p subc)
						       (compose-class subc))
						    (do ((cpl (rest (class-precedence-list subc)) (rest cpl)))
							 ((atom cpl))
						       (cond ((eq (first cpl) specializer)
							       (when (equal cpl spec-cpl)
								  (return)))
							      ((and (member (first cpl) method-classes
									      :test #'eq)
								     (not (member (first cpl)
										    spec-cpl :test #'eq)))
							        ;; Found a class, SUBC, which inherits from both
							        ;; SPECIALIZER and (FIRST CPL).  Make this a 
							        ;; combination point.
							        (push (cons subc nil) augmented-method-list)
								(return-from process-subc))
							      ))
						    (push subc checked) )
						 (let ((next-subs (class-direct-subclasses subc)))
						    (unless (null next-subs)
						       (check-subs next-subs)))
						 )))))
				        (check-subs subclasses)
					)))))))
		   ;; Make sure we handle the given specializer.
		   (unless (or (null arg-specializers)
			        (assoc (first arg-specializers) augmented-method-list :test #'equal))
		     (push (cons (first arg-specializers) nil) augmented-method-list))
		   (do ((tail augmented-method-list (rest tail))) ; for each specializer on the current argument
		       ((atom tail))
		     (let* ((elt (first tail))
			    (specializer (car elt)))
		       (unless (or (and (not (zerop nn))
					(assoc specializer (rest tail) :test #'equal))	; avoid duplication
				   (and arg-specializers
					(not (subclassp specializer (first arg-specializers))))
				   (and arg-values
					(not (typep (first arg-values) specializer))) )
			 (let ((new-previous-specializers (cons specializer previous-specializers))
			       (new-method-list (cdr elt)))
			   (unless (or (and (eq specializer *t-class*) ; T is not a subclass of anything else.
					    (null previous-specializers)) ; else could have more than one T.
				       (and (zerop nn)	; no more arguments
					    (or (not (null (cdr elt)))	; not an EQL base class
						(member elt method-list :test #'eq))))
			     ;; Need to also follow path of remaining arguments for any specializers 
			     ;; on this argument that are superclasses of the current specializer.
			     (dolist (other method-list)
			       (when (and (not (eq other elt))
					  (subclassp specializer (car other)))
				 (setq new-method-list (append (cdr other) new-method-list))
				 )))
			   (combine-tree new-previous-specializers new-method-list nn
					 (rest arg-specializers) (rest arg-values)))))))
		 ) ; end if
	       (values)))
      (combine-tree '() (generic-function-method-list generic-function)
		    (length (generic-function-argument-precedence-order generic-function))
		    arg-specializers arg-values)
      ) ; end labels
    (dolist (specs combination-specs)
      (declare (list specs))
      (let ((specializers (reverse specs)))
	(ignore-method-combination-error
	  (multiple-value-bind (handler new)
	      ;; Find or create the combined method.
	      (combine-method generic-function specializers dont-reuse-old-combined-methods-p)
	    (unless (or (null handler) new arg-specializers arg-values
			(not (combined-effective-method-p handler)))
	      ;; When using an inherited combined method, make an entry for it in the 
	      ;; method list so that BUILD-METHOD-HASH-TABLE will know about it.
	      (let ((location (method-function-location handler)))
		(setf (generic-function-method-list generic-function)
		      (insert-in-method-list specializers (generic-function-method-list generic-function)
					     handler (method-qualifiers handler) nil))
		;; Restore original value before INSERT-IN-METHOD-LIST changed it.
		(setf (method-function-location handler) location)
	      ))))))
    )
  (values))

;;  9/15/89 Original.
;;  9/27/89 Use :HAS-SUBCLASSES-P instead of CLASS-DIRECT-SUBCLASSES so that 
;;	    we don't have to actually cons up the list for flavor classes.
(defun possible-common-subclass (class1 class2)
  ;; Return true if neither class is a subclass of the other but they might 
  ;; possibly have a common subclass.
  (and (or (eq (sys:%class-description class1) (sys:%class-description class2))
	   (typecase class1
	     (built-in-class (typep class2 'built-in-class))
	     (structure-class (typep class2 'structure-class))
	     (t (not (typep class2 '(or built-in-class structure-class))))))
       (or (send class1 :has-subclasses-p)
	   (send class2 :has-subclasses-p))
       (not (send class1 :subclassp class2))
       (not (send class2 :subclassp class1))))

(defmethod (class :has-slots-p) ()
  (or (class-description-all-slots class-description)
      (class-description-direct-slots class-description)))
(defmethod (built-in-class :has-slots-p) ignore)

(defmethod (class :has-subclasses-p) ()
  (not (null (class-description-direct-subclasses class-description))))


;;  9/20/88 DNG - Add use of IGNORE-METHOD-COMBINATION-ERROR .
;;  6/23/89 DNG - Add dont-reuse-old-combined-methods-p argument as part of fix for SPR 9630.
;;  9/05/89 DNG - Simplified to share code with the new COMBINE-METHODS.
(defun recombine-methods (generic-function arg-classes &optional arg-values
			  dont-reuse-old-combined-methods-p)
  ;;Starting at arg-classes, refigures out the handler for subclasses
  ;;Combine-method is the expensive call.  However, combining method for
  ;;only cached classes will tend to make combined methods too specific.
  ;;Arg-classes is supposed to be ordered by argument-precedence-order.
  ;;Take the method-alist, 
  ;;then combine each node of the tree.
  
  ;;First combine the method for arg-classes, recombine-method is called
  ;;when a new method is added.
  ;;This will prevent a more specific set of arguments that would inherit this
  ;;combined method to make a combined method of their own, just because they were
  ;;in the hashtable
  (unless arg-values
    (ignore-method-combination-error (combine-method generic-function arg-classes)))
  (combine-methods generic-function arg-classes arg-values dont-reuse-old-combined-methods-p)
  (when (and (null arg-values) (generic-function-method-hash-table generic-function))
    (fix-cached-methods generic-function arg-classes))
  (values))
))

#!C
; From file FLAVOR-METACLASS.LISP#> SYS6.CLOS; Kelvin:
#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; FLAVOR-METACLASS.#"


;; 9/26/89 DNG - Added for use by new version of COMBINE-METHODS .
(defmethod (flavor-class :has-slots-p) ()
   (or (sys:flavor-all-instance-variables class-description)
        (sys:flavor-local-instance-variables class-description)))
))

#!C
; From file STRUCTURE-METACLASS.LISP#> SYS6.CLOS; Kelvin:
#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; STRUCTURE-METACLASS.#"


;; 9/26/89 DNG - Added for use by new version of COMBINE-METHODS .
(defmethod (structure-class :has-slots-p) () t)
))

#!C
; From file METHOD-COMBINATION.LISP#> SYS6.CLOS; Kelvin:
#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; METHOD-COMBINATION.#"


;;  9/12/89 DNG - Fix to not call COMBINE-METHOD on the identical classes 
;;		given, since that has already been done by RECOMBINE-METHODS.
(defun fix-cached-methods (gfunc arg-classes)
  (map-all-hash-entries
    gfunc
    #'(lambda (key mloc mtl ht rargs)
	(declare (ignore mtl ))
	;;remove obsolete class-descriptions
	(if (and (arrayp key) (obsolete-class-description-p key))
	    (remhash key ht)
	    (when (locativep mloc)
	      (let* ((classes (let ((l nil))
				(dolist (x (if key (cons key rargs) rargs) l)
				  (push (if (consp x) x
					    (class-description-class-object x))
					l)))))
		(when				;(every #'subclassp classes arg-classes)
		  (do ((cl classes (cdr cl))
		       (argc arg-classes (cdr argc))
		       (different nil))
		      ((null cl) different)
		    (unless (subclassp (car cl) (car argc))
		      (return nil))
		    (unless (eq (car cl) (car argc))
		       (setq different t)) )
		  (combine-method gfunc (nconc classes
					       (nthcdr (length classes) arg-classes))))))))))
))

#!C
; From file METHOD-HASH-TABLE.LISP#> SYS6.CLOS; Kelvin:
#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; METHOD-HASH-TABLE.#"


(defun only-t-p (method-list nargs &optional arg-specs)
  ;; For all methods applicable to ARGS-SPECS for the highest precedence 
  ;; arguments, are all of the remaining arguments specialized on class T?
  ;; In other words, is there no way that the remaining arguments can 
  ;; affect which method is to be used?
  (if (= nargs 0 ) t
    (dolist (elt method-list t)
      (let ((specializer (car elt)))
	(if (or (eq specializer *t-class*)
		(and arg-specs (subclassp (first arg-specs) specializer)))
	    (unless (only-t-p (cdr elt) (- nargs 1) (rest arg-specs))
	      (return nil))
	  (when (null arg-specs)
	    (return nil)))))))


;;This function is called at compile time and at run time to add methods into the
;;generic function's method hash table hierarchy.
(defun put-method-in-hash-table (gfunc method &optional
				 (arg-specializers  nil))
  ;;arg-specializers are already ordered by arguments-precedence-order
  ;; 05/30/89 clm - made two fixes so that methods will be put into the
  ;;                correct hash tables.
  ;; 05/31/89 clm - fix for last fix; when updating the hash-table of a
  ;;                subclass, make sure we don't overwrite a more specific
  ;;                method for that class.
  ;; 06/01/89 clm - temporarily back out this fix until can get the bugs ironed out.
  ;; 06/07/89 clm - the previous fix was not responsible for other problems found
  ;;                running the test; the fix is left intact.
  ;; 06/26/89 clm - When adding a method, if an argument is specialized on a class, and
  ;;                a method has previously been defined that specializes on a superclass
  ;;                of that class, then the new method must have access to the other method's
  ;;                hash tables.  In determining which method to invoke, a method that has 
  ;;                been specialized on a super-class of an argument is also applicable
  ;;                to the subclass.
  ;; 07/06/89 DNG - Use function SPECIALIZER-CLASS instead of a duplicate LAMBDA.
  ;;		Broke out COPY-METHOD-HASH-TABLE as a separate function for readability.
  ;;		Changed (CLASS-HASH-KEY (CADR ARGS)) to 
  ;;		(CLASS-HASH-KEY (SPECIALIZER-CLASS (CADR ARGS))) to fix SPR 10105.
  ;; 07/14/89 clm - Fixes yet another problem occurring because the method hash tables
  ;;                for EQL specialized methods are not being set up correctly.
  ;;                This one occurred because default methods were not being placed in the
  ;;                in the proper hash tables.
  ;; 07/22/89 clm - Fixes latest CLIO:CONVERT problem.  First we make a parent's T (default)
  ;;                information accessible to it children.  Second, if we add a method specialized
  ;;                on a subclass of some superclass already in the hash table, that subclass entry
  ;;                should be able to access the default methods of the super.
  ;;  8/30/89 DNG - For simplicity, call PUT-DEFAULT-VALUE-IN-HASH-TABLE with 
  ;;		a 3rd argument instead of using a 3-element value list.
  ;;  8/31/89 DNG - Added some comments and made a few minor adjustments to 
  ;;		improve efficiency and readability of the code.
  ;;  9/06/89 DNG - Remove some code that has been obsoleted by fixes elsewhere.
  ;;  9/12/89 DNG - When calling MAKE-HASH-ARRAY, specify the size as 6 instead of defaulting to 64.
  ;;  9/13/89 DNG - Comment out more obsolete code.
  ;;  9/20/89 DNG - Fix the optimization for trailing Ts to check the method 
  ;;		list instead of the hash table.
  (let*((ht (generic-function-method-hash-table gfunc))
	(method-specs (method-parameter-specializers method))
	(specializers (reorder-parameter-specializers gfunc method-specs)))
    (multiple-value-bind (meth-loc mtl)
	(get-hash-entries-from-handler method method-specs
				       (if arg-specializers
					   (order-parameter-specializers gfunc arg-specializers)
					 method-specs))
      ;; There are no more references to METHOD or METHOD-SPECS below this point.
      (labels
	((put-arg-in-hash-table (args specs ht   &aux arg-key)
	   (declare (list args specs))
	   ;;
	   ;;		-------------------------------------
	   ;;		At end of chain, return method pointer
	   ;;		-------------------------------------
	   ;;
	   (when (null args)
	     (return-from put-arg-in-hash-table (values meth-loc mtl)))
	   (setq arg-key (class-hash-key (specializer-class (car args))))
	   (when (or (null ht) (not (hash-table-p ht)))
	     ;;there are no hash tables set up for this method - we must create
	     (when (and (every #'(lambda (c) (eq c *t-class*)) specs)
			(let* ((nargs (length specializers))
			       (nprevious (- nargs (length specs))))
			  (and (> nprevious 0)
			       (only-t-p (generic-function-method-list gfunc)
					 nargs
					 (firstn nprevious (or arg-specializers specializers))))))
	       ;; There is no need to dispatch on the remaining arguments.
	       (return-from put-arg-in-hash-table meth-loc mtl))
	     ;;
	     ;;		------------------------------
	     ;;		Create hash table when necessary
	     ;;		------------------------------
	     ;;
	     (setf ht (sys:make-hash-array :size 6 :number-of-values 2 :funcallable-p t :test #'eq))
	     )
	   ;;		---------------------------------
	   ;;		Make entry for an EQL specializer
	   ;;		---------------------------------
	   ;;
	   (if (individual-typep (car args))
	       ;;create a new iht for the arg if necessary
	       (let (dht)
		 ;;We either create a new iht to hold the info or we use an already existing one
		 ;;we then put that iht as the value of (car args) hash-table (ht) entry
		 (multiple-value-bind (ov ignore vals)
		     (gethash arg-key ht)
		   (if (individual-hash-table-p ov)
		       (setq dht ov)  ;;one already exists and we can plug into it
		     ;;or we have to make a new one
		     (progn (setq dht (make-individual-dispatch-hash-table 
					:default-value (or (copy-list (cdr vals))
							   (list nil nil))))
			    (puthash arg-key dht ht t))))
		 (multiple-value-bind (subh mtl)
		     (put-arg-in-hash-table (cdr args) (cdr specs)
					    (gethash (individual-type (car args))
						     ;; this is the same as dht
						     (individual-dispatch-hash-table-ht dht)) )
		   (puthash (individual-type (car args))
			    subh
			    (individual-dispatch-hash-table-ht dht)
			    mtl))
		 ht)
	     ;;		---------------------------------------------
	     ;;		Make entry for a specializer which is a class
	     ;;		---------------------------------------------
	     ;;
	     (let ((ov (gethash arg-key ht)))
	       (if (individual-hash-table-p ov)
		   (multiple-value-bind  (subh mtl)
		       (put-arg-in-hash-table (cdr args) (cdr specs)
					      (car (individual-dispatch-hash-table-default-value ov)))
		     (put-default-value-in-hash-table ov (list subh mtl)))
		 (multiple-value-bind (subh mtl)
		     (put-arg-in-hash-table (cdr args) (cdr specs)
					    (gethash arg-key ht))
		   (puthash arg-key subh ht mtl)
		   ))
	       ht)))) ; end of put-arg-in-hash-table
	(put-arg-in-hash-table (or arg-specializers specializers ) specializers  ht)
	)))
  (values))
))

#!C
; From file METHOD-COMBINATION.LISP#> SYS6.CLOS; Kelvin:
#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; METHOD-COMBINATION.#"


;;  8/31/89 DNG - Added call to ORDER-PARAMETER-SPECIALIZERS to fix SPR 10315.
;;		Modified to not recurse forever if RECOMBINE-METHODS doesn't help.
;;		Simplified by removing unnecessary test on
;;		(GENERIC-FUNCTION-METHOD-HASH-TABLE GEN-FUNCTION).
;;  9/05/89 DNG - Pass arg-values to RECOMBINE-METHODS instead of using COMPUTE-INITIAL-POINTS .
;;  9/14/89 DNG - Use COMBINE-METHODS instead of RECOMBINE-METHODS.
(defun prepare-effective-code (gen-function &rest arg-values)
  ;;arg-values are the actual argument values, reordered in precedence order.
  ;;At this point, it shouldn't have to make new combined methods.
  ;;Combined method are done when the methods are defined or the generic function called the
  ;;first time.
  (let ((second nil))
    (tagbody
     repeat
      (let ((mloc (apply #'find-right-method (generic-function-method-hash-table gen-function)
			 arg-values)))
	(when (null mloc)
	  (multiple-value-bind (handler code derivation methods)
	      (find-handler gen-function arg-values #'get-sorted-alists-by-value)
	    (declare (ignore derivation methods))
	    (if (null handler)
		(if (null code)
		    (let* ((arglist (compute-combined-lambda-list gen-function nil))
			   (fn (compile nil `(lambda ,arglist
					       ,@(make-unspecial arglist)
					       (apply #'no-applicable-method
						      (contents (COMPILER:%LOCAL-SLOT
								  SYS:LOCAL-FOR-FIRST-MAPPING-TABLE))
						      ,@(if (member '&rest arglist)
							    (remove '&rest arglist)
							  (append arglist '(nil)))))))
			   (handler (sys:make-flavor-instance
				      'no-applicable-method-handler :function fn
				      :generic-function gen-function
				      :parameter-specializers
				      (order-parameter-specializers
					gen-function
					(mapcar #'class-of arg-values)))))
		      (cache-handler-for-arguments  gen-function handler))
		  (if second
		      (error "Internal CLOS Error, can't find effective method.")
		    (PROGN 
		      (combine-methods gen-function nil arg-values)
		      (setq second t)
		      (go repeat))))
	      (cache-handler-for-arguments  gen-function handler arg-values)
	      ))))))
  (values))
))

#!C
; From file METHOD-COMBINATION.LISP#> SYS6.CLOS; Kelvin:
#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; METHOD-COMBINATION.#"


;;  9/05/89 DNG - Fix handling of DERIVATION for non-trivial combinations.
(defun find-handler (gen-function arg-types &optional (sort-function #'get-sorted-alists)
		     dont-reuse-old-combined-methods-p)
  ;;Arg-types is supposed to be ordered as arguments-precedence-order
  ;;Returns one to four values:
  ;;First value is the handler, if found;
  ;;Second value is the code of the combined method (if the handler is a combined method)
  ;;Third value is the combined method derivation.
  ;;Fourth value is the applicable methods, so make-combined-method can compute its arglist.
  (declare (values handler code derivation applicable-methods))
  (let* ((generic-function gen-function)
	 (ml (generic-function-method-list  generic-function))
	 (combination (generic-function-method-combination generic-function))
	 (derivation))
    (declare (special generic-function derivation))
    (multiple-value-bind (methods combined-methods)
	(compute-method-precedence-list ml arg-types sort-function)
      (if methods
	  (multiple-value-bind (ignore keylist)
	      (compute-combined-lambda-list gen-function methods)
	    (when (trivial-method-combination-p (car combination))
	      (setf derivation (list  combination
				      (mapcar #'(lambda (m) (function-name (*method-function m))) methods)
				      keylist))
	      (unless dont-reuse-old-combined-methods-p
		 (let* ((handler (have-combined-method combined-methods derivation)))
		   (when handler (return-from find-handler handler nil derivation)))))
	    (let ((code `(macrolet ((call-method (method next-method-list)
						 ,(call-next-method-code gen-function)))
			   ,(compute-effective-method gen-function combination methods))))
	      (if (trivial-method-combination-p (car combination))
		  (values nil code derivation methods)
		(progn (setq derivation (list combination (copy-tree code) keylist))
		       (values (and (not dont-reuse-old-combined-methods-p)
				    (have-combined-method combined-methods derivation))
			       code derivation methods)))))))))
))

#!C
; From file METHOD-HASH-TABLE.LISP#> SYS6.CLOS; Kelvin:
#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; METHOD-HASH-TABLE.#"


;;  8/31/89 DNG - Add call to REORDER-PARAMETER-SPECIALIZERS to fix SPR 10573.
;;  9/14/89 DNG - Major redesign to use COMBINE-METHODS when necessary to 
;;		ensure that individual hash tables are created when needed.
;;  9/18/89 DNG - Changed from a flavor method to a function.
(defun cache-handler-for-arguments (gfunc method &optional args)
  (let* ((method-specializers (reorder-parameter-specializers
				gfunc (method-parameter-specializers method)))
	 (arg-specializers (if (null args)
			       method-specializers
			     (mapcar #'(lambda (arg  specializer)
					 (if (individual-typep specializer)
					     specializer
					   (class-of arg)))
				     args method-specializers))))
    ;; If we need to create a new hash table to accommodate an inherited method, 
    ;; need to check the original dispatch path of the inherited method to see 
    ;; if if passes through any individual hash tables at or after the 
    ;; argument for which we make a new hash table.  If so, call 
    ;; COMBINE-METHODS to install all of the necessary individual entries in 
    ;; the new dispatch path.
    ;; Note: for release 7, it would be more efficient to have add-method 
    ;; maintain in the generic function object a list of specializer lists 
    ;; for which there are eql methods defined, so that we don't have to scan 
    ;; the method list every time here.
    (labels ((any-eql (mspecs aspecs mlist)
		(when (or (null mspecs) (null mlist))
		  (return-from any-eql nil))
		(dolist (x mlist)
		  (when (and (individual-typep (car x))
			     (not (equal (car x) (first aspecs)))
			     (eq (class-of (individual-type (car x))) (first aspecs)))
		    (return-from any-eql t) ))
		;; Follow down the most likely path first.
		(or (any-eql (rest mspecs) (rest aspecs)
			     (cdr (assoc (first mspecs) mlist :test #'equal)))
		    ;; Use SUBCLASSP as the last resort since it takes time.
		    (dolist (x mlist nil)
		      (when (and (not (individual-typep (car x)))
				 (not (eq (car x) (first mspecs))) ; already checked that path
				 (subclassp (first aspecs) (car x))
				 (any-eql (rest mspecs) (rest aspecs) (cdr x)))
			(return t))))
		))
      (if (any-eql method-specializers arg-specializers (generic-function-method-list gfunc))
	  ;; Update this path and all others that may be affected.
	  (combine-methods gfunc arg-specializers)
	;; Else no EQL specializers involved, just install this one path.
	(put-method-in-hash-table gfunc method arg-specializers)))
    (values)))
))

#!C
; From file GENERIC.LISP#> SYS6.CLOS; Kelvin:
#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.#"


;;  9/06/89 DNG - When rebuilding the method list, set the method hash table to 
;;		NIL before calling ADD-METHOD to avoid trying to install the new methods 
;;		in the old hash table.  [SPR 10571]
(defmethod (standard-generic-function :modify-generic-function)
	   (&key ((:name nam) nil name-p) ((:lambda-list ll) nil lambda-list-p)
	    ((:argument-precedence-order apo) nil argument-precedence-order-p)
	    ((:declare decl) nil declare-p) ((:documentation doc ) nil documentation-p)
	    ((:generic-function-class gfc))
	    ((:method-class mc) nil method-class-p)
	    ((:method-combination mcomb) nil method-combination-type-p)
	    ((:environment env)))
  (declare (ignore gfc env))
  (without-interrupts
    (let* ((specializable-ll (specializable-arguments ll))
	   (rorder-specs (if (or (null apo) (= (length specializable-ll) (length apo)))
			     (mapcar #'(lambda (x) (position x specializable-ll))
				     (or apo specializable-ll))
			     (error "The length of argument-precedence-order does not match the number of required
arguments for generic-function ~S" self)))
	   (old-reorder-spec (or (generic-function-reorder-specs self)
				 (collect-body (dotimes (i (length (generic-function-argument-precedence-order self)) )
						 (collect i))))))
      (declare (list specializable-ll))
      (when lambda-list-p
	(let ((new-arg-desc (check-lambda-list-for-generic-function ll)))
	  (when (and (generic-function-method-list self)
		     (incompatible-arg-desc-p new-arg-desc (generic-function-arglist-description self)))
	    (cerror "Remove all the methods"
		    "The new lambda-list of ~s, ~s is not congruent with the old one: ~s."
		    self  ll (generic-function-lambda-list self))
	    (setf (generic-function-method-list self) nil)
	    (setf (generic-function-method-hash-table self ) nil))
	  (setf (generic-function-lambda-list self) ll)
	  (setf (generic-function-arglist-description self) new-arg-desc)))
      (when name-p (setf (generic-function-name self ) nam))
      (when argument-precedence-order-p
	(setf (generic-function-argument-precedence-order self) apo ))
      (when declare-p (setf (generic-function-declare self) decl))
      (when documentation-p (setf (generic-function-documentation self) doc ))
      (when method-class-p (setf (generic-function-method-class self) mc ))
      (when method-combination-type-p (setf (generic-function-method-combination self) mcomb))
      (if  apo
	   (setf (generic-function-reorder-specs self)
		 rorder-specs)
	   (setf (generic-function-argument-precedence-order self)
		 specializable-ll))
      (unless (equal rorder-specs old-reorder-spec )
	;;We have to rebuild the method-list
	(setf (generic-function-method-hash-table self ) nil)
	(dolist (m (prog1 (generic-function-direct-methods self)
			  (setf (generic-function-method-list self ) nil)))
	  (add-method self m))
	))))
))

#!C
; From file METHOD-HASH-TABLE.LISP#> SYS6.CLOS; Kelvin:
#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; METHOD-HASH-TABLE.#"



(defun put-default-value-in-hash-table (hash-table &optional value-list #| args |# )
  ;; HASH-TABLE is the table we intend to fill with default values.
  ;; VALUE-LIST contains the entries to be put into HASH-TABLE.  The first item
  ;;  in the list is either a locative to the default method or a hash table
  ;;  containing the default method.  The second item is the mapping table list.
  ;; ARGS, if supplied, is the list of arguments passed to put-method-
  ;;  in-hash-table.  This is needed so that we can traverse down the levels of
  ;;  hash tables and put the default method in its proper place.
  ;; 05/30/89 clm - put the default value into the proper hash table.
  ;; 05/31/89 clm - fix problem in previous patch; was destructively modifying
  ;;                needed info within the DO.
  ;; 06/26/89 clm - fixes a problem found when the last item in the hash table
  ;;                path is an individual hash table
  ;;  8/30/89 DNG - For efficiency, use DESTRUCTURING-BIND instead of VALUES-LIST.
  ;;		and use (SYS:%P-CONTENTS-OFFSET P 1) instead of the first call to GETHASH.
  ;;		Simplify by replacing references to components of VALUE-LIST with the 
  ;;		component names and make ARGS a separate argument.
  ;;  8/31/89 DNG - Don't do last GETHASH call if SUBH is not a hash table. [SPR 10572]
  ;;  9/14/89 DNG - Remove obsolete code using ARGS.
  (with-lock ((sys:hash-table-lock hash-table) :whostate "Hash Table Lock")
    (without-interrupts
      (setf hash-table (sys:follow-structure hash-table))
      (if value-list
	  (setf (sys:hash-table-instance hash-table )
		(if (cddr value-list) (list (first value-list) (second value-list)) value-list) )
	(setf value-list (sys:hash-table-instance hash-table )))
      (destructuring-bind (subh mtl) value-list
	;;Do a do loop in order to preserve the existing entries.
	(let ((hlen (array-total-size hash-table)))
	  (do ((p (locf (aref hash-table 0)) (sys:%make-pointer-offset sys:dtp-locative p 3)))
	      ((> (sys:%pointer-difference p hash-table) hlen))
	    (if (= (sys:%p-data-type p) sys:dtp-null)
		(progn
		  ;;fill in all the empty slots in the hash table with the default value
		  (sys:%p-store-contents (sys:%make-pointer-offset sys:dtp-locative p 1) subh)
		  (sys:%p-store-contents (sys:%make-pointer-offset sys:dtp-locative p 2) mtl))
	      (comment ; removed 9/14/89
	        (unless (null args)
		  ;;if the slot is not empty and the entry is another hash table, go to next level to
		  ;;enter the default value
		  (let ((new-hash (sys:%p-contents-offset p 1))  ; (gethash (car p) hash-table)
		      new-hash2 arg-key)
		    (when (and new-hash
			      (hash-table-p new-hash))
		      (setq arg-key (class-hash-key (car args)))
		      (setq new-hash2 (gethash arg-key new-hash))
		      (if (individual-hash-table-p new-hash2)
			 ;;When recursing, if this is the last level of recursion (indicated by
			 ;;the next arg being nil, we cannot use a hash table value to fill in the default
			 ;;slots in the next level individual-hash-table, this would cause a "ran out of
			 ;;args to dispatch on before finding method" error.  The next level iht must
			 ;;be filled in with pointers to the default method itself.
			 (let (subh-t
			     mtl-t
			     (argl (cdr args)))
			   (when (null argl)
			     ;;This is the last level of recursion, get value from hash-table in value-list
			     ;;and pass that;
			     ;;06/21/89 fixes problem occurring if the value is itself an
			     ;;individual-hash-table.  In that case, take the default value of that
			     ;;table and pass it along.
			     (multiple-value-bind (loc ignore entry)
				 (gethash arg-key subh)
			       (if (individual-hash-table-p loc)
				  (let ((default-value (individual-dispatch-hash-table-default-value loc)))
				   (setf subh-t (first default-value))
				   (setf mtl-t (second default-value)))
				 (progn
				   (setf subh-t loc)
				   (setf mtl-t (third entry)))) ) )
			   (put-default-value-in-hash-table new-hash2 (list subh-t mtl-t) argl))
		        (when (hash-table-p subh)
			  (multiple-value-bind (nil nil entry)
			      (gethash arg-key subh)
			    ;;The value (gethash arg-key subh)
			    ;;is the hash table in which we have stuffed the default method that we are
			    ;;filling up the iht with - after this each entry in the hash table will be
			    ;;set to this
			    (puthash arg-key (second entry) new-hash (third entry)))) )  ) ))
		)
	      )))
	)					;destructuring-bind
      ))
  value-list
  )

))

#!C
; From file MAKE-INSTANCE.LISP#> SYS6.CLOS; Kelvin:
#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; MAKE-INSTANCE.#"


;;  9/11/89 DNG - Remove first test on CLASS-COMPOSED-P because there could be a 
;;		composed subclass even if the current class is not composed.
(defun refinalize-methods (class)
  (when (internal-class-finalized-p class)
    (finalize-inheritance-internal class :methods t))
  (dolist (c (class-direct-subclasses class))
    (unless (class-composed-p c)
      ;; We shouldn't ever get here, but just in case the data structures have 
      ;; gotten into an inconsistent state, this should clean things up.
      (clos:finalize-inheritance c))
    (refinalize-methods c))
  (values))
))

#!C
; From file METHOD-HASH-TABLE.LISP#> SYS6.CLOS; Kelvin:
#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; METHOD-HASH-TABLE.#"


;;  8/03/89 DNG - original version [included here 9/26].
(defsubst abstract-class-p (class) ; a class which will never be returned by CLASS-OF ?
  (send class :abstract-class-p))
(defmethod (class :abstract-class-p) ignore)
(defmethod (built-in-class :abstract-class-p) ()
  (and (class-description-direct-subclasses class-description)
       (member (class-description-name class-description)
	       '(t number function standard-object sequence integer)
	       :test #'eq)
       t))
))

#!C
; From file FLAVOR-METACLASS.LISP#> SYS6.CLOS; Kelvin:
#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; FLAVOR-METACLASS.#"


;; added 9/26/89
(defmethod (flavor-class :abstract-class-p) ()
  (getf (sys:flavor-plist class-description) :abstract-flavor))
))

#!C
; From file METHOD-HASH-TABLE.LISP#> SYS6.CLOS; Kelvin:
#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; METHOD-HASH-TABLE.#"


;;  8/29/89 DNG - Some re-arrangement of the code to simplify it and make it 
;;		easier to understand. 
;;  9/14/89 DNG - Save space by not making a hash table entry for an abstract 
;;		class as the last specializer.
;;  9/19/89 DNG - No longer need to make an entry for an abstract class with 
;;		trailing T specializers.  
;;  9/21/89 DNG - Avoid creating an empty hash table for arguments other than the first.
(defun build-method-hash-table (gfunc)
  ;; Creates and initializes a generic function's method hash table.
  (let ((nargs (length (generic-function-argument-precedence-order gfunc))))
    (labels
      ((bht (ml n rargs)
	    ;; ml = method list -- a-list with specializer as key.
	    ;; n = number of specialized arguments remaining.
	    ;; rargs = reversed list of specializers for previous arguments.
	    (declare (list ml rargs))
	    (if (or (= n 0) ; last argument
		    (and (not (= n nargs)) ; not 1st argument
			 (only-t-p ml n))) ; all remaining specializers are class t
		;; Return the method location and mapping tables.
		(let* ((args (if (= n 0)
				 (reverse rargs)
			       (nconc (reverse rargs)
				      (make-list n :initial-element *t-class*))))
		       (handler (ignore-method-combination-error (find-handler gfunc args))))
		  (and handler
		       (get-hash-entries-from-handler
			 handler (method-parameter-specializers handler)
			 (order-parameter-specializers gfunc args))))
	      ;; Else build and initialize hash table.
	      (let ((ht nil))
		(dolist (msubl ml)
		  (unless (and (atom (car msubl)) 
			       ;; Don't build a hash table tree for a key that will never be 
			       ;; returned by %class-description and hence never used.
			       (abstract-class-p (car msubl)))
		    (when (null ht)
		      ;;  Size of hash table is current number of methods plus room for one more, 
		      ;;  divided by the rehash threshold.
		      (setq ht (sys:make-hash-array :size (truncate (* (+ (length ml) 1) 10) 7)
						    :number-of-values 2
						    :funcallable-p t :test #'eq)))
		    (multiple-value-bind (subh mapping-table-list)	; new hash table entry values
			(bht (cdr msubl) (1- n) (cons (car msubl) rargs))
		      (unless (null subh)
			(let ((hash-key (class-hash-key (specializer-class (car msubl)))))
			  (multiple-value-bind (old-entry ignore vals)	; old entry, if any.
			      (gethash hash-key ht)
			    (if (individual-typep (car msubl))
				;;Nasty case, we have to have an individual-dispatch hash-table
				(let (dht)
				  (if (individual-hash-table-p old-entry)
				      (setq dht old-entry)
				    (progn (setq dht (make-individual-dispatch-hash-table 
						       :default-value (or (copy-list (cdr vals))
									  (list nil nil))))
					   (puthash hash-key dht ht t)))
				  (puthash (individual-type (car msubl)) ; the object is the key
					   subh
					   (individual-dispatch-hash-table-ht dht)
					   mapping-table-list))
			      (if (individual-hash-table-p old-entry)
				  (setf (individual-dispatch-hash-table-default-value old-entry)
					(list subh mapping-table-list))
				(puthash hash-key subh ht mapping-table-list)))))))))
		;; return the hash table
		ht))))
      (combine-methods gfunc)
      (setf (generic-function-method-hash-table gfunc)
	    (let ((ml (generic-function-method-list  gfunc)))
	      (or (bht ml nargs nil)
		  ;; At the top level must create a hash table even if we didn't find any 
		  ;; methods to put in it.  Allow room for two subclasses of each abstract 
		  ;; class in the method list.
		  (sys:make-hash-array :size (truncate (* (+ (* 2 (length ml)) 1) 10) 7)
				       :number-of-values 2
				       :funcallable-p t :test #'eq))) ))))
))

#!C
; From file METHOD-HASH-TABLE.LISP#> SYS6.CLOS; Kelvin:
#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; METHOD-HASH-TABLE.#"


;; DNG 8/25/89 - Original.
;; DNG 9/06/89 - Add use of DISCARD-METHOD-HASH-TABLE .
(defun rebuild-method-hash-table (generic-function)
  "Reconstruct the generic function's method hash table.
This can be used to try to manually correct errors in method dispatch."
  (let* ((object (generic-function-named generic-function))
	 (fef (generic-function-discriminator-code object)))
    (check-type fef compiled-function)
    (let ((old (generic-function-method-hash-table object)))
      (setf (generic-function-method-hash-table object) nil)
      (%build-method-hash-table fef)
      (discard-method-hash-table old))
    object))

;;  9/6/89 original.
(defun discard-method-hash-table (hash-table)
  ;; If a hash table isn't going to be used anymore, make sure that it can be garbage-collected.
  (labels ((process-hash-value (key value mtl)
	     (declare (ignore key mtl))
	     (when (typep value 'hash-table)
	       (when (individual-hash-table-p value)
		 (setq *individual-hash-tables*
		       (delete value (the list *individual-hash-tables*) :test #'eq :count 1))
		 (apply #'process-hash-value nil (individual-dispatch-hash-table-default-value value)))
	       (discard-method-hash-table value))
	     (values)))
    (maphash #'process-hash-value hash-table))
  (values))
))

#!C
; From file FLAVOR-METACLASS.LISP#> SYS6.CLOS; Kelvin:
#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; FLAVOR-METACLASS.#"


;;  9/27/89 DNG - Add use of *COMPILE-FILE-ENVIRONMENT* and don't error if the 
;;		class can't be found.
(defmethod (flavor-class :class-direct-subclasses) ()
  (let ((environment (class-description-environment class-description)))
    (collect-body
      (dolist (flavor-name (sys:flavor-depended-on-by class-description))
	(let ((class (or (class-named flavor-name t environment)
			 (class-named flavor-name t compiler:*compile-file-environment*))))
	  ;; We might not be able to find the class object if it is defined in the 
	  ;; compile-time environment of another process, which can happen in the 
	  ;; case of a metaclass that needs to be instantiated at compile-time.
	  (unless (null class)
	    (collect class)))))))

;;  9/27/89 DNG - Added for use by function POSSIBLE-COMMON-SUBCLASS .
(defmethod (flavor-class :has-subclasses-p) ()
  (not (null (sys:flavor-depended-on-by class-description))))
))