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.
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.
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/>.
16 (/debug "loading print.lisp!")
20 (defun lisp-escape-string (string)
23 (size (length string)))
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 "\\"))
31 (setq output (concat output (string ch))))
33 (concat "\"" output "\"")))
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)
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)
45 (not (char= ch (char-upcase ch)))
47 (return-from escape-symbol-name-p t))))
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
58 (dotimes (i (length string))
59 (let ((char (char string i)))
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.
65 ;; Signs, ratios, decimal point and extension mark
66 ((find 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)))
75 ;; fail: there is a non-allowed character
76 (return-from potential-number-p)))))
78 ;; Second Rule. In particular string is not empty.
79 (find-if #'digit-char-p string)
81 (let ((first (char string 0)))
82 (and (not (char= first #\:))
83 (or (digit-char-p first)
84 (find first "+-._^"))))
86 (not (find (char string (1- (length string))) "+-)"))))
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"))
95 (mapcar #'potential-number-p '("/" "/5" "+" "1+" "1-" "foo+" "ab.cd" "_" "^" "^/-"))
97 (defun escape-token-p (string)
98 (or (potential-number-p string)
99 (escape-symbol-name-p string)))
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)
105 (dotimes (i (length s))
106 (let ((ch (char s i)))
107 (when (or (char= ch #\|)
109 (setf result (concat result "\\")))
110 (setf result (concat result (string ch)))))
114 #+jscl (defvar *print-escape* t)
115 #+jscl (defvar *print-circle* nil)
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
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.
128 ;; The processing is O(n^2) with n = number of tracked
129 ;; objects. Hopefully it will become good enough when the new compiler
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)
138 (let ((i (position x known-objects)))
141 (vector-push-extend x known-objects)
142 (vector-push-extend 0 object-ids)
145 (setf (aref object-ids i) (incf count))
149 ((and x (symbolp x) (null (symbol-package x)))
157 (dotimes (i (length x))
158 (visit (aref x i))))))))
160 (values known-objects object-ids)))
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))
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)
173 (let ((char (char fmt i)))
175 (let ((next (if (< i (1- (length fmt)))
177 (error "`~~' appears in the last position of the format control string ~S." fmt))))
179 (#\~ (write-char #\~ stream))
180 (#\d (write-integer (pop args) stream))
181 (#\a (write-string (pop args) stream)))
183 (write-char char stream)))))
186 (defun write-aux (form stream known-objects object-ids)
188 (let* ((ix (or (position form known-objects) 0))
189 (id (aref object-ids ix)))
192 (simple-format stream "#~d=" id)
193 (setf (aref object-ids id) (- id)))
195 (simple-format stream "#~d#" (- id))
196 (return-from write-aux)))))
200 (write-string "NIL" stream))
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.
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)))))
224 (write-integer form stream))
227 (write-string (float-to-string form) stream))
230 (write-string "#\\" stream)
232 (#\newline (write-string "newline" stream))
233 (#\space (write-string "space" stream))
234 (otherwise (write-char form stream))))
238 (write-string (lisp-escape-string form) stream)
239 (write-string form stream)))
242 (let ((name #+jscl (oget form "fname")
245 (simple-format stream "#<FUNCTION ~a>" name)
246 (write-string "#<FUNCTION>" stream))))
249 (write-char #\( stream)
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.
257 (let* ((ix (or (position tail known-objects) 0))
258 (id (aref object-ids ix)))
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))
268 (write-string "#(" stream)
269 (when (plusp (length form))
270 (write-aux (aref form 0) stream known-objects object-ids)
272 ((= i (length form)))
273 (write-char #\space stream)
274 (write-aux (aref form i) stream known-objects object-ids)))
275 (write-char #\) stream))
278 (simple-format stream "#<PACKAGE ~a>" (package-name form)))
281 (write-string "#<javascript object>" stream))))
285 (defun write (form &key (stream *standard-output*))
286 (write-aux form stream))
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))
298 (defun prin1-to-string (form)
299 (let ((*print-escape* t))
300 (write-to-string form)))
302 (defun princ-to-string (form)
303 (let ((*print-escape* nil))
304 (write-to-string form)))
307 (write-char #\newline)
310 (defun write-line (x)
315 (defun warn (fmt &rest args)
316 (write-string "WARNING: ")
317 (apply #'format t fmt args)
321 (write-line (prin1-to-string x))
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))
332 (warn "~S is not implemented yet, using ~~S instead" chr)
333 (prin1-to-string arg))))
335 (defun !format (destination fmt &rest args)
336 (let ((len (length fmt))
341 (let ((c (char fmt i)))
343 (let ((next (char fmt (incf i))))
348 (concatf res (string #\newline)))
352 (concatf res (format-special next (car arguments)))
354 (setq res (concat res (string c))))
361 #+jscl (fset 'format (fdefinition '!format))