;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*- ;;; Reason: 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. ;;; 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 2909, M/S 2151 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1989 Texas Instruments Incorporated. ;;; All rights reserved. ;;; Written 07/25/89 08:44:03 by MCCREARY, ;;; while running on Jules-Verne from band LODA ;;; With SYSTEM 6.14, 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, ;;; COMPILER 6.10, 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.2, TI-CLOS 6.19, CLEH 6.5, IP 3.47, ;;; Experimental CLX 6.2, CLUE 6.10, X11M 6.13, Experimental BUG 11.11, Experimental DOCUMENTER 6.0, ;;; Experimental CLIO 3.0, Experimental CLIO-DEMO 1.0, microcode 429, Band Name: 6.0 time #!C ; From file METHOD-HASH-TABLE.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; METHOD-HASH-TABLE.#" (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. (let*((ht (generic-function-method-hash-table gfunc)) (specializers (reorder-parameter-specializers gfunc (method-parameter-specializers method)))) (multiple-value-bind (meth-loc mtl) (get-hash-entries-from-handler method (method-parameter-specializers method) (order-parameter-specializers gfunc (or arg-specializers specializers ))) (labels ((put-arg-in-hash-table (args specs ht &optional parent super) (declare (list args specs)) (if (null args) (values meth-loc mtl) (progn (when (or (null ht) (not (hash-table-p ht))) ;;there are no hash tables set up for this method - we must create ;;but if this is at run time that means we may have to copy the hash-table ;;structure of the super-class to get the correct hash tables created. (if (and parent (every #'(lambda (c) (class-eql c *t-class*)) specs) (locativep (gethash (class-hash-key *t-class*) parent))) (return-from put-arg-in-hash-table meth-loc mtl) (progn (setf ht (sys:make-hash-array :number-of-values 2 :funcallable-p t :test #'eq)) ;;from here on, new ground... (if (and parent (every #'(lambda (c) (class-eql c *t-class*)) specs)) ;;this is the original pass constructing the mhts for this method; ;;if we are creating method hash tables for a method specialized on ;;a subclass of a superclass which has already been entered into the ;;hash table, then we must make sure that the method specialized ;;on the subclass has access to all the methods specialized ;;on the superclass. We must copy this information, not share it, ;;as sharing would cause new methods specialized on the subclass ;;to be added to the mhts of methods specialized on the superclass. (let ((arg (specializer-class (car args)))) (when super (let ((from-hash (gethash (class-hash-key super) parent))) (when (hash-table-p from-hash) (setq from-hash (gethash (class-hash-key arg) ;;(car args)) from-hash)) ;;FROM-HASH is the "from" hash table, the super's hash table ;;from which we are copying; NEW-HASH is the new hash table ;;into which we are copying (when (individual-hash-table-p from-hash) (let ((new-hash (make-individual-dispatch-hash-table :default-value (individual-dispatch-hash-table-default-value from-hash))) ) ;;copy the contents of ht FROM-HASH into ht NEW-HASH (copy-method-hash-table from-hash new-hash) (puthash (class-hash-key arg) ;;(car args)) new-hash ht mtl) )))) ) ;;updating default paths ;;07/14/89 - wasn't doing this if there was a super, but it turns ;;out that the default paths need updating in any case. (let ((from-hash (gethash (class-hash-key *t-class*) parent))) (when (hash-table-p from-hash) (if (and args (individual-hash-table-p (gethash (class-hash-key arg) ;;(car args)) from-hash))) (let ((new-hash (gethash (class-hash-key arg) ;;(car args)) from-hash))) (setf (individual-dispatch-hash-table-default-value new-hash) (list meth-loc mtl)) (puthash (class-hash-key arg) ;;(car args)) new-hash ht mtl) (return-from put-arg-in-hash-table ht)) (when (hash-table-p (gethash (class-hash-key *t-class*) from-hash)) (puthash (class-hash-key *t-class*) (gethash (class-hash-key *t-class*) from-hash) ht nil) ) ))) ) ;;If the parent hash table has an entry for *t-class* then ;;this default path needs to be entered into this hash table as well - ;;a default on T is applicable to all methods. (when parent (let ((from-hash (gethash (class-hash-key *t-class*) parent))) (when (hash-table-p from-hash) (puthash (class-hash-key *t-class*) (gethash (class-hash-key *t-class*) from-hash) ht nil) ))) )) )) (if (individual-typep (car args)) ;;create a new iht for the arg if necessary (let ((dht (multiple-value-bind (ov ignore vals) (gethash (class-hash-key (class-of (individual-type (car args)))) ht) (if (individual-hash-table-p ov) ov ;;one already exists and we can plug into it ;;or we have to make a new one (make-individual-dispatch-hash-table :default-value (or (copy-list (cdr vals)) (list nil nil))))))) ;;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 ;;this is redundant in certain cases, i.e. if the iht already existed ;;we don't really need to do this puthash again - doesn't hurt but slows ;;us down one step - may want to check into this later ;; 7/14/89 CLM - The hash table we are setting up is a default hash table ;;which may need to include other already defined methods besides the one ;;given here. We need to check the path of the "super" and make use of ;;those as needed. (puthash (class-hash-key (class-of (individual-type (car args)))) dht ht t) (when super (let ((from-hash (gethash (class-hash-key super) parent))) (when (hash-table-p from-hash) (setq from-hash (gethash (class-hash-key (class-of (individual-type (car args)))) from-hash)) ;;copy the contents of the parent's super hash tables to the new hash ;;table --- * this will recopy the method we just placed here if it ;;already exists in the super hash - check this (copy-method-hash-table from-hash dht)))) (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) (multiple-value-bind (ov ignore ) (gethash (class-hash-key (car args)) ht) (if (individual-hash-table-p ov) (let ((super-class (car specs))) (when (eq super-class (car args)) (setq super-class nil)) (multiple-value-bind (subh mtl) (put-arg-in-hash-table (cdr args) (cdr specs) (car (individual-dispatch-hash-table-default-value ov)) ht super-class) ;;We use the arg list now in put-default-value-in-hash-table ;;to determine if the default value should go into other hash tables as ;;well as the one we pass in. We do this because a default value for ;;this method may also be a valid default value for other methods. ;;If the arg list contains some eql specialized arguments, these must ;;first be converted to the appropriate class in order to traverse hash ;;tables correctly. (let ((def-arg-list (cdr args))) (setq def-arg-list (mapcar #'specializer-class def-arg-list)) (setf (individual-dispatch-hash-table-default-value ov) (list subh mtl def-arg-list) ))) ) (let ((super-class (car specs))) (when (eq super-class (car args)) (setq super-class nil)) (multiple-value-bind (subh mtl) (put-arg-in-hash-table (cdr args) (cdr specs) (gethash (class-hash-key (car args)) ht) ht super-class) (prog1 (puthash (class-hash-key (car args)) subh ht mtl) (when (classp (car args)) (maphash #'(lambda (key val ignore) ;;if (car args) is a super-class of other classes ;;in this hash-table level, then we also need to ;;add the method to subclasses of the super. (when (and (subclassp (class-description-class-object key) (car args)) (not (eq (class-description-class-object key) (car args)))) (if (individual-hash-table-p val) (setf (individual-dispatch-hash-table-default-value val) (list subh mtl )) ;;must check the _last_ node to make sure we are ;;not overwriting an already existing more specific ;;method for the subclass (when (and (hash-table-p val) (or (cddr args) ;not the last node (not (gethash (class-hash-key (specializer-class (cadr args))) val)))) ;method already exists (put-arg-in-hash-table (cdr args) (cdr specs) val ht)) ))) ht) ) ;;Conversely, if this method is specialized on a sub-class of some ;;class already represented in the hash table hierarchy, then ;;must check the super for valid methods to use here. (when (and super parent) (let ((from-hash (gethash (class-hash-key super) parent))) (when (hash-table-p from-hash) (setq from-hash (gethash (class-hash-key (car args)) from-hash)) (when (individual-hash-table-p from-hash) (let ((new-hash (make-individual-dispatch-hash-table :default-value (individual-dispatch-hash-table-default-value from-hash))) ) ;;copy the contents of ht FROM-HASH into ht NEW-HASH (copy-method-hash-table from-hash new-hash) (setf (individual-dispatch-hash-table-default-value new-hash) (list subh mtl) ) (puthash (class-hash-key (car args)) new-hash ht mtl) ))))) ))) ) ht)))))) (put-arg-in-hash-table (or arg-specializers specializers ) specializers ht) ))) (values)) ))