(in-package :lisp-on-lines)
+(defvar *object* nil)
+(defvar *description*)
+
(define-layered-function description-of (thing)
(:method (thing)
(find-description 't)))
(defun description-attributes (description)
(description-class-attributes (class-of description)))
-(defun find-attribute (description attribute-name)
- (find attribute-name (description-attributes description)
- :key #'attribute-name))
+(defun description-current-attributes (description)
+ (remove-if-not
+ (lambda (attribute)
+ (and
+ (some #'layer-active-p
+ (mapcar #'find-layer
+ (slot-definition-layers
+ (attribute-effective-attribute-definition attribute))))))
+ (description-attributes description)))
+
+(defun description-active-attributes (description)
+ (remove-if-not
+ #'attribute-active-p
+ (description-attributes description)))
+
+(defun find-attribute (description attribute-name &optional (errorp t))
+ (or (find attribute-name (description-attributes description)
+ :key #'attribute-name)
+ (when errorp (error "No attribute named ~A found in ~A" attribute-name description))))
(define-layered-function description-active-descriptions (description)
(:method ((description standard-description-object))
(let* ((active-attributes
(find-attribute description 'active-attributes))
(attributes (when active-attributes
- (attribute-value active-attributes))))
- (if attributes
- (mapcar (lambda (spec)
- (find-attribute
- description
- (if (listp spec)
- (car spec)
- spec)))
- attributes)
- (remove-if-not
- (lambda (attribute)
- (and (attribute-active-p attribute)
- (some #'layer-active-p
- (mapcar #'find-layer
- (slot-definition-layers
- (attribute-effective-attribute-definition attribute))))))
+ (ignore-errors (attribute-value active-attributes)))))
+ (remove-if-not
+ (lambda (attribute)
+ (and attribute
+ (attribute-active-p attribute)
+ (some #'layer-active-p
+ (mapcar #'find-layer
+ (slot-definition-layers
+ (attribute-effective-attribute-definition attribute))))))
+ (if attributes
+ (mapcar (lambda (spec)
+ (find-attribute
+ description
+ (if (listp spec)
+ (car spec)
+ spec)))
+ attributes)
(description-attributes description))))))
-
-
-
-
-;;; A handy macro.
+(defun funcall-with-described-object (function object description &rest args)
+ (setf description (or description (description-of object)))
+ (let ((*description* description)
+ (*object* object))
+ (dletf (((described-object *description*) object))
+ (funcall-with-layer-context
+ (modify-layer-context
+ (if (standard-description-p *description*)
+ (adjoin-layer *description* (current-layer-context))
+ (current-layer-context))
+ :activate (description-active-descriptions *description*)
+ :deactivate (description-inactive-descriptions *description*))
+ (lambda () (contextl::funcall-with-special-initargs
+ (loop
+ :for (key val) :on args :by #'cddr
+ :collect (list (find key (description-attributes *description*)
+ :key #'attribute-keyword)
+ :value val))
+ (lambda ()
+ (contextl::funcall-with-special-initargs
+ (let ((attribute (ignore-errors (find-attribute *description* 'active-attributes))))
+ (when attribute
+ (loop for spec in (attribute-value attribute)
+ if (listp spec)
+ collect (cons (or
+ (find-attribute *description* (car spec))
+ (error "No attribute matching ~A" (car spec)))
+ (cdr spec)))))
+ function))))))))
+
+
+(defmacro with-described-object ((object description &rest args)
+ &body body)
+ `(funcall-with-described-object
+ (lambda () ,@body)
+ ,object
+ ,description
+ ,@args))
+
(defmacro define-description (name &optional superdescriptions &body options)
(let ((description-name (defining-description name)))
(destructuring-bind (&optional slots &rest options) options