Commit | Line | Data |
---|---|---|
dea4d055 MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Protocol for property sets | |
4 | ;;; | |
5 | ;;; (c) 2009 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
e0808c47 | 10 | ;;; This file is part of the Sensible Object Design, an object system for C. |
dea4d055 MW |
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 | ||
048d0b2d | 41 | (export '(property propertyp p-name p-value p-type p-key p-seenp)) |
dea4d055 MW |
42 | (defstruct (property |
43 | (:predicate propertyp) | |
44 | (:conc-name p-) | |
048d0b2d MW |
45 | (:constructor %make-property |
46 | (name value | |
47 | &key type location seenp | |
4b8e5c03 | 48 | &aux (key (property-key name)) (%type type)))) |
dea4d055 MW |
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 | ||
6ee19709 MW |
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) | |
dea4d055 | 63 | (seenp nil :type boolean)) |
96baf945 | 64 | (define-access-wrapper p-type p-%type :read-only t) |
dea4d055 | 65 | |
048d0b2d MW |
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))) | |
ea578bb4 | 74 | (:method ((raw cons)) (values (car raw) (cdr raw))) |
6ee19709 MW |
75 | (:method ((raw function)) (values :func raw)) |
76 | (:method ((raw c-type)) (values :type raw))) | |
048d0b2d MW |
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 | ||
dea4d055 MW |
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))) | |
1d8cc67a | 152 | (declare (ignore type)) |
dea4d055 MW |
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 | ||
268f7777 | 177 | If there's no property by that name, return nil." |
dea4d055 MW |
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 () | |
048d0b2d MW |
201 | `(multiple-value-bind (,',win ,',key ,',value) (,',next) |
202 | (declare (ignore ,',key)) | |
203 | (and ,',win ,',value)))) | |
dea4d055 MW |
204 | ,@body)))) |
205 | ||
206 | ;;;-------------------------------------------------------------------------- | |
207 | ;;; `Cooked' property set operations. | |
208 | ||
209 | (export 'store-property) | |
210 | (defun store-property | |
048d0b2d | 211 | (pset name value &key type location) |
dea4d055 MW |
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 | ||
3109662a MW |
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. | |
dea4d055 | 230 | |
ea578bb4 MW |
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." | |
dea4d055 MW |
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) | |
048d0b2d | 251 | (defun add-property (pset name value &key type location) |
dea4d055 MW |
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 | |
3109662a | 273 | alternative is manufacturing a `property-value' object by hand and |
048d0b2d | 274 | stuffing it into the set." |
dea4d055 MW |
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 | ||
b2d75547 | 294 | (export 'check-unused-properties) |
dea4d055 MW |
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 | |
ecdf14f0 | 310 | ((instance slot &optional (slot-names t)) |
dea4d055 MW |
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 the slot is named in SLOT-NAMES and currently | |
321 | unbound, then evaluate DEFAULT-FORMS and use their value to compute the | |
322 | slot value." | |
323 | ||
324 | (once-only (instance slot slot-names pset property type) | |
b8c698ee MW |
325 | (multiple-value-bind (docs decls body) |
326 | (parse-body default-forms :docp nil) | |
327 | (declare (ignore docs)) | |
328 | (with-gensyms (floc) | |
329 | `(multiple-value-bind (,pvar ,floc) | |
330 | (get-property ,pset ,property ,type) | |
331 | ,@decls | |
332 | (if ,floc | |
333 | (setf (slot-value ,instance ,slot) | |
334 | (with-default-error-location (,floc) | |
335 | ,@(or convert-forms `(,pvar)))) | |
336 | (default-slot (,instance ,slot ,slot-names) | |
337 | ,@body))))))) | |
dea4d055 MW |
338 | |
339 | ;;;----- That's all, folks -------------------------------------------------- |