oget support multiple key chaining

[jscl.git] / src / print.lisp

diff --git a/src/print.lisp b/src/print.lisp
index 80db1f5..f9b5aff 100644 (file)
--- a/src/print.lisp
+++ b/src/print.lisp
@@ -100,6 +100,7 @@
 (defvar *print-escape* t)
 (defvar *print-circle* nil)
 
+;;; FIXME: Please, rewrite this in a more organized way.
 (defun write-to-string (form &optional known-objects object-ids)
   (when (and (not known-objects) *print-circle*)
     ;; To support *print-circle* some objects must be tracked for
@@ -113,22 +114,26 @@
     ;; 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,
-    ;; but it should be reasonably fast because is based on afind that
-    ;; is a primitive function that compiles to [].indexOf.
+    ;; The processing is O(n^2) with n = number of tracked
+    ;; objects. Hopefully it will become good enough when the new
+    ;; compiler is available.
     (setf known-objects (make-array 100))
     (setf object-ids (make-array 100))
     (let ((n 0)
           (sz 100)
           (count 0))
       (labels ((mark (x)
-                 (let ((i (afind x known-objects)))
+                 (let ((i (position x known-objects)))
                    (if (= i -1)
                        (progn
                          (when (= n sz)
                            (setf sz (* 2 sz))
-                           (aresize known-objects sz)
-                           (aresize object-ids sz))
+                           ;; KLUDGE: storage vectors are an internal
+                           ;; object which the printer should not know
+                           ;; about. Use standard vector with fill
+                           ;; pointers instead.
+                           (resize-storage-vector known-objects sz)
+                           (resize-storage-vector object-ids sz))
                          (aset known-objects (1- (incf n)) x)
                          t)
                        (unless (aref object-ids i)
@@ -142,7 +147,7 @@
                     (when (mark x)
                       (visit (car x))
                       (visit (cdr x))))
-                   ((arrayp x)
+                   ((vectorp x)
                     (when (mark x)
                       (dotimes (i (length x))
                         (visit (aref x i))))))))
@@ -150,9 +155,9 @@
   (let ((prefix ""))
     (when (and *print-circle*
                (or (consp form)
-                   (arrayp form)
+                   (vectorp form)
                    (and form (symbolp form) (null (symbol-package form)))))
-      (let* ((ix (afind form known-objects))
+      (let* ((ix (position form known-objects))
              (id (aref object-ids ix)))
         (cond
           ((and id (> id 0))
@@ -213,8 +218,8 @@
                                      " . "
                                      (write-to-string (cdr last) known-objects object-ids))))
                        ")"))
-              ((arrayp form)
-               (let ((result "(")
+              ((vectorp form)
+               (let ((result "#(")
                      (sep ""))
                  (dotimes (i (length form))
                    (setf result (concat result sep
@@ -265,7 +270,7 @@
                (t
                 (concatf res (format-special next (car arguments)))
                 (pop arguments))))
-            (setq res (concat res (char-to-string c))))
+            (setq res (concat res (string c))))
         (incf i)))
     (if destination
         (progn