Major patch touching a lot, representing the new lol. is mostly drop-in backwards...

[clinton/lisp-on-lines.git] / src / properties.lisp

diff --git a/src/properties.lisp b/src/properties.lisp
new file mode 100644 (file)
index 0000000..9c2c129
--- /dev/null
+++ b/src/properties.lisp
@@ -0,0 +1,57 @@
+(in-package :lisp-on-lines)
+
+
+
+
+;;;; PLIST Utilities.
+
+(defun plist-nunion (new-props plist)
+  "Destructive Merge of plists. PLIST is modified and returned. 
+NEW-PROPS is merged into PLIST such that any properties
+in both PLIST and NEW-PROPS get the value in NEW-PROPS. 
+The other properties in PLIST are left untouched."
+  (loop for cons on new-props by #'cddr
+       do (setf (getf plist (first cons)) (second cons))
+       finally (return plist))
+  plist)
+
+(defun plist-union (new-props plist)
+  "Non-destructive version of plist-nunion"
+                  (plist-nunion new-props (copy-list plist)))
+
+
+
+
+    
+
+(defun slots-as-properties (object)
+  "Makes a plist by making a keyword from the ...ahh .. read the damn code"
+  (mapcan 
+   #'(lambda (slot-name)
+       (when (slot-boundp object slot-name)
+        
+        (list (intern (symbol-name slot-name) 
+                      (find-package :keyword))
+              (slot-value object slot-name))))
+   (list-slots object)))
+
+(defun properties-as-slots (plist)
+  "takes a plist and turns it into slot-definitions, interning the key names in *package*"
+  (loop for (key val) on plist by #'cddr
+       collect (let ((name (intern (symbol-name key))))
+                 `(,name :accessor ,name :initarg ,key :special t :initform ,val))))
+
+(defmacro with-properties ((properties &optional (prefix '||))  &body body)
+  (with-unique-names (p)
+    (let ((get (intern (strcat prefix '.get)))
+         (set (intern (strcat prefix '.set)))
+         (props (intern (strcat prefix '.properties))))
+      `(let ((,p ,properties))
+       (flet ((,get  (p)
+                (getf ,p p))
+              (,set (p v)
+                (setf (getf ,p p) v))
+              (,props ()
+                ,p))
+         (declare (ignorable #',get #',set #',props))
+         ,@body)))))
\ No newline at end of file