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