3 ;;; Protocol for property sets
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensble Object Design, an object system for C.
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.
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.
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.
28 ;;;--------------------------------------------------------------------------
29 ;;; Property representation.
31 (export 'property-key)
32 (defun property-key (name)
33 "Convert NAME into a keyword.
35 If NAME isn't a symbol already, then flip its case (using
36 `frob-identifier'), and intern into the `keyword' package."
39 (string (intern (frob-identifier name) :keyword))))
41 (export '(property propertyp p-name p-value p-type p-key p-seenp))
43 (:predicate propertyp)
45 (:constructor %make-property
47 &key type location seenp
48 &aux (key (property-key name)))))
49 "A simple structure for holding a property in a property set.
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.
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."
58 (name nil :type (or string symbol))
60 (type nil :type symbol)
61 (location (file-location nil) :type file-location)
62 (key nil :type symbol)
63 (seenp nil :type boolean))
65 (export 'decode-property)
66 (defgeneric decode-property (raw)
67 (:documentation "Decode a RAW value into a TYPE, VALUE pair.")
68 (:method ((raw symbol)) (values :symbol raw))
69 (:method ((raw integer)) (values :int raw))
70 (:method ((raw string)) (values :string raw))
71 (:method ((raw character)) (values :char raw))
72 (:method ((raw property)) (values (p-type raw) (p-value raw)))
73 (:method ((raw cons)) (values (car raw) (cdr raw))))
75 (export 'make-property)
76 (defun make-property (name raw-value &key type location seenp)
77 (multiple-value-bind (type value)
79 (values type raw-value)
80 (decode-property raw-value))
81 (%make-property name value
83 :location (file-location location)
86 (defun string-to-symbol
87 (string &key (package *package*) (swap-case t) (swap-hyphen t))
88 "Convert STRING to a symbol in PACKAGE.
90 Parse off a `PACKAGE:' prefix from STRING if necessary, to identify the
91 package; PACKAGE is used if there isn't a prefix. A doubled colon allows
92 access to internal symbols, and will intern if necessary. Note that
93 escape characters are /not/ processed; don't put colons in package names
94 if you want to use them from SOD property sets.
96 The portions of the string are modified by `frob-identifier'; the
97 arguments SWAP-CASE and SWAP-HYPHEN are passed to `frob-identifier' to
98 control this process."
100 (let* ((length (length string))
101 (colon (position #\: string)))
102 (multiple-value-bind (start internalp)
103 (cond ((not colon) (values 0 t))
104 ((and (< (1+ colon) length)
105 (char= (char string (1+ colon)) #\:))
106 (values (+ colon 2) t))
108 (values (1+ colon) nil)))
110 (let* ((package-name (if (zerop colon) "KEYWORD"
111 (frob-identifier (subseq string 0 colon)
113 :swap-hyphen swap-hyphen)))
114 (found (find-package package-name)))
116 (error "Unknown package `~A'" package-name))
117 (setf package found)))
118 (let ((name (frob-identifier (subseq string start)
120 :swap-hyphen swap-hyphen)))
121 (multiple-value-bind (symbol status)
122 (funcall (if internalp #'intern #'find-symbol) name package)
123 (cond ((or internalp (eq status :external))
126 (error "Symbol `~A' not found in package `~A'"
127 name (package-name package)))
129 (error "Symbol `~A' not external in package `~A'"
130 name (package-name package)))))))))
132 (export 'coerce-property-value)
133 (defgeneric coerce-property-value (value type wanted)
135 "Convert VALUE, a property of type TYPE, to be of type WANTED.
137 It's sensible to add additional methods to this function, but there are
138 all the ones we need.")
140 ;; If TYPE matches WANTED, we'll assume that VALUE already has the right
141 ;; form. Otherwise, if nothing else matched, then I guess we'll have to
142 ;; say it didn't work.
143 (:method (value type wanted)
144 (if (eql type wanted) value
145 (error "Incorrect type: expected ~A but found ~A" wanted type)))
147 ;; If the caller asks for type T then give him the raw thing.
148 (:method (value type (wanted (eql t)))
151 ;;;--------------------------------------------------------------------------
152 ;;; Property set representation.
154 (export '(pset psetp))
155 (defstruct (pset (:predicate psetp)
156 (:constructor %make-pset)
160 Wrapped up in a structure so that we can define a print function."
161 (hash (make-hash-table) :type hash-table))
163 (export '(make-pset pset-get pset-store pset-map))
164 (declaim (inline make-pset pset-get pset-store pset-map))
167 "Constructor for property sets."
170 (defun pset-get (pset key)
171 "Look KEY up in PSET and return what we find.
173 If there's no property by that name, return NIL."
174 (values (gethash key (%pset-hash pset))))
176 (defun pset-store (pset prop)
177 "Store property PROP in PSET.
179 Overwrite or replace any previous property with the same name. Mutates
181 (setf (gethash (p-key prop) (%pset-hash pset)) prop))
183 (defun pset-map (func pset)
184 "Call FUNC for each property in PSET."
185 (maphash (lambda (key value) (declare (ignore key)) (funcall func value))
188 (export 'with-pset-iterator)
189 (defmacro with-pset-iterator ((name pset) &body body)
190 "Evaluate BODY with NAME bound to a macro returning properties from PSET.
192 Evaluating (NAME) returns a property object or nil if all properties have
194 (with-gensyms (next win key value)
195 `(with-hash-table-iterator (,next (%pset-hash ,pset))
197 `(multiple-value-bind (,',win ,',key ,',value) (,',next)
198 (declare (ignore ,',key))
199 (and ,',win ,',value))))
202 ;;;--------------------------------------------------------------------------
203 ;;; `Cooked' property set operations.
205 (export 'store-property)
206 (defun store-property
207 (pset name value &key type location)
208 "Store a property in PSET."
210 (make-property name value :type type :location location)))
212 (export 'get-property)
213 (defun get-property (pset name type &optional default)
214 "Fetch a property from a property set.
216 If a property NAME is not found in PSET, or if a property is found, but
217 its type doesn't match TYPE, then return DEFAULT and nil; otherwise return
218 the value and its file location. In the latter case, mark the property as
221 The value returned depends on the TYPE argument provided. If you pass
222 `nil' then you get back the entire `property' object. If you pass `t',
223 then you get whatever was left in the property set, uninterpreted.
224 Otherwise the value is coerced to the right kind of thing (where possible)
227 If PSET is nil, then return DEFAULT."
229 (let ((prop (and pset (pset-get pset (property-key name)))))
230 (with-default-error-location ((and prop (p-location prop)))
232 (values default nil))
234 (setf (p-seenp prop) t)
235 (values prop (p-location prop)))
237 (setf (p-seenp prop) t)
238 (values (coerce-property-value (p-value prop)
241 (p-location prop)))))))
243 (export 'add-property)
244 (defun add-property (pset name value &key type location)
245 "Add a property to PSET.
247 If a property with the same NAME already exists, report an error."
249 (with-default-error-location (location)
250 (let ((existing (get-property pset name nil)))
252 (error "Property ~S already defined~@[ at ~A~]"
253 name (p-location existing)))
254 (store-property pset name value :type type :location location))))
256 (export 'make-property-set)
257 (defun make-property-set (&rest plist)
258 "Make a new property set, with given properties.
260 This isn't the way to make properties when parsing, but it works well for
261 programmatic generation. The arguments should form a property list
262 (alternating keywords and values is good).
264 An attempt is made to guess property types from the Lisp types of the
265 values. This isn't always successful but it's not too bad. The
266 alternative is manufacturing a `property-value' object by hand and
267 stuffing it into the set."
269 (property-set plist))
271 (export 'property-set)
272 (defgeneric property-set (thing)
274 "Convert THING into a property set.")
275 (:method ((pset pset)) pset)
276 (:method ((list list))
277 "Convert a list into a property set. This works for alists and plists."
278 (multiple-value-bind (next name value)
279 (if (and list (consp (car list)))
280 (values #'cdr #'caar #'cdar)
281 (values #'cddr #'car #'cadr))
282 (do ((pset (make-pset))
283 (list list (funcall next list)))
285 (add-property pset (funcall name list) (funcall value list))))))
287 (export 'check--unused-properties)
288 (defun check-unused-properties (pset)
289 "Issue errors about unused properties in PSET."
291 (pset-map (lambda (prop)
292 (unless (p-seenp prop)
293 (cerror*-with-location (p-location prop)
294 "Unknown property `~A'"
296 (setf (p-seenp prop) t)))
299 ;;;--------------------------------------------------------------------------
302 (defmacro default-slot-from-property
303 ((instance slot slot-names)
305 &optional (pvar (gensym "PROP-"))
308 "Initialize a slot from a property.
310 We initialize SLOT in INSTANCE. In full: if PSET contains a property
311 called NAME, then convert it to TYPE, bind the value to PVAR and evaluate
312 CONVERT-FORMS -- these default to just using the property value. If
313 there's no property, and the slot is named in SLOT-NAMES and currently
314 unbound, then evaluate DEFAULT-FORMS and use their value to compute the
317 (once-only (instance slot slot-names pset property type)
319 `(multiple-value-bind (,pvar ,floc)
320 (get-property ,pset ,property ,type)
322 (setf (slot-value ,instance ,slot)
323 (with-default-error-location (,floc)
324 ,@(or convert-forms `(,pvar))))
325 (default-slot (,instance ,slot ,slot-names)
326 ,@default-forms))))))
328 ;;;----- That's all, folks --------------------------------------------------