3 ;; Copyright (C) 2012, 2013 David Vazquez
4 ;; Copyright (C) 2012 Raimon Grau
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.
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.
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/>.
19 (/debug "loading print.lisp!")
23 (defun lisp-escape-string (string)
26 (size (length string)))
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 "\\"))
34 (setq output (concat output (string ch))))
36 (concat "\"" output "\"")))
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)
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)
48 (not (char= ch (char-upcase ch)))
50 (return-from escape-symbol-name-p t))))
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
61 (dotimes (i (length string))
62 (let ((char (char string i)))
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.
68 ;; Signs, ratios, decimal point and extension mark
69 ((find 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)))
78 ;; fail: there is a non-allowed character
79 (return-from potential-number-p)))))
81 ;; Second Rule. In particular string is not empty.
82 (find-if #'digit-char-p string)
84 (let ((first (char string 0)))
85 (and (not (char= first #\:))
86 (or (digit-char-p first)
87 (find first "+-._^"))))
89 (not (find (char string (1- (length string))) "+-)"))))
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"))
98 (mapcar #'potential-number-p '("/" "/5" "+" "1+" "1-" "foo+" "ab.cd" "_" "^" "^/-"))
100 (defun escape-token-p (string)
101 (or (potential-number-p string)
102 (escape-symbol-name-p string)))
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)
108 (dotimes (i (length s))
109 (let ((ch (char s i)))
110 (when (or (char= ch #\|)
112 (setf result (concat result "\\")))
113 (setf result (concat result (string ch)))))
117 (defvar *print-escape* t)
118 (defvar *print-circle* nil)
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.
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.
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))
143 (let ((i (position x known-objects)))
148 ;; KLUDGE: storage vectors are an internal
149 ;; object which the printer should not know
150 ;; about. Use standard vector with fill
152 (resize-storage-vector known-objects sz)
153 (resize-storage-vector object-ids sz))
154 (aset known-objects (1- (incf n)) x)
156 (unless (aref object-ids i)
157 (aset object-ids i (incf count))
161 ((and x (symbolp x) (null (symbol-package x)))
169 (dotimes (i (length x))
170 (visit (aref x i))))))))
173 (when (and *print-circle*
176 (and form (symbolp form) (null (symbol-package form)))))
177 (let* ((ix (position form known-objects))
178 (id (aref object-ids ix)))
181 (setf prefix (format nil "#~S=" id))
182 (aset object-ids ix (- id)))
184 (return-from !write-to-string (format nil "#~S#" (- id)))))))
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.
200 ((eq package (find-package "KEYWORD")) "")
201 (t (escape-token (package-name package))))
204 (eq (second (multiple-value-list
205 (find-symbol name package)))
209 (escape-token name)))))
210 ((integerp form) (integer-to-string form))
211 ((floatp form) (float-to-string form))
215 (#\newline "newline")
217 (otherwise (string form)))))
218 ((stringp form) (if *print-escape*
219 (lisp-escape-string form)
222 (let ((name #+jscl (oget form "fname")
225 (concat "#<FUNCTION " name ">")
226 (concat "#<FUNCTION>"))))
229 (join-trailing (mapcar (lambda (x)
230 (!write-to-string x known-objects object-ids))
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)
237 (!write-to-string (cdr last) known-objects object-ids))))
242 (dotimes (i (length form))
243 (setf result (concat result sep
244 (!write-to-string (aref form i)
248 (concat result ")")))
250 (concat "#<PACKAGE " (package-name form) ">"))
251 (t "#<javascript object>")))))
254 (fset 'write-to-string (fdefinition '!write-to-string))
257 (defun prin1-to-string (form)
258 (let ((*print-escape* t))
259 (write-to-string form)))
261 (defun princ-to-string (form)
262 (let ((*print-escape* nil))
263 (write-to-string form)))
266 (write-char #\newline)
269 (defun write-line (x)
274 (defun warn (fmt &rest args)
275 (write-string "WARNING: ")
276 (apply #'format t fmt args)
280 (write-line (prin1-to-string x))
283 (defun format (destination fmt &rest args)
284 (let ((len (length fmt))
289 (let ((c (char fmt i)))
291 (let ((next (char fmt (incf i))))
296 (concatf res (string #\newline)))
300 (concatf res (format-special next (car arguments)))
302 (setq res (concat res (string c))))
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))
316 (warn "~S is not implemented yet, using ~~S instead" chr)
317 (prin1-to-string arg))))