;;; -*- Mode: Common-Lisp; Package: User; Base: 8.; Patch-File: T -*-
;;; Patch file for DEBUG-TOOLS version 6.2
;;; Reason: Altered method of basic-inspect :object-instance to recognize & report CLOS class objects correctly.
;;; Written 06/15/89 09:25:16 by CROWE,
;;; while running on Bravo from band LODA
;;; With SYSTEM 6.4, VIRTUAL-MEMORY 6.1, EH 6.0, MAKE-SYSTEM 6.0, MICRONET 6.0, LOCAL-FILE 6.0,
;;;  BASIC-PATHNAME 6.0, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.0, NETWORK-NAMESPACE 6.0,
;;;  DISK-IO 6.0, DISK-LABEL 6.0, BASIC-FILE 6.0, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0,
;;;  COMPILER 6.2, TV 6.6, DATALINK 6.0, CHAOSNET 6.0, GC 6.1, MEMORY-AUX 6.0, NVRAM 6.0,
;;;  SYSLOG 6.0, STREAMER-TAPE 6.0, UCL 6.0, INPUT-EDITOR 6.0, METER 6.0, ZWEI 6.0,
;;;  Experimental DEBUG-TOOLS 6.1, 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.0, TI-CLOS 6.5, CLEH 6.0, IP 3.45,
;;;  Experimental BUG 11.6, CLX 6.0, CLUE 6.4, X11M 6.1,  microcode 429, Band Name: Release 6.0 + SLE 6/5

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


(DEFMETHOD (BASIC-INSPECT :OBJECT-INSTANCE) (OBJ)     ;fi + hash tables
  (LET ((maxl -1)
        result flavor class) ;*** TAC 6/15/89 - added local class variable
    ;;If the instance to inspect is an instance of INSPECTION-DATA and our superior's INSPECTION-DATA-ACTIVE? is T,
    ;;let the instance generate the inspection item.  This is used in special-purpose inspectors such as the flavor inspector.
    (IF (AND (SI:SEND-IF-HANDLES SUPERIOR :INSPECTION-DATA-ACTIVE?) (TYPEP OBJ 'INSPECTION-DATA))
        (MULTIPLE-VALUE-BIND (TEXT-ITEMS INSPECTOR-LABEL)
            (SEND OBJ :GENERATE-ITEM)
          (VALUES TEXT-ITEMS () 'INSPECT-PRINTER () INSPECTOR-LABEL))
        ;;Otherwise inspect the flavor instance in the normal fashion.
        (PROGN
	  (WHEN (ticlos:clos-instance-p obj) ;*** TAC 6/15/89 - if CLOS instance then get it's class
	      (SETQ class (ticlos:class-of obj))) 
	  (SETQ FLAVOR (SI:INSTANCE-FLAVOR OBJ)) 
	  (IF class
	      (SETQ RESULT ;*** TAC 6/15/89 - different label for a class 
                (LIST '("")
                      `("An object of class " (:ITEM1 CLASS ,(TYPE-OF OBJ))
                        ".  Class object is " (:ITEM1 CLASS-OBJECT ,class)))) 
	      (SETQ RESULT ;*** TAC 6/15/89 - same label as always for a flavor 
                (LIST '("")
                      `("An object of flavor " (:ITEM1 FLAVOR ,(TYPE-OF OBJ))
                        ".  Function is " (:ITEM1 FLAVOR-FUNCTION ,(SI:INSTANCE-FUNCTION OBJ)))))) 
          (LET ((IVARS
                  (IF FLAVOR
                      (SI:FLAVOR-ALL-INSTANCE-VARIABLES FLAVOR)
                      (%P-CONTENTS-OFFSET (%P-CONTENTS-AS-LOCATIVE-OFFSET OBJ 0)
                                          %INSTANCE-DESCRIPTOR-BINDINGS))))
            (DO ((BINDINGS IVARS (CDR BINDINGS))
                 (I 1 (1+ I)))
                ((NULL BINDINGS))
              (SETQ MAXL (MAX (FLATSIZE (CAR BINDINGS)) MAXL)))
            ;(SETQ MAXL (MAX (FLATSIZE (%FIND-STRUCTURE-HEADER (CAR BINDINGS))) MAXL)))
            (DO ((BINDINGS IVARS (CDR BINDINGS))
                 (SYM)
                 (I 1 (1+ I)))
                ((NULL BINDINGS))
              (SETQ SYM (CAR BINDINGS))
              ;(SETQ SYM (%FIND-STRUCTURE-HEADER (CAR BINDINGS)))
              (PUSH
                `((:ITEM1 INSTANCE-SLOT ,SYM) (:COLON ,(+ 2 MAXL))
                  ,(IF (= dtp-null (%p-data-type (%instance-loc obj i)))
                       ;,(IF (= (%P-LDB-OFFSET %%Q-DATA-TYPE OBJ I) DTP-NULL)
                       "unbound"
                       `(:item1 instance-value ,(%instance-ref obj i))))
                ;`(:ITEM1 INSTANCE-VALUE ,(%P-CONTENTS-OFFSET OBJ I))))
                RESULT)
              (if (equal (First Bindings) 'Si::Hash-Array)
                  (let ((window-items (make-window-items-for-hash-table (send obj :hash-array))))
                    (dolist (element window-items) (push element result))))
              ))
          (NREVERSE RESULT)))))
))