X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/80fcd57c2870eac29dc3e21849d358b6b58adcf8..6de8d30004efc9337b8c40d2ff2d0a76651d23eb:/src/contextl-hacks.lisp?ds=sidebyside

diff --git a/src/contextl-hacks.lisp b/src/contextl-hacks.lisp
index ec78c35..ee4e38a 100644
--- a/src/contextl-hacks.lisp
+++ b/src/contextl-hacks.lisp
@@ -40,4 +40,25 @@
                      (list 
 		      (find-class 'special-object)))
              initargs)))
-     (call-next-method))
\ No newline at end of file
+     (call-next-method))
+
+
+
+(defun funcall-with-special-initargs (bindings thunk)
+  (let ((arg-count 0))
+  (special-symbol-progv
+      (loop for (object . initargs) in bindings
+            for initarg-keys = (loop for key in initargs by #'cddr 
+				     collect key into keys
+				    count t into count
+				    finally (incf arg-count count)
+				            (return keys))
+            nconc (loop for slot in (class-slots (class-of object))
+                        when (and (slot-definition-specialp slot)
+                                  (intersection initarg-keys (slot-definition-initargs slot)))
+                        collect (with-symbol-access
+                                  (slot-value object (slot-definition-name slot)))))
+      (make-list arg-count :initial-element nil)
+    (loop for (object . initargs) in bindings
+          do (apply #'shared-initialize object nil :allow-other-keys t initargs))
+    (funcall thunk))))
\ No newline at end of file