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

[clinton/lisp-on-lines.git] / src / special-initargs.lisp

diff --git a/src/special-initargs.lisp b/src/special-initargs.lisp
new file mode 100644 (file)
index 0000000..5fffa46
--- /dev/null
+++ b/src/special-initargs.lisp
@@ -0,0 +1,38 @@
+(in-package :lisp-on-lines)
+
+(defmethod initargs.slot-names (object)
+  "Returns ALIST of (initargs) . slot-name."
+  (nreverse (mapcar #'(lambda (slot)
+             (cons (closer-mop:slot-definition-initargs slot)
+                   (closer-mop:slot-definition-name slot)))
+         (closer-mop:class-slots (class-of object)))))
+
+(defun find-slot-names-from-initargs-plist (object initargs-plist)
+  "returns (VALUES SLOT-NAMES VALUES), Given a plist of initargs such as one would pass to :DEFAULT-INITARGS.
+SLOT-NAMES contains the slot-names specified by the initarg, and VALUES the corresponding VALUE."
+  (let (slot-names values
+       (initargs.slot-names-alist (initargs.slot-names object))) 
+    (loop for (initarg value) on initargs-plist
+         do (let ((slot-name
+                   (cdr (assoc-if #'(lambda (x) (member initarg x))
+                                  initargs.slot-names-alist))))
+              (when slot-name ;ignore invalid initargs. (good idea/bad idea?)
+                (push slot-name slot-names)
+                (push value values)))
+         finally (return (values slot-names values)))))
+
+(defun funcall-with-special-initargs (object initargs function &rest args)
+  "Call FUNCTION with dynnamic bindings of the slots in OBJECT specified by the INITARGS plist"
+  (multiple-value-bind (slot-names values)
+       (find-slot-names-from-initargs-plist object initargs)
+      (special-symbol-progv
+         (with-symbol-access
+           (loop for slot-name in slot-names
+                 collect (slot-value object slot-name)))
+         values
+       (apply function args))))
+
+(defmacro with-special-initargs ((object &rest initargs) &body body)
+  `(funcall-with-special-initargs ,object ,initargs
+    #'(lambda ()
+       ,@body)))
\ No newline at end of file