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 ;;;--------------------------------------------------------------------------
  78 ;;; Property representation.
  79
  80 (defmethod file-location ((prop property))
  81   (file-location (p-location prop)))
  82
  83 ;;; Keywords.
  84
  85 (defmethod coerce-property-value
  86     ((value symbol) (type (eql :symbol)) (wanted (eql :keyword)))
  87   value)
  88
  89 (defmethod coerce-property-value
  90     ((value string) (type (eql :id)) (wanted (eql :keyword)))
  91   (string-to-symbol value :package :keyword))
  92
  93 (defmethod coerce-property-value
  94     ((value string) (type (eql :string)) (wanted (eql :keyword)))
  95   (string-to-symbol value :package :keyword :swap-hyphen nil))
  96
  97 ;;; Symbols.
  98
  99 (defmethod coerce-property-value
 100     ((value string) (type (eql :id)) (wanted (eql :symbol)))
 101   (string-to-symbol value))
 102
 103 (defmethod coerce-property-value
 104     ((value string) (type (eql :string)) (wanted (eql :symbol)))
 105   (string-to-symbol value :swap-hyphen nil))
 106
 107 ;;; Identifiers.
 108
 109 (defmethod coerce-property-value
 110     ((value string) (type (eql :string)) (wanted (eql :id)))
 111   value)
 112
 113 (defmethod coerce-property-value
 114     ((value symbol) (type (eql :symbol)) (wanted (eql :id)))
 115   (frob-identifier (symbol-name value)))
 116
 117 ;;; Types.
 118
 119 (defmethod coerce-property-value
 120     ((value string) (type (eql :id)) (wanted (eql :type)))
 121   (or (and (boundp '*module-type-map*)
 122            (gethash value *module-type-map*))
 123       (find-simple-c-type value)
 124       (error "Unknown type `~A'" value)))
 125
 126 ;;;--------------------------------------------------------------------------
 127 ;;; Property sets.
 128
 129 (defmethod print-object ((pset pset) stream)
 130   (print-unreadable-object (pset stream :type t)
 131     (pprint-logical-block (stream nil)
 132       (let ((firstp t))
 133         (pset-map (lambda (prop)
 134                     (cond (firstp (setf firstp nil))
 135                           (t (write-char #\space stream)
 136                              (pprint-newline :linear stream)))
 137                     (format stream "~:@<~S ~@_~S ~@_~S~:>"
 138                             (p-name prop) (p-type prop) (p-value prop)))
 139                   pset)))))
 140
 141 ;;;----- That's all, folks --------------------------------------------------