merged trunk

[jscl.git] / src / print.lisp

diff --git a/src/print.lisp b/src/print.lisp
index f60d068..565d554 100644 (file)
--- a/src/print.lisp
+++ b/src/print.lisp
@@ -1,4 +1,4 @@
-;;; print.lisp --- 
+;;; print.lisp ---
 
 ;; Copyright (C) 2012, 2013 David Vazquez
 ;; Copyright (C) 2012 Raimon Grau
@@ -36,7 +36,7 @@
         (n (length s))
         (ch nil))
     (flet ((next ()
-             (setf ch (and (< i n) (char s (1- (incf i)))))))
+                 (setf ch (and (< i n) (char s (1- (incf i)))))))
       (next)
       (cond
        ((null ch) (return-from potential-number))
@@ -70,6 +70,7 @@
       (null ch))))
 
 (defun special-escape (s package)
+  (return-from special-escape s)
   (if (or (potential-number s)
           (special-symbol-name s :uppercase (not (eq package (find-package "JS")))))
       (let ((result "|"))
@@ -82,56 +83,69 @@
         (concat result "|"))
       s))
 
-(defun prin1-to-string (form)
+(defvar *print-escape* t)
+
+(defun write-to-string (form)
   (cond
-    ((null form) "NIL")
-    ((symbolp form)
-     (multiple-value-bind (found-symbol status)
-         (find-symbol (symbol-name form))
-       (if (eq found-symbol form)
-           (special-escape (symbol-name form) *package*)
-           (let ((package (symbol-package form))
-                 (name (symbol-name form)))
-             (concat (cond
-                      ((null package) "#")
-                      ((eq package (find-package "KEYWORD")) "")
-                      (t (package-name package)))
-                     ":"
-                     (if (eq (cadr (multiple-value-list (find-symbol name package)))
-                             :internal)
-                         ":"
-                         "")
-                     (special-escape name package))))))
-    ((integerp form) (integer-to-string form))
-    ((floatp form) (float-to-string form))
-    ((characterp form)
-     (concat "#\\"
-             (case form
-               (#\newline "newline")
-               (#\space "space")
-               (otherwise (string form)))))
-    ((stringp form) (concat "\"" (escape-string form) "\""))
-    ((functionp form)
-     (let ((name (oget form "fname")))
-       (if name
-           (concat "#<FUNCTION " name ">")
-           (concat "#<FUNCTION>"))))
-    ((listp form)
-     (concat "("
-             (join-trailing (mapcar #'prin1-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)))))
-             ")"))
-    ((arrayp form)
-     (concat "#" (if (zerop (length form))
-                     "()"
-                     (prin1-to-string (vector-to-list form)))))
-    ((packagep form)
-     (concat "#<PACKAGE " (package-name form) ">"))
-    (t
-     (concat "#<javascript object>"))))
+   ((null form) "NIL")
+   ((symbolp form)
+    (multiple-value-bind (found-symbol status)
+        (find-symbol (symbol-name form))
+      (if (eq found-symbol form)
+          (special-escape (symbol-name form) *package*)
+          (let ((package (symbol-package form))
+                (name (symbol-name form)))
+            (concat (cond
+                     ((null package) "#")
+                     ((eq package (find-package "KEYWORD")) "")
+                     (t (package-name package)))
+                    ":"
+                    (if (eq (cadr (multiple-value-list
+                                   (find-symbol name)))
+                            :internal)
+                        ":"
+                        "")
+                    (special-escape name package))))))
+   ((integerp form) (integer-to-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
+          (concat "#<FUNCTION " name ">")
+          (concat "#<FUNCTION>"))))
+   ((listp form)
+    (concat "("
+            (join-trailing (mapcar #'write-to-string (butlast form)) " ")
+            (let ((last (last form)))
+              (if (null (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))
+                    "()"
+                    (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)
@@ -145,3 +159,33 @@
 (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))))