src/print.lisp

   1 ;;; print.lisp ---
   2
   3 ;; JSCL is free software: you can redistribute it and/or
   4 ;; modify it under the terms of the GNU General Public License as
   5 ;; published by the Free Software Foundation, either version 3 of the
   6 ;; License, or (at your option) any later version.
   7 ;;
   8 ;; JSCL is distributed in the hope that it will be useful, but
   9 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11 ;; General Public License for more details.
  12 ;;
  13 ;; You should have received a copy of the GNU General Public License
  14 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
  15
  16 (/debug "loading print.lisp!")
  17
  18 ;;; Printer
  19
  20 (defun lisp-escape-string (string)
  21   (let ((output "")
  22         (index 0)
  23         (size (length string)))
  24     (while (< index size)
  25       (let ((ch (char string index)))
  26         (when (or (char= ch #\") (char= ch #\\))
  27           (setq output (concat output "\\")))
  28         (when (or (char= ch #\newline))
  29           (setq output (concat output "\\"))
  30           (setq ch #\n))
  31         (setq output (concat output (string ch))))
  32       (incf index))
  33     (concat "\"" output "\"")))
  34
  35 ;;; Return T if the string S contains characters which need to be
  36 ;;; escaped to print the symbol name, NIL otherwise.
  37 (defun escape-symbol-name-p (s)
  38   (let ((dots-only t))
  39     (dotimes (i (length s))
  40       (let ((ch (char s i)))
  41         (setf dots-only (and dots-only (char= ch #\.)))
  42         (when (or (terminalp ch)
  43                   (char= ch #\:)
  44                   (char= ch #\\)
  45                   (not (char= ch (char-upcase ch)))
  46                   (char= ch #\|))
  47           (return-from escape-symbol-name-p t))))
  48     dots-only))
  49
  50 ;;; Return T if the specified string can be read as a number
  51 ;;; In case such a string is the name of a symbol then escaping
  52 ;;; is required when printing to ensure correct reading.
  53 (defun potential-number-p (string)
  54   ;; The four rules for being a potential number are described in
  55   ;; 2.3.1.1 Potential Numbers as Token
  56   ;;
  57   ;; First Rule
  58   (dotimes (i (length string))
  59     (let ((char (char string i)))
  60       (cond
  61         ;; Digits TODO: DIGIT-CHAR-P should work with the current
  62         ;; radix here. If the radix is not decimal, then we have to
  63         ;; make sure there is not a decimal-point in the string.
  64         ((digit-char-p char))
  65         ;; Signs, ratios, decimal point and extension mark
  66         ((find char "+-/._^"))
  67         ;; Number marker
  68         ((alpha-char-p char)
  69          (when (and (< i (1- (length string)))
  70                     (alpha-char-p (char string (1+ i))))
  71            ;; fail: adjacent letters are not number marker, or
  72            ;; there is a decimal point in the string.
  73            (return-from potential-number-p)))
  74         (t
  75          ;; fail: there is a non-allowed character
  76          (return-from potential-number-p)))))
  77   (and
  78    ;; Second Rule. In particular string is not empty.
  79    (find-if #'digit-char-p string)
  80    ;; Third rule
  81    (let ((first (char string 0)))
  82      (and (not (char= first #\:))
  83           (or (digit-char-p first)
  84               (find first "+-._^"))))
  85    ;; Fourth rule
  86    (not (find (char string (1- (length string))) "+-)"))))
  87
  88 #+nil
  89 (mapcar #'potential-number-p
  90         '("1b5000" "777777q" "1.7J" "-3/4+6.7J" "12/25/83" "27^19"
  91           "3^4/5" "6//7" "3.1.2.6" "^-43^" "3.141_592_653_589_793_238_4"
  92           "-3.7+2.6i-6.17j+19.6k"))
  93
  94 #+nil
  95 (mapcar #'potential-number-p '("/" "/5" "+" "1+" "1-" "foo+" "ab.cd" "_" "^" "^/-"))
  96
  97 (defun escape-token-p (string)
  98   (or (potential-number-p string)
  99       (escape-symbol-name-p string)))
 100
 101 ;;; Returns the token in a form that can be used for reading it back.
 102 (defun escape-token (s)
 103   (if (escape-token-p s)
 104       (let ((result "|"))
 105         (dotimes (i (length s))
 106           (let ((ch (char s i)))
 107             (when (or (char= ch #\|)
 108                       (char= ch #\\))
 109               (setf result (concat result "\\")))
 110             (setf result (concat result (string ch)))))
 111         (concat result "|"))
 112       s))
 113
 114 #+jscl (defvar *print-escape* t)
 115 #+jscl (defvar *print-circle* nil)
 116
 117 ;; To support *print-circle* some objects must be tracked for sharing:
 118 ;; conses, arrays and apparently-uninterned symbols.  These objects
 119 ;; are placed in an array and a parallel array is used to mark if
 120 ;; they're found multiple times by assining them an id starting from
 121 ;; 1.
 122 ;;
 123 ;; After the tracking has been completed the printing phase can begin:
 124 ;; if an object has an id > 0 then #<n>= is prefixed and the id is
 125 ;; changed to negative. If an object has an id < 0 then #<-n># is
 126 ;; printed instead of the object.
 127 ;;
 128 ;; The processing is O(n^2) with n = number of tracked
 129 ;; objects. Hopefully it will become good enough when the new compiler
 130 ;; is available.
 131 (defun scan-multiple-referenced-objects (form)
 132   (let ((known-objects (make-array 0 :adjustable t :fill-pointer 0))
 133         (object-ids    (make-array 0 :adjustable t :fill-pointer 0)))
 134     (vector-push-extend nil known-objects)
 135     (vector-push-extend 0 object-ids)
 136     (let ((count 0))
 137       (labels ((mark (x)
 138                  (let ((i (position x known-objects)))
 139                    (cond
 140                      ((null i)
 141                       (vector-push-extend x known-objects)
 142                       (vector-push-extend 0 object-ids)
 143                       t)
 144                      (t
 145                       (setf (aref object-ids i) (incf count))
 146                       nil))))
 147                (visit (x)
 148                  (cond
 149                    ((and x (symbolp x) (null (symbol-package x)))
 150                     (mark x))
 151                    ((consp x)
 152                     (when (mark x)
 153                       (visit (car x))
 154                       (visit (cdr x))))
 155                    ((vectorp x)
 156                     (when (mark x)
 157                       (dotimes (i (length x))
 158                         (visit (aref x i))))))))
 159         (visit form)))
 160     (values known-objects object-ids)))
 161
 162 ;;; Write an integer to stream.
 163 ;;; TODO: Support for different basis.
 164 (defun write-integer (value stream)
 165   (write-string (integer-to-string value) stream))
 166
 167 ;;; This version of format supports only ~A for strings and ~D for
 168 ;;; integers. It is used to avoid circularities. Indeed, it just
 169 ;;; ouputs to streams.
 170 (defun simple-format (stream fmt &rest args)
 171   (do ((i 0 (1+ i)))
 172       ((= i (length fmt)))
 173     (let ((char (char fmt i)))
 174       (if (char= char #\~)
 175           (let ((next (if (< i (1- (length fmt)))
 176                           (char fmt (1+ i))
 177                           (error "`~~' appears in the last position of the format control string ~S." fmt))))
 178             (ecase next
 179               (#\~ (write-char #\~ stream))
 180               (#\d (write-integer (pop args) stream))
 181               (#\a (write-string (pop args) stream)))
 182             (incf i))
 183           (write-char char stream)))))
 184
 185
 186 (defun write-aux (form stream known-objects object-ids)
 187   (when *print-circle*
 188     (let* ((ix (or (position form known-objects) 0))
 189            (id (aref object-ids ix)))
 190       (cond
 191         ((and id (> id 0))
 192          (simple-format stream "#~d=" id)
 193          (setf (aref object-ids id) (- id)))
 194         ((and id (< id 0))
 195          (simple-format stream "#~d#" (- id))
 196          (return-from write-aux)))))
 197   (typecase form
 198     ;; NIL
 199     (null
 200      (write-string "NIL" stream))
 201     ;; Symbols
 202     (symbol
 203      (let ((name (symbol-name form))
 204            (package (symbol-package form)))
 205        ;; Check if the symbol is accesible from the current package. It
 206        ;; is true even if the symbol's home package is not the current
 207        ;; package, because it could be inherited.
 208        (if (eq form (find-symbol (symbol-name form)))
 209            (write-string (escape-token (symbol-name form)) stream)
 210            ;; Symbol is not accesible from *PACKAGE*, so let us prefix
 211            ;; the symbol with the optional package or uninterned mark.
 212            (progn
 213              (cond
 214                ((null package) (write-char #\# stream))
 215                ((eq package (find-package "KEYWORD")))
 216                (t (write-char (escape-token (package-name package)) stream)))
 217              (write-char #\: stream)
 218              (let ((symbtype (and package (second (multiple-value-list (find-symbol name package))))))
 219                (when (and package (eq symbtype :internal))
 220                  (write-char #\: stream)))
 221              (write-string (escape-token name) stream)))))
 222     ;; Integers
 223     (integer
 224      (write-integer form stream))
 225     ;; Floats
 226     (float
 227      (write-string (float-to-string form) stream))
 228     ;; Characters
 229     (character
 230      (write-string "#\\" stream)
 231      (case form
 232        (#\newline (write-string "newline" stream))
 233        (#\space   (write-string "space"   stream))
 234        (otherwise (write-char form stream))))
 235     ;; Strings
 236     (string
 237      (if *print-escape*
 238          (write-string (lisp-escape-string form) stream)
 239          (write-string form stream)))
 240     ;; Functions
 241     (function
 242      (let ((name #+jscl (oget form "fname")
 243                  #-jscl nil))
 244        (if name
 245            (simple-format stream "#<FUNCTION ~a>" name)
 246            (write-string "#<FUNCTION>" stream))))
 247     ;; Lists
 248     (list
 249      (write-char #\( stream)
 250      (unless (null form)
 251        (write-aux (car form) stream known-objects object-ids)
 252        (do ((tail (cdr form) (cdr tail)))
 253            ;; Stop on symbol OR if the object is already known when we
 254            ;; accept circular printing.
 255            ((or (atom tail)
 256                 (and *print-circle*
 257                      (let* ((ix (or (position tail known-objects) 0))
 258                             (id (aref object-ids ix)))
 259                        (not (zerop id)))))
 260             (unless (null tail)
 261               (write-string " . " stream)
 262               (write-aux tail stream known-objects object-ids)))
 263          (write-char #\space stream)
 264          (write-aux (car tail) stream known-objects object-ids)))
 265      (write-char #\) stream))
 266     ;; Vectors
 267     (vector
 268      (write-string "#(" stream)
 269      (when (plusp (length form))
 270        (write-aux (aref form 0) stream known-objects object-ids)
 271        (do ((i 1 (1+ i)))
 272            ((= i (length form)))
 273          (write-char #\space stream)
 274          (write-aux (aref form i) stream known-objects object-ids)))
 275      (write-char #\) stream))
 276     ;; Packages
 277     (package
 278      (simple-format stream "#<PACKAGE ~a>" (package-name form)))
 279     ;; Others
 280     (otherwise
 281      (write-string "#<javascript object>" stream))))
 282
 283
 284 #+jscl
 285 (defun write (form &key (stream *standard-output*))
 286   (write-aux form stream))
 287
 288 (defun !write-to-string (form)
 289   (with-output-to-string (output)
 290     (multiple-value-bind (objs ids)
 291         (scan-multiple-referenced-objects form)
 292       (write-aux form output objs ids))))
 293 #+jscl (fset 'write-to-string (fdefinition '!write-to-string))
 294
 295 #+jscl
 296 (progn
 297
 298   (defun prin1-to-string (form)
 299     (let ((*print-escape* t))
 300       (write-to-string form)))
 301
 302   (defun princ-to-string (form)
 303     (let ((*print-escape* nil))
 304       (write-to-string form)))
 305
 306   (defun terpri ()
 307     (write-char #\newline)
 308     (values))
 309
 310   (defun write-line (x)
 311     (write-string x)
 312     (terpri)
 313     x)
 314
 315   (defun warn (fmt &rest args)
 316     (write-string "WARNING: ")
 317     (apply #'format t fmt args)
 318     (terpri))
 319
 320   (defun print (x)
 321     (write-line (prin1-to-string x))
 322     x))
 323
 324 ;;; Format
 325
 326 (defun format-special (chr arg)
 327   (case (char-upcase chr)
 328     (#\S (prin1-to-string arg))
 329     (#\A (princ-to-string arg))
 330     (#\D (princ-to-string arg))
 331     (t
 332      (warn "~S is not implemented yet, using ~~S instead" chr)
 333      (prin1-to-string arg))))
 334
 335 (defun !format (destination fmt &rest args)
 336   (let ((len (length fmt))
 337         (i 0)
 338         (res "")
 339         (arguments args))
 340     (while (< i len)
 341       (let ((c (char fmt i)))
 342         (if (char= c #\~)
 343             (let ((next (char fmt (incf i))))
 344               (cond
 345                 ((char= next #\~)
 346                  (concatf res "~"))
 347                 ((char= next #\%)
 348                  (concatf res (string #\newline)))
 349                 ((char= next #\*)
 350                  (pop arguments))
 351                 (t
 352                  (concatf res (format-special next (car arguments)))
 353                  (pop arguments))))
 354             (setq res (concat res (string c))))
 355         (incf i)))
 356     (if destination
 357         (progn
 358           (write-string res)
 359           nil)
 360         res)))
 361 #+jscl (fset 'format (fdefinition '!format))