From: Andrea Griffini <agriff@tin.it>
Date: Thu, 2 May 2013 17:57:49 +0000 (+0200)
Subject: wip printer
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=cbe9ba2949ffb4d81e3fa10c5d2e0196f667b7b7;p=jscl.git

wip printer
---

diff --git a/src/print.lisp b/src/print.lisp
index dfa1b69..f60d068 100644
--- a/src/print.lisp
+++ b/src/print.lisp
@@ -18,24 +18,94 @@
 
 ;;; 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))
+
 (defun prin1-to-string (form)
   (cond
+    ((null form) "NIL")
     ((symbolp form)
-     (multiple-value-bind (symbol foundp)
-         (find-symbol (symbol-name form) *package*)
-       (if (and foundp (eq symbol form))
-           (symbol-name 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)))
-                     ":" name)))))
+                      ((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 "#\\" 
+     (concat "#\\"
              (case form
                (#\newline "newline")
                (#\space "space")
diff --git a/src/read.lisp b/src/read.lisp
index 7478b37..0d24d25 100644
--- a/src/read.lisp
+++ b/src/read.lisp
@@ -45,7 +45,7 @@
       (setq ch (%peek-char stream)))))
 
 (defun terminalp (ch)
-  (or (null ch) (whitespacep ch) (char= #\) ch) (char= #\( ch)))
+  (or (null ch) (whitespacep ch) (char= #\" ch) (char= #\) ch) (char= #\( ch)))
 
 (defun read-until (stream func)
   (let ((string "")
diff --git a/tests/print.lisp b/tests/print.lisp
new file mode 100644
index 0000000..efb3843
--- /dev/null
+++ b/tests/print.lisp
@@ -0,0 +1,3 @@
+(dolist (s '(foo  fo\o 1..2 \1 \-10 \.\.\. 1E \1E+2 1E+))
+  (test (let ((x (read-from-string (prin1-to-string 'foo))))
+          (and (symbolp x) (equal (symbol-name x) (symbol-name 'foo))))))