projects
/
jscl.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Merge pull request #117 from Ferada/small-fixes
[jscl.git]
/
src
/
print.lisp
diff --git
a/src/print.lisp
b/src/print.lisp
index
db6b9a2
..
42ceba4
100644
(file)
--- a/
src/print.lisp
+++ b/
src/print.lisp
@@
-100,6
+100,7
@@
(defvar *print-escape* t)
(defvar *print-circle* nil)
(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
(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 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)
(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))
(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)
(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))))
(when (mark x)
(visit (car x))
(visit (cdr x))))
- ((arrayp x)
+ ((vectorp x)
(when (mark x)
(dotimes (i (length x))
(visit (aref x i))))))))
(when (mark x)
(dotimes (i (length x))
(visit (aref x i))))))))
@@
-150,9
+155,9
@@
(let ((prefix ""))
(when (and *print-circle*
(or (consp form)
(let ((prefix ""))
(when (and *print-circle*
(or (consp form)
- (arrayp form)
+ (vectorp form)
(and form (symbolp form) (null (symbol-package 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))
(id (aref object-ids ix)))
(cond
((and id (> id 0))
@@
-213,7
+218,7
@@
" . "
(write-to-string (cdr last) known-objects object-ids))))
")"))
" . "
(write-to-string (cdr last) known-objects object-ids))))
")"))
- ((arrayp form)
+ ((vectorp form)
(let ((result "#(")
(sep ""))
(dotimes (i (length form))
(let ((result "#(")
(sep ""))
(dotimes (i (length form))
@@
-262,10
+267,12
@@
(concatf res "~"))
((char= next #\%)
(concatf res *newline*))
(concatf res "~"))
((char= next #\%)
(concatf res *newline*))
+ ((char= next #\*)
+ (pop arguments))
(t
(concatf res (format-special next (car arguments)))
(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
(incf i)))
(if destination
(progn
@@
-274,6
+281,6
@@
res)))
(defun format-special (chr arg)
res)))
(defun format-special (chr arg)
- (case chr
+ (case (char-upcase chr)
(#\S (prin1-to-string arg))
(#\S (prin1-to-string arg))
- (#\a (princ-to-string arg))))
+ (#\A (princ-to-string arg))))