X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fprint.lisp;h=a8ac834dbb42f969dd2678bd937aff63e34812c6;hb=18ada11fb234e336a3d2ac4370d384d80d36f9f0;hp=1544091a0abe1407924b7ad0b9e5113fa6e762c8;hpb=fc970a48c4326a2309ad0efd0b1c557fe25c7413;p=jscl.git

diff --git a/src/print.lisp b/src/print.lisp
index 1544091..a8ac834 100644
--- a/src/print.lisp
+++ b/src/print.lisp
@@ -16,18 +16,34 @@
 ;; You should have received a copy of the GNU General Public License
 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
 
+(/debug "loading print.lisp!")
+
 ;;; Printer
 
+(defun lisp-escape-string (string)
+  (let ((output "")
+        (index 0)
+        (size (length string)))
+    (while (< index size)
+      (let ((ch (char string index)))
+        (when (or (char= ch #\") (char= ch #\\))
+          (setq output (concat output "\\")))
+        (when (or (char= ch #\newline))
+          (setq output (concat output "\\"))
+          (setq ch #\n))
+        (setq output (concat output (string ch))))
+      (incf index))
+    (concat "\"" output "\"")))
+
 ;;; 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)
+(defun escape-symbol-name-p (s)
   (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))))
@@ -36,52 +52,57 @@
 ;;; 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 (s)
-  (let ((i 0)
-        (n (length s))
-        (ch nil))
-    (flet ((next ()
-                 (setf ch (and (< i n) (char s (1- (incf i)))))))
-      (next)
+(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
-       ((null ch) (return-from potential-number-p))
-       ((digit-char-p ch))
-       ((char= ch #\.))
-       ((char= ch #\+) (next))
-       ((char= ch #\-) (next))
-       (t (return-from potential-number-p)))
-      (when ch
-        (while (and ch (digit-char-p ch)) (next))
-        (when (null ch)
-          (return-from potential-number-p 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-p))
-         ((digit-char-p ch))
-         ((char= ch #\+) (next))
-         ((char= ch #\-) (next))
-         (t (return-from potential-number-p)))
-        (unless (and ch (digit-char-p ch))
-          (return-from potential-number-p))
-        (while (and ch (digit-char-p ch)) (next)))
-      (null ch))))
-
-(defun escape-token-p (string &optional uppercase)
+        ;; 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)
   (or (potential-number-p string)
-      (escape-symbol-name-p string uppercase)))
+      (escape-symbol-name-p string)))
 
-;;; Returns the token in a form that can be used for
-;;; reading it back as a symbol in the specified package.
-(defun escape-token (s package)
-  (if (escape-token-p s (not (eq package (find-package "JS"))))
+;;; Returns the token in a form that can be used for reading it back.
+(defun escape-token (s)
+  (if (escape-token-p s)
       (let ((result "|"))
         (dotimes (i (length s))
           (let ((ch (char s i)))
@@ -93,64 +114,139 @@
       s))
 
 (defvar *print-escape* t)
+(defvar *print-circle* nil)
 
-(defun write-to-string (form)
-  (cond
-    ((null form) "NIL")
-    ((symbolp 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) *package*)
-         ;; Symbol is not accesible from *PACKAGE*, so let us prefix
-         ;; the symbol with the optional package or uninterned mark.
-         (let ((package (symbol-package form))
-               (name (symbol-name form)))
-           (concat (cond
-                     ((null package) "#")
-                     ((eq package (find-package "KEYWORD")) "")
-                     (t (package-name package)))
-                   ":"
-                   (if (and package
-                            (eq (second (multiple-value-list
-                                         (find-symbol name package)))
-                                :internal))
-                       ":"
-                       "")
-                   (escape-token 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>"))))
+;;; FIXME: Please, rewrite this in a more organized way.
+(defun write-to-string (form &optional known-objects object-ids)
+  (when (and (not known-objects) *print-circle*)
+    ;; To support *print-circle* some objects must be tracked for
+    ;; sharing: conses, arrays and apparently-uninterned symbols.
+    ;; These objects are placed in an array and a parallel array is
+    ;; used to mark if they're found multiple times by assining them
+    ;; an id starting from 1.
+    ;;
+    ;; After the tracking has been completed the printing phas can
+    ;; begin: if an object has an id > 0 then #<n>= is prefixed and
+    ;; the id is changed to negative. If an object has an id < 0 then
+    ;; #<-n># is printed instead of the object.
+    ;;
+    ;; The processing is O(n^2) with n = number of tracked
+    ;; objects. Hopefully it will become good enough when the new
+    ;; compiler is available.
+    (setf known-objects (make-array 100))
+    (setf object-ids (make-array 100))
+    (let ((n 0)
+          (sz 100)
+          (count 0))
+      (labels ((mark (x)
+                 (let ((i (position x known-objects)))
+                   (if (= i -1)
+                       (progn
+                         (when (= n sz)
+                           (setf sz (* 2 sz))
+                           ;; KLUDGE: storage vectors are an internal
+                           ;; object which the printer should not know
+                           ;; about. Use standard vector with fill
+                           ;; pointers instead.
+                           (resize-storage-vector known-objects sz)
+                           (resize-storage-vector object-ids sz))
+                         (aset known-objects (1- (incf n)) x)
+                         t)
+                       (unless (aref object-ids i)
+                         (aset object-ids i (incf count))
+                         nil))))
+               (visit (x)
+                 (cond
+                   ((and x (symbolp x) (null (symbol-package x)))
+                    (mark x))
+                   ((consp x)
+                    (when (mark x)
+                      (visit (car x))
+                      (visit (cdr x))))
+                   ((vectorp x)
+                    (when (mark x)
+                      (dotimes (i (length x))
+                        (visit (aref x i))))))))
+        (visit form))))
+  (let ((prefix ""))
+    (when (and *print-circle*
+               (or (consp form)
+                   (vectorp form)
+                   (and form (symbolp form) (null (symbol-package form)))))
+      (let* ((ix (position form known-objects))
+             (id (aref object-ids ix)))
+        (cond
+          ((and id (> id 0))
+           (setf prefix (format nil "#~S=" id))
+           (aset object-ids ix (- id)))
+          ((and id (< id 0))
+           (return-from write-to-string (format nil "#~S#" (- id)))))))
+    (concat prefix
+            (cond
+              ((null form) "NIL")
+              ((symbolp form)
+               (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))
+                     ;; 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))))
+                             ":"
+                             (if (and package
+                                      (eq (second (multiple-value-list
+                                                      (find-symbol name package)))
+                                          :internal))
+                                 ":"
+                                 "")
+                             (escape-token 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*
+                                  (lisp-escape-string form)
+                                  form))
+              ((functionp form)
+               (let ((name (oget form "fname")))
+                 (if name
+                     (concat "#<FUNCTION " name ">")
+                     (concat "#<FUNCTION>"))))
+              ((listp form)
+               (concat "("
+                       (join-trailing (mapcar (lambda (x)
+                                                (write-to-string x known-objects object-ids))
+                                              (butlast form)) " ")
+                       (let ((last (last form)))
+                         (if (null (cdr last))
+                             (write-to-string (car last) known-objects object-ids)
+                             (concat (write-to-string (car last) known-objects object-ids)
+                                     " . "
+                                     (write-to-string (cdr last) known-objects object-ids))))
+                       ")"))
+              ((vectorp form)
+               (let ((result "#(")
+                     (sep ""))
+                 (dotimes (i (length form))
+                   (setf result (concat result sep
+                                        (write-to-string (aref form i)
+                                                         known-objects
+                                                         object-ids)))
+                   (setf sep " "))
+                 (concat result ")")))
+              ((packagep form)
+               (concat "#<PACKAGE " (package-name form) ">"))
+              (t "#<javascript object>")))))
 
 (defun prin1-to-string (form)
   (let ((*print-escape* t))
@@ -187,10 +283,12 @@
                 (concatf res "~"))
                ((char= next #\%)
                 (concatf res *newline*))
+               ((char= next #\*)
+                (pop arguments))
                (t
                 (concatf res (format-special next (car arguments)))
                 (pop arguments))))
-            (setq res (concat res (char-to-string c))))
+            (setq res (concat res (string c))))
         (incf i)))
     (if destination
         (progn
@@ -199,6 +297,6 @@
         res)))
 
 (defun format-special (chr arg)
-  (case chr
+  (case (char-upcase chr)
     (#\S (prin1-to-string arg))
-    (#\a (princ-to-string arg))))
+    (#\A (princ-to-string arg))))