[no subject]

[SOBO@s66.Prime.COM]

To:       (commonloops.pa@xerox.com)
From:     Nadine Sobolevitch (sobo@s66)
Date:     27 Oct 88  1:57 PM
Subject:  New version of Symbolics Window Inspector patch for AAAI-PCL.

This may be a bit late in the day, but I just switched to AAAI-PCL and
updated my Inspector patches to handle the changes.


;;; -*- Mode: LISP; Package: TV; Base: 8; Syntax: Zetalisp -*-

;;;This file provides changes to the Symbolics Window Inspector to make it
behave
;;;in a useful way vis-a-vis Portable Common Loops instances.
;;;This code has been updated to run in  8/28/88 PCL.
;;;Also, it now handles shared and unbound slots in a nice way.

;;;PCL is the Portable Common Loops package.
;;;PCL:IWMC-CLASS is the Common Lisp "type-of" a Portable Common Loops
object.
;;;New code (not in the default Symbolics Window Inspector) is in lower
case.

;;;I have eliminated use of multiple fonts in this file in order to make
this code
;;;easily readable even on ASCII terminals. However, bear in mind that any
font used
;;;to write a string in this file will be preserved in the Inspector
window.  Thus,
;;;in my own code, I write " [shared slot]" and "[unbound slot]" in italics
in order
;;;to make the Inspector display easier to read.

;;;Shuts up compiler redefinition query
(record-source-file-name 'inspect-setup-object-display-list 'defun t)

(DEFUN INSPECT-SETUP-OBJECT-DISPLAY-LIST (OBJECT WINDOW &OPTIONAL TOP-ITEM
LABEL
                                          &AUX DISPLAY-LIST ARG STR
ALT-PRINT-FUN
                                          FIRST-TOP-ITEM OBJ-LABEL
                                          (OOBJECT OBJECT))
  (MACROLET ((INSPECT-DATA-TYPE
                (TYPE)
               `(MULTIPLE-VALUE (DISPLAY-LIST ARG ALT-PRINT-FUN
FIRST-TOP-ITEM OBJ-LABEL)
                  (SEND WINDOW
                        ,(INTERN (STRING-APPEND "OBJECT-" TYPE)
SI:PKG-KEYWORD-PACKAGE)
                        OBJECT))))
    (FLET ((INSPECT-TYPECASE ()
             (CL:TYPECASE OBJECT
               (INSPECTOR-STACK-FRAME (INSPECT-DATA-TYPE STACK-FRAME))
               (FLAVOR-MESSAGE-HANDLER
                 (INSPECT-DATA-TYPE FLAVOR-MESSAGE-HANDLER))
               (SI:BASIC-HASH-TABLE
                 (INSPECT-DATA-TYPE BASIC-HASH-TABLE))
               (pcl:iwmc-class (inspect-data-type class-instance))
               (SCL:STRUCTURE (INSPECT-DATA-TYPE NAMED-STRUCTURE))
               (SCL:INSTANCE (INSPECT-DATA-TYPE INSTANCE))
               (SCL:ARRAY (INSPECT-DATA-TYPE ARRAY))
               (LIST (INSPECT-DATA-TYPE LIST))
               (SYMBOL (INSPECT-DATA-TYPE SYMBOL))
               (SYS:DYNAMIC-CLOSURE (INSPECT-DATA-TYPE CLOSURE))
               (COMPILED-FUNCTION (INSPECT-DATA-TYPE COMPILED-FUNCTION))))
           (INSPECT-FORCED-TYPE (TYPE)
             (COND ((SCL:EQUAL-TYPEP TYPE 'INSPECTOR-STACK-FRAME)
                    (INSPECT-DATA-TYPE STACK-FRAME))
                   ((SCL:EQUAL-TYPEP TYPE 'FLAVOR-MESSAGE-HANDLER)
                    (INSPECT-DATA-TYPE FLAVOR-MESSAGE-HANDLER))
                   ((SCL:EQUAL-TYPEP TYPE 'SI:BASIC-HASH-TABLE)
                    (INSPECT-DATA-TYPE BASIC-HASH-TABLE))
                   ((scl:equal-typep type 'pcl:iwmc-class)
                    (inspect-data-type class-instance))
                   ((SCL:EQUAL-TYPEP TYPE 'CL:STRUCTURE)
                    (INSPECT-DATA-TYPE NAMED-STRUCTURE))
                   ((SCL:EQUAL-TYPEP TYPE 'SCL:INSTANCE)
                    (INSPECT-DATA-TYPE INSTANCE))
                   ((SCL:EQUAL-TYPEP TYPE 'SCL:ARRAY)
                    (INSPECT-DATA-TYPE ARRAY))
                   ((SCL:EQUAL-TYPEP TYPE 'LIST)
                    (INSPECT-DATA-TYPE LIST))
                   ((SCL:EQUAL-TYPEP TYPE 'SYMBOL)
                    (INSPECT-DATA-TYPE SYMBOL))
                   ((SCL:EQUAL-TYPEP TYPE 'DYNAMIC-CLOSURE)
                    (INSPECT-DATA-TYPE CLOSURE))
                   ((SCL:EQUAL-TYPEP TYPE 'COMPILED-FUNCTION)
                    (INSPECT-DATA-TYPE COMPILED-FUNCTION)))))
      (LOOP NAMED RETRY-TYPE-ANALYSIS
            DO (SETQ OBJECT
                     (CATCH 'INSPECT-REAL-OBJECT        ; IF THIS IS THROWN
TO,
                                                ; THE VALUE IS A BETTER
OBJECT TO LOOK AT.
                                                ; TOO BAD THE HEADER WON'T
REVEAL THAT THIS
                                                ; HAPPENED.
                       (INSPECT-FORCED-TYPE
                         (CATCH 'INSPECT-FORCE-TYPE     ; IS THIS IS THROWN
TO,
                                                ; THE VALUE IS A BETTER
TYPE TO
                                                ; LOOK AT. AGAIN, TOO BAD
THAT THERE
                                                ; IS NO PROVISION TO
ANNOTATE.
                           (INSPECT-TYPECASE)
                           (RETURN-FROM RETRY-TYPE-ANALYSIS NIL)))
                       (RETURN-FROM RETRY-TYPE-ANALYSIS NIL))))))
  (LIST OBJECT
        (OR ALT-PRINT-FUN 'INSPECT-PRINTER)
        ARG DISPLAY-LIST (OR TOP-ITEM FIRST-TOP-ITEM 0)
        (OR LABEL
            OBJ-LABEL
            (LIST NIL NIL NIL NIL (LABEL-STYLE (SEND WINDOW ':LABEL))
                  (IF (LISTP OOBJECT)
                      "a list"
                      (NSUBSTRING (SETQ STR (FORMAT NIL "~S~%" OOBJECT))
                                  0 (STRING-SEARCH-CHAR #\CR STR)))))))


;;;Needed revision because pcl:all-slots went away in 8/28/88 pcl.
;;;Also, needed to handle unbound slots.
;;;(incidentally, pcl:describe-instance does not do this!)
(defmethod (:object-class-instance basic-inspect) (obj)
  (let* ((class (pcl:class-of obj))
         (slots (loop for slotd in (pcl:class-slots class)
                      for slot-name = (pcl:slotd-name slotd)
                      collecting (list slot-name (pcl:slotd-allocation
slotd)
                                       (if (pcl:slot-boundp obj slot-name)
                                           (pcl:slot-value obj slot-name)
                                           'slot-unbound))))
         (maxl -1)
         (result (list '("")
                       `("A Common Loops instance of "
                         (:item class ,class)))))
    (loop for (name allocation value) in slots
          when (eql allocation :instance)
            do (setq maxl (max (flatsize name) maxl))
          else
            do (setq maxl (max (+ (flatsize name) 16) maxl))    ;room for "
[shared slot]"
          finally (setq maxl (+ maxl 2)))
    (loop for (name allocation value) in slots
          do (push `((:item class-iv ,name)
                     ,@(and (eql allocation :class) '(" [shared slot]"))
                     (:colon ,maxl)
                     ,(if (eql value 'slot-unbound)
                          "[unbound slot]"
                          `(:item class-ivvalue ,value)))
                   result))
    (nreverse result)))

(defun (class-iv set-function) (item new-value object)
  (let ((slot (third (second item))))
    (setf (pcl:slot-value object slot) new-value)))

(defprop class-iv t only-when-modify)