;;; -*- Mode:LISP; Package:SI; Cold-Load:T; Base:8; Readtable:ZL -*-

(DEFUN GRIND-PRINT-CIRCULAR-OBJECT (EXP)
  (AND *PRINT-HASH-TABLE*			;*print-circle* in effect...
       (IF (SYMBOLP EXP)			;this object is a candidate for circularity
	   (NULL (SYMBOL-PACKAGE EXP))
	 (%POINTERP EXP))
       (CATCH 'LABEL-PRINTED
	 (SEND *PRINT-HASH-TABLE* :MODIFY-HASH EXP
	       #'(LAMBDA (KEY VALUE KEY-FOUND-P)
		   (DECLARE (IGNORE KEY KEY-FOUND-P)
			    (SYS:DOWNWARD-FUNCTION))
		   (COND ((NULL VALUE)
			  ;; this object hasn't been seen
			  NIL)
			 ((EQ VALUE T)
			  ;; this object has been seen but not printed
			  (LET ((LABEL (INCF *PRINT-LABEL-NUMBER*)))
			    (GTYO #/#)
			    (LET ((*PRINT-BASE* 10.))
			      (GRIND-ATOM LABEL GRIND-IO (LOCF LABEL)))
			    (GTYO #/=)
			    LABEL))
			 (T
			  ;; this object has been seen and printed before
			  (GTYO #/#)
			  (LET ((*PRINT-BASE* 10.))
			    (GRIND-ATOM VALUE GRIND-IO (LOCF VALUE)))
			  (GTYO #/#)
			  (THROW 'LABEL-PRINTED T)))))
	 NIL)))

(DEFUN GRIND-REST-OF-LIST (TAIL LOC FORM)
  (GIND (DO ((X TAIL (CDR X))
	     (COUNT 0 (1+ COUNT))
	     (LOC LOC (LOCF (CDR X))))
	    (())
	  (COND ((or (ATOM X)
		     (and *print-hash-table*
			  (send *print-hash-table* :get-hash x)))
		 (RETURN (GRIND-DOTTED-CDR X LOC)))
		((EQ COUNT PRINLENGTH)
		 (FUNCALL FORM (PTTBL-PRINLENGTH *READTABLE*) LOC)
		 (GTYO-CLOSE T)
		 (RETURN T))
		((ATOM (CDR X))
		 (LET ((GRIND-WIDTH (1- GRIND-WIDTH)))	;last form needs room for right paren
		   (FUNCALL FORM (CAR X) (LOCF (CAR X))))
		 (RETURN (GRIND-DOTTED-CDR (CDR X) (LOCF (CDR X))))))
	  (FUNCALL FORM (CAR X) (LOCF (CAR X)))
	  (GRIND-TERPRI))))			;not last form, terpri before next

(DEFUN GRIND-LINEAR-TAIL (EXP LOC)
  (GTYO-OPEN LOC)				;Do linear list
  (DO ((X EXP (CDR X))
       (LOC1 LOC (LOCF (CDR X)))
       (first t nil))
      ((or (ATOM X)
	   (and *print-hash-table*
		(not first)
		(send *print-hash-table* :get-hash x)))
       (when (NOT (NULL X))
	 (GSTRING (PTTBL-CONS-DOT *READTABLE*))
	 (GIND (GRIND-LINEAR-FORM X LOC1)))
       (GTYO-CLOSE T))
    (or first (gtyo-space))
    (GIND (GRIND-LINEAR-FORM (CAR X) (LOCF (CAR X))))))