1 (in-package :lisp-on-lines
)
7 (define-layered-function display-using-description
(description display object
&rest args
)
9 "Displays OBJECT via description using/in/with/on display"))
13 (defun modify-layer-context (context &key activate deactivate
)
14 (dolist (d deactivate
)
15 (setf context
(remove-layer (find-description d
)
17 (dolist (d activate context
)
18 (setf context
(adjoin-layer (find-description (if (consp d
) (car d
) d
))
21 (defun funcall-with-attribute-context (attribute thunk
)
22 (funcall-with-layer-context
23 (modify-layer-context (current-layer-context)
24 :activate
(attribute-active-descriptions attribute
)
25 :deactivate
(attribute-inactive-descriptions attribute
))
27 (with-special-symbol-access
28 (contextl::funcall-with-special-initargs
29 (without-special-symbol-access
30 (mappend (lambda (desc)
32 (let ((description (find-description (car desc
))))
34 :for
(key val
) :on
(cdr desc
) :by
#'cddr
35 :collect
(list (find key
(description-attributes description
)
36 :key
#'attribute-keyword
)
38 (attribute-active-descriptions attribute
)))
40 (without-special-symbol-access
41 (funcall thunk
))))))))
43 (defmacro with-attribute-context
((attribute) &body body
)
44 `(funcall-with-attribute-context ,attribute
(lambda () ,@body
)))
47 (defun display (display object
&rest args
&key deactivate activate
&allow-other-keys
)
48 (funcall-with-layer-context
49 (modify-layer-context (current-layer-context)
51 :deactivate deactivate
)
53 (apply #'display-using-description
(description-of object
) display object args
))))
55 (define-layered-method display-using-description
56 :around
((description standard-description-object
) display object
&rest args
)
57 (declare (ignorable args
))
58 #+nil
(break "Entering DISPLAY for ~A on ~A using ~A" object display description
)
59 (let ((*display
* display
))
60 (apply #'funcall-with-described-object
63 object description args
)))
68 (defun display/d
(&rest args
)
69 (apply #'display-using-description args
))
71 (define-layered-method display-using-description
(description display object
&rest args
)
72 (error "No DISPLAY-USING-DESCRIPTION methods are specified for: ~% DESCRIPTION: ~A ~% DISPLAY: ~A ~% OBJECT: ~A ~% ARGS: ~S
74 OMGWTF! If you didn't do this, it's a bug!" description display object args
))
76 (defmacro define-display
(&body body
)
77 (loop with in-descriptionp
= (eq (car body
) :in-description
)
78 with description
= (if in-descriptionp
(cadr body
) 't
)
79 for tail on
(if in-descriptionp
(cddr body
) body
)
80 until
(listp (car tail
))
81 collect
(car tail
) into qualifiers
83 (when (member :in-description qualifiers
)
84 (error "Incorrect occurrence of :in-description in defdisplay. Must occur before qualifiers."))
86 (destructuring-bind (description-spec &optional
(display-spec (gensym)) (object-spec (gensym)))
88 `(define-layered-method
89 display-using-description
90 :in-layer
,(if (eq t description
)
92 (defining-description description
))
94 (,(if (listp description-spec
)
95 (list (first description-spec
)
96 (if (eq 'description
(second description-spec
))
98 (contextl::defining-layer
(defining-description (second description-spec
))))))
100 ,object-spec
&rest args
)
101 (declare (ignorable args
))