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 (defvar *print-escape* t)
23 (defun write-to-string (form)
26 (multiple-value-bind (symbol foundp)
27 (find-symbol (symbol-name form) *package*)
28 (if (and foundp (eq symbol form))
30 (let ((package (symbol-package form))
31 (name (symbol-name form)))
34 ((eq package (find-package "KEYWORD")) "")
35 (t (package-name package)))
37 ((integerp form) (integer-to-string form))
38 ((floatp form) (float-to-string form))
44 (otherwise (string form)))))
45 ((stringp form) (concat "\"" (escape-string form) "\""))
47 (let ((name (oget form "fname")))
49 (concat "#<FUNCTION " name ">")
50 (concat "#<FUNCTION>"))))
53 (join-trailing (mapcar #'write-to-string (butlast form)) " ")
54 (let ((last (last form)))
56 (write-to-string (car last))
57 (concat (write-to-string (car last)) " . " (write-to-string (cdr last)))))
60 (concat "#" (if (zerop (length form))
62 (write-to-string (vector-to-list form)))))
64 (concat "#<PACKAGE " (package-name form) ">"))
66 (concat "#<javascript object>"))))
68 (defun prin1-to-string (form)
69 (let ((*print-escape* t))
70 (write-to-string form)))
72 (defun princ-to-string (form)
73 (let ((*print-escape* nil))
74 (write-to-string form)))
78 (write-string *newline*)
82 (write-string "WARNING: ")
86 (write-line (prin1-to-string x))
89 (defun format (destination fmt &rest args)
90 (let ((len (length fmt))
95 (let ((c (char fmt i)))
97 (let ((next (char fmt (incf i))))
100 (setq res (concat res "~")))
102 (setq res (concat res *newline*)))
104 (setq res (concat res (format-special next (car arguments))))
105 (setq arguments (cdr arguments)))))
106 (setq res (concat res (char-to-string c))))
115 (defun format-special (chr arg)
117 (#\S (prin1-to-string arg))
118 (#\a (princ-to-string arg))))