+(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))