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 prin1-to-string (form)
  22   (cond
  23     ((symbolp form)
  24      (multiple-value-bind (symbol foundp)
  25          (find-symbol (symbol-name form) *package*)
  26        (if (and foundp (eq symbol form))
  27            (symbol-name form)
  28            (let ((package (symbol-package form))
  29                  (name (symbol-name form)))
  30              (concat (cond
  31                        ((null package) "#")
  32                        ((eq package (find-package "KEYWORD")) "")
  33                        (t (package-name package)))
  34                      ":" name)))))
  35     ((integerp form) (integer-to-string form))
  36     ((floatp form) (float-to-string form))
  37     ((characterp form)
  38      (concat "#\\"
  39              (case form
  40                (#\newline "newline")
  41                (#\space "space")
  42                (otherwise (string form)))))
  43     ((stringp form) (concat "\"" (escape-string form) "\""))
  44     ((functionp form)
  45      (let ((name (oget form "fname")))
  46        (if name
  47            (concat "#<FUNCTION " name ">")
  48            (concat "#<FUNCTION>"))))
  49     ((listp form)
  50      (concat "("
  51              (join-trailing (mapcar #'prin1-to-string (butlast form)) " ")
  52              (let ((last (last form)))
  53                (if (null (cdr last))
  54                    (prin1-to-string (car last))
  55                    (concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last)))))
  56              ")"))
  57     ((arrayp form)
  58      (concat "#" (if (zerop (length form))
  59                      "()"
  60                      (prin1-to-string (vector-to-list form)))))
  61     ((packagep form)
  62      (concat "#<PACKAGE " (package-name form) ">"))
  63     (t
  64      (concat "#<javascript object>"))))
  65
  66 (defun write-line (x)
  67   (write-string x)
  68   (write-string *newline*)
  69   x)
  70
  71 (defun warn (string)
  72   (write-string "WARNING: ")
  73   (write-line string))
  74
  75 (defun print (x)
  76   (write-line (prin1-to-string x))
  77   x)