Merge branch 'master' of https://github.com/davazp/jscl into experimental
[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 ;;; Printer
20
21 ;;; Return T if the string S contains characters which need to be
22 ;;; escaped to print the symbol name, NIL otherwise.
23 (defun escape-symbol-name-p (s &optional uppercase)
24   (let ((dots-only t))
25     (dotimes (i (length s))
26       (let ((ch (char s i)))
27         (setf dots-only (and dots-only (char= ch #\.)))
28         (when (or (terminalp ch)
29                   (char= ch #\:)
30                   (and uppercase (not (char= ch (char (string-upcase (string ch)) 0))))
31                   (char= ch #\\)
32                   (char= ch #\|))
33           (return-from escape-symbol-name-p t))))
34     dots-only))
35
36 ;;; Return T if the specified string can be read as a number
37 ;;; In case such a string is the name of a symbol then escaping
38 ;;; is required when printing to ensure correct reading.
39 (defun potential-number-p (string)
40   ;; The four rules for being a potential number are described in
41   ;; 2.3.1.1 Potential Numbers as Token
42   ;;
43   ;; First Rule
44   (dotimes (i (length string))
45     (let ((char (char string i)))
46       (cond
47         ;; Digits TODO: DIGIT-CHAR-P should work with the current
48         ;; radix here. If the radix is not decimal, then we have to
49         ;; make sure there is not a decimal-point in the string.
50         ((digit-char-p char))
51         ;; Signs, ratios, decimal point and extension mark
52         ((find char "+-/._^"))
53         ;; Number marker
54         ((alpha-char-p char)
55          (when (and (< i (1- (length string)))
56                     (alpha-char-p (char string (1+ i))))
57            ;; fail: adjacent letters are not number marker, or
58            ;; there is a decimal point in the string.
59            (return-from potential-number-p)))
60         (t
61          ;; fail: there is a non-allowed character
62          (return-from potential-number-p)))))
63   (and
64    ;; Second Rule. In particular string is not empty.
65    (find-if #'digit-char-p string)
66    ;; Third rule
67    (let ((first (char string 0)))
68      (and (not (char= first #\:))
69           (or (digit-char-p first)
70               (find first "+-._^"))))
71    ;; Fourth rule
72    (not (find (char string (1- (length string))) "+-)"))))
73
74 #+nil
75 (mapcar #'potential-number-p
76         '("1b5000" "777777q" "1.7J" "-3/4+6.7J" "12/25/83" "27^19"
77           "3^4/5" "6//7" "3.1.2.6" "^-43^" "3.141_592_653_589_793_238_4"
78           "-3.7+2.6i-6.17j+19.6k"))
79
80 #+nil
81 (mapcar #'potential-number-p '("/" "/5" "+" "1+" "1-" "foo+" "ab.cd" "_" "^" "^/-"))
82
83 (defun escape-token-p (string &optional uppercase)
84   (or (potential-number-p string)
85       (escape-symbol-name-p string uppercase)))
86
87 ;;; Returns the token in a form that can be used for reading it back.
88 (defun escape-token (s &optional uppercase)
89   (if (escape-token-p s uppercase)
90       (let ((result "|"))
91         (dotimes (i (length s))
92           (let ((ch (char s i)))
93             (when (or (char= ch #\|)
94                       (char= ch #\\))
95               (setf result (concat result "\\")))
96             (setf result (concat result (string ch)))))
97         (concat result "|"))
98       s))
99
100 (defvar *print-escape* t)
101 (defvar *print-circle* nil)
102
103 (defun write-to-string (form &optional known-objects object-ids)
104   (when (and (not known-objects) *print-circle*)
105     ;; To support *print-circle* some objects must be tracked for
106     ;; sharing: conses, arrays and apparently-uninterned symbols.
107     ;; These objects are placed in an array and a parallel array is
108     ;; used to mark if they're found multiple times by assining them
109     ;; an id starting from 1.
110     ;;
111     ;; After the tracking has been completed the printing phas can
112     ;; begin: if an object has an id > 0 then #<n>= is prefixed and
113     ;; the id is changed to negative. If an object has an id < 0 then
114     ;; #<-n># is printed instead of the object.
115     ;;
116     ;; The processing is O(n^2) with n = number of tracked objects,
117     ;; but it should be reasonably fast because is based on afind that
118     ;; is a primitive function that compiles to [].indexOf.
119     (setf known-objects (make-array 100))
120     (setf object-ids (make-array 100))
121     (let ((n 0)
122           (sz 100)
123           (count 0))
124       (labels ((mark (x)
125                  (let ((i (afind x known-objects)))
126                    (if (= i -1)
127                        (progn
128                          (when (= n sz)
129                            (setf sz (* 2 sz))
130                            (aresize known-objects sz)
131                            (aresize object-ids sz))
132                          (aset known-objects (1- (incf n)) x)
133                          t)
134                        (unless (aref object-ids i)
135                          (aset object-ids i (incf count))
136                          nil))))
137                (visit (x)
138                  (cond
139                    ((and x (symbolp x) (null (symbol-package x)))
140                     (mark x))
141                    ((consp x)
142                     (when (mark x)
143                       (visit (car x))
144                       (visit (cdr x))))
145                    ((arrayp x)
146                     (when (mark x)
147                       (dotimes (i (length x))
148                         (visit (aref x i))))))))
149         (visit form))))
150   (let ((prefix ""))
151     (when (and *print-circle*
152                (or (consp form)
153                    (arrayp form)
154                    (and form (symbolp form) (null (symbol-package form)))))
155       (let* ((ix (afind form known-objects))
156              (id (aref object-ids ix)))
157         (cond
158           ((and id (> id 0))
159            (setf prefix (format nil "#~S=" id))
160            (aset object-ids ix (- id)))
161           ((and id (< id 0))
162            (return-from write-to-string (format nil "#~S#" (- id)))))))
163     (concat prefix
164             (cond
165               ((null form) "NIL")
166               ((symbolp form)
167                (let ((name (symbol-name form))
168                      (package (symbol-package form)))
169                  ;; Check if the symbol is accesible from the current package. It
170                  ;; is true even if the symbol's home package is not the current
171                  ;; package, because it could be inherited.
172                  (if (eq form (find-symbol (symbol-name form)))
173                      (escape-token (symbol-name form) (not (eq package *js-package*)))
174                      ;; Symbol is not accesible from *PACKAGE*, so let us prefix
175                      ;; the symbol with the optional package or uninterned mark.
176                      (concat (cond
177                                ((null package) "#")
178                                ((eq package (find-package "KEYWORD")) "")
179                                (t (escape-token (package-name package) t)))
180                              ":"
181                              (if (and package
182                                       (eq (second (multiple-value-list
183                                                       (find-symbol name package)))
184                                           :internal))
185                                  ":"
186                                  "")
187                              (escape-token name (not (eq package *js-package*)))))))
188               ((integerp form) (integer-to-string form))
189               ((floatp form) (float-to-string form))
190               ((characterp form)
191                (concat "#\\"
192                        (case form
193                          (#\newline "newline")
194                          (#\space "space")
195                          (otherwise (string form)))))
196               ((stringp form) (if *print-escape*
197                                   (concat "\"" (escape-string form) "\"")
198                                   form))
199               ((functionp form)
200                (let ((name (oget form "fname")))
201                  (if name
202                      (concat "#<FUNCTION " name ">")
203                      (concat "#<FUNCTION>"))))
204               ((listp form)
205                (concat "("
206                        (join-trailing (mapcar (lambda (x)
207                                                 (write-to-string x known-objects object-ids))
208                                               (butlast form)) " ")
209                        (let ((last (last form)))
210                          (if (null (cdr last))
211                              (write-to-string (car last) known-objects object-ids)
212                              (concat (write-to-string (car last) known-objects object-ids)
213                                      " . "
214                                      (write-to-string (cdr last) known-objects object-ids))))
215                        ")"))
216               ((arrayp form)
217                (let ((result "#(")
218                      (sep ""))
219                  (dotimes (i (length form))
220                    (setf result (concat result sep
221                                         (write-to-string (aref form i)
222                                                          known-objects
223                                                          object-ids)))
224                    (setf sep " "))
225                  (concat result ")")))
226               ((packagep form)
227                (concat "#<PACKAGE " (package-name form) ">"))
228               (t "#<javascript object>")))))
229
230 (defun prin1-to-string (form)
231   (let ((*print-escape* t))
232     (write-to-string form)))
233
234 (defun princ-to-string (form)
235   (let ((*print-escape* nil))
236     (write-to-string form)))
237
238 (defun write-line (x)
239   (write-string x)
240   (write-string *newline*)
241   x)
242
243 (defun warn (string)
244   (write-string "WARNING: ")
245   (write-line string))
246
247 (defun print (x)
248   (write-line (prin1-to-string x))
249   x)
250
251 (defun format (destination fmt &rest args)
252   (let ((len (length fmt))
253         (i 0)
254         (res "")
255         (arguments args))
256     (while (< i len)
257       (let ((c (char fmt i)))
258         (if (char= c #\~)
259             (let ((next (char fmt (incf i))))
260               (cond
261                ((char= next #\~)
262                 (concatf res "~"))
263                ((char= next #\%)
264                 (concatf res *newline*))
265                (t
266                 (concatf res (format-special next (car arguments)))
267                 (pop arguments))))
268             (setq res (concat res (char-to-string c))))
269         (incf i)))
270     (if destination
271         (progn
272           (write-string res)
273           nil)
274         res)))
275
276 (defun format-special (chr arg)
277   (case chr
278     (#\S (prin1-to-string arg))
279     (#\a (princ-to-string arg))))