src/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 (defun potential-number-p (s)
  37   (let ((i 0)
  38         (n (length s))
  39         (ch nil))
  40     (flet ((next ()
  41                  (setf ch (and (< i n) (char s (1- (incf i)))))))
  42       (next)
  43       (cond
  44        ((null ch) (return-from potential-number-p))
  45        ((digit-char-p ch))
  46        ((char= ch #\.))
  47        ((char= ch #\+) (next))
  48        ((char= ch #\-) (next))
  49        (t (return-from potential-number-p)))
  50       (when ch
  51         (while (and ch (digit-char-p ch)) (next))
  52         (when (null ch)
  53           (return-from potential-number-p t)))
  54       (when (char= ch #\.)
  55         (next)
  56         (when ch
  57           (while (and ch (digit-char-p ch)) (next))))
  58       (when (or (char= ch #\E) (char= ch #\e)
  59                 (char= ch #\D) (char= ch #\d)
  60                 (char= ch #\F) (char= ch #\f)
  61                 (char= ch #\L) (char= ch #\l))
  62         (next)
  63         (cond
  64          ((null ch) (return-from potential-number-p))
  65          ((digit-char-p ch))
  66          ((char= ch #\+) (next))
  67          ((char= ch #\-) (next))
  68          (t (return-from potential-number-p)))
  69         (unless (and ch (digit-char-p ch))
  70           (return-from potential-number-p))
  71         (while (and ch (digit-char-p ch)) (next)))
  72       (null ch))))
  73
  74 (defun escape-token-p (string &optional uppercase)
  75   (or (potential-number-p string)
  76       (escape-symbol-name-p string uppercase)))
  77
  78 (defun escape-token (s &optional uppercase)
  79   (if (escape-token-p s uppercase)
  80       (let ((result "|"))
  81         (dotimes (i (length s))
  82           (let ((ch (char s i)))
  83             (when (or (char= ch #\|)
  84                       (char= ch #\\))
  85               (setf result (concat result "\\")))
  86             (setf result (concat result (string ch)))))
  87         (concat result "|"))
  88       s))
  89
  90
  91 (defvar *print-escape* t)
  92
  93 (defun write-to-string (form)
  94   (cond
  95     ((null form) "NIL")
  96     ((symbolp form)
  97      (let ((name (symbol-name form))
  98            (package (symbol-package form)))
  99        (if (eq package *package*)
 100            (escape-token (symbol-name form) (not (eq package *js-package*)))
 101            (concat (cond
 102                      ((null package) "#")
 103                      ((eq package (find-package "KEYWORD")) "")
 104                      (t (escape-token (package-name package) t)))
 105                    ":"
 106                    (if (or (null package)
 107                            (multiple-value-bind (_ status)
 108                                (find-symbol name package)
 109                              (eq status :external)))
 110                        "" ":")
 111                    (escape-token name (not (eq (symbol-package form) *js-package*)))))))
 112     ((integerp form) (integer-to-string form))
 113     ((floatp form) (float-to-string form))
 114     ((characterp form)
 115      (concat "#\\"
 116              (case form
 117                (#\newline "newline")
 118                (#\space "space")
 119                (otherwise (string form)))))
 120     ((stringp form) (if *print-escape*
 121                         (concat "\"" (escape-string form) "\"")
 122                         form))
 123     ((functionp form)
 124      (let ((name (oget form "fname")))
 125        (if name
 126            (concat "#<FUNCTION " name ">")
 127            (concat "#<FUNCTION>"))))
 128     ((listp form)
 129      (concat "("
 130              (join-trailing (mapcar #'write-to-string (butlast form)) " ")
 131              (let ((last (last form)))
 132                (if (null (cdr last))
 133                    (write-to-string (car last))
 134                    (concat (write-to-string (car last)) " . " (write-to-string (cdr last)))))
 135              ")"))
 136     ((arrayp form)
 137      (concat "#" (if (zerop (length form))
 138                      "()"
 139                      (write-to-string (vector-to-list form)))))
 140     ((packagep form)
 141      (concat "#<PACKAGE " (package-name form) ">"))
 142     (t
 143      (concat "#<javascript object>"))))
 144
 145 (defun prin1-to-string (form)
 146   (let ((*print-escape* t))
 147     (write-to-string form)))
 148
 149 (defun princ-to-string (form)
 150   (let ((*print-escape* nil))
 151     (write-to-string form)))
 152
 153 (defun write-line (x)
 154   (write-string x)
 155   (write-string *newline*)
 156   x)
 157
 158 (defun warn (string)
 159   (write-string "WARNING: ")
 160   (write-line string))
 161
 162 (defun print (x)
 163   (write-line (prin1-to-string x))
 164   x)
 165
 166 (defun format (destination fmt &rest args)
 167   (let ((len (length fmt))
 168         (i 0)
 169         (res "")
 170         (arguments args))
 171     (while (< i len)
 172       (let ((c (char fmt i)))
 173         (if (char= c #\~)
 174             (let ((next (char fmt (incf i))))
 175               (cond
 176                ((char= next #\~)
 177                 (concatf res "~"))
 178                ((char= next #\%)
 179                 (concatf res *newline*))
 180                (t
 181                 (concatf res (format-special next (car arguments)))
 182                 (pop arguments))))
 183             (setq res (concat res (char-to-string c))))
 184         (incf i)))
 185     (if destination
 186         (progn
 187           (write-string res)
 188           nil)
 189         res)))
 190
 191 (defun format-special (chr arg)
 192   (case chr
 193     (#\S (prin1-to-string arg))
 194     (#\a (princ-to-string arg))))