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     ((floatp form) (float-to-string form))
  37     ((stringp form) (concat "\"" (escape-string form) "\""))
  38     ((functionp form)
  39      (let ((name (oget form "fname")))
  40        (if name
  41            (concat "#<FUNCTION " name ">")
  42            (concat "#<FUNCTION>"))))
  43     ((listp form)
  44      (concat "("
  45              (join-trailing (mapcar #'prin1-to-string (butlast form)) " ")
  46              (let ((last (last form)))
  47                (if (null (cdr last))
  48                    (prin1-to-string (car last))
  49                    (concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last)))))
  50              ")"))
  51     ((arrayp form)
  52      (concat "#" (if (zerop (length form))
  53                      "()"
  54                      (prin1-to-string (vector-to-list form)))))
  55     ((packagep form)
  56      (concat "#<PACKAGE " (package-name form) ">"))
  57     (t
  58      (concat "#<javascript object>"))))
  59
  60 (defun write-line (x)
  61   (write-string x)
  62   (write-string *newline*)
  63   x)
  64
  65 (defun warn (string)
  66   (write-string "WARNING: ")
  67   (write-line string))
  68
  69 (defun print (x)
  70   (write-line (prin1-to-string x))
  71   x)
  72
  73 #+jscl
  74 (progn
  75   (defun format (destination fmt &rest args)
  76     (let ((len (length fmt))
  77           (i 0)
  78           (res "")
  79           (arguments args))
  80       (cl:%while (< i len)
  81                  (let ((c (char fmt i)))
  82                    (if (char= c #\~)
  83                        (let ((next (char fmt (incf i))))
  84                          (if (char= next #\~)
  85                              (progn (setq res (cl:concat res "~"))
  86                                     (incf i))
  87                              (progn
  88                                (format-special next (car arguments))
  89                                (setq arguments (cdr arguments)))))
  90                        (progn
  91                          (setq res (cl:concat res (cl:char-to-string c)))))
  92                    (incf i)))
  93       (if destination
  94           (progn
  95             (write-string res)
  96             nil)
  97           res)))
  98
  99
 100   (defun format-special (chr arg)
 101     chr))