;;; -*- Mode: Common-Lisp; Package: TV; Base: 8.; Patch-File: T -*-

;;; Reason: Binded *print-circle* in (BASIC-INSPECT :OBJECT-LIST) to handle circular lists. [10783]

;;;                           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 12/11/89 07:50:50 by berger,
;;; while running on ARIES from band LODX
;;; With SYSTEM 6.27, VIRTUAL-MEMORY 6.3, EH 6.5, MAKE-SYSTEM 6.2, MICRONET 6.0, LOCAL-FILE 6.1,
;;;  BASIC-PATHNAME 6.2, NETWORK-SUPPORT-COLD 6.2, BASIC-NAMESPACE 6.7, NETWORK-NAMESPACE 6.0,
;;;  DISK-IO 6.2, DISK-LABEL 6.0, Inconsistent BASIC-FILE 6.7, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0,
;;;  COMPILER 6.14, TV 6.19, DATALINK 6.0, CHAOSNET 6.5, GC 6.3, MEMORY-AUX 6.0, NVRAM 6.2,
;;;  SYSLOG 6.2, STREAMER-TAPE 6.5, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, ZWEI 6.11,
;;;  DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.1, NETWORK-SERVICE 6.2, DATALINK-DISPLAYS 6.0,
;;;  FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.3, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.2,
;;;  IMAGEN 6.1, SUGGESTIONS 6.1, MAIL-DAEMON 6.4, MAIL-READER 6.6, TELNET 6.0, VT100 6.0,
;;;  NAMESPACE-EDITOR 6.4, PROFILE 6.2, VISIDOC 6.7, TI-CLOS 6.26, CLEH 6.5, IP 3.56,
;;;  Experimental CLX 6.7, CLUE 6.35, X11M 6.19, Experimental BUG 11.17,  microcode 429,
;;;  Band Name: REL 6.0 + SLE 11/28

#!C
; From file INSPECT.LISP#> DEBUG-TOOLS; SYS:
#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-LIST) (LIST)
  (let ((*print-circle* t))			; DAB 12-11-89
    (MULTIPLE-VALUE-BIND (STRING-LIST ATOMIC-ITEMS LIST-ITEMS)
	(GRIND-INTO-LIST LIST
			 (1- (TRUNCATE (SHEET-INSIDE-WIDTH) CHAR-WIDTH))	;01-05-88 DAB Added 1- to fix losing the last char
			 T)
      ;; turn string-list into a list of elements, one for each line, of the form
      ;; (NIL contents-string atom-item-list line-contains-lozenged-characters-p).
      (DO ((L STRING-LIST (CDR L))
	   (AIS ATOMIC-ITEMS (CDR AIS)))
	  ((NULL L))
	(LET ((LOZENGED-CHARACTERS
		(DOTIMES (I (LENGTH (CAR L)))
		  (IF (>= (AREF (CAR L) I) 200) (RETURN T)))))
	  ;; Convert the start and end indices for each atom-item from characters to pixels.
	  ;; If this line contains no lozenged characters,
	  ;; this can be done by multiplying.  Otherwise, SHEET-STRING-LENGTH must be used.
	  (DOLIST (I (CAR AIS))
	    (SETF (THIRD I)
		  (+ (SHEET-INSIDE-LEFT)
		     (IF LOZENGED-CHARACTERS
			 (MULTIPLE-VALUE-BIND (IGNORE ignore z)
			     (SHEET-STRING-LENGTH SELF (CAR L) 0 (THIRD I))
			   (VALUES z))
			 (* (THIRD I) CHAR-WIDTH))))
	    (SETF (FOURTH I)
		  (+ (SHEET-INSIDE-LEFT)
		     (IF LOZENGED-CHARACTERS
			 (MULTIPLE-VALUE-BIND (IGNORE ignore z)
			     (SHEET-STRING-LENGTH SELF (CAR L) 0 (FOURTH I))
			   (VALUES z))
			 (* (FOURTH I) CHAR-WIDTH)))))
	  (RPLACA L (LIST NIL (CAR L) (CAR AIS) LOZENGED-CHARACTERS))))
      ;; Convert the starting and ending hpos of each list-item from characters to pixels
      ;; Must find the line which the start or end appears on
      ;; and see whether that line had any lozenged characters
      ;; to decide whether a multiplication is sufficient.
      (DOLIST (I LIST-ITEMS)
	(SETF (SECOND I)
	      (+ (SHEET-INSIDE-LEFT)
		 (LET ((LINE-DESC (NTH (THIRD I) STRING-LIST)))
		   (IF (FOURTH LINE-DESC)
                       (MULTIPLE-VALUE-BIND (IGNORE ignore z)
                           (SHEET-STRING-LENGTH SELF (SECOND LINE-DESC) 0 (SECOND I))
                         (VALUES z))
		       (* (SECOND I) CHAR-WIDTH)))))
	(SETF (FOURTH I)
	      (+ (SHEET-INSIDE-LEFT)
		 (LET ((LINE-DESC (NTH (FIFTH I) STRING-LIST)))
		   (IF (FOURTH LINE-DESC)
                       (MULTIPLE-VALUE-BIND (IGNORE ignore z)
                           (SHEET-STRING-LENGTH SELF (SECOND LINE-DESC) 0 (FOURTH I))
                         (VALUES z))
		       (* (FOURTH I) CHAR-WIDTH))))))
      (SETQ LIST-ITEMS
	    (SORT LIST-ITEMS
		  #'(LAMBDA (X Y)
		      (COND
			((< (THIRD Y) (THIRD X)) T)
			((> (THIRD Y) (THIRD X)) NIL)
			(T (> (SECOND X) (SECOND Y)))))))
      (DO ((LINE (1- (LENGTH STRING-LIST)) (1- LINE))
	   (CURRENT LIST-ITEMS))
	  ((< LINE 0))
	(DO ()
	    ((OR (NULL CURRENT) (<= (THIRD (CAR CURRENT)) LINE)))
	  (SETQ CURRENT (CDR CURRENT)))
	(RPLACA (CAR (NTHCDR LINE STRING-LIST)) CURRENT))
      (VALUES STRING-LIST :LIST-STRUCTURE 'INSPECT-LIST-PRINTER))))
))