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)
  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                   (char= ch #\\)
  31                   (char= ch #\|))
  32           (return-from escape-symbol-name-p t))))
  33     dots-only))
  34
  35 ;;; Return T if the specified string can be read as a number
  36 ;;; In case such a string is the name of a symbol then escaping
  37 ;;; is required when printing to ensure correct reading.
  38 (defun potential-number-p (string)
  39   ;; The four rules for being a potential number are described in
  40   ;; 2.3.1.1 Potential Numbers as Token
  41   ;;
  42   ;; First Rule
  43   (dotimes (i (length string))
  44     (let ((char (char string i)))
  45       (cond
  46         ;; Digits TODO: DIGIT-CHAR-P should work with the current
  47         ;; radix here. If the radix is not decimal, then we have to
  48         ;; make sure there is not a decimal-point in the string.
  49         ((digit-char-p char))
  50         ;; Signs, ratios, decimal point and extension mark
  51         ((find char "+-/._^"))
  52         ;; Number marker
  53         ((alpha-char-p char)
  54          (when (and (< i (1- (length string)))
  55                     (alpha-char-p (char string (1+ i))))
  56            ;; fail: adjacent letters are not number marker, or
  57            ;; there is a decimal point in the string.
  58            (return-from potential-number-p)))
  59         (t
  60          ;; fail: there is a non-allowed character
  61          (return-from potential-number-p)))))
  62   (and
  63    ;; Second Rule. In particular string is not empty.
  64    (find-if #'digit-char-p string)
  65    ;; Third rule
  66    (let ((first (char string 0)))
  67      (and (not (char= first #\:))
  68           (or (digit-char-p first)
  69               (find first "+-._^"))))
  70    ;; Fourth rule
  71    (not (find (char string (1- (length string))) "+-)"))))
  72
  73 #+nil
  74 (mapcar #'potential-number-p
  75         '("1b5000" "777777q" "1.7J" "-3/4+6.7J" "12/25/83" "27^19"
  76           "3^4/5" "6//7" "3.1.2.6" "^-43^" "3.141_592_653_589_793_238_4"
  77           "-3.7+2.6i-6.17j+19.6k"))
  78
  79 #+nil
  80 (mapcar #'potential-number-p '("/" "/5" "+" "1+" "1-" "foo+" "ab.cd" "_" "^" "^/-"))
  81
  82 (defun escape-token-p (string)
  83   (or (potential-number-p string)
  84       (escape-symbol-name-p string)))
  85
  86 ;;; Returns the token in a form that can be used for reading it back.
  87 (defun escape-token (s)
  88   (if (escape-token-p s)
  89       (let ((result "|"))
  90         (dotimes (i (length s))
  91           (let ((ch (char s i)))
  92             (when (or (char= ch #\|)
  93                       (char= ch #\\))
  94               (setf result (concat result "\\")))
  95             (setf result (concat result (string ch)))))
  96         (concat result "|"))
  97       s))
  98
  99 (defvar *print-escape* t)
 100 (defvar *print-circle* nil)
 101
 102 ;;; FIXME: Please, rewrite this in a more organized way.
 103 (defun write-to-string (form &optional known-objects object-ids)
 104   (when (and (not known-objects) *print-circle*)
 105     ;; To support *print-circle* some objects must be tracked for
 106     ;; sharing: conses, arrays and apparently-uninterned symbols.
 107     ;; These objects are placed in an array and a parallel array is
 108     ;; used to mark if they're found multiple times by assining them
 109     ;; an id starting from 1.
 110     ;;
 111     ;; After the tracking has been completed the printing phas can
 112     ;; begin: if an object has an id > 0 then #<n>= is prefixed and
 113     ;; the id is changed to negative. If an object has an id < 0 then
 114     ;; #<-n># is printed instead of the object.
 115     ;;
 116     ;; The processing is O(n^2) with n = number of tracked
 117     ;; objects. Hopefully it will become good enough when the new
 118     ;; compiler is available.
 119     (setf known-objects (make-array 100))
 120     (setf object-ids (make-array 100))
 121     (let ((n 0)
 122           (sz 100)
 123           (count 0))
 124       (labels ((mark (x)
 125                  (let ((i (position x known-objects)))
 126                    (if (= i -1)
 127                        (progn
 128                          (when (= n sz)
 129                            (setf sz (* 2 sz))
 130                            ;; KLUDGE: storage vectors are an internal
 131                            ;; object which the printer should not know
 132                            ;; about. Use standard vector with fill
 133                            ;; pointers instead.
 134                            (resize-storage-vector known-objects sz)
 135                            (resize-storage-vector object-ids sz))
 136                          (aset known-objects (1- (incf n)) x)
 137                          t)
 138                        (unless (aref object-ids i)
 139                          (aset object-ids i (incf count))
 140                          nil))))
 141                (visit (x)
 142                  (cond
 143                    ((and x (symbolp x) (null (symbol-package x)))
 144                     (mark x))
 145                    ((consp x)
 146                     (when (mark x)
 147                       (visit (car x))
 148                       (visit (cdr x))))
 149                    ((vectorp x)
 150                     (when (mark x)
 151                       (dotimes (i (length x))
 152                         (visit (aref x i))))))))
 153         (visit form))))
 154   (let ((prefix ""))
 155     (when (and *print-circle*
 156                (or (consp form)
 157                    (vectorp form)
 158                    (and form (symbolp form) (null (symbol-package form)))))
 159       (let* ((ix (position form known-objects))
 160              (id (aref object-ids ix)))
 161         (cond
 162           ((and id (> id 0))
 163            (setf prefix (format nil "#~S=" id))
 164            (aset object-ids ix (- id)))
 165           ((and id (< id 0))
 166            (return-from write-to-string (format nil "#~S#" (- id)))))))
 167     (concat prefix
 168             (cond
 169               ((null form) "NIL")
 170               ((symbolp form)
 171                (let ((name (symbol-name form))
 172                      (package (symbol-package form)))
 173                  ;; Check if the symbol is accesible from the current package. It
 174                  ;; is true even if the symbol's home package is not the current
 175                  ;; package, because it could be inherited.
 176                  (if (eq form (find-symbol (symbol-name form)))
 177                      (escape-token (symbol-name form))
 178                      ;; Symbol is not accesible from *PACKAGE*, so let us prefix
 179                      ;; the symbol with the optional package or uninterned mark.
 180                      (concat (cond
 181                                ((null package) "#")
 182                                ((eq package (find-package "KEYWORD")) "")
 183                                (t (escape-token (package-name package))))
 184                              ":"
 185                              (if (and package
 186                                       (eq (second (multiple-value-list
 187                                                       (find-symbol name package)))
 188                                           :internal))
 189                                  ":"
 190                                  "")
 191                              (escape-token name)))))
 192               ((integerp form) (integer-to-string form))
 193               ((floatp form) (float-to-string form))
 194               ((characterp form)
 195                (concat "#\\"
 196                        (case form
 197                          (#\newline "newline")
 198                          (#\space "space")
 199                          (otherwise (string form)))))
 200               ((stringp form) (if *print-escape*
 201                                   (lisp-escape-string form)
 202                                   form))
 203               ((functionp form)
 204                (let ((name (oget form "fname")))
 205                  (if name
 206                      (concat "#<FUNCTION " name ">")
 207                      (concat "#<FUNCTION>"))))
 208               ((listp form)
 209                (concat "("
 210                        (join-trailing (mapcar (lambda (x)
 211                                                 (write-to-string x known-objects object-ids))
 212                                               (butlast form)) " ")
 213                        (let ((last (last form)))
 214                          (if (null (cdr last))
 215                              (write-to-string (car last) known-objects object-ids)
 216                              (concat (write-to-string (car last) known-objects object-ids)
 217                                      " . "
 218                                      (write-to-string (cdr last) known-objects object-ids))))
 219                        ")"))
 220               ((vectorp form)
 221                (let ((result "#(")
 222                      (sep ""))
 223                  (dotimes (i (length form))
 224                    (setf result (concat result sep
 225                                         (write-to-string (aref form i)
 226                                                          known-objects
 227                                                          object-ids)))
 228                    (setf sep " "))
 229                  (concat result ")")))
 230               ((packagep form)
 231                (concat "#<PACKAGE " (package-name form) ">"))
 232               (t "#<javascript object>")))))
 233
 234 (defun prin1-to-string (form)
 235   (let ((*print-escape* t))
 236     (write-to-string form)))
 237
 238 (defun princ-to-string (form)
 239   (let ((*print-escape* nil))
 240     (write-to-string form)))
 241
 242 (defun write-line (x)
 243   (write-string x)
 244   (write-string *newline*)
 245   x)
 246
 247 (defun warn (string)
 248   (write-string "WARNING: ")
 249   (write-line string))
 250
 251 (defun print (x)
 252   (write-line (prin1-to-string x))
 253   x)
 254
 255 (defun format (destination fmt &rest args)
 256   (let ((len (length fmt))
 257         (i 0)
 258         (res "")
 259         (arguments args))
 260     (while (< i len)
 261       (let ((c (char fmt i)))
 262         (if (char= c #\~)
 263             (let ((next (char fmt (incf i))))
 264               (cond
 265                ((char= next #\~)
 266                 (concatf res "~"))
 267                ((char= next #\%)
 268                 (concatf res *newline*))
 269                ((char= next #\*)
 270                 (pop arguments))
 271                (t
 272                 (concatf res (format-special next (car arguments)))
 273                 (pop arguments))))
 274             (setq res (concat res (string c))))
 275         (incf i)))
 276     (if destination
 277         (progn
 278           (write-string res)
 279           nil)
 280         res)))
 281
 282 (defun format-special (chr arg)
 283   (case (char-upcase chr)
 284     (#\S (prin1-to-string arg))
 285     (#\A (princ-to-string arg))))