rcl/attributes.lisp

   1 ;; Copyright (c) 2006-2007 Carlos Ungil
   2
   3 ;; Permission is hereby granted, free of charge, to any person obtaining
   4 ;; a copy of this software and associated documentation files (the
   5 ;; "Software"), to deal in the Software without restriction, including
   6 ;; without limitation the rights to use, copy, modify, merge, publish,
   7 ;; distribute, sublicense, and/or sell copies of the Software, and to
   8 ;; permit persons to whom the Software is furnished to do so, subject to
   9 ;; the following conditions:
  10
  11 ;; The above copyright notice and this permission notice shall be
  12 ;; included in all copies or substantial portions of the Software.
  13
  14 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  15 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  16 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  17 ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
  18 ;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
  19 ;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
  20 ;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  21
  22 (in-package :rcl)
  23
  24 (defvar *print-attributes* nil
  25   "Print to standard output details about attributes when encountered")
  26
  27 (defvar *r-attributes-prefix* ";R. "
  28   "Default prefix used to print attributes")
  29
  30 (defun attributes-list (list)
  31   (unless (= (length list) 3)
  32     (error "the list doesn't have three elements"))
  33   (unless (typep (third list) 'r-symbol)
  34     (error "I expected a symbol, I got ~A" (third list)))
  35   (append (list (cons (intern (string-upcase (pname (third list))) "KEYWORD")
  36                       (first list)))
  37           (if (second list) (attributes-list (second list)))))
  38
  39 (defun print-attributes (attributes)
  40   (let ((*print-pretty* nil))
  41     (format t
  42             (concatenate 'string "~{"  *r-attributes-prefix* "~S~&~}")
  43             attributes)))