Major patch touching a lot, representing the new lol. is mostly drop-in backwards...
[clinton/lisp-on-lines.git] / src / special-initargs.lisp
1 (in-package :lisp-on-lines)
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)))))
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)))))
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))))
35 (defmacro with-special-initargs ((object &rest initargs) &body body)
36 `(funcall-with-special-initargs ,object ,initargs
37 #'(lambda ()
38 ,@body)))