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/>.
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)
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)
30 (and uppercase (not (char= ch (char (string-upcase (string ch)) 0))))
33 (return-from escape-symbol-name-p t))))
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
44 (dotimes (i (length string))
45 (let ((char (char string i)))
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.
51 ;; Signs, ratios, decimal point and extension mark
52 ((find 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)))
61 ;; fail: there is a non-allowed character
62 (return-from potential-number-p)))))
64 ;; Second Rule. In particular string is not empty.
65 (find-if #'digit-char-p string)
67 (let ((first (char string 0)))
68 (and (not (char= first #\:))
69 (or (digit-char-p first)
70 (find first "+-._^"))))
72 (not (find (char string (1- (length string))) "+-)"))))
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"))
81 (mapcar #'potential-number-p '("/" "/5" "+" "1+" "1-" "foo+" "ab.cd" "_" "^" "^/-"))
83 (defun escape-token-p (string &optional uppercase)
84 (or (potential-number-p string)
85 (escape-symbol-name-p string uppercase)))
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)
91 (dotimes (i (length s))
92 (let ((ch (char s i)))
93 (when (or (char= ch #\|)
95 (setf result (concat result "\\")))
96 (setf result (concat result (string ch)))))
100 (defvar *print-escape* t)
102 (defun write-to-string (form)
106 (let ((name (symbol-name form))
107 (package (symbol-package form)))
108 ;; Check if the symbol is accesible from the current package. It
109 ;; is true even if the symbol's home package is not the current
110 ;; package, because it could be inherited.
111 (if (eq form (find-symbol (symbol-name form)))
112 (escape-token (symbol-name form) (not (eq package *js-package*)))
113 ;; Symbol is not accesible from *PACKAGE*, so let us prefix
114 ;; the symbol with the optional package or uninterned mark.
117 ((eq package (find-package "KEYWORD")) "")
118 (t (escape-token (package-name package) t)))
121 (eq (second (multiple-value-list
122 (find-symbol name package)))
126 (escape-token name (not (eq package *js-package*)))))))
127 ((integerp form) (integer-to-string form))
128 ((floatp form) (float-to-string form))
132 (#\newline "newline")
134 (otherwise (string form)))))
135 ((stringp form) (if *print-escape*
136 (concat "\"" (escape-string form) "\"")
139 (let ((name (oget form "fname")))
141 (concat "#<FUNCTION " name ">")
142 (concat "#<FUNCTION>"))))
145 (join-trailing (mapcar #'write-to-string (butlast form)) " ")
146 (let ((last (last form)))
147 (if (null (cdr last))
148 (write-to-string (car last))
149 (concat (write-to-string (car last)) " . " (write-to-string (cdr last)))))
152 (concat "#" (if (zerop (length form))
154 (write-to-string (vector-to-list form)))))
156 (concat "#<PACKAGE " (package-name form) ">"))
158 (concat "#<javascript object>"))))
160 (defun prin1-to-string (form)
161 (let ((*print-escape* t))
162 (write-to-string form)))
164 (defun princ-to-string (form)
165 (let ((*print-escape* nil))
166 (write-to-string form)))
168 (defun write-line (x)
170 (write-string *newline*)
174 (write-string "WARNING: ")
178 (write-line (prin1-to-string x))
181 (defun format (destination fmt &rest args)
182 (let ((len (length fmt))
187 (let ((c (char fmt i)))
189 (let ((next (char fmt (incf i))))
194 (concatf res *newline*))
196 (concatf res (format-special next (car arguments)))
198 (setq res (concat res (char-to-string c))))
206 (defun format-special (chr arg)
208 (#\S (prin1-to-string arg))
209 (#\a (princ-to-string arg))))