Commit | Line | Data |
---|---|---|
2b0fd9c8 DC |
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))) |