;;; -*- Mode:Common-Lisp; Package:TICLOS; Base:10; Patch-file:T; Fonts:(CPTFONT CPTFONTB HL12BI HL12) -*- ;;; Reason: Fix a problem with using the wrong method for SHARED-INITIALIZE. [SPR 10432] ;;; 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. ;;; Written 09/21/89 14:45:26 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, ;;; 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.4, TI-CLOS 6.20, 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 430, Band Name: 6.0+Scribe,&c,u430 9/6 ;;; BUG REPORT NUMBER: 10432 ;;; ;;; PROBLEM: When doing a MAKE-INSTANCE of a class whose superclass has no ;;; slots, the slots of the instantiated class do not get initialized. ;;; This is due to two problems in (:METHOD STANDARD-CLASS :FINALIZE-INHERITANCE): ;;; ;;; 1. There is a bug in the code that decides whether a custom ;;; SHARED-INITIALIZE method should be computed, such that the method is ;;; created only for classes that have no initargs. ;;; ;;; 2. If for any reason a SHARED-INITIALIZE method is not created for a ;;; class, it could use a method inherited from a superclass. Inheriting ;;; a computed method produces incorrect results. ;;; ;;; SOLUTION: The first problem is not corrected here since it is really a ;;; performance issue and a change at this time could be risky since it would ;;; invoke the use of code that has not been well tested. [It has, ;;; however, already been fixed in the source for release 7.] ;;; ;;; The second problem is fixed by this patch by adding code at the end of ;;; (:METHOD STANDARD-CLASS :FINALIZE-INHERITANCE) which, if a ;;; SHARED-INITIALIZE method is not computed, looks in the method list to see ;;; if there is any method that could be inherited. If there is an inherited ;;; method which is a computed method, then it is shadowed by adding a method ;;; for the current class which uses the method FEF for the method on ;;; STANDARD-OBJECT. ;;; ;;; DEPENDENCIES: [none] ;;; ;;; CODEREAD: G.K. #!C ; From file MAKE-INSTANCE.LISP#> CLOS; Hotel: #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.#" 1;; 9/21/89 DNG - Add code to prevent inheriting a computed SHARED-INITIALIZE method. [SPR 10432]* (defmethod (standard-class :finalize-inheritance) (&rest options &key slots methods initargs) ;; If changing slots or initargs, compute lists (when (or slots initargs ) (compute-all-initarg-defaults self) (setf (class-description-finalize-status (class-description self)) (LOGIOR (class-description-finalize-status (class-description self)) 1)) (compute-all-slot-initargs self) (setf (class-description-finalize-status (class-description self)) (logior (class-description-finalize-status (class-description self)) 2))) (when (or methods slots) (progn (compute-all-initargs self) (setf (class-description-finalize-status (class-description self)) (logior (class-description-finalize-status (class-description self)) 4)))) (unless (let ((m (*find-method #'make-instance nil (list `(eql ,self)) nil))) (and m (null (getf (method-plist m) 'computed-method)))) (compute-make-instance-method self)) (if (and (let ((ms (compute-applicable-methods #'shared-initialize (list (class-prototype self) nil)))) (dolist (m ms t) (when (and (null (method-qualifiers m)) (and (null (getf (method-plist m) 'system-defined)) (null (getf (method-plist m) 'computed-method)))) (return nil)))) ;; The specialized method can't be compiled if there are too many keyword ;; arguments. (<= (length (class-all-slot-initargs self)) #.(- compiler:MAX-LOCAL-SLOTS sys:LOCALS-FOR-MAPPING-TABLE-BASE)) (LET ((init-list (class-all-slot-initargs self))) (EVERY #'(lambda (x) (LET (first-initarg-found (name-of-x (slot-name x))) (DO* ((remainder-of-init-list init-list (REST remainder-of-init-list)) (init-pair (CAR remainder-of-init-list) (CAR remainder-of-init-list))) ;; T if no duplicates found ((ENDP remainder-of-init-list) t) ;; Pause when slot name found (WHEN (EQ name-of-x (SECOND init-pair)) (LET ((this-initarg (FIRST init-pair))) (IF (BOUNDP first-initarg-found) ;; Bail out when a different one is found (UNLESS (EQ this-initarg first-initarg-found) (RETURN nil)) ;; Save the first (SETQ first-initarg-found this-initarg))))))) (class-all-slots self)))) (compute-shared-initialize-method self) 1 (block else (with-stack-list (specializers* self *t-class*1)* (let ((old-method (*find-method #'shared-initialize nil 1specializers* nil))) (when old-method 1(if* (getf (method-plist old-method ) 'computed-method) (remove-method #'shared-initialize old-method) 1 (return-from else))*)) 1(unless (equal (class-description-direct-supers (class-description self))* 1 '(standard-object))* 1 (dolist (alist (get-sorted-alists* 1 self (generic-function-method-list* 1 (get-generic-function-object #'shared-initialize))))* 1 (if (eq (car alist) '#,(find-class 'standard-object))* 1(return)* 1 (dolist (x (cdr alist))* 1(dolist (m (cdr x))* 1 (let ((inherited-method (method-spec-object-method m)))* 1 (unless (null inherited-method)* 1 (when (getf (method-plist inherited-method ) 'computed-method)* 1;; Inheriting an automatically created method; that won't work.* 1;; Make it use the default method.* 1(add-method #'shared-initialize* 1 (make-method nil specializers* 1 #'(method shared-initialize (standard-object t))* 1 `((instance ,self)* 1 slots-for-initform &rest initargs)) )* 1(return-from else))* 1 (when (null (method-qualifiers inherited-method))* 1;; a user-defined primary method* 1(return-from else))* 1 )))))))))*)) ))