;;; -*- Mode:Common-Lisp; Package:TICLOS; Base:10; Patch-file:T -*-

;;; Reason: Fix handling of *PRINT-CIRCLE* by PRINT-OBJECT.  [SPR 9885 and 9924]

;;;                           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 07/11/89 12:10:02 by GRAY,
;;; while running on Kelvin from band LOD2
;;; With Inconsistent SYSTEM 6.11, VIRTUAL-MEMORY 6.1, EH 6.3, MAKE-SYSTEM 6.0, MICRONET 6.0,
;;;  LOCAL-FILE 6.0, BASIC-PATHNAME 6.1, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.1,
;;;  NETWORK-NAMESPACE 6.0, DISK-IO 6.0, DISK-LABEL 6.0, BASIC-FILE 6.2, MAC-PATHNAME 6.0,
;;;  NETWORK-PATHNAME 6.0, Inconsistent COMPILER 6.8, TV 6.12, 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.3, 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.1,
;;;  TELNET 6.0, VT100 6.0, NAMESPACE-EDITOR 6.0, PROFILE 6.1, VISIDOC 6.2, Inconsistent TI-CLOS 6.16,
;;;  CLEH 6.4, IP 3.47, Experimental BUG 11.10, Experimental CLX 6.2, CLUE 6.9, X11M 6.1,
;;;  Experimental DOCUMENTER 619.0,  microcode 429, Band Name: 6.0 SLE 6/5 + u429 6/8

;;; BUG REPORT NUMBER:  9885 and 9924
;;;
;;; PROBLEM:  The changes to the print routines for CLOS broke the use of 
;;;	*PRINT-CIRCLE*.
;;;
;;; DIAGNOSIS:  The code to handle circular or recursive references which was 
;;;	part of function SYS:PRINT-OBJECT in previous releases appeared in 6.0 
;;;	only in (METHOD PRINT-OBJECT :AROUND (STANDARD-OBJECT T)).  Thus, it 
;;;	didn't work for lists, arrays, structures, or flavor instances.
;;;
;;; SOLUTION:  Extracted the code for handling circular references from 
;;;	(METHOD PRINT-OBJECT :AROUND (STANDARD-OBJECT T)) and made it a separate
;;;	function called PRINT-STRUCTURED-OBJECT.  Use this new function in
;;;	the PRINT-OBJECT methods for CONS, ARRAY, STANDARD-OBJECT,
;;;	STRUCTURE-OBJECT, and SYS:PRINT-READABLY-MIXIN.  For CONS and
;;;	ARRAY, this can be done directly in the primary method since users
;;;	can't define subclasses for these; for the others, an :AROUND
;;;	method is needed.  An :AROUND method on class T is not used
;;;	because that still doesn't seem to work right [breaks printing of
;;;	error conditions].  For flavor instances, the :AROUND method is
;;;	put on SYS:PRINT-READABLY-MIXIN instead of SYS:VANILLA-FLAVOR
;;;	because that handles the cases where it is most needed while
;;;	avoiding strange problems [e.g. breaks printing of local
;;;	pathnames] and an explosion of mapping tables that result from
;;;	trying to put an :AROUND method on SYS:VANILLA-FLAVOR.
;;;
;;;	This is a temporary solution.  The proper solution for the next
;;;	release is to change everyone who calls CLOS:PRINT-OBJECT to call
;;;	PRINT-STRUCTURED-OBJECT instead.  That will avoid the need for combined 
;;;	methods for the :AROUND methods.  This has not been done now because there 
;;;	are at least 15 functions affected and those changes need to be considered 
;;;	in the light of SPR 10214 which we aren't ready to address yet.

#!C
; From file NEW-PRINT-OBJECT.LISP#> CLOS; MR-X:
#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; NEW-PRINT-OBJECT.#"


;;  7/11/89 DNG - Original; adapted from old (METHOD PRINT-OBJECT :AROUND (STANDARD-OBJECT T)).
(defun print-structured-object (pobj stream &optional (print-function #'print-object))
  "Print an object which has components that may be recursive or circular references."
  (let ((si:*which-operations*  (si:which-operations-for-print stream)))
    (catch-continuation-if t 'print-object
	#'(lambda ()
	    (format stream "...error printing ")
	    (si:printing-random-object (pobj stream :typep :fastp t ))
	    (format stream "..."))
	()
      (condition-resume
	'((error) :abort-printing t ("Give up trying to print this object.")
	  si:catch-error-restart-throw print-object)
      
	(or
	  (and (member :print si:*which-operations*  :test #'eq)
	       ;Allow stream to intercept print operation
	       (send stream :print pobj (or si:*prindepth* 0) *print-escape*))
	  
	  (and *print-circle* (si:%pointerp pobj)
	     (or (not (symbolp pobj)) (not (symbol-package pobj)))
	     ;; This is a candidate for circular or shared structure printing.
	     ;; See what the hash table says about the object:
	     ;; NIL - occurs only once.
	     ;; T - occurs more than once, but no occurrences printed yet.
	     ;; Allocate a label this time and print #label= as prefix.
	     ;; A number - that is the label.  Print only #label#.
	     
	     (catch 'label-printed
	       (si:modifyhash pobj si:print-hash-table 
			   #'(lambda (key
				       value
				       key-found-p
				       stream)
			       key
			       key-found-p
			       (cond
				 ((null value) NIL)
				 ((eq value t)
				  (let ((label (incf si:print-label-number))
					(*print-base* 10.)
					(*print-radix* NIL)
					(*nopoint t))
				    (send stream :tyo #\#)
				    (si:print-fixnum label stream)
				    (send stream :tyo #\=)
				    label))
				 (t
				  (let ((*print-base* 10.)
					(*print-radix* NIL)
					(*nopoint t))
				    (send stream :tyo #\#)
				    (si:print-fixnum value stream)
				    (send stream :tyo #\#)
				    (throw 'label-printed
					   t)))))
			   stream)
	       ()))
	  (funcall print-function pobj stream) ))))
  pobj)
))

#!C
; From file NEW-PRINT-OBJECT.LISP#> CLOS; MR-X:
#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; NEW-PRINT-OBJECT.#"


;;  7/11/89 DNG - Add use of PRINT-STRUCTURED-OBJECT to fix SPR 9885.
(defmethod print-object ((pobj cons) stream)
  (print-structured-object
    pobj stream
    #'(lambda (pobj stream)
	(if (and *print-level* (>= (or si:*prindepth* 0) *print-level*))
	    (si:print-raw-string (si:pttbl-prinlevel *readtable*) stream t )
	  (progn
	    (if *print-pretty*
		(if *print-escape*
		    (si:pprin1 pobj stream)
		  (si:pprinc pobj stream))
	      (si:print-list pobj (or si:*prindepth* 0) stream si:*which-operations* ))))
	)))
))

#!C
; From file NEW-PRINT-OBJECT.LISP#> CLOS; MR-X:
#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; NEW-PRINT-OBJECT.#"


;;  7/11/89 DNG - Add use of PRINT-STRUCTURED-OBJECT to fix handling of *PRINT-CIRCLE*.
(defmethod print-object ((pobj array) stream)
  (print-structured-object
    pobj stream
    #'(lambda (pobj stream)
	(if (stringp pobj)
	    (if (<= (array-active-length pobj) (array-total-size pobj))
		(si:print-quoted-string pobj stream t)
	      (si:print-random-object pobj stream t (or si:*prindepth* 0)
				      si:*which-operations* ))
	  (si:print-array pobj stream t  (or si:*prindepth* 0) si:*which-operations* )))))
))

#!C
; From file NEW-PRINT-OBJECT.LISP#> CLOS; MR-X:
#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; NEW-PRINT-OBJECT.#"


;;  7/11/89 DNG - Use new function PRINT-STRUCTURED-OBJECT to avoid duplication of code.
(defmethod print-object :around ((pobj standard-object) stream)
  (print-structured-object pobj stream #'call-next-method))

;;  7/11/89 DNG - Added to fix SPR 9924.
(defmethod print-object :around ((pobj si:print-readably-mixin) stream)
  (print-structured-object pobj stream #'call-next-method))

;;  7/11/89 DNG - Added to fix handling of *PRINT-CIRCLE*.
(defmethod print-object :around ((pobj structure-object) stream)
  (print-structured-object pobj stream #'call-next-method))
))

;; Build the new combined methods now.
(prepare-generic-function #'print-object (make-instance 'condition) *terminal-io*)
(prepare-generic-function #'print-object (si:get-debug-info-struct #'print) *terminal-io*)