X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fprint.lisp;h=1718b823ca2be419056f01ba73913f793f03e49d;hb=2ff4cf0a60d5187b27bc07c6bcfdef88cc89f22b;hp=f0752e94dcdbf5cfb217f206029c4eaeec549f6f;hpb=0c6d6e73af9834ba1eb5d7c5e4325006febfa295;p=jscl.git

diff --git a/src/print.lisp b/src/print.lisp
index f0752e9..1718b82 100644
--- a/src/print.lisp
+++ b/src/print.lisp
@@ -18,54 +18,125 @@
 
 ;;; Printer
 
+(defun special-symbol-name (s &key uppercase)
+  (let ((dots-only t))
+    (dotimes (i (length s))
+      (let ((ch (char s i)))
+        (setf dots-only (and dots-only (char= ch #\.)))
+        (when (or (terminalp ch)
+                  (char= ch #\:)
+                  (and uppercase (not (char= ch (char (string-upcase (string ch)) 0))))
+                  (char= ch #\\)
+                  (char= ch #\|))
+          (return-from special-symbol-name t))))
+    dots-only))
+
+(defun potential-number (s)
+  (let ((i 0)
+        (n (length s))
+        (ch nil))
+    (flet ((next ()
+                 (setf ch (and (< i n) (char s (1- (incf i)))))))
+      (next)
+      (cond
+       ((null ch) (return-from potential-number))
+       ((digit-char-p ch))
+       ((char= ch #\.))
+       ((char= ch #\+) (next))
+       ((char= ch #\-) (next))
+       (t (return-from potential-number)))
+      (when ch
+        (while (and ch (digit-char-p ch)) (next))
+        (when (null ch)
+          (return-from potential-number t)))
+      (when (char= ch #\.)
+        (next)
+        (when ch
+          (while (and ch (digit-char-p ch)) (next))))
+      (when (or (char= ch #\E) (char= ch #\e)
+                (char= ch #\D) (char= ch #\d)
+                (char= ch #\F) (char= ch #\f)
+                (char= ch #\L) (char= ch #\l))
+        (next)
+        (cond
+         ((null ch) (return-from potential-number))
+         ((digit-char-p ch))
+         ((char= ch #\+) (next))
+         ((char= ch #\-) (next))
+         (t (return-from potential-number)))
+        (unless (and ch (digit-char-p ch))
+          (return-from potential-number))
+        (while (and ch (digit-char-p ch)) (next)))
+      (null ch))))
+
+(defun special-escape (s package)
+  (if (or (potential-number s)
+          (special-symbol-name s :uppercase (not (eq package (find-package "JS")))))
+      (let ((result "|"))
+        (dotimes (i (length s))
+          (let ((ch (char s i)))
+            (when (or (char= ch #\|)
+                      (char= ch #\\))
+              (setf result (concat result "\\")))
+            (setf result (concat result (string ch)))))
+        (concat result "|"))
+      s))
+
 (defvar *print-escape* t)
 
 (defun write-to-string (form)
   (cond
-    ((symbolp form)
-     (multiple-value-bind (symbol foundp)
-         (find-symbol (symbol-name form) *package*)
-       (if (and foundp (eq symbol form))
-           (symbol-name form)
-           (let ((package (symbol-package form))
-                 (name (symbol-name form)))
-             (concat (cond
-                       ((null package) "#")
-                       ((eq package (find-package "KEYWORD")) "")
-                       (t (package-name package)))
-                     ":" name)))))
-    ((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>"))))
+   ((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))
@@ -90,29 +161,28 @@
 
 (defun format (destination fmt &rest args)
   (let ((len (length fmt))
-	(i 0)
-	(res "")
-	(arguments args))
+        (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 (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)))
-
+        (progn
+          (write-string res)
+          nil)
+        res)))
 
 (defun format-special (chr arg)
   (case chr