1 (in-package :lisp-on-lines
)
8 (deflayer display-layer
)
10 (define-layered-function display-using-description
(description display object
&rest args
)
12 "Displays OBJECT via description using/in/with/on display"))
14 (defun display (display object
&rest args
&key attributes
)
15 (let ((*display-attributes
* attributes
))
16 (apply #'display-using-description
(description-of object
) display object args
)))
18 (define-layered-method display-using-description
19 :around
(description display object
&rest args
)
20 (declare (ignorable args
))
21 (let ((*description
* description
)
24 (dletf (((described-object description
) object
))
25 (contextl::funcall-with-special-initargs
27 :for
(key val
) :on args
:by
#'cddr
28 :collect
(list (find key
(description-attributes description
)
29 :key
#'attribute-keyword
)
32 (contextl::funcall-with-special-initargs
33 (let ((attribute (find-attribute description
'active-attributes
)))
35 (loop for spec in
(attribute-value attribute
)
38 (find-attribute description
(car spec
))
39 (error "No attribute matching ~A" (car spec
)))
42 (call-next-method))))))))
46 (defun display/d
(&rest args
)
47 (apply #'display-using-description args
))
49 (define-layered-method display-using-description
(description display object
&rest args
)
50 (error "No DISPLAY-USING-DESCRIPTION methods are specified for: ~% DESCRIPTION: ~A ~% DISPLAY: ~A ~% OBJECT: ~A ~% ARGS: ~S
52 OMGWTF! If you didn't do this, it's a bug!" description display object args
))
54 (defmacro define-display
(&body body
)
55 (loop with in-descriptionp
= (eq (car body
) :in-description
)
56 with description
= (if in-descriptionp
(cadr body
) 't
)
57 for tail on
(if in-descriptionp
(cddr body
) body
)
58 until
(listp (car tail
))
59 collect
(car tail
) into qualifiers
61 (when (member :in-description qualifiers
)
62 (error "Incorrect occurrence of :in-description in defdisplay. Must occur before qualifiers."))
64 (destructuring-bind (description-spec &optional
(display-spec (gensym)) (object-spec (gensym)))
66 `(define-layered-method
67 display-using-description
68 :in-layer
,(if (eq t description
)
70 (defining-description description
))
72 (,(if (listp description-spec
)
73 (list (first description-spec
)
74 (if (eq 'description
(second description-spec
))
76 (defining-description (second description-spec
)))))
78 ,object-spec
&rest args
)
79 (declare (ignorable args
))