Run tests asynchronously so it reports incrementally
[jscl.git] / src / print.lisp
1 ;;; print.lisp ---
2
3 ;; JSCL is free software: you can redistribute it and/or
4 ;; modify it under the terms of the GNU General Public License as
5 ;; published by the Free Software Foundation, either version 3 of the
6 ;; License, or (at your option) any later version.
7 ;;
8 ;; JSCL is distributed in the hope that it will be useful, but
9 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
10 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11 ;; General Public License for more details.
12 ;;
13 ;; You should have received a copy of the GNU General Public License
14 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
15
16 (/debug "loading print.lisp!")
17
18 ;;; Printer
19
20 (defun lisp-escape-string (string)
21   (let ((output "")
22         (index 0)
23         (size (length string)))
24     (while (< index size)
25       (let ((ch (char string index)))
26         (when (or (char= ch #\") (char= ch #\\))
27           (setq output (concat output "\\")))
28         (when (or (char= ch #\newline))
29           (setq output (concat output "\\"))
30           (setq ch #\n))
31         (setq output (concat output (string ch))))
32       (incf index))
33     (concat "\"" output "\"")))
34
35 ;;; Return T if the string S contains characters which need to be
36 ;;; escaped to print the symbol name, NIL otherwise.
37 (defun escape-symbol-name-p (s)
38   (let ((dots-only t))
39     (dotimes (i (length s))
40       (let ((ch (char s i)))
41         (setf dots-only (and dots-only (char= ch #\.)))
42         (when (or (terminalp ch)
43                   (char= ch #\:)
44                   (char= ch #\\)
45                   (not (char= ch (char-upcase ch)))
46                   (char= ch #\|))
47           (return-from escape-symbol-name-p t))))
48     dots-only))
49
50 ;;; Return T if the specified string can be read as a number
51 ;;; In case such a string is the name of a symbol then escaping
52 ;;; is required when printing to ensure correct reading.
53 (defun potential-number-p (string)
54   ;; The four rules for being a potential number are described in
55   ;; 2.3.1.1 Potential Numbers as Token
56   ;;
57   ;; First Rule
58   (dotimes (i (length string))
59     (let ((char (char string i)))
60       (cond
61         ;; Digits TODO: DIGIT-CHAR-P should work with the current
62         ;; radix here. If the radix is not decimal, then we have to
63         ;; make sure there is not a decimal-point in the string.
64         ((digit-char-p char))
65         ;; Signs, ratios, decimal point and extension mark
66         ((find char "+-/._^"))
67         ;; Number marker
68         ((alpha-char-p char)
69          (when (and (< i (1- (length string)))
70                     (alpha-char-p (char string (1+ i))))
71            ;; fail: adjacent letters are not number marker, or
72            ;; there is a decimal point in the string.
73            (return-from potential-number-p)))
74         (t
75          ;; fail: there is a non-allowed character
76          (return-from potential-number-p)))))
77   (and
78    ;; Second Rule. In particular string is not empty.
79    (find-if #'digit-char-p string)
80    ;; Third rule
81    (let ((first (char string 0)))
82      (and (not (char= first #\:))
83           (or (digit-char-p first)
84               (find first "+-._^"))))
85    ;; Fourth rule
86    (not (find (char string (1- (length string))) "+-)"))))
87
88 #+nil
89 (mapcar #'potential-number-p
90         '("1b5000" "777777q" "1.7J" "-3/4+6.7J" "12/25/83" "27^19"
91           "3^4/5" "6//7" "3.1.2.6" "^-43^" "3.141_592_653_589_793_238_4"
92           "-3.7+2.6i-6.17j+19.6k"))
93
94 #+nil
95 (mapcar #'potential-number-p '("/" "/5" "+" "1+" "1-" "foo+" "ab.cd" "_" "^" "^/-"))
96
97 (defun escape-token-p (string)
98   (or (potential-number-p string)
99       (escape-symbol-name-p string)))
100
101 ;;; Returns the token in a form that can be used for reading it back.
102 (defun escape-token (s)
103   (if (escape-token-p s)
104       (let ((result "|"))
105         (dotimes (i (length s))
106           (let ((ch (char s i)))
107             (when (or (char= ch #\|)
108                       (char= ch #\\))
109               (setf result (concat result "\\")))
110             (setf result (concat result (string ch)))))
111         (concat result "|"))
112       s))
113
114 #+jscl (defvar *print-escape* t)
115 #+jscl (defvar *print-circle* nil)
116
117 ;; To support *print-circle* some objects must be tracked for sharing:
118 ;; conses, arrays and apparently-uninterned symbols.  These objects
119 ;; are placed in an array and a parallel array is used to mark if
120 ;; they're found multiple times by assining them an id starting from
121 ;; 1.
122 ;;
123 ;; After the tracking has been completed the printing phase can begin:
124 ;; if an object has an id > 0 then #<n>= is prefixed and the id is
125 ;; changed to negative. If an object has an id < 0 then #<-n># is
126 ;; printed instead of the object.
127 ;;
128 ;; The processing is O(n^2) with n = number of tracked
129 ;; objects. Hopefully it will become good enough when the new compiler
130 ;; is available.
131 (defun scan-multiple-referenced-objects (form)
132   (let ((known-objects (make-array 0 :adjustable t :fill-pointer 0))
133         (object-ids    (make-array 0 :adjustable t :fill-pointer 0)))
134     (vector-push-extend nil known-objects)
135     (vector-push-extend 0 object-ids)
136     (let ((count 0))
137       (labels ((mark (x)
138                  (let ((i (position x known-objects)))
139                    (cond
140                      ((null i)
141                       (vector-push-extend x known-objects)
142                       (vector-push-extend 0 object-ids)
143                       t)
144                      (t
145                       (setf (aref object-ids i) (incf count))
146                       nil))))
147                (visit (x)
148                  (cond
149                    ((and x (symbolp x) (null (symbol-package x)))
150                     (mark x))
151                    ((consp x)
152                     (when (mark x)
153                       (visit (car x))
154                       (visit (cdr x))))
155                    ((vectorp x)
156                     (when (mark x)
157                       (dotimes (i (length x))
158                         (visit (aref x i))))))))
159         (visit form)))
160     (values known-objects object-ids)))
161
162 ;;; Write an integer to stream.
163 ;;; TODO: Support for different basis.
164 (defun write-integer (value stream)
165   (write-string (integer-to-string value) stream))
166
167 ;;; This version of format supports only ~A for strings and ~D for
168 ;;; integers. It is used to avoid circularities. Indeed, it just
169 ;;; ouputs to streams.
170 (defun simple-format (stream fmt &rest args)
171   (do ((i 0 (1+ i)))
172       ((= i (length fmt)))
173     (let ((char (char fmt i)))
174       (if (char= char #\~)
175           (let ((next (if (< i (1- (length fmt)))
176                           (char fmt (1+ i))
177                           (error "`~~' appears in the last position of the format control string ~S." fmt))))
178             (ecase next
179               (#\~ (write-char #\~ stream))
180               (#\d (write-integer (pop args) stream))
181               (#\a (write-string (pop args) stream)))
182             (incf i))
183           (write-char char stream)))))
184
185
186 (defun write-aux (form stream known-objects object-ids)
187   (when *print-circle*
188     (let* ((ix (or (position form known-objects) 0))
189            (id (aref object-ids ix)))
190       (cond
191         ((and id (> id 0))
192          (simple-format stream "#~d=" id)
193          (setf (aref object-ids id) (- id)))
194         ((and id (< id 0))
195          (simple-format stream "#~d#" (- id))
196          (return-from write-aux)))))
197   (typecase form
198     ;; NIL
199     (null
200      (write-string "NIL" stream))
201     ;; Symbols
202     (symbol
203      (let ((name (symbol-name form))
204            (package (symbol-package form)))
205        ;; Check if the symbol is accesible from the current package. It
206        ;; is true even if the symbol's home package is not the current
207        ;; package, because it could be inherited.
208        (if (eq form (find-symbol (symbol-name form)))
209            (write-string (escape-token (symbol-name form)) stream)
210            ;; Symbol is not accesible from *PACKAGE*, so let us prefix
211            ;; the symbol with the optional package or uninterned mark.
212            (progn
213              (cond
214                ((null package) (write-char #\# stream))
215                ((eq package (find-package "KEYWORD")))
216                (t (write-char (escape-token (package-name package)) stream)))
217              (write-char #\: stream)
218              (let ((symbtype (and package (second (multiple-value-list (find-symbol name package))))))
219                (when (and package (eq symbtype :internal))
220                  (write-char #\: stream)))
221              (write-string (escape-token name) stream)))))
222     ;; Integers
223     (integer
224      (write-integer form stream))
225     ;; Floats
226     (float
227      (write-string (float-to-string form) stream))
228     ;; Characters
229     (character
230      (write-string "#\\" stream)
231      (case form
232        (#\newline (write-string "newline" stream))
233        (#\space   (write-string "space"   stream))
234        (otherwise (write-char form stream))))
235     ;; Strings
236     (string
237      (if *print-escape*
238          (write-string (lisp-escape-string form) stream)
239          (write-string form stream)))
240     ;; Functions
241     (function
242      (let ((name #+jscl (oget form "fname")
243                  #-jscl nil))
244        (if name
245            (simple-format stream "#<FUNCTION ~a>" name)
246            (write-string "#<FUNCTION>" stream))))
247     ;; Lists
248     (list
249      (write-char #\( stream)
250      (unless (null form)
251        (write-aux (car form) stream known-objects object-ids)
252        (do ((tail (cdr form) (cdr tail)))
253            ;; Stop on symbol OR if the object is already known when we
254            ;; accept circular printing.
255            ((or (atom tail)
256                 (and *print-circle*
257                      (let* ((ix (or (position tail known-objects) 0))
258                             (id (aref object-ids ix)))
259                        (not (zerop id)))))
260             (unless (null tail)
261               (write-string " . " stream)
262               (write-aux tail stream known-objects object-ids)))
263          (write-char #\space stream)
264          (write-aux (car tail) stream known-objects object-ids)))
265      (write-char #\) stream))
266     ;; Vectors
267     (vector
268      (write-string "#(" stream)
269      (when (plusp (length form))
270        (write-aux (aref form 0) stream known-objects object-ids)
271        (do ((i 1 (1+ i)))
272            ((= i (length form)))
273          (write-char #\space stream)
274          (write-aux (aref form i) stream known-objects object-ids)))
275      (write-char #\) stream))
276     ;; Packages
277     (package
278      (simple-format stream "#<PACKAGE ~a>" (package-name form)))
279     ;; Others
280     (otherwise
281      (write-string "#<javascript object>" stream))))
282
283
284 #+jscl
285 (defun write (form &key (stream *standard-output*))
286   (write-aux form stream))
287
288 (defun !write-to-string (form)
289   (with-output-to-string (output)
290     (multiple-value-bind (objs ids)
291         (scan-multiple-referenced-objects form)
292       (write-aux form output objs ids))))
293 #+jscl (fset 'write-to-string (fdefinition '!write-to-string))
294
295 #+jscl
296 (progn
297   
298   (defun prin1-to-string (form)
299     (let ((*print-escape* t))
300       (write-to-string form)))
301
302   (defun princ-to-string (form)
303     (let ((*print-escape* nil))
304       (write-to-string form)))
305
306   (defun terpri ()
307     (write-char #\newline)
308     (values))
309   
310   (defun write-line (x)
311     (write-string x)
312     (terpri)
313     x)
314   
315   (defun warn (fmt &rest args)
316     (write-string "WARNING: ")
317     (apply #'format t fmt args)
318     (terpri))
319   
320   (defun print (x)
321     (write-line (prin1-to-string x))
322     x))
323
324 ;;; Format
325
326 (defun format-special (chr arg)
327   (case (char-upcase chr)
328     (#\S (prin1-to-string arg))
329     (#\A (princ-to-string arg))
330     (#\D (princ-to-string arg))
331     (t
332      (warn "~S is not implemented yet, using ~~S instead" chr)
333      (prin1-to-string arg))))
334
335 (defun !format (destination fmt &rest args)
336   (let ((len (length fmt))
337         (i 0)
338         (res "")
339         (arguments args))
340     (while (< i len)
341       (let ((c (char fmt i)))
342         (if (char= c #\~)
343             (let ((next (char fmt (incf i))))
344               (cond
345                 ((char= next #\~)
346                  (concatf res "~"))
347                 ((char= next #\%)
348                  (concatf res (string #\newline)))
349                 ((char= next #\*)
350                  (pop arguments))
351                 (t
352                  (concatf res (format-special next (car arguments)))
353                  (pop arguments))))
354             (setq res (concat res (string c))))
355         (incf i)))
356     (if destination
357         (progn
358           (write-string res)
359           nil)
360         res)))
361 #+jscl (fset 'format (fdefinition '!format))