| 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))))) |