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