X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fprint.lisp;h=8a3fd1daf0f8723943a03acaaf674e0f4f58e55e;hb=68cd2db6542fa3442d46b0331ecf8be8f86c09c2;hp=dfa1b694996c84bb5c123d42b0039489caeeeae4;hpb=5f52a049c75fd0eeaa33656785891dea65b55a1f;p=jscl.git

diff --git a/src/print.lisp b/src/print.lisp
index dfa1b69..8a3fd1d 100644
--- 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
@@ -18,29 +18,123 @@
 
 ;;; Printer
 
-(defun prin1-to-string (form)
+;;; Return T if the string S contains characters which need to be
+;;; escaped to print the symbol name, NIL otherwise.
+(defun escape-symbol-name-p (s &optional 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 escape-symbol-name-p t))))
+    dots-only))
+
+;;; Return T if the specified string can be read as a number
+;;; In case such a string is the name of a symbol then escaping
+;;; is required when printing to ensure correct reading.
+(defun potential-number-p (string)
+  ;; The four rules for being a potential number are described in
+  ;; 2.3.1.1 Potential Numbers as Token
+  ;;
+  ;; First Rule
+  (dotimes (i (length string))
+    (let ((char (char string i)))
+      (cond
+        ;; Digits TODO: DIGIT-CHAR-P should work with the current
+        ;; radix here. If the radix is not decimal, then we have to
+        ;; make sure there is not a decimal-point in the string.
+        ((digit-char-p char))
+        ;; Signs, ratios, decimal point and extension mark
+        ((find char "+-/._^"))
+        ;; Number marker
+        ((alpha-char-p char)
+         (when (and (< i (1- (length string)))
+                    (alpha-char-p (char string (1+ i))))
+           ;; fail: adjacent letters are not number marker, or
+           ;; there is a decimal point in the string.
+           (return-from potential-number-p)))
+        (t
+         ;; fail: there is a non-allowed character
+         (return-from potential-number-p)))))
+  (and
+   ;; Second Rule. In particular string is not empty.
+   (find-if #'digit-char-p string)
+   ;; Third rule
+   (let ((first (char string 0)))
+     (and (not (char= first #\:))
+          (or (digit-char-p first)
+              (find first "+-._^"))))
+   ;; Fourth rule
+   (not (find (char string (1- (length string))) "+-)"))))
+
+#+nil
+(mapcar #'potential-number-p
+        '("1b5000" "777777q" "1.7J" "-3/4+6.7J" "12/25/83" "27^19"
+          "3^4/5" "6//7" "3.1.2.6" "^-43^" "3.141_592_653_589_793_238_4"
+          "-3.7+2.6i-6.17j+19.6k"))
+
+#+nil
+(mapcar #'potential-number-p '("/" "/5" "+" "1+" "1-" "foo+" "ab.cd" "_" "^" "^/-"))
+
+(defun escape-token-p (string &optional uppercase)
+  (or (potential-number-p string)
+      (escape-symbol-name-p string uppercase)))
+
+;;; Returns the token in a form that can be used for reading it back.
+(defun escape-token (s &optional uppercase)
+  (if (escape-token-p s uppercase)
+      (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
+    ((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)
-           (let ((package (symbol-package form))
-                 (name (symbol-name form)))
-             (concat (cond
-                       ((null package) "#")
-                       ((eq package (find-package "KEYWORD")) "")
-                       (t (package-name package)))
-                     ":" name)))))
+     (let ((name (symbol-name form))
+           (package (symbol-package form)))
+       ;; Check if the symbol is accesible from the current package. It
+       ;; is true even if the symbol's home package is not the current
+       ;; package, because it could be inherited.
+       (if (eq form (find-symbol (symbol-name form)))
+           (escape-token (symbol-name form) (not (eq package *js-package*)))
+           ;; Symbol is not accesible from *PACKAGE*, so let us prefix
+           ;; the symbol with the optional package or uninterned mark.
+           (concat (cond
+                     ((null package) "#")
+                     ((eq package (find-package "KEYWORD")) "")
+                     (t (escape-token (package-name package) t)))
+                   ":"
+                   (if (and package
+                            (eq (second (multiple-value-list
+                                         (find-symbol name package)))
+                                :internal))
+                       ":"
+                       "")
+                   (escape-token name (not (eq package *js-package*)))))))
     ((integerp form) (integer-to-string form))
     ((floatp form) (float-to-string form))
     ((characterp form)
-     (concat "#\\" 
+     (concat "#\\"
              (case form
                (#\newline "newline")
                (#\space "space")
                (otherwise (string form)))))
-    ((stringp form) (concat "\"" (escape-string form) "\""))
+    ((stringp form) (if *print-escape*
+                        (concat "\"" (escape-string form) "\"")
+                        form))
     ((functionp form)
      (let ((name (oget form "fname")))
        (if name
@@ -48,21 +142,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*)
@@ -75,3 +177,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))))