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

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Protocol 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 ;;; Property representation.
  30
  31 (export 'property-key)
  32 (defun property-key (name)
  33   "Convert NAME into a keyword.
  34
  35    If NAME isn't a symbol already, then flip its case (using
  36    `frob-identifier'), and intern into the `keyword' package."
  37   (etypecase name
  38     (symbol name)
  39     (string (intern (frob-identifier name) :keyword))))
  40
  41 (export '(property propertyp p-name p-value p-type p-key p-seenp))
  42 (defstruct (property
  43              (:predicate propertyp)
  44              (:conc-name p-)
  45              (:constructor %make-property
  46                  (name value
  47                   &key type location seenp
  48                   &aux (key (property-key name)) (%type type))))
  49   "A simple structure for holding a property in a property set.
  50
  51    The main useful feature is the ability to tick off properties which have
  52    been used, so that we can complain about unrecognized properties.
  53
  54    An explicit type tag is necessary because we need to be able to talk
  55    distinctly about identifiers, strings and symbols, and we've only got two
  56    obvious Lisp types to play with.  Sad, but true."
  57
  58   (name nil :type (or string symbol) :read-only t)
  59   (value nil :type t :read-only t)
  60   (%type nil :type symbol :read-only t)
  61   (location (file-location nil) :type file-location :read-only t)
  62   (key nil :type symbol :read-only t)
  63   (seenp nil :type boolean))
  64 (define-access-wrapper p-type p-%type :read-only t)
  65
  66 (export 'decode-property)
  67 (defgeneric decode-property (raw)
  68   (:documentation "Decode a RAW value into a TYPE, VALUE pair.")
  69   (:method ((raw property)) (values (p-type raw) (p-value raw)))
  70   (:method ((raw cons)) (values (car raw) (cdr raw))))
  71
  72 (export 'make-property)
  73 (defun make-property (name raw-value &key type location seenp)
  74   (multiple-value-bind (type value)
  75       (if type
  76           (values type raw-value)
  77           (decode-property raw-value))
  78     (%make-property name value
  79                     :type type
  80                     :location (file-location location)
  81                     :seenp seenp)))
  82
  83 (export 'coerce-property-value)
  84 (defgeneric coerce-property-value (value type wanted)
  85   (:documentation
  86    "Convert VALUE, a property of type TYPE, to be of type WANTED.
  87
  88    It's sensible to add additional methods to this function, but there are
  89    all the ones we need.")
  90
  91   ;; If TYPE matches WANTED, we'll assume that VALUE already has the right
  92   ;; form.  Otherwise, if nothing else matched, then I guess we'll have to
  93   ;; say it didn't work.
  94   (:method (value type wanted)
  95     (if (eql type wanted) value
  96         (error "Incorrect type: expected ~A but found ~A" wanted type)))
  97
  98   ;; If the caller asks for type T then give them the raw thing.
  99   (:method (value type (wanted (eql t)))
 100     (declare (ignore type))
 101     value))
 102
 103 ;;;--------------------------------------------------------------------------
 104 ;;; Property set representation.
 105
 106 (export '(pset psetp))
 107 (defstruct (pset (:predicate psetp)
 108                  (:constructor %make-pset)
 109                  (:conc-name %pset-))
 110   "A property set.
 111
 112    Wrapped up in a structure so that we can define a print function."
 113   (hash (make-hash-table) :type hash-table))
 114
 115 (export '(make-pset pset-get pset-store pset-map))
 116 (declaim (inline make-pset pset-get pset-store pset-map))
 117
 118 (defun make-pset ()
 119   "Constructor for property sets."
 120   (%make-pset))
 121
 122 (defun pset-get (pset key)
 123   "Look KEY up in PSET and return what we find.
 124
 125    If there's no property by that name, return nil."
 126   (values (gethash key (%pset-hash pset))))
 127
 128 (defun pset-store (pset prop)
 129   "Store property PROP in PSET.
 130
 131    Overwrite or replace any previous property with the same name.  Mutates
 132    the property set."
 133   (setf (gethash (p-key prop) (%pset-hash pset)) prop))
 134
 135 (defun pset-map (func pset)
 136   "Call FUNC for each property in PSET."
 137   (maphash (lambda (key value) (declare (ignore key)) (funcall func value))
 138            (%pset-hash pset)))
 139
 140 (export 'with-pset-iterator)
 141 (defmacro with-pset-iterator ((name pset) &body body)
 142   "Evaluate BODY with NAME bound to a macro returning properties from PSET.
 143
 144    Evaluating (NAME) returns a property object or nil if all properties have
 145    been read."
 146   (with-gensyms (next win key value)
 147     `(with-hash-table-iterator (,next (%pset-hash ,pset))
 148        (macrolet ((,name ()
 149                     `(multiple-value-bind (,',win ,',key ,',value) (,',next)
 150                       (declare (ignore ,',key))
 151                       (and ,',win ,',value))))
 152          ,@body))))
 153
 154 ;;;--------------------------------------------------------------------------
 155 ;;; `Cooked' property set operations.
 156
 157 (export 'store-property)
 158 (defun store-property
 159     (pset name value &key type location)
 160   "Store a property in PSET."
 161   (pset-store pset
 162               (make-property name value :type type :location location)))
 163
 164 (export 'get-property)
 165 (defun get-property (pset name type &optional default)
 166   "Fetch a property from a property set.
 167
 168    If a property NAME is not found in PSET, or if a property is found, but
 169    its type doesn't match TYPE, then return DEFAULT and nil; otherwise return
 170    the value and its file location.  In the latter case, mark the property as
 171    having been used.
 172
 173    The value returned depends on the TYPE argument provided.  If you pass
 174    `nil' then you get back the entire `property' object.  If you pass `t',
 175    then you get whatever was left in the property set, uninterpreted.
 176    Otherwise the value is coerced to the right kind of thing (where possible)
 177    and returned.
 178
 179    The file location at which the property was defined is returned as a
 180    second value.
 181
 182    If PSET is nil, then return DEFAULT and nil."
 183
 184   (let ((prop (and pset (pset-get pset (property-key name)))))
 185     (with-default-error-location ((and prop (p-location prop)))
 186       (cond ((not prop)
 187              (values default nil))
 188             ((not type)
 189              (setf (p-seenp prop) t)
 190              (values prop (p-location prop)))
 191             (t
 192              (setf (p-seenp prop) t)
 193              (values (coerce-property-value (p-value prop)
 194                                             (p-type prop)
 195                                             type)
 196                      (p-location prop)))))))
 197
 198 (export 'add-property)
 199 (defun add-property (pset name value &key type location)
 200   "Add a property to PSET.
 201
 202    If a property with the same NAME already exists, report an error."
 203
 204   (with-default-error-location (location)
 205     (let ((existing (get-property pset name nil)))
 206       (when existing
 207         (error "Property ~S already defined~@[ at ~A~]"
 208                name (p-location existing)))
 209       (store-property pset name value :type type :location location))))
 210
 211 (export 'make-property-set)
 212 (defun make-property-set (&rest plist)
 213   "Make a new property set, with given properties.
 214
 215    This isn't the way to make properties when parsing, but it works well for
 216    programmatic generation.  The arguments should form a property list
 217    (alternating keywords and values is good).
 218
 219    An attempt is made to guess property types from the Lisp types of the
 220    values.  This isn't always successful but it's not too bad.  The
 221    alternative is manufacturing a `property-value' object by hand and
 222    stuffing it into the set."
 223
 224   (property-set plist))
 225
 226 (export 'property-set)
 227 (defgeneric property-set (thing)
 228   (:documentation
 229    "Convert THING into a property set.")
 230   (:method ((pset pset)) pset)
 231   (:method ((list list))
 232     "Convert a list into a property set.  This works for alists and plists."
 233     (multiple-value-bind (next name value)
 234         (if (and list (consp (car list)))
 235             (values #'cdr #'caar #'cdar)
 236             (values #'cddr #'car #'cadr))
 237       (do ((pset (make-pset))
 238            (list list (funcall next list)))
 239           ((endp list) pset)
 240         (add-property pset (funcall name list) (funcall value list))))))
 241
 242 (export 'check-unused-properties)
 243 (defun check-unused-properties (pset)
 244   "Issue errors about unused properties in PSET."
 245   (when pset
 246     (pset-map (lambda (prop)
 247                 (unless (p-seenp prop)
 248                   (cerror*-with-location (p-location prop)
 249                                          "Unknown property `~A'"
 250                                          (p-name prop))
 251                   (setf (p-seenp prop) t)))
 252               pset)))
 253
 254 ;;;--------------------------------------------------------------------------
 255 ;;; Utility macros.
 256
 257 (export 'default-slot-from-property)
 258 (defmacro default-slot-from-property
 259     ((instance slot &optional (slot-names t))
 260      (pset property type
 261       &optional (pvar (gensym "PROP-"))
 262       &rest convert-forms)
 263      &body default-forms)
 264   "Initialize a slot from a property.
 265
 266    We initialize SLOT in INSTANCE.  In full: if PSET contains a property
 267    called NAME, then convert it to TYPE, bind the value to PVAR and evaluate
 268    CONVERT-FORMS -- these default to just using the property value.  If
 269    there's no property, and DEFAULT-FORMS contains at least one non-
 270    declaration form, and the slot is named in SLOT-NAMES and currently
 271    unbound, then evaluate DEFAULT-FORMS and use their value to compute the
 272    slot value."
 273
 274   (once-only (instance slot slot-names pset property type)
 275     (multiple-value-bind (docs decls body)
 276         (parse-body default-forms :docp nil)
 277       (declare (ignore docs))
 278       (with-gensyms (floc)
 279         `(multiple-value-bind (,pvar ,floc)
 280              (get-property ,pset ,property ,type)
 281            ,@decls
 282            (if ,floc
 283                (setf (slot-value ,instance ,slot)
 284                      (with-default-error-location (,floc)
 285                        ,@(or convert-forms `(,pvar))))
 286                ,@(and body
 287                       `((default-slot (,instance ,slot ,slot-names)
 288                           ,@body)))))))))
 289
 290 ;;;----- That's all, folks --------------------------------------------------