src/print.lisp

   1 ;;; print.lisp ---
   2
   3 ;; Copyright (C) 2012, 2013 David Vazquez
   4 ;; Copyright (C) 2012 Raimon Grau
   5
   6 ;; This program 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 ;; This program 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 this program.  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     ((stringp form) (concat "\"" (escape-string form) "\""))
  37     ((functionp form)
  38      (let ((name (oget form "fname")))
  39        (if name
  40            (concat "#<FUNCTION " name ">")
  41            (concat "#<FUNCTION>"))))
  42     ((listp form)
  43      (concat "("
  44              (join-trailing (mapcar #'prin1-to-string (butlast form)) " ")
  45              (let ((last (last form)))
  46                (if (null (cdr last))
  47                    (prin1-to-string (car last))
  48                    (concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last)))))
  49              ")"))
  50     ((arrayp form)
  51      (concat "#" (if (zerop (length form))
  52                      "()"
  53                      (prin1-to-string (vector-to-list form)))))
  54     ((packagep form)
  55      (concat "#<PACKAGE " (package-name form) ">"))
  56     (t
  57      (concat "#<javascript object>"))))
  58
  59 (defun write-line (x)
  60   (write-string x)
  61   (write-string *newline*)
  62   x)
  63
  64 (defun warn (string)
  65   (write-string "WARNING: ")
  66   (write-line string))
  67
  68 (defun print (x)
  69   (write-line (prin1-to-string x))
  70   x)