-(defvar *print-escape* t)
-
-(defun write-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)))
- :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) (if *print-escape*
- (concat "\"" (escape-string form) "\"")
- form))
- ((functionp form)
- (let ((name (oget form "fname")))
- (if name
- (concat "#<FUNCTION " name ">")
- (concat "#<FUNCTION>"))))
- ((listp form)
- (concat "("
- (join-trailing (mapcar #'write-to-string (butlast form)) " ")
- (let ((last (last form)))
- (if (null (cdr last))
- (write-to-string (car last))
- (concat (write-to-string (car last)) " . " (write-to-string (cdr last)))))
- ")"))
- ((arrayp form)
- (concat "#" (if (zerop (length form))
- "()"
- (write-to-string (vector-to-list form)))))
- ((packagep form)
- (concat "#<PACKAGE " (package-name form) ">"))
- (t
- (concat "#<javascript object>"))))
-
-(defun prin1-to-string (form)
- (let ((*print-escape* t))
- (write-to-string form)))
-
-(defun princ-to-string (form)
- (let ((*print-escape* nil))
- (write-to-string form)))
-
-(defun write-line (x)
- (write-string x)
- (write-string *newline*)
- x)
-
-(defun warn (string)
- (write-string "WARNING: ")
- (write-line string))
-
-(defun print (x)
- (write-line (prin1-to-string x))
- x)
-
-(defun format (destination fmt &rest args)
+#+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))
+ (if name
+ (simple-format stream "#<FUNCTION ~a>" name)
+ (write-string "#<FUNCTION>" stream))))
+ ;; Lists
+ (list
+ (write-char #\( stream)
+ (unless (null form)
+ (write-aux (car form) stream known-objects object-ids)
+ (do ((tail (cdr form) (cdr tail)))
+ ;; Stop on symbol OR if the object is already known when we
+ ;; accept circular printing.
+ ((or (atom tail)
+ (and *print-circle*
+ (let* ((ix (or (position tail known-objects) 0))
+ (id (aref object-ids ix)))
+ (not (zerop id)))))
+ (unless (null tail)
+ (write-string " . " stream)
+ (write-aux tail stream known-objects object-ids)))
+ (write-char #\space stream)
+ (write-aux (car tail) stream known-objects object-ids)))
+ (write-char #\) stream))
+ ;; Vectors
+ (vector
+ (write-string "#(" stream)
+ (when (plusp (length form))
+ (write-aux (aref form 0) stream known-objects object-ids)
+ (do ((i 1 (1+ i)))
+ ((= i (length form)))
+ (write-char #\space stream)
+ (write-aux (aref form i) stream known-objects object-ids)))
+ (write-char #\) stream))
+ ;; Packages
+ (package
+ (simple-format stream "#<PACKAGE ~a>" (package-name form)))
+ ;; Others
+ (otherwise
+ (write-string "#<javascript object>" stream))))
+
+
+#+jscl
+(defun write (form &key (stream *standard-output*))
+ (write-aux form stream))
+
+(defun !write-to-string (form)
+ (with-output-to-string (output)
+ (multiple-value-bind (objs ids)
+ (scan-multiple-referenced-objects form)
+ (write-aux form output objs ids))))
+#+jscl (fset 'write-to-string (fdefinition '!write-to-string))
+
+#+jscl
+(progn
+
+ (defun prin1-to-string (form)
+ (let ((*print-escape* t))
+ (write-to-string form)))
+
+ (defun princ-to-string (form)
+ (let ((*print-escape* nil))
+ (write-to-string form)))
+
+ (defun terpri ()
+ (write-char #\newline)
+ (values))
+
+ (defun write-line (x)
+ (write-string x)
+ (terpri)
+ x)
+
+ (defun warn (fmt &rest args)
+ (write-string "WARNING: ")
+ (apply #'format t fmt args)
+ (terpri))
+
+ (defun print (x)
+ (write-line (prin1-to-string x))
+ x))
+
+;;; Format
+
+(defun format-special (chr arg)
+ (case (char-upcase chr)
+ (#\S (prin1-to-string arg))
+ (#\A (princ-to-string arg))
+ (#\D (princ-to-string arg))
+ (t
+ (warn "~S is not implemented yet, using ~~S instead" chr)
+ (prin1-to-string arg))))
+
+(defun !format (destination fmt &rest args)