| 1 | (in-package :lisp-on-lines) |
| 2 | |
| 3 | (defmethod initargs.slot-names (object) |
| 4 | "Returns ALIST of (initargs) . slot-name." |
| 5 | (nreverse (mapcar #'(lambda (slot) |
| 6 | (cons (closer-mop:slot-definition-initargs slot) |
| 7 | (closer-mop:slot-definition-name slot))) |
| 8 | (closer-mop:class-slots (class-of object))))) |
| 9 | |
| 10 | (defun find-slot-names-from-initargs-plist (object initargs-plist) |
| 11 | "returns (VALUES SLOT-NAMES VALUES), Given a plist of initargs such as one would pass to :DEFAULT-INITARGS. |
| 12 | SLOT-NAMES contains the slot-names specified by the initarg, and VALUES the corresponding VALUE." |
| 13 | (let (slot-names values |
| 14 | (initargs.slot-names-alist (initargs.slot-names object))) |
| 15 | (loop for (initarg value) on initargs-plist |
| 16 | do (let ((slot-name |
| 17 | (cdr (assoc-if #'(lambda (x) (member initarg x)) |
| 18 | initargs.slot-names-alist)))) |
| 19 | (when slot-name ;ignore invalid initargs. (good idea/bad idea?) |
| 20 | (push slot-name slot-names) |
| 21 | (push value values))) |
| 22 | finally (return (values slot-names values))))) |
| 23 | |
| 24 | (defun funcall-with-special-initargs (object initargs function &rest args) |
| 25 | "Call FUNCTION with dynnamic bindings of the slots in OBJECT specified by the INITARGS plist" |
| 26 | (multiple-value-bind (slot-names values) |
| 27 | (find-slot-names-from-initargs-plist object initargs) |
| 28 | (special-symbol-progv |
| 29 | (with-symbol-access |
| 30 | (loop for slot-name in slot-names |
| 31 | collect (slot-value object slot-name))) |
| 32 | values |
| 33 | (apply function args)))) |
| 34 | |
| 35 | (defmacro with-special-initargs ((object &rest initargs) &body body) |
| 36 | `(funcall-with-special-initargs ,object ,initargs |
| 37 | #'(lambda () |
| 38 | ,@body))) |