[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Inspector loses on CLOS objects [Important]

[Added SLUG, as this might be of interest to them]

    Date: Wed, 13 Jun 90 16:04 EDT
    From: Kent M Pitman <KMP@STONY-BROOK.SCRC.Symbolics.COM>

	Date: Tue, 12 Jun 90 16:20 PDT
	From: Charles R. Fry <Chucko@CHARON.arc.nasa.gov>
	Subject: Inspector loses on CLOS objects [Important]

	Please leave Bug-Lispm@Charon in the return addresses for tracking
	purposes on our end.  Thanks.

	From a brief look at the sources, it appears that inspector support for
	CLOS was never implemented.

    Right.

	Since CLOS is crucial to our work here, I
	would very much appreciate receiving this support, as I haven't yet
	learned enough about CLOS internals to implement it myself.  Thanks.

    This is fixed in the devo system.  I'm not clear on how easy it's going to
    be to get you a patch for 8.0, but I'm checking into it and will get back to you.
    It might be that it will be fixed in 8.0.1, but I'm still checking into that,
    too.

	 -- Chuck Fry
	    Lisp Systems Manager, Dept. FI
	    NASA Ames Research Center

At the end of this message is the local private patch I derived from
PCL's inspector support.  -- Chucko

	--- Begin forwarded message ---
	Date: Tue, 12 Jun 90 15:09 PDT
	From: will taylor <taylor@CHARON.arc.nasa.gov>
	Subject: Inspector loses on CLOS objects
	To: Bug-Lispm@CHARON.arc.nasa.gov

1	In Symbolics 3653 Command Processor in Genera 8.0, Logical Pathnames Translation Files NEWEST, IP-TCP 422.2, NFS Client 415.0, Network RPC 415.1,
	RPC 415.0, DNA 414.1, NASA Ames Research Center 4.2, Ames Scheduler And Planner User Interface-[Genera 8.0] 1, microcode 3653-FPA-MIC 430, FEP 208,
	Fep0:>g208-lisp.flod(4), Fep0:>g208-loaders.flod(4), Fep0:>g208-debug.flod(2), Fep0:>g208-info.flod(4), 1024x806 B&W Screen,
	Machine serial number 80173, Fix VT100 region scrolling (from SYS:NARC;FIX-VT100-EMULATOR.LISP.1),
	Make domains work without handholding (from SYS:NARC;DOMAIN-QUERY-FIX.LISP.15),
	Signal appropriate error when bad packets found by NETI:DOMAIN-PARSE-NAME (from SYS:NARC;SAFER-DOMAIN-PARSE-NAME.LISP.1),
	Default to solid bar highlighting in menus (from SYS:NARC;SOLID-BAR-PATCH.LISP.1),
	Define column-width before someone else tries to use it. (from SYS:NARC;PATCH;NARC-REL8-4-2.LISP.1),
	Patch to BASIC-MENU flavor. Use solid bar highlighting. (from ASAP-8:UI-LIB;SOLID-BAR-PATCH),
	world booted from FEP0:>Genera-8-0-Configured.load.1 on Symbolics 3653 #80173 (Roman-a-Clef):
	Processes forcibly aborted:
	  Asap Scheduler 3 aborted with the following warning:
	    The function SCHEDULER-PROCESS-TOP-LEVEL is executing a cleanup form.
	   Aborting before the cleanup is complete could leave the program in
	   an inconsistent state and cause it to operate incorrectly later.

0  

	(defclass will ()
	   ((x :initarg :x)
	(y :init-arg :y)))
	Use the definition of CLOS:DEFCLASS? (Y, N, V, P, or G)
	For DEFCLASS WILL
	  :INIT-ARG is an invalid slot option.  It will be ignored.
	#<CLOS:STANDARD-CLASS WILL 33703402>
	(clos:make-instance 'will)
	#<WILL 51765152>
	  (inspect *)

	;;; Inspector does this:

2	Trap: The subscript given to the ZL:AR-1 instruction, 21, on #<CLOS-INTERNALS::CLASS-INSTANCE-INFORMATION ASAP::WILL 51724721> was beyond the length, 19.
0	While in the function (FLAVOR:METHOD :OBJECT-INSTANCE TV:BASIC-INSPECT)  (:INTERNAL TV:INSPECT-SETUP-OBJECT-DISPLAY-LIST 0 TV:INSPECT-TYPECASE)  TV:INSPECT-SETUP-OBJECT-DISPLAY-LIST

	The condition signalled was DBG:SUBSCRIPT-OUT-OF-BOUNDS-TRAP
	Trap microcode PC = #o32726 in 3653-FPA-MIC 430
	Error-table entry = (ILLEGAL-SUBSCRIPT)

	2(FLAVOR:METHOD :OBJECT-INSTANCE TV:BASIC-INSPECT)0  (P.C. = 27)
	   Arg 0 (SELF): #<INSPECT-PANE-WITH-TYPEOUT Inspect Pane With Typeout 5 (pane INSPECTOR-2 of Inspect Frame 5) 1143217 exposed>
	   Arg 1 (SYS:SELF-MAPPING-TABLE): #<Map to flavor TV:BASIC-INSPECT 410235425>
	   Arg 2 (FLAVOR::.GENERIC.): :OBJECT-INSTANCE
	   Arg 3 (TV:OBJ): #<ASAP::WILL 51765152>
	   Local 4 (TV:MAXL): -1
	   Local 5 (TV:RESULT): NIL
	   Local 6 (TV:FL): #<CLOS-INTERNALS::CLASS-INSTANCE-INFORMATION ASAP::WILL 51724721>
	[rest of backtrace deleted]
	--- End forwarded message ---

;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: USER; Base: 10; Patch-File: T -*-
;;; Patch file for Private version 0.0
;;; Reason: Function TV:INSPECT-SETUP-OBJECT-DISPLAY-LIST:  Add support for CLOS objects.
;;; Function (FLAVOR:METHOD :OBJECT-CLASS-INSTANCE TV:BASIC-INSPECT):  New.
;;; Function (:PROPERTY CLOS-INTERNALS::SLOT-NAME TV:SET-FUNCTION):  New;
;;;  allows modification of slots.
;;; Written by Chucko, 6/12/90 15:48:24
;;; while running on Bento from FEP0:>Genera-8-0-Metering.load.1
;;; with Genera 8.0, Logical Pathnames Translation Files NEWEST, IP-TCP 422.2,
;;; NFS Client 415.0, Network RPC 415.1, RPC 415.0, DNA 414.1,
;;; NASA Ames Research Center 4.3, Metering 419.0, Metering Substrate 419.1,
;;; microcode 3675-FPA-MIC 430, FEP 127, FEP0:>v127-lisp.flod(64),
;;; FEP0:>v127-loaders.flod(64), FEP0:>v127-debug.flod(38), FEP0:>v127-info.flod(64),
;;; 1067x748 B&W Screen, Machine serial number 2683,
;;; Fix VT100 region scrolling (from SYS:NARC;FIX-VT100-EMULATOR.LISP.1),
;;; Make domains work without handholding (from SYS:NARC;DOMAIN-QUERY-FIX.LISP.15),
;;; Signal appropriate error when bad packets found by NETI:DOMAIN-PARSE-NAME (from SYS:NARC;SAFER-DOMAIN-PARSE-NAME.LISP.1),
;;; Default to solid bar highlighting in menus (from SYS:NARC;SOLID-BAR-PATCH.LISP.1),
;;; Define column-width before someone else tries to use it. (from SYS:NARC;PATCH;NARC-REL8-4-2.LISP.1),
;;; Smaller menus for Zmail sequences (from CHA:>u>chucko>hacks>smaller-zmail-menus.lisp.2),
;;; Default Dired spec to *.*.newest (from CHA:>u>Chucko>hacks>zmacs-hacks-7-2),
;;; Provide font for FIX.CONDENSED.TINY (from CHA:>u>Chucko>hacks>fix-for-Brad-Miller's-bug-reports).


(SYSTEM-INTERNALS:FILES-PATCHED-IN-THIS-PATCH-FILE 
  "SYS:WINDOW;INSPCT.LISP.2545")


(NOTE-PRIVATE-PATCH "Inspector support for CLOS objects")


;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
(SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:WINDOW;INSPCT.LISP.2545")
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
  "-*- Mode: LISP; Package: TV; Base: 8; Syntax: Zetalisp -*-")

;;--- This function embodies a design insufficiency.  When an object is a malformed
;;--- example of some type, the :OBJECT- message can throw to INSPECT-REAL-OBJECT.
;;--- similiarly, if it believes that the inspect method for some other type would
;;--- do a better job, it can throw to INSPECT-FORCE-TYPE.  In neither of these cases,
;;--- though, will the display give any hint of the fact that there is something
;;--- unusual going on.  If the :OBJECT- handler for a FOO throws to direct the inspector
;;--- to display FOO-INTERNAL instead, the header in the display pane will talk of 
;;--- FOO-INTERNAL, and not mention FOO at all.  There is also no graceful support
;;--- for an object that fails the TYPECASE in here. --BIM

(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))
	       (CLI::BASIC-TABLE (INSPECT-DATA-TYPE TABLE))
	       (SCL:STRUCTURE (INSPECT-DATA-TYPE NAMED-STRUCTURE))
	       (clos::standard-object (inspect-data-type class-instance))
	       (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 'CLI::BASIC-TABLE)
		    (INSPECT-DATA-TYPE TABLE))
		   ((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)))))))


;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
; added by hand
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
  "-*- Mode: LISP; Package: CLOS-INTERNALS; Base: 8; Syntax: Zetalisp -*-")

(FLAVOR:DEFMETHOD (:OBJECT-class-instance TV:BASIC-INSPECT) (OBJ)
  (let* ((ii (%instance-information obj))
	 (slots (%class-instance-information-effective-slots ii))
	 (RESULT (LIST '("")
		       `("An instance of class "
			 (:ITEM class
			  ,(%class-instance-information-class-name ii)
			  )
			 ,@(when (%class-instance-information-obsolete-p ii)
			     '(" (superseded)"))
			 ".")))
	 (maxl -1)				;just in case
	 )
    (DOLIST (slot slots)
      (SETQ MAXL (MAX (+ (zl:FLATSIZE (slot-definition-name slot))
			 (if (eq (slot-definition-allocation slot) ':class) 9 0))
		      MAXL)))
    (SETQ MAXL (+ MAXL 2))
    (LOOP FOR slot IN slots
	  as slot-name = (slot-definition-name slot)
	  as allocation = (slot-definition-allocation slot)
	  do
      (push
	`((:item slot-name ,slot-name)
	  ,@(when (eq allocation ':class)
	      '(" (shared)"))
	  (:colon ,maxl)
	  ,(if (slot-boundp obj slot-name)
	       `(:item slot-value ,(slot-value obj slot-name))
	     "unbound"))
	RESULT))
    (NREVERSE RESULT)))

(defun (slot-name tv:set-function) (item new-value object)
  (setf (slot-value object (third (second item))) new-value))

;;; *** end of patch ***