| 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~)" |
| 97 | wanted type))) |
| 98 | |
| 99 | ;; If the caller asks for type T then give them the raw thing. |
| 100 | (:method (value type (wanted (eql t))) |
| 101 | (declare (ignore type)) |
| 102 | value)) |
| 103 | |
| 104 | ;;;-------------------------------------------------------------------------- |
| 105 | ;;; Property set representation. |
| 106 | |
| 107 | (export '(pset psetp)) |
| 108 | (defstruct (pset (:predicate psetp) |
| 109 | (:constructor %make-pset) |
| 110 | (:conc-name %pset-)) |
| 111 | "A property set. |
| 112 | |
| 113 | Wrapped up in a structure so that we can define a print function." |
| 114 | (hash (make-hash-table) :type hash-table)) |
| 115 | |
| 116 | (export '(make-pset pset-get pset-store pset-map)) |
| 117 | (declaim (inline make-pset pset-get pset-store pset-map)) |
| 118 | |
| 119 | (defun make-pset () |
| 120 | "Constructor for property sets." |
| 121 | (%make-pset)) |
| 122 | |
| 123 | (defun pset-get (pset key) |
| 124 | "Look KEY up in PSET and return what we find. |
| 125 | |
| 126 | If there's no property by that name, return nil." |
| 127 | (values (gethash key (%pset-hash pset)))) |
| 128 | |
| 129 | (defun pset-store (pset prop) |
| 130 | "Store property PROP in PSET. |
| 131 | |
| 132 | Overwrite or replace any previous property with the same name. Mutates |
| 133 | the property set." |
| 134 | (setf (gethash (p-key prop) (%pset-hash pset)) prop)) |
| 135 | |
| 136 | (defun pset-map (func pset) |
| 137 | "Call FUNC for each property in PSET." |
| 138 | (maphash (lambda (key value) (declare (ignore key)) (funcall func value)) |
| 139 | (%pset-hash pset))) |
| 140 | |
| 141 | (export 'with-pset-iterator) |
| 142 | (defmacro with-pset-iterator ((name pset) &body body) |
| 143 | "Evaluate BODY with NAME bound to a macro returning properties from PSET. |
| 144 | |
| 145 | Evaluating (NAME) returns a property object or nil if all properties have |
| 146 | been read." |
| 147 | (with-gensyms (next win key value) |
| 148 | `(with-hash-table-iterator (,next (%pset-hash ,pset)) |
| 149 | (macrolet ((,name () |
| 150 | `(multiple-value-bind (,',win ,',key ,',value) (,',next) |
| 151 | (declare (ignore ,',key)) |
| 152 | (and ,',win ,',value)))) |
| 153 | ,@body)))) |
| 154 | |
| 155 | ;;;-------------------------------------------------------------------------- |
| 156 | ;;; `Cooked' property set operations. |
| 157 | |
| 158 | (export 'store-property) |
| 159 | (defun store-property |
| 160 | (pset name value &key type location) |
| 161 | "Store a property in PSET." |
| 162 | (pset-store pset |
| 163 | (make-property name value :type type :location location))) |
| 164 | |
| 165 | (export 'get-property) |
| 166 | (defun get-property (pset name type &optional default) |
| 167 | "Fetch a property from a property set. |
| 168 | |
| 169 | If a property NAME is not found in PSET, or if a property is found, but |
| 170 | its type doesn't match TYPE, then return DEFAULT and nil; otherwise return |
| 171 | the value and its file location. In the latter case, mark the property as |
| 172 | having been used. |
| 173 | |
| 174 | The value returned depends on the TYPE argument provided. If you pass |
| 175 | `nil' then you get back the entire `property' object. If you pass `t', |
| 176 | then you get whatever was left in the property set, uninterpreted. |
| 177 | Otherwise the value is coerced to the right kind of thing (where possible) |
| 178 | and returned. |
| 179 | |
| 180 | The file location at which the property was defined is returned as a |
| 181 | second value. |
| 182 | |
| 183 | If PSET is nil, then return DEFAULT and nil." |
| 184 | |
| 185 | (let ((prop (and pset (pset-get pset (property-key name))))) |
| 186 | (with-default-error-location ((and prop (p-location prop))) |
| 187 | (cond ((not prop) |
| 188 | (values default nil)) |
| 189 | ((not type) |
| 190 | (setf (p-seenp prop) t) |
| 191 | (values prop (p-location prop))) |
| 192 | (t |
| 193 | (setf (p-seenp prop) t) |
| 194 | (values (coerce-property-value (p-value prop) |
| 195 | (p-type prop) |
| 196 | type) |
| 197 | (p-location prop))))))) |
| 198 | |
| 199 | (export 'add-property) |
| 200 | (defun add-property (pset name value &key type location) |
| 201 | "Add a property to PSET. |
| 202 | |
| 203 | If a property with the same NAME already exists, report an error." |
| 204 | |
| 205 | (with-default-error-location (location) |
| 206 | (let ((existing (get-property pset name nil))) |
| 207 | (when existing |
| 208 | (error "Property ~S already defined~@[ at ~A~]" |
| 209 | name (p-location existing))) |
| 210 | (store-property pset name value :type type :location location)))) |
| 211 | |
| 212 | (export 'make-property-set) |
| 213 | (defun make-property-set (&rest plist) |
| 214 | "Make a new property set, with given properties. |
| 215 | |
| 216 | This isn't the way to make properties when parsing, but it works well for |
| 217 | programmatic generation. The arguments should form a property list |
| 218 | (alternating keywords and values is good). |
| 219 | |
| 220 | An attempt is made to guess property types from the Lisp types of the |
| 221 | values. This isn't always successful but it's not too bad. The |
| 222 | alternative is manufacturing a `property-value' object by hand and |
| 223 | stuffing it into the set." |
| 224 | |
| 225 | (property-set plist)) |
| 226 | |
| 227 | (export 'property-set) |
| 228 | (defgeneric property-set (thing) |
| 229 | (:documentation |
| 230 | "Convert THING into a property set.") |
| 231 | (:method ((pset pset)) pset) |
| 232 | (:method ((list list)) |
| 233 | "Convert a list into a property set. This works for alists and plists." |
| 234 | (multiple-value-bind (next name value) |
| 235 | (if (and list (consp (car list))) |
| 236 | (values #'cdr #'caar #'cdar) |
| 237 | (values #'cddr #'car #'cadr)) |
| 238 | (do ((pset (make-pset)) |
| 239 | (list list (funcall next list))) |
| 240 | ((endp list) pset) |
| 241 | (add-property pset (funcall name list) (funcall value list)))))) |
| 242 | |
| 243 | (export 'check-unused-properties) |
| 244 | (defun check-unused-properties (pset) |
| 245 | "Issue errors about unused properties in PSET." |
| 246 | (when pset |
| 247 | (pset-map (lambda (prop) |
| 248 | (unless (p-seenp prop) |
| 249 | (cerror*-with-location (p-location prop) |
| 250 | "Unknown property `~A'" |
| 251 | (p-name prop)) |
| 252 | (setf (p-seenp prop) t))) |
| 253 | pset))) |
| 254 | |
| 255 | ;;;-------------------------------------------------------------------------- |
| 256 | ;;; Utility macros. |
| 257 | |
| 258 | (export 'default-slot-from-property) |
| 259 | (defmacro default-slot-from-property |
| 260 | ((instance slot &optional (slot-names t)) |
| 261 | (pset property type |
| 262 | &optional (pvar (gensym "PROP-")) |
| 263 | &rest convert-forms) |
| 264 | &body default-forms) |
| 265 | "Initialize a slot from a property. |
| 266 | |
| 267 | We initialize SLOT in INSTANCE. In full: if PSET contains a property |
| 268 | called NAME, then convert it to TYPE, bind the value to PVAR and evaluate |
| 269 | CONVERT-FORMS -- these default to just using the property value. If |
| 270 | there's no property, and DEFAULT-FORMS contains at least one non- |
| 271 | declaration form, and the slot is named in SLOT-NAMES and currently |
| 272 | unbound, then evaluate DEFAULT-FORMS and use their value to compute the |
| 273 | slot value." |
| 274 | |
| 275 | (once-only (instance slot slot-names pset property type) |
| 276 | (multiple-value-bind (docs decls body) |
| 277 | (parse-body default-forms :docp nil) |
| 278 | (declare (ignore docs)) |
| 279 | (with-gensyms (floc) |
| 280 | `(multiple-value-bind (,pvar ,floc) |
| 281 | (get-property ,pset ,property ,type) |
| 282 | ,@decls |
| 283 | (if ,floc |
| 284 | (setf (slot-value ,instance ,slot) |
| 285 | (with-default-error-location (,floc) |
| 286 | ,@(or convert-forms `(,pvar)))) |
| 287 | ,@(and body |
| 288 | `((default-slot (,instance ,slot ,slot-names) |
| 289 | ,@body))))))))) |
| 290 | |
| 291 | ;;;----- That's all, folks -------------------------------------------------- |