X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fprint.lisp;h=42ceba4b08d2dc9a4d015323998c6d01be17511c;hb=b2de12c4e1a6e77e7f3f22d056adcfeda79d085b;hp=7daa14330de05fee7953dd05f8710e0e004b87bd;hpb=df5813a90dd0ea1501d9fafe95719f7056286edd;p=jscl.git

diff --git a/src/print.lisp b/src/print.lisp
index 7daa143..42ceba4 100644
--- 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))
@@ -194,7 +199,7 @@
                          (#\space "space")
                          (otherwise (string form)))))
               ((stringp form) (if *print-escape*
-                                  (concat "\"" (escape-string form) "\"")
+                                  (lisp-escape-string form)
                                   form))
               ((functionp form)
                (let ((name (oget form "fname")))
@@ -213,7 +218,7 @@
                                      " . "
                                      (write-to-string (cdr last) known-objects object-ids))))
                        ")"))
-              ((arrayp form)
+              ((vectorp form)
                (let ((result "#(")
                      (sep ""))
                  (dotimes (i (length form))
@@ -262,10 +267,12 @@
                 (concatf res "~"))
                ((char= next #\%)
                 (concatf res *newline*))
+               ((char= next #\*)
+                (pop arguments))
                (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
@@ -274,6 +281,6 @@
         res)))
 
 (defun format-special (chr arg)
-  (case chr
+  (case (char-upcase chr)
     (#\S (prin1-to-string arg))
-    (#\a (princ-to-string arg))))
+    (#\A (princ-to-string arg))))