Commit | Line | Data |
---|---|---|
2b0fd9c8 DC |
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))))) |