print.lisp

   1 ;;; print.lisp ---
   2
   3 ;; Copyright (C) 2012, 2013 David Vazquez
   4 ;; Copyright (C) 2012 Raimon Grau
   5
   6 ;; JSCL is free software: you can redistribute it and/or
   7 ;; modify it under the terms of the GNU General Public License as
   8 ;; published by the Free Software Foundation, either version 3 of the
   9 ;; License, or (at your option) any later version.
  10 ;;
  11 ;; JSCL is distributed in the hope that it will be useful, but
  12 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;; General Public License for more details.
  15 ;;
  16 ;; You should have received a copy of the GNU General Public License
  17 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 ;;; Printer
  20
  21 ;;; Return T if the string S contains characters which need to be
  22 ;;; escaped to print the symbol name, NIL otherwise.
  23 (defun escape-symbol-name-p (s &optional uppercase)
  24   (let ((dots-only t))
  25     (dotimes (i (length s))
  26       (let ((ch (char s i)))
  27         (setf dots-only (and dots-only (char= ch #\.)))
  28         (when (or (terminalp ch)
  29                   (char= ch #\:)
  30                   (and uppercase (not (char= ch (char (string-upcase (string ch)) 0))))
  31                   (char= ch #\\)
  32                   (char= ch #\|))
  33           (return-from escape-symbol-name-p t))))
  34     dots-only))
  35
  36 ;;; Return T if the specified string can be read as a number
  37 ;;; In case such a string is the name of a symbol then escaping
  38 ;;; is required when printing to ensure correct reading.
  39 (defun potential-number-p (s)
  40   (let ((i 0)
  41         (n (length s))
  42         (ch nil))
  43     (flet ((next ()
  44                  (setf ch (and (< i n) (char s (1- (incf i)))))))
  45       (next)
  46       (cond
  47        ((null ch) (return-from potential-number-p))
  48        ((digit-char-p ch))
  49        ((char= ch #\.))
  50        ((char= ch #\+) (next))
  51        ((char= ch #\-) (next))
  52        (t (return-from potential-number-p)))
  53       (when ch
  54         (while (and ch (digit-char-p ch)) (next))
  55         (when (null ch)
  56           (return-from potential-number-p t)))
  57       (when (char= ch #\.)
  58         (next)
  59         (when ch
  60           (while (and ch (digit-char-p ch)) (next))))
  61       (when (or (char= ch #\E) (char= ch #\e)
  62                 (char= ch #\D) (char= ch #\d)
  63                 (char= ch #\F) (char= ch #\f)
  64                 (char= ch #\L) (char= ch #\l))
  65         (next)
  66         (cond
  67          ((null ch) (return-from potential-number-p))
  68          ((digit-char-p ch))
  69          ((char= ch #\+) (next))
  70          ((char= ch #\-) (next))
  71          (t (return-from potential-number-p)))
  72         (unless (and ch (digit-char-p ch))
  73           (return-from potential-number-p))
  74         (while (and ch (digit-char-p ch)) (next)))
  75       (null ch))))
  76
  77 (defun escape-token-p (string &optional uppercase)
  78   (or (potential-number-p string)
  79       (escape-symbol-name-p string uppercase)))
  80
  81 ;;; Returns the token in a form that can be used for
  82 ;;; reading it back as a symbol in the specified package.
  83 (defun escape-token (s package)
  84   (if (escape-token-p s (not (eq package (find-package "JS"))))
  85       (let ((result "|"))
  86         (dotimes (i (length s))
  87           (let ((ch (char s i)))
  88             (when (or (char= ch #\|)
  89                       (char= ch #\\))
  90               (setf result (concat result "\\")))
  91             (setf result (concat result (string ch)))))
  92         (concat result "|"))
  93       s))
  94
  95 (defvar *print-escape* t)
  96
  97 (defun write-to-string (form)
  98   (cond
  99     ((null form) "NIL")
 100     ((symbolp form)
 101      ;; Check if the symbol is accesible from the current package. It
 102      ;; is true even if the symbol's home package is not the current
 103      ;; package, because it could be inherited.
 104      (if (eq form (find-symbol (symbol-name form)))
 105          (escape-token (symbol-name form) *package*)
 106          ;; Symbol is not accesible from *PACKAGE*, so let us prefix
 107          ;; the symbol with the optional package or uninterned mark.
 108          (let ((package (symbol-package form))
 109                (name (symbol-name form)))
 110            (concat (cond
 111                      ((null package) "#")
 112                      ((eq package (find-package "KEYWORD")) "")
 113                      (t (package-name package)))
 114                    ":"
 115                    (if (and package
 116                             (eq (second (multiple-value-list
 117                                          (find-symbol name package)))
 118                                 :internal))
 119                        ":"
 120                        "")
 121                    (escape-token name package)))))
 122     ((integerp form) (integer-to-string form))
 123     ((floatp form) (float-to-string form))
 124     ((characterp form)
 125      (concat "#\\"
 126              (case form
 127                (#\newline "newline")
 128                (#\space "space")
 129                (otherwise (string form)))))
 130     ((stringp form) (if *print-escape*
 131                         (concat "\"" (escape-string form) "\"")
 132                         form))
 133     ((functionp form)
 134      (let ((name (oget form "fname")))
 135        (if name
 136            (concat "#<FUNCTION " name ">")
 137            (concat "#<FUNCTION>"))))
 138     ((listp form)
 139      (concat "("
 140              (join-trailing (mapcar #'write-to-string (butlast form)) " ")
 141              (let ((last (last form)))
 142                (if (null (cdr last))
 143                    (write-to-string (car last))
 144                    (concat (write-to-string (car last)) " . " (write-to-string (cdr last)))))
 145              ")"))
 146     ((arrayp form)
 147      (concat "#" (if (zerop (length form))
 148                      "()"
 149                      (write-to-string (vector-to-list form)))))
 150     ((packagep form)
 151      (concat "#<PACKAGE " (package-name form) ">"))
 152     (t
 153      (concat "#<javascript object>"))))
 154
 155 (defun prin1-to-string (form)
 156   (let ((*print-escape* t))
 157     (write-to-string form)))
 158
 159 (defun princ-to-string (form)
 160   (let ((*print-escape* nil))
 161     (write-to-string form)))
 162
 163 (defun write-line (x)
 164   (write-string x)
 165   (write-string *newline*)
 166   x)
 167
 168 (defun warn (string)
 169   (write-string "WARNING: ")
 170   (write-line string))
 171
 172 (defun print (x)
 173   (write-line (prin1-to-string x))
 174   x)
 175
 176 (defun format (destination fmt &rest args)
 177   (let ((len (length fmt))
 178         (i 0)
 179         (res "")
 180         (arguments args))
 181     (while (< i len)
 182       (let ((c (char fmt i)))
 183         (if (char= c #\~)
 184             (let ((next (char fmt (incf i))))
 185               (cond
 186                ((char= next #\~)
 187                 (concatf res "~"))
 188                ((char= next #\%)
 189                 (concatf res *newline*))
 190                (t
 191                 (concatf res (format-special next (car arguments)))
 192                 (pop arguments))))
 193             (setq res (concat res (char-to-string c))))
 194         (incf i)))
 195     (if destination
 196         (progn
 197           (write-string res)
 198           nil)
 199         res)))
 200
 201 (defun format-special (chr arg)
 202   (case chr
 203     (#\S (prin1-to-string arg))
 204     (#\a (princ-to-string arg))))