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 (defvar *print-escape* t)
  22
  23 (defun write-to-string (form)
  24   (cond
  25     ((symbolp form)
  26      (multiple-value-bind (symbol foundp)
  27          (find-symbol (symbol-name form) *package*)
  28        (if (and foundp (eq symbol form))
  29            (symbol-name form)
  30            (let ((package (symbol-package form))
  31                  (name (symbol-name form)))
  32              (concat (cond
  33                        ((null package) "#")
  34                        ((eq package (find-package "KEYWORD")) "")
  35                        (t (package-name package)))
  36                      ":" name)))))
  37     ((integerp form) (integer-to-string form))
  38     ((floatp form) (float-to-string form))
  39     ((characterp form)
  40      (concat "#\\"
  41              (case form
  42                (#\newline "newline")
  43                (#\space "space")
  44                (otherwise (string form)))))
  45     ((stringp form) (if *print-escape*
  46                         (concat "\"" (escape-string form) "\"")
  47                         form))
  48     ((functionp form)
  49      (let ((name (oget form "fname")))
  50        (if name
  51            (concat "#<FUNCTION " name ">")
  52            (concat "#<FUNCTION>"))))
  53     ((listp form)
  54      (concat "("
  55              (join-trailing (mapcar #'write-to-string (butlast form)) " ")
  56              (let ((last (last form)))
  57                (if (null (cdr last))
  58                    (write-to-string (car last))
  59                    (concat (write-to-string (car last)) " . " (write-to-string (cdr last)))))
  60              ")"))
  61     ((arrayp form)
  62      (concat "#" (if (zerop (length form))
  63                      "()"
  64                      (write-to-string (vector-to-list form)))))
  65     ((packagep form)
  66      (concat "#<PACKAGE " (package-name form) ">"))
  67     (t
  68      (concat "#<javascript object>"))))
  69
  70 (defun prin1-to-string (form)
  71   (let ((*print-escape* t))
  72     (write-to-string form)))
  73
  74 (defun princ-to-string (form)
  75   (let ((*print-escape* nil))
  76     (write-to-string form)))
  77
  78 (defun write-line (x)
  79   (write-string x)
  80   (write-string *newline*)
  81   x)
  82
  83 (defun warn (string)
  84   (write-string "WARNING: ")
  85   (write-line string))
  86
  87 (defun print (x)
  88   (write-line (prin1-to-string x))
  89   x)
  90
  91 (defun format (destination fmt &rest args)
  92   (let ((len (length fmt))
  93         (i 0)
  94         (res "")
  95         (arguments args))
  96     (while (< i len)
  97       (let ((c (char fmt i)))
  98         (if (char= c #\~)
  99             (let ((next (char fmt (incf i))))
 100               (cond
 101                ((char= next #\~)
 102                 (setq res (concat res "~")))
 103                ((char= next #\%)
 104                 (setq res (concat res *newline*)))
 105                (t
 106                 (setq res (concat res (format-special next (car arguments))))
 107                 (setq arguments (cdr arguments)))))
 108           (setq res (concat res (char-to-string c))))
 109         (incf i)))
 110     (if destination
 111         (progn
 112           (write-string res)
 113           nil)
 114       res)))
 115
 116
 117 (defun format-special (chr arg)
 118   (case chr
 119     (#\S (prin1-to-string arg))
 120     (#\a (princ-to-string arg))))