;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*- ;;; Reason: Fix in PUT-METHOD-IN-HASH-TABLE for another aspect of the method hash table problem when ;;; dealing with EQL specialized methods. Also included is a fix for a problem in PUT-DEFAULT- ;;; VALUE-IN-HASH-TABLE discovered during testing. ;;; 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 06/26/89 13:08:01 by MCCREARY, ;;; while running on Jules-Verne from band LOD9 ;;; With SYSTEM 6.9, 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, ;;; COMPILER 6.4, TV 6.11, 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, METER 6.0, ZWEI 6.3, ;;; DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.0, DATALINK-DISPLAYS 6.0, ;;; FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.1, 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, TI-CLOS 6.8, CLEH 6.4, IP 3.46, ;;; Experimental BUG 11.10, Experimental CLX 6.1, CLUE 6.5, X11M 6.1, microcode 429, ;;; Band Name: Release 6.0 + SLE 6/5 #!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-default-value-in-hash-table (hash-table &optional value-list) ;; 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. ;; The third item, 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 (with-lock ((sys:hash-table-lock hash-table) :whostate "Hash Table Lock") ;; Set all of hash table to NIL with cdr-next. (without-interrupts (multiple-value-bind (subh mtl args) (values-list value-list) (setf hash-table (sys:follow-structure hash-table)) (if value-list (setf (sys:hash-table-instance hash-table ) (if (third value-list) (list subh mtl) value-list) ) (setf value-list (sys:hash-table-instance hash-table ))) ;;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) (car value-list)) (sys:%p-store-contents (sys:%make-pointer-offset sys:dtp-locative p 2) (cadr value-list))) ;;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 (gethash (car p) hash-table)) new-hash2) (when (and new-hash (hash-table-p new-hash) args ) (setq new-hash2 (gethash (class-hash-key (car args)) 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 ((key (car args)) 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 (class-hash-key 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))) (multiple-value-bind (nil nil entry) (gethash (class-hash-key (car (third value-list))) (car value-list)) ;;the value (gethash (class-hash-key (third value-list)) (car value-list)) ;;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 (class-hash-key (car (third value-list))) (cadr entry) new-hash (caddr entry))) ) ) ) ))) ) ;multiple-value-bind value-list ))) )) #!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.#" ;;This function is called at compile time and at run time to add methods into the ;;generic function's method hash table hierarchy. Unfortunately, we cannot just add ;;the method into the hierarchy. We must make sure that all the preexisting paths ;;through the hash tables are updated to incorporate the new method. We must also ;;make sure that the new hash tables for the new method include all the correct defaults ;;that already exist for "default" cases, and that if this method is specialized on ;;certain arguments, then any methods specialized on superclass of those arguments ;;are also incorporated into this method's hash tables. (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. (let*((ht (generic-function-method-hash-table gfunc)) m (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... (when (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. (if super (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)) ;;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 (car args)) new-hash ht mtl) )))) ;;updating default paths (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 (car args)) from-hash))) (let ((new-hash (gethash (class-hash-key (car args)) from-hash))) (setf (individual-dispatch-hash-table-default-value new-hash) (list meth-loc mtl)) (puthash (class-hash-key (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 (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 (puthash (class-hash-key (class-of (individual-type (car args)))) 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) (multiple-value-bind (ov ignore ) (gethash (class-hash-key (car args)) 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))) ;;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 (or (eq super-class (car args)) (eq super-class *t-class*) ;;decide on this ) (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) ) ))) ) ht)))))) (put-arg-in-hash-table (or arg-specializers specializers ) specializers ht) (when m (put-method-in-hash-table gfunc m))))) (values)) (defun copy-method-hash-table (f-hash n-hash) ; used by PUT-METHOD-IN-HASH-TABLE above. (declare (arglist old-hash-table new-hash-table)) (maphash #'(lambda (key val1 val2) (when key (if (hash-table-p val1) ;;We must copy this hash-table ;;so that the super doesn't ;;get a sub's methods put into its ht. (puthash key ;;recurse - take the values from ht val1 ;;and put into ht n-hash - recursing on any ;;hash tables we find there *** note we ;;will be recursing through individual-hash-tables ;;also - need to check for those (copy-method-hash-table val1 (if (individual-hash-table-p val1) (make-individual-dispatch-hash-table :default-value (individual-dispatch-hash-table-default-value val1)) (sys:make-hash-array :number-of-values 2 :funcallable-p t :test #'eq))) n-hash val2) ;;else a non-hash-table entry , i.e., a pointer to a ;;method (puthash key val1 n-hash val2)) ;if )) f-hash) ;;return this ht in case we have been called recursively via puthash; n-hash) ))