From: Andrea Griffini <agriff@tin.it>
Date: Fri, 3 May 2013 17:49:03 +0000 (+0200)
Subject: merged trunk
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=9d06dad66c317af94030e12a8d316b9777164a2f;p=jscl.git

merged trunk
---

9d06dad66c317af94030e12a8d316b9777164a2f
diff --cc src/print.lisp
index f60d068,f0752e9..565d554
--- a/src/print.lisp
+++ b/src/print.lisp
@@@ -18,120 -18,62 +18,134 @@@
  
  ;;; 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)))))))
++                 (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)
++  (return-from special-escape s)
 +  (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)
+ (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>"))))
 -     (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))
+     (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 -87,34 +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))
++        (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
+     (#\S (prin1-to-string arg))
+     (#\a (princ-to-string arg))))
diff --cc tests/print.lisp
index efb3843,0000000..786d6d3
mode 100644,000000..100644
--- a/tests/print.lisp
+++ b/tests/print.lisp
@@@ -1,3 -1,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))))))
++(dolist (s '(foo fo\o 1..2 \1 \-10 \.\.\. 1E \1E+2 1E+))
++  (test (let ((x (read-from-string (prin1-to-string s))))
++          (and (symbolp x) (equal (symbol-name x) (symbol-name s))))))