| 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 symbol)) (values :symbol raw)) |
| 70 | (:method ((raw integer)) (values :int raw)) |
| 71 | (:method ((raw string)) (values :string raw)) |
| 72 | (:method ((raw character)) (values :char raw)) |
| 73 | (:method ((raw property)) (values (p-type raw) (p-value raw))) |
| 74 | (:method ((raw cons)) (values (car raw) (cdr raw))) |
| 75 | (:method ((raw function)) (values :func raw)) |
| 76 | (:method ((raw c-type)) (values :type raw))) |
| 77 | |
| 78 | (export 'make-property) |
| 79 | (defun make-property (name raw-value &key type location seenp) |
| 80 | (multiple-value-bind (type value) |
| 81 | (if type |
| 82 | (values type raw-value) |
| 83 | (decode-property raw-value)) |
| 84 | (%make-property name value |
| 85 | :type type |
| 86 | :location (file-location location) |
| 87 | :seenp seenp))) |
| 88 | |
| 89 | (defun string-to-symbol |
| 90 | (string &key (package *package*) (swap-case t) (swap-hyphen t)) |
| 91 | "Convert STRING to a symbol in PACKAGE. |
| 92 | |
| 93 | Parse off a `PACKAGE:' prefix from STRING if necessary, to identify the |
| 94 | package; PACKAGE is used if there isn't a prefix. A doubled colon allows |
| 95 | access to internal symbols, and will intern if necessary. Note that |
| 96 | escape characters are /not/ processed; don't put colons in package names |
| 97 | if you want to use them from SOD property sets. |
| 98 | |
| 99 | The portions of the string are modified by `frob-identifier'; the |
| 100 | arguments SWAP-CASE and SWAP-HYPHEN are passed to `frob-identifier' to |
| 101 | control this process." |
| 102 | |
| 103 | (let* ((length (length string)) |
| 104 | (colon (position #\: string))) |
| 105 | (multiple-value-bind (start internalp) |
| 106 | (cond ((not colon) (values 0 t)) |
| 107 | ((and (< (1+ colon) length) |
| 108 | (char= (char string (1+ colon)) #\:)) |
| 109 | (values (+ colon 2) t)) |
| 110 | (t |
| 111 | (values (1+ colon) nil))) |
| 112 | (when colon |
| 113 | (let* ((package-name (if (zerop colon) "KEYWORD" |
| 114 | (frob-identifier (subseq string 0 colon) |
| 115 | :swap-case swap-case |
| 116 | :swap-hyphen swap-hyphen))) |
| 117 | (found (find-package package-name))) |
| 118 | (unless found |
| 119 | (error "Unknown package `~A'" package-name)) |
| 120 | (setf package found))) |
| 121 | (let ((name (frob-identifier (subseq string start) |
| 122 | :swap-case swap-case |
| 123 | :swap-hyphen swap-hyphen))) |
| 124 | (multiple-value-bind (symbol status) |
| 125 | (funcall (if internalp #'intern #'find-symbol) name package) |
| 126 | (cond ((or internalp (eq status :external)) |
| 127 | symbol) |
| 128 | ((not status) |
| 129 | (error "Symbol `~A' not found in package `~A'" |
| 130 | name (package-name package))) |
| 131 | (t |
| 132 | (error "Symbol `~A' not external in package `~A'" |
| 133 | name (package-name package))))))))) |
| 134 | |
| 135 | (export 'coerce-property-value) |
| 136 | (defgeneric coerce-property-value (value type wanted) |
| 137 | (:documentation |
| 138 | "Convert VALUE, a property of type TYPE, to be of type WANTED. |
| 139 | |
| 140 | It's sensible to add additional methods to this function, but there are |
| 141 | all the ones we need.") |
| 142 | |
| 143 | ;; If TYPE matches WANTED, we'll assume that VALUE already has the right |
| 144 | ;; form. Otherwise, if nothing else matched, then I guess we'll have to |
| 145 | ;; say it didn't work. |
| 146 | (:method (value type wanted) |
| 147 | (if (eql type wanted) value |
| 148 | (error "Incorrect type: expected ~A but found ~A" wanted type))) |
| 149 | |
| 150 | ;; If the caller asks for type T then give him the raw thing. |
| 151 | (:method (value type (wanted (eql t))) |
| 152 | (declare (ignore type)) |
| 153 | value)) |
| 154 | |
| 155 | ;;;-------------------------------------------------------------------------- |
| 156 | ;;; Property set representation. |
| 157 | |
| 158 | (export '(pset psetp)) |
| 159 | (defstruct (pset (:predicate psetp) |
| 160 | (:constructor %make-pset) |
| 161 | (:conc-name %pset-)) |
| 162 | "A property set. |
| 163 | |
| 164 | Wrapped up in a structure so that we can define a print function." |
| 165 | (hash (make-hash-table) :type hash-table)) |
| 166 | |
| 167 | (export '(make-pset pset-get pset-store pset-map)) |
| 168 | (declaim (inline make-pset pset-get pset-store pset-map)) |
| 169 | |
| 170 | (defun make-pset () |
| 171 | "Constructor for property sets." |
| 172 | (%make-pset)) |
| 173 | |
| 174 | (defun pset-get (pset key) |
| 175 | "Look KEY up in PSET and return what we find. |
| 176 | |
| 177 | If there's no property by that name, return nil." |
| 178 | (values (gethash key (%pset-hash pset)))) |
| 179 | |
| 180 | (defun pset-store (pset prop) |
| 181 | "Store property PROP in PSET. |
| 182 | |
| 183 | Overwrite or replace any previous property with the same name. Mutates |
| 184 | the property set." |
| 185 | (setf (gethash (p-key prop) (%pset-hash pset)) prop)) |
| 186 | |
| 187 | (defun pset-map (func pset) |
| 188 | "Call FUNC for each property in PSET." |
| 189 | (maphash (lambda (key value) (declare (ignore key)) (funcall func value)) |
| 190 | (%pset-hash pset))) |
| 191 | |
| 192 | (export 'with-pset-iterator) |
| 193 | (defmacro with-pset-iterator ((name pset) &body body) |
| 194 | "Evaluate BODY with NAME bound to a macro returning properties from PSET. |
| 195 | |
| 196 | Evaluating (NAME) returns a property object or nil if all properties have |
| 197 | been read." |
| 198 | (with-gensyms (next win key value) |
| 199 | `(with-hash-table-iterator (,next (%pset-hash ,pset)) |
| 200 | (macrolet ((,name () |
| 201 | `(multiple-value-bind (,',win ,',key ,',value) (,',next) |
| 202 | (declare (ignore ,',key)) |
| 203 | (and ,',win ,',value)))) |
| 204 | ,@body)))) |
| 205 | |
| 206 | ;;;-------------------------------------------------------------------------- |
| 207 | ;;; `Cooked' property set operations. |
| 208 | |
| 209 | (export 'store-property) |
| 210 | (defun store-property |
| 211 | (pset name value &key type location) |
| 212 | "Store a property in PSET." |
| 213 | (pset-store pset |
| 214 | (make-property name value :type type :location location))) |
| 215 | |
| 216 | (export 'get-property) |
| 217 | (defun get-property (pset name type &optional default) |
| 218 | "Fetch a property from a property set. |
| 219 | |
| 220 | If a property NAME is not found in PSET, or if a property is found, but |
| 221 | its type doesn't match TYPE, then return DEFAULT and nil; otherwise return |
| 222 | the value and its file location. In the latter case, mark the property as |
| 223 | having been used. |
| 224 | |
| 225 | The value returned depends on the TYPE argument provided. If you pass |
| 226 | `nil' then you get back the entire `property' object. If you pass `t', |
| 227 | then you get whatever was left in the property set, uninterpreted. |
| 228 | Otherwise the value is coerced to the right kind of thing (where possible) |
| 229 | and returned. |
| 230 | |
| 231 | The file location at which the property was defined is returned as a |
| 232 | second value. |
| 233 | |
| 234 | If PSET is nil, then return DEFAULT and nil." |
| 235 | |
| 236 | (let ((prop (and pset (pset-get pset (property-key name))))) |
| 237 | (with-default-error-location ((and prop (p-location prop))) |
| 238 | (cond ((not prop) |
| 239 | (values default nil)) |
| 240 | ((not type) |
| 241 | (setf (p-seenp prop) t) |
| 242 | (values prop (p-location prop))) |
| 243 | (t |
| 244 | (setf (p-seenp prop) t) |
| 245 | (values (coerce-property-value (p-value prop) |
| 246 | (p-type prop) |
| 247 | type) |
| 248 | (p-location prop))))))) |
| 249 | |
| 250 | (export 'add-property) |
| 251 | (defun add-property (pset name value &key type location) |
| 252 | "Add a property to PSET. |
| 253 | |
| 254 | If a property with the same NAME already exists, report an error." |
| 255 | |
| 256 | (with-default-error-location (location) |
| 257 | (let ((existing (get-property pset name nil))) |
| 258 | (when existing |
| 259 | (error "Property ~S already defined~@[ at ~A~]" |
| 260 | name (p-location existing))) |
| 261 | (store-property pset name value :type type :location location)))) |
| 262 | |
| 263 | (export 'make-property-set) |
| 264 | (defun make-property-set (&rest plist) |
| 265 | "Make a new property set, with given properties. |
| 266 | |
| 267 | This isn't the way to make properties when parsing, but it works well for |
| 268 | programmatic generation. The arguments should form a property list |
| 269 | (alternating keywords and values is good). |
| 270 | |
| 271 | An attempt is made to guess property types from the Lisp types of the |
| 272 | values. This isn't always successful but it's not too bad. The |
| 273 | alternative is manufacturing a `property-value' object by hand and |
| 274 | stuffing it into the set." |
| 275 | |
| 276 | (property-set plist)) |
| 277 | |
| 278 | (export 'property-set) |
| 279 | (defgeneric property-set (thing) |
| 280 | (:documentation |
| 281 | "Convert THING into a property set.") |
| 282 | (:method ((pset pset)) pset) |
| 283 | (:method ((list list)) |
| 284 | "Convert a list into a property set. This works for alists and plists." |
| 285 | (multiple-value-bind (next name value) |
| 286 | (if (and list (consp (car list))) |
| 287 | (values #'cdr #'caar #'cdar) |
| 288 | (values #'cddr #'car #'cadr)) |
| 289 | (do ((pset (make-pset)) |
| 290 | (list list (funcall next list))) |
| 291 | ((endp list) pset) |
| 292 | (add-property pset (funcall name list) (funcall value list)))))) |
| 293 | |
| 294 | (export 'check-unused-properties) |
| 295 | (defun check-unused-properties (pset) |
| 296 | "Issue errors about unused properties in PSET." |
| 297 | (when pset |
| 298 | (pset-map (lambda (prop) |
| 299 | (unless (p-seenp prop) |
| 300 | (cerror*-with-location (p-location prop) |
| 301 | "Unknown property `~A'" |
| 302 | (p-name prop)) |
| 303 | (setf (p-seenp prop) t))) |
| 304 | pset))) |
| 305 | |
| 306 | ;;;-------------------------------------------------------------------------- |
| 307 | ;;; Utility macros. |
| 308 | |
| 309 | (defmacro default-slot-from-property |
| 310 | ((instance slot &optional (slot-names t)) |
| 311 | (pset property type |
| 312 | &optional (pvar (gensym "PROP-")) |
| 313 | &rest convert-forms) |
| 314 | &body default-forms) |
| 315 | "Initialize a slot from a property. |
| 316 | |
| 317 | We initialize SLOT in INSTANCE. In full: if PSET contains a property |
| 318 | called NAME, then convert it to TYPE, bind the value to PVAR and evaluate |
| 319 | CONVERT-FORMS -- these default to just using the property value. If |
| 320 | there's no property, and DEFAULT-FORMS contains at least one non- |
| 321 | declaration form, and the slot is named in SLOT-NAMES and currently |
| 322 | unbound, then evaluate DEFAULT-FORMS and use their value to compute the |
| 323 | slot value." |
| 324 | |
| 325 | (once-only (instance slot slot-names pset property type) |
| 326 | (multiple-value-bind (docs decls body) |
| 327 | (parse-body default-forms :docp nil) |
| 328 | (declare (ignore docs)) |
| 329 | (with-gensyms (floc) |
| 330 | `(multiple-value-bind (,pvar ,floc) |
| 331 | (get-property ,pset ,property ,type) |
| 332 | ,@decls |
| 333 | (if ,floc |
| 334 | (setf (slot-value ,instance ,slot) |
| 335 | (with-default-error-location (,floc) |
| 336 | ,@(or convert-forms `(,pvar)))) |
| 337 | ,@(and body |
| 338 | `((default-slot (,instance ,slot ,slot-names) |
| 339 | ,@body))))))))) |
| 340 | |
| 341 | ;;;----- That's all, folks -------------------------------------------------- |