fixed up display mechanism
[clinton/lisp-on-lines.git] / src / properties.lisp
1 (in-package :lisp-on-lines)
2
3
4
5
6 ;;;; PLIST Utilities.
7
8 (defun plist-nunion (new-props plist)
9 "Destructive Merge of plists. PLIST is modified and returned.
10 NEW-PROPS is merged into PLIST such that any properties
11 in both PLIST and NEW-PROPS get the value in NEW-PROPS.
12 The other properties in PLIST are left untouched."
13 (loop for cons on new-props by #'cddr
14 do (setf (getf plist (first cons)) (second cons))
15 finally (return plist))
16 plist)
17
18 (defun plist-union (new-props plist)
19 "Non-destructive version of plist-nunion"
20 (plist-nunion new-props (copy-list plist)))
21
22
23
24
25
26
27 (defun slots-as-properties (object)
28 "Makes a plist by making a keyword from the ...ahh .. read the damn code"
29 (mapcan
30 #'(lambda (slot-name)
31 (when (slot-boundp object slot-name)
32
33 (list (intern (symbol-name slot-name)
34 (find-package :keyword))
35 (slot-value object slot-name))))
36 (list-slots object)))
37
38 (defun properties-as-slots (plist)
39 "takes a plist and turns it into slot-definitions, interning the key names in *package*"
40 (loop for (key val) on plist by #'cddr
41 collect (let ((name (intern (symbol-name key))))
42 `(,name :accessor ,name :initarg ,key :special t :initform ,val))))
43
44 (defmacro with-properties ((properties &optional (prefix '||)) &body body)
45 (with-unique-names (p)
46 (let ((get (intern (strcat prefix '.get)))
47 (set (intern (strcat prefix '.set)))
48 (props (intern (strcat prefix '.properties))))
49 `(let ((,p ,properties))
50 (flet ((,get (p)
51 (getf ,p p))
52 (,set (p v)
53 (setf (getf ,p p) v))
54 (,props ()
55 ,p))
56 (declare (ignorable #',get #',set #',props))
57 ,@body)))))