+#+jscl (defvar *print-escape* t)
+#+jscl (defvar *print-circle* nil)
+
+;; To support *print-circle* some objects must be tracked for sharing:
+;; conses, arrays and apparently-uninterned symbols. These objects
+;; are placed in an array and a parallel array is used to mark if
+;; they're found multiple times by assining them an id starting from
+;; 1.
+;;
+;; After the tracking has been completed the printing phase can begin:
+;; if an object has an id > 0 then #<n>= is prefixed and the id is
+;; changed to negative. If an object has an id < 0 then #<-n># is
+;; printed instead of the object.
+;;
+;; The processing is O(n^2) with n = number of tracked
+;; objects. Hopefully it will become good enough when the new compiler
+;; is available.
+(defun scan-multiple-referenced-objects (form)
+ (let ((known-objects (make-array 0 :adjustable t :fill-pointer 0))
+ (object-ids (make-array 0 :adjustable t :fill-pointer 0)))
+ (vector-push-extend nil known-objects)
+ (vector-push-extend 0 object-ids)
+ (let ((count 0))
+ (labels ((mark (x)
+ (let ((i (position x known-objects)))
+ (cond
+ ((null i)
+ (vector-push-extend x known-objects)
+ (vector-push-extend 0 object-ids)
+ t)
+ (t
+ (setf (aref object-ids i) (incf count))
+ nil))))
+ (visit (x)
+ (cond
+ ((and x (symbolp x) (null (symbol-package x)))
+ (mark x))
+ ((consp x)
+ (when (mark x)
+ (visit (car x))
+ (visit (cdr x))))
+ ((vectorp x)
+ (when (mark x)
+ (dotimes (i (length x))
+ (visit (aref x i))))))))
+ (visit form)))
+ (values known-objects object-ids)))
+
+;;; Write an integer to stream.
+;;; TODO: Support for different basis.
+(defun write-integer (value stream)
+ (write-string (integer-to-string value) stream))
+
+;;; This version of format supports only ~A for strings and ~D for
+;;; integers. It is used to avoid circularities. Indeed, it just
+;;; ouputs to streams.
+(defun simple-format (stream fmt &rest args)
+ (do ((i 0 (1+ i)))
+ ((= i (length fmt)))
+ (let ((char (char fmt i)))
+ (if (char= char #\~)
+ (let ((next (if (< i (1- (length fmt)))
+ (char fmt (1+ i))
+ (error "`~~' appears in the last position of the format control string ~S." fmt))))
+ (ecase next
+ (#\~ (write-char #\~ stream))
+ (#\d (write-integer (pop args) stream))
+ (#\a (write-string (pop args) stream)))
+ (incf i))
+ (write-char char stream)))))
+