-(defun prin1-to-string (form)
- (cond
- ((null form) "NIL")
- ((symbolp form)
- (multiple-value-bind (found-symbol status)
- (find-symbol (symbol-name form))
- (if (eq found-symbol form)
- (special-escape (symbol-name form) *package*)
- (let ((package (symbol-package form))
- (name (symbol-name form)))
- (concat (cond
- ((null package) "#")
- ((eq package (find-package "KEYWORD")) "")
- (t (package-name package)))
- ":"
- (if (eq (cadr (multiple-value-list (find-symbol name package)))
- :internal)
- ":"
- "")
- (special-escape name package))))))
- ((integerp form) (integer-to-string form))
- ((floatp form) (float-to-string form))
- ((characterp form)
- (concat "#\\"
- (case form
- (#\newline "newline")
- (#\space "space")
- (otherwise (string form)))))
- ((stringp form) (concat "\"" (escape-string form) "\""))
- ((functionp form)
- (let ((name (oget form "fname")))
+#+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)))))
+
+
+(defun write-aux (form stream known-objects object-ids)
+ (when *print-circle*
+ (let* ((ix (or (position form known-objects) 0))
+ (id (aref object-ids ix)))
+ (cond
+ ((and id (> id 0))
+ (simple-format stream "#~d=" id)
+ (setf (aref object-ids id) (- id)))
+ ((and id (< id 0))
+ (simple-format stream "#~d#" (- id))
+ (return-from write-aux)))))
+ (typecase form
+ ;; NIL
+ (null
+ (write-string "NIL" stream))
+ ;; Symbols
+ (symbol
+ (let ((name (symbol-name form))
+ (package (symbol-package form)))
+ ;; Check if the symbol is accesible from the current package. It
+ ;; is true even if the symbol's home package is not the current
+ ;; package, because it could be inherited.
+ (if (eq form (find-symbol (symbol-name form)))
+ (write-string (escape-token (symbol-name form)) stream)
+ ;; Symbol is not accesible from *PACKAGE*, so let us prefix
+ ;; the symbol with the optional package or uninterned mark.
+ (progn
+ (cond
+ ((null package) (write-char #\# stream))
+ ((eq package (find-package "KEYWORD")))
+ (t (write-char (escape-token (package-name package)) stream)))
+ (write-char #\: stream)
+ (let ((symbtype (and package (second (multiple-value-list (find-symbol name package))))))
+ (when (and package (eq symbtype :internal))
+ (write-char #\: stream)))
+ (write-string (escape-token name) stream)))))
+ ;; Integers
+ (integer
+ (write-integer form stream))
+ ;; Floats
+ (float
+ (write-string (float-to-string form) stream))
+ ;; Characters
+ (character
+ (write-string "#\\" stream)
+ (case form
+ (#\newline (write-string "newline" stream))
+ (#\space (write-string "space" stream))
+ (otherwise (write-char form stream))))
+ ;; Strings
+ (string
+ (if *print-escape*
+ (write-string (lisp-escape-string form) stream)
+ (write-string form stream)))
+ ;; Functions
+ (function
+ (let ((name #+jscl (oget form "fname")
+ #-jscl nil))