mdw@git.distorted.org.uk Git - 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 ((truth-map (make-hash-table :test #'equalp)))
  78   (dolist (string '("true" "t" "yes" "on" "yup" "verily"))
  79     (setf (gethash string truth-map) t))
  80   (dolist (string '("false" "nil" "no" "off" "nope" "nowise"))
  81     (setf (gethash string truth-map) nil))
  82   (defun truishp (string)
  83     "Convert STRING to a boolean."
  84     (multiple-value-bind (val foundp) (gethash string truth-map)
  85       (if foundp val
  86           (error "Unrecognized boolean value `~A'" string)))))
  87
  88 ;;;--------------------------------------------------------------------------
  89 ;;; Property representation.
  90
  91 (defmethod file-location ((prop property))
  92   (file-location (p-location prop)))
  93
  94 ;;; Input conversions.
  95
  96 (defmethod decode-property ((raw symbol)) (values :symbol raw))
  97 (defmethod decode-property ((raw integer)) (values :int raw))
  98 (defmethod decode-property ((raw string)) (values :string raw))
  99 (defmethod decode-property ((raw character)) (values :char raw))
 100 (defmethod decode-property ((raw function)) (values :func raw))
 101 (defmethod decode-property ((raw c-type)) (values :type raw))
 102 (defmethod decode-property ((raw c-fragment)) (values :c-fragment raw))
 103
 104 ;;; Keywords.
 105
 106 (defmethod coerce-property-value
 107     ((value symbol) (type (eql :symbol)) (wanted (eql :keyword)))
 108   value)
 109
 110 (defmethod coerce-property-value
 111     ((value string) (type (eql :id)) (wanted (eql :keyword)))
 112   (string-to-symbol value :package :keyword))
 113
 114 (defmethod coerce-property-value
 115     ((value string) (type (eql :string)) (wanted (eql :keyword)))
 116   (string-to-symbol value :package :keyword :swap-hyphen nil))
 117
 118 ;;; Symbols.
 119
 120 (defmethod coerce-property-value
 121     ((value string) (type (eql :id)) (wanted (eql :symbol)))
 122   (string-to-symbol value))
 123
 124 (defmethod coerce-property-value
 125     ((value string) (type (eql :string)) (wanted (eql :symbol)))
 126   (string-to-symbol value :swap-hyphen nil))
 127
 128 ;;; Identifiers.
 129
 130 (defmethod coerce-property-value
 131     ((value string) (type (eql :string)) (wanted (eql :id)))
 132   value)
 133
 134 (defmethod coerce-property-value
 135     ((value symbol) (type (eql :symbol)) (wanted (eql :id)))
 136   (frob-identifier (symbol-name value)))
 137
 138 ;;; Boolean.
 139
 140 (defmethod coerce-property-value
 141     ((value symbol) (type (eql :symbol)) (wanted (eql :boolean)))
 142   value)
 143
 144 (defmethod coerce-property-value
 145     ((value string) (type (eql :id)) (wanted (eql :boolean)))
 146   (truishp value))
 147
 148 (defmethod coerce-property-value
 149     ((value integer) (type (eql :int)) (wanted (eql :boolean)))
 150   (not (zerop value)))
 151
 152 ;;; Types.
 153
 154 (defmethod coerce-property-value
 155     ((value string) (type (eql :id)) (wanted (eql :type)))
 156   (or (and (boundp '*module-type-map*)
 157            (gethash value *module-type-map*))
 158       (find-simple-c-type value)
 159       (error "Unknown type `~A'" value)))
 160
 161 ;;;--------------------------------------------------------------------------
 162 ;;; Property sets.
 163
 164 (defmethod print-object ((pset pset) stream)
 165   (print-unreadable-object (pset stream :type t)
 166     (pprint-logical-block (stream nil)
 167       (let ((firstp t))
 168         (pset-map (lambda (prop)
 169                     (cond (firstp (setf firstp nil))
 170                           (t (write-char #\space stream)
 171                              (pprint-newline :linear stream)))
 172                     (format stream "~:@<~S ~@_~S ~@_~S~:>"
 173                             (p-name prop) (p-type prop) (p-value prop)))
 174                   pset)))))
 175
 176 ;;;----- That's all, folks --------------------------------------------------