X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fprint.lisp;h=f0752e94dcdbf5cfb217f206029c4eaeec549f6f;hb=3930890ddbf4e1fbdcc400879ca8245b5cd6c564;hp=9d3693668b475ddd90ff6b0eb3de8f8911f4f282;hpb=261c79ce0f1b20b7f917a4139239facbd3e89eed;p=jscl.git

diff --git a/src/print.lisp b/src/print.lisp
index 9d36936..f0752e9 100644
--- a/src/print.lisp
+++ b/src/print.lisp
@@ -1,24 +1,26 @@
-;;; print.lisp --- 
+;;; print.lisp ---
 
 ;; Copyright (C) 2012, 2013 David Vazquez
 ;; Copyright (C) 2012 Raimon Grau
 
-;; This program is free software: you can redistribute it and/or
+;; JSCL is free software: you can redistribute it and/or
 ;; modify it under the terms of the GNU General Public License as
 ;; published by the Free Software Foundation, either version 3 of the
 ;; License, or (at your option) any later version.
 ;;
-;; This program is distributed in the hope that it will be useful, but
+;; JSCL is distributed in the hope that it will be useful, but
 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 ;; General Public License for more details.
 ;;
 ;; You should have received a copy of the GNU General Public License
-;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
 
 ;;; Printer
 
-(defun prin1-to-string (form)
+(defvar *print-escape* t)
+
+(defun write-to-string (form)
   (cond
     ((symbolp form)
      (multiple-value-bind (symbol foundp)
@@ -33,7 +35,16 @@
                        (t (package-name package)))
                      ":" name)))))
     ((integerp form) (integer-to-string form))
-    ((stringp form) (concat "\"" (escape-string form) "\""))
+    ((floatp form) (float-to-string form))
+    ((characterp form)
+     (concat "#\\"
+             (case form
+               (#\newline "newline")
+               (#\space "space")
+               (otherwise (string form)))))
+    ((stringp form) (if *print-escape*
+			(concat "\"" (escape-string form) "\"")
+			form))
     ((functionp form)
      (let ((name (oget form "fname")))
        (if name
@@ -41,21 +52,29 @@
            (concat "#<FUNCTION>"))))
     ((listp form)
      (concat "("
-             (join-trailing (mapcar #'prin1-to-string (butlast form)) " ")
+             (join-trailing (mapcar #'write-to-string (butlast form)) " ")
              (let ((last (last form)))
                (if (null (cdr last))
-                   (prin1-to-string (car last))
-                   (concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last)))))
+                   (write-to-string (car last))
+                   (concat (write-to-string (car last)) " . " (write-to-string (cdr last)))))
              ")"))
     ((arrayp form)
      (concat "#" (if (zerop (length form))
                      "()"
-                     (prin1-to-string (vector-to-list form)))))
+                     (write-to-string (vector-to-list form)))))
     ((packagep form)
      (concat "#<PACKAGE " (package-name form) ">"))
     (t
      (concat "#<javascript object>"))))
 
+(defun prin1-to-string (form)
+  (let ((*print-escape* t))
+    (write-to-string form)))
+
+(defun princ-to-string (form)
+  (let ((*print-escape* nil))
+    (write-to-string form)))
+
 (defun write-line (x)
   (write-string x)
   (write-string *newline*)
@@ -68,3 +87,34 @@
 (defun print (x)
   (write-line (prin1-to-string x))
   x)
+
+(defun format (destination fmt &rest args)
+  (let ((len (length fmt))
+	(i 0)
+	(res "")
+	(arguments args))
+    (while (< i len)
+      (let ((c (char fmt i)))
+	(if (char= c #\~)
+	    (let ((next (char fmt (incf i))))
+	      (cond
+	       ((char= next #\~)
+		(concatf res "~"))
+	       ((char= next #\%)
+		(concatf res *newline*))
+	       (t
+		(concatf res (format-special next (car arguments)))
+		(pop arguments))))
+	  (setq res (concat res (char-to-string c))))
+	(incf i)))
+    (if destination
+	(progn
+	  (write-string res)
+	  nil)
+      res)))
+
+
+(defun format-special (chr arg)
+  (case chr
+    (#\S (prin1-to-string arg))
+    (#\a (princ-to-string arg))))