head     1.4;
access   ;
symbols  ;
locks    ; strict;
comment  @@;


1.4
date     90.02.22.11.09.46;  author ram;  state Exp;
branches ;
next     1.3;

1.3
date     90.02.12.15.10.50;  author ram;  state Exp;
branches ;
next     1.2;

1.2
date     90.02.12.12.14.47;  author ram;  state Exp;
branches ;
next     1.1;

1.1
date     90.02.06.17.28.01;  author ram;  state Exp;
branches ;
next     ;


desc
@@


1.4
log
@.../systems-work/code/xp-patch.lisp, 10-Feb-90 11:45:56, Edit by William.
  Replaced *print-level* with *current-level* when calling a structure's print
  function.  We were erroneously passing nil in instead of a correct integer.
@
text
@;;; -*- Mode: Lisp; Log: code.log; Package: XP -*-
;;;
;;; New default structure print-function that interfaces with XP properly
;;; and correctly handles printing of circular structures.
;;;
;;; Note that it's still possible to define a print-function for a
;;; structure which will loop when the structure is circular and
;;; *print-circle* is T.  But the default structure print-function
;;; uses the XP primitives, so it will not loop on circular structures
;;; (when *print-circle* is T).
;;;
;;; Warning:  If the code for XP changes, this should be carefully compared
;;; to the new version because it redefines WRITE+.
;;;
;;; Written by Jim Healy,  April 1989.
;;;

(in-package "XP")

;;; A revised version of WRITE+ that has a special case for CMU structures.

(defun write+ (object xp)
  (unless (if (and *print-circle* (not (listp object)))
	      ;;lists checked in handle-logical-block.
	      (eq (circularity-process xp object nil) :subsequent))
    (let* ((printer (if *print-pretty*
			(get-printer object *print-dispatch*)
			nil))
	   type)
      (cond (printer (funcall printer xp object))
	    ((maybe-print-fast xp object))
	    ((and *print-pretty*
		  (symbolp (setq type (type-of object)))
		  (setq printer (get type 'structure-printer))
		  (not (eq printer :none)))
	     (funcall printer xp object))
	    ((and *print-pretty* *print-array* (arrayp object)
		  (not (stringp object)) (not (bit-vector-p object))
		  (not (structure-type-p (type-of object))))
	     (pretty-array xp object))
    #+:CMU  ((lisp::structurep object)
	     (pretty-structure xp object))
	    (T (let ((stuff
		       (with-output-to-string (s)
			 (lisp:write object
				     :level
				     (if *print-level*
					 (- *print-level* *current-level*))
				     :pretty
				     nil ;reduces chance of infinite loops.
				     :stream s))))
		 (write-string+ stuff xp 0 (length stuff))))))))


;;; Pretty-Structure is called from the hacked up version of WRITE+
;;; above whenever the object satifies lisp::structurep.

(defun pretty-structure (xp structure)
  (let* ((name (svref structure 0))
	 (print-fn (ext:info type printer name)))
    (if print-fn
	;; Just funcall the user defined print function into a string. 
	(let ((stuff (with-output-to-string (ss)
		       (funcall print-fn structure ss *current-level*))))
	  (write-string+ stuff xp 0 (length stuff)))
	;; This is the default print function.  Try to be careful to use
	;; the XP primitives to catch possible circularities.
	(default-structure-xp xp structure))))


;;; XP calls this function on two arguments, an XP pretty-printing stream
;;; and the structure to be printed.  Since this function uses the
;;; primitives of XP, any circularities are caught by XP itself.

(defun default-structure-xp (xp structure)
  (funcall (XP::FS "XP" "~@@<#S(~;~W ~:I~@@_~{~A ~@@_~W~^ ~:_~}~;)~:>")
	   xp (svref structure 0)
	   (let ((length (length structure))
		 (values nil))
	     (do ((slots (c::dd-slots (ext:info type defined-structure-info
						(svref structure 0)))
			 (cdr slots))
		  (index 1 (1+ index)))
		 ((= index length) (nreverse values))
	       (push (c::dsd-name (car slots)) values)
	       (push (svref structure index) values)))))

@


1.3
log
@Deleted now unused binding.
@
text
@d1 1
a1 1
;;; -*- Mode: Lisp; Package: Lisp -*-
d26 3
a28 1
    (let* ((printer (if *print-pretty* (get-printer object *print-dispatch*) nil))
d46 5
a50 3
				     :level (if *print-level*
						(- *print-level* *current-level*))
				     :pretty nil;reduces chance of infinite loops.
d62 1
a62 2
	;; Otherwise just funcall the user defined print function into a
	;; string. 
d64 1
a64 1
		       (funcall print-fn structure ss *print-level*))))
d87 1
@


1.2
log
@Fixed to use INFO TYPE PRINTER and INFO TYPE DEFINED-STRUCTURE-INFO.
@
text
@a55 1
	 (info (ext:info type defined-structure-info name))
a83 1

@


1.1
log
@Initial revision
@
text
@d55 4
a58 6
  (let* ((info (ext:info type structure-info (svref structure 0)))
	 (print-fn (c::dd-print-function info)))
    (if (eq print-fn 'c::default-structure-print)
	;; This is the default print function.  Try to be careful to use
	;; the XP primitives to catch possible circularities.
	(default-structure-xp xp structure)
d63 4
a66 1
	  (write-string+ stuff xp 0 (length stuff))))))
d78 1
a78 1
	     (do ((slots (c::dd-slots (ext:info type structure-info
@