chiark - git - mdw - sod/blob - src/pset-impl.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Implementation for property sets
   4 ;;;
   5 ;;; (c) 2009 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Sensible Object Design, an object system for C.
  11 ;;;
  12 ;;; SOD is free software; you can redistribute it and/or modify
  13 ;;; it under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 2 of the License, or
  15 ;;; (at your option) any later version.
  16 ;;;
  17 ;;; SOD is distributed in the hope that it will be useful,
  18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with SOD; if not, write to the Free Software Foundation,
  24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25
  26 (cl:in-package #:sod)
  27
  28 ;;;--------------------------------------------------------------------------
  29 ;;; Conversion utilities.
  30
  31 (defun string-to-symbol
  32     (string &key (package *package*) (swap-case t) (swap-hyphen t))
  33   "Convert STRING to a symbol in PACKAGE.
  34
  35    Parse off a `PACKAGE:' prefix from STRING if necessary, to identify the
  36    package; PACKAGE is used if there isn't a prefix.  A doubled colon allows
  37    access to internal symbols, and will intern if necessary.  Note that
  38    escape characters are /not/ processed; don't put colons in package names
  39    if you want to use them from SOD property sets.
  40
  41    The portions of the string are modified by `frob-identifier'; the
  42    arguments SWAP-CASE and SWAP-HYPHEN are passed to `frob-identifier' to
  43    control this process."
  44
  45   (let* ((length (length string))
  46          (colon (position #\: string)))
  47     (multiple-value-bind (start internalp)
  48         (cond ((not colon) (values 0 t))
  49               ((and (< (1+ colon) length)
  50                     (char= (char string (1+ colon)) #\:))
  51                (values (+ colon 2) t))
  52               (t
  53                (values (1+ colon) nil)))
  54       (when colon
  55         (let* ((package-name (if (zerop colon) "KEYWORD"
  56                                  (frob-identifier (subseq string 0 colon)
  57                                                   :swap-case swap-case
  58                                                   :swap-hyphen swap-hyphen)))
  59                (found (find-package package-name)))
  60           (unless found
  61             (error "Unknown package `~A'" package-name))
  62           (setf package found)))
  63       (let ((name (frob-identifier (subseq string start)
  64                                    :swap-case swap-case
  65                                    :swap-hyphen swap-hyphen)))
  66         (multiple-value-bind (symbol status)
  67             (funcall (if internalp #'intern #'find-symbol) name package)
  68           (cond ((or internalp (eq status :external))
  69                  symbol)
  70                 ((not status)
  71                  (error "Symbol `~A' not found in package `~A'"
  72                         name (package-name package)))
  73                 (t
  74                  (error "Symbol `~A' not external in package `~A'"
  75                         name (package-name package)))))))))
  76
  77 (let ((truish '("true" "t" "yes" "verily"))
  78       (falsish '("false" "nil" "no" "nowise")))
  79   (defun truishp (string)
  80     "Convert STRING to a boolean."
  81     (cond ((member string truish :test #'string=) t)
  82           ((member string falsish :test #'string=) nil)
  83           (t (error "Unrecognized boolean value `~A'" string)))))
  84
  85 ;;;--------------------------------------------------------------------------
  86 ;;; Property representation.
  87
  88 (defmethod file-location ((prop property))
  89   (file-location (p-location prop)))
  90
  91 ;;; Keywords.
  92
  93 (defmethod coerce-property-value
  94     ((value symbol) (type (eql :symbol)) (wanted (eql :keyword)))
  95   value)
  96
  97 (defmethod coerce-property-value
  98     ((value string) (type (eql :id)) (wanted (eql :keyword)))
  99   (string-to-symbol value :package :keyword))
 100
 101 (defmethod coerce-property-value
 102     ((value string) (type (eql :string)) (wanted (eql :keyword)))
 103   (string-to-symbol value :package :keyword :swap-hyphen nil))
 104
 105 ;;; Symbols.
 106
 107 (defmethod coerce-property-value
 108     ((value string) (type (eql :id)) (wanted (eql :symbol)))
 109   (string-to-symbol value))
 110
 111 (defmethod coerce-property-value
 112     ((value string) (type (eql :string)) (wanted (eql :symbol)))
 113   (string-to-symbol value :swap-hyphen nil))
 114
 115 ;;; Identifiers.
 116
 117 (defmethod coerce-property-value
 118     ((value string) (type (eql :string)) (wanted (eql :id)))
 119   value)
 120
 121 (defmethod coerce-property-value
 122     ((value symbol) (type (eql :symbol)) (wanted (eql :id)))
 123   (frob-identifier (symbol-name value)))
 124
 125 ;;; Boolean.
 126
 127 (defmethod coerce-property-value
 128     ((value symbol) (type (eql :symbol)) (wanted (eql :boolean)))
 129   value)
 130
 131 (defmethod coerce-property-value
 132     ((value string) (type (eql :id)) (wanted (eql :boolean)))
 133   (truishp value))
 134
 135 (defmethod coerce-property-value
 136     ((value integer) (type (eql :int)) (wanted (eql :boolean)))
 137   (not (zerop value)))
 138
 139 ;;; Types.
 140
 141 (defmethod coerce-property-value
 142     ((value string) (type (eql :id)) (wanted (eql :type)))
 143   (or (and (boundp '*module-type-map*)
 144            (gethash value *module-type-map*))
 145       (find-simple-c-type value)
 146       (error "Unknown type `~A'" value)))
 147
 148 ;;;--------------------------------------------------------------------------
 149 ;;; Property sets.
 150
 151 (defmethod print-object ((pset pset) stream)
 152   (print-unreadable-object (pset stream :type t)
 153     (pprint-logical-block (stream nil)
 154       (let ((firstp t))
 155         (pset-map (lambda (prop)
 156                     (cond (firstp (setf firstp nil))
 157                           (t (write-char #\space stream)
 158                              (pprint-newline :linear stream)))
 159                     (format stream "~:@<~S ~@_~S ~@_~S~:>"
 160                             (p-name prop) (p-type prop) (p-value prop)))
 161                   pset)))))
 162
 163 ;;;----- That's all, folks --------------------------------------------------