write-to-string is available at host via !write-to-string

[jscl.git] / src / print.lisp

diff --git a/src/print.lisp b/src/print.lisp
index f7b558d..e262be1 100644 (file)
--- a/src/print.lisp
+++ b/src/print.lisp
@@ -16,8 +16,25 @@
 ;; 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)
@@ -101,7 +118,7 @@
 (defvar *print-circle* nil)
 
 ;;; FIXME: Please, rewrite this in a more organized way.
-(defun write-to-string (form &optional known-objects object-ids)
+(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.
@@ -164,7 +181,7 @@
            (setf prefix (format nil "#~S=" id))
            (aset object-ids ix (- id)))
           ((and id (< id 0))
-           (return-from write-to-string (format nil "#~S#" (- id)))))))
+           (return-from !write-to-string (format nil "#~S#" (- id)))))))
     (concat prefix
             (cond
               ((null form) "NIL")
@@ -185,7 +202,7 @@
                              ":"
                              (if (and package
                                       (eq (second (multiple-value-list
-                                                      (find-symbol name package)))
+                                                   (find-symbol name package)))
                                           :internal))
                                  ":"
                                  "")
@@ -202,36 +219,41 @@
                                   (lisp-escape-string form)
                                   form))
               ((functionp form)
-               (let ((name (oget form "fname")))
+               (let ((name #+jscl (oget form "fname")
+                           #-jscl "noname"))
                  (if name
                      (concat "#<FUNCTION " name ">")
                      (concat "#<FUNCTION>"))))
               ((listp form)
                (concat "("
                        (join-trailing (mapcar (lambda (x)
-                                                (write-to-string x known-objects object-ids))
+                                                (!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 (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))))
+                                     (!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)))
+                                        (!write-to-string (aref form i)
+                                                          known-objects
+                                                          object-ids)))
                    (setf sep " "))
                  (concat result ")")))
               ((packagep form)
                (concat "#<PACKAGE " (package-name form) ">"))
               (t "#<javascript object>")))))
 
+#+jscl
+(fset 'write-to-string (fdefinition '!write-to-string))
+
+
 (defun prin1-to-string (form)
   (let ((*print-escape* t))
     (write-to-string form)))
@@ -240,14 +262,19 @@
   (let ((*print-escape* nil))
     (write-to-string form)))
 
+(defun terpri ()
+  (write-char #\newline)
+  (values))
+
 (defun write-line (x)
   (write-string x)
-  (write-string *newline*)
+  (terpri)
   x)
 
-(defun warn (string)
+(defun warn (fmt &rest args)
   (write-string "WARNING: ")
-  (write-line string))
+  (apply #'format t fmt args)
+  (terpri))
 
 (defun print (x)
   (write-line (prin1-to-string x))
@@ -266,7 +293,7 @@
                ((char= next #\~)
                 (concatf res "~"))
                ((char= next #\%)
-                (concatf res *newline*))
+                (concatf res (string #\newline)))
                ((char= next #\*)
                 (pop arguments))
                (t
@@ -283,4 +310,8 @@
 (defun format-special (chr arg)
   (case (char-upcase chr)
     (#\S (prin1-to-string arg))
-    (#\A (princ-to-string arg))))
+    (#\A (princ-to-string arg))
+    (#\D (princ-to-string arg))
+    (t
+     (warn "~S is not implemented yet, using ~~S instead" chr)
+     (prin1-to-string arg))))