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 ;;; 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 (string)
  40   ;; The four rules for being a potential number are described in
  41   ;; 2.3.1.1 Potential Numbers as Token
  42   ;;
  43   ;; First Rule
  44   (dotimes (i (length string))
  45     (let ((char (char string i)))
  46       (cond
  47         ;; Digits TODO: DIGIT-CHAR-P should work with the current
  48         ;; radix here. If the radix is not decimal, then we have to
  49         ;; make sure there is not a decimal-point in the string.
  50         ((digit-char-p char))
  51         ;; Signs, ratios, decimal point and extension mark
  52         ((find char "+-/._^"))
  53         ;; Number marker
  54         ((alpha-char-p char)
  55          (when (and (< i (1- (length string)))
  56                     (alpha-char-p (char string (1+ i))))
  57            ;; fail: adjacent letters are not number marker, or
  58            ;; there is a decimal point in the string.
  59            (return-from potential-number-p)))
  60         (t
  61          ;; fail: there is a non-allowed character
  62          (return-from potential-number-p)))))
  63   (and
  64    ;; Second Rule. In particular string is not empty.
  65    (find-if #'digit-char-p string)
  66    ;; Third rule
  67    (let ((first (char string 0)))
  68      (and (not (char= first #\:))
  69           (or (digit-char-p first)
  70               (find first "+-._^"))))
  71    ;; Fourth rule
  72    (not (find (char string (1- (length string))) "+-)"))))
  73
  74 #+nil
  75 (mapcar #'potential-number-p
  76         '("1b5000" "777777q" "1.7J" "-3/4+6.7J" "12/25/83" "27^19"
  77           "3^4/5" "6//7" "3.1.2.6" "^-43^" "3.141_592_653_589_793_238_4"
  78           "-3.7+2.6i-6.17j+19.6k"))
  79
  80 #+nil
  81 (mapcar #'potential-number-p '("/" "/5" "+" "1+" "1-" "foo+" "ab.cd" "_" "^" "^/-"))
  82
  83 (defun escape-token-p (string &optional uppercase)
  84   (or (potential-number-p string)
  85       (escape-symbol-name-p string uppercase)))
  86
  87 ;;; Returns the token in a form that can be used for reading it back.
  88 (defun escape-token (s &optional uppercase)
  89   (if (escape-token-p s uppercase)
  90       (let ((result "|"))
  91         (dotimes (i (length s))
  92           (let ((ch (char s i)))
  93             (when (or (char= ch #\|)
  94                       (char= ch #\\))
  95               (setf result (concat result "\\")))
  96             (setf result (concat result (string ch)))))
  97         (concat result "|"))
  98       s))
  99
 100 (defvar *print-escape* t)
 101
 102 (defun write-to-string (form)
 103   (cond
 104     ((null form) "NIL")
 105     ((symbolp form)
 106      (let ((name (symbol-name form))
 107            (package (symbol-package form)))
 108        ;; Check if the symbol is accesible from the current package. It
 109        ;; is true even if the symbol's home package is not the current
 110        ;; package, because it could be inherited.
 111        (if (eq form (find-symbol (symbol-name form)))
 112            (escape-token (symbol-name form) (not (eq package *js-package*)))
 113            ;; Symbol is not accesible from *PACKAGE*, so let us prefix
 114            ;; the symbol with the optional package or uninterned mark.
 115            (concat (cond
 116                      ((null package) "#")
 117                      ((eq package (find-package "KEYWORD")) "")
 118                      (t (escape-token (package-name package) t)))
 119                    ":"
 120                    (if (and package
 121                             (eq (second (multiple-value-list
 122                                          (find-symbol name package)))
 123                                 :internal))
 124                        ":"
 125                        "")
 126                    (escape-token name (not (eq package *js-package*)))))))
 127     ((integerp form) (integer-to-string form))
 128     ((floatp form) (float-to-string form))
 129     ((characterp form)
 130      (concat "#\\"
 131              (case form
 132                (#\newline "newline")
 133                (#\space "space")
 134                (otherwise (string form)))))
 135     ((stringp form) (if *print-escape*
 136                         (concat "\"" (escape-string form) "\"")
 137                         form))
 138     ((functionp form)
 139      (let ((name (oget form "fname")))
 140        (if name
 141            (concat "#<FUNCTION " name ">")
 142            (concat "#<FUNCTION>"))))
 143     ((listp form)
 144      (concat "("
 145              (join-trailing (mapcar #'write-to-string (butlast form)) " ")
 146              (let ((last (last form)))
 147                (if (null (cdr last))
 148                    (write-to-string (car last))
 149                    (concat (write-to-string (car last)) " . " (write-to-string (cdr last)))))
 150              ")"))
 151     ((arrayp form)
 152      (concat "#" (if (zerop (length form))
 153                      "()"
 154                      (write-to-string (vector-to-list form)))))
 155     ((packagep form)
 156      (concat "#<PACKAGE " (package-name form) ">"))
 157     (t
 158      (concat "#<javascript object>"))))
 159
 160 (defun prin1-to-string (form)
 161   (let ((*print-escape* t))
 162     (write-to-string form)))
 163
 164 (defun princ-to-string (form)
 165   (let ((*print-escape* nil))
 166     (write-to-string form)))
 167
 168 (defun write-line (x)
 169   (write-string x)
 170   (write-string *newline*)
 171   x)
 172
 173 (defun warn (string)
 174   (write-string "WARNING: ")
 175   (write-line string))
 176
 177 (defun print (x)
 178   (write-line (prin1-to-string x))
 179   x)
 180
 181 (defun format (destination fmt &rest args)
 182   (let ((len (length fmt))
 183         (i 0)
 184         (res "")
 185         (arguments args))
 186     (while (< i len)
 187       (let ((c (char fmt i)))
 188         (if (char= c #\~)
 189             (let ((next (char fmt (incf i))))
 190               (cond
 191                ((char= next #\~)
 192                 (concatf res "~"))
 193                ((char= next #\%)
 194                 (concatf res *newline*))
 195                (t
 196                 (concatf res (format-special next (car arguments)))
 197                 (pop arguments))))
 198             (setq res (concat res (char-to-string c))))
 199         (incf i)))
 200     (if destination
 201         (progn
 202           (write-string res)
 203           nil)
 204         res)))
 205
 206 (defun format-special (chr arg)
 207   (case chr
 208     (#\S (prin1-to-string arg))
 209     (#\a (princ-to-string arg))))