;;;; A description is an object which is used
;;;; to describe another object.
-;;; HACK:
-;;; Since i'm not using deflayer, ensure-layer etc,
-;;; There are a few places where contextl gets confused
-;;; trying to locate my description layers.
-
-;;; TODO: investigate switching to deflayer!
-
-(defun contextl::prepare-layer (layer)
- (if (symbolp layer)
- (if (eq (symbol-package layer)
- (find-package :description-definers))
- layer
- (contextl::defining-layer layer))
-
- layer))
-
-(defmethod find-layer-class :around ((layer symbol) &optional errorp environment)
- (if (eq (symbol-package layer)
- (find-package :description-definers))
- (find-class layer)
- (call-next-method)))
;;; #+HACK
;;; I'm having some 'issues' with
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *defined-descriptions* nil))
-(defclass description-access-class (standard-layer-class contextl::special-layered-access-class )
+(define-layered-class description-access-class (standard-layer-class contextl::special-layered-access-class )
((defined-in-descriptions :initarg :in-description)
+ (class-active-attributes-definition :initarg :attributes)
(mixin-class-p :initarg :mixinp)))
(defmethod direct-slot-definition-class
(declare (ignore name))
(let ((attribute (call-next-method)))
(setf (attribute-direct-attributes attribute) direct-slot-definitions)
- (setf (attribute-object attribute)
- (make-instance 'standard-attribute
- :name name
- 'effective-attribute attribute
- 'description-class class))
+ (setf (attribute-object-initargs attribute)
+ ;; This plist will be used to init the attribute object
+ ;; Once the description itself is properly initiated.
+ (list :name name
+ 'effective-attribute attribute))
attribute))
+
+(defmethod slot-value-using-class ((class description-access-class) object slotd)
+ (call-next-method)
+#+nil (if (or
+ (eq (slot-definition-name slotd) 'described-object)
+ (not (slot-boundp slotd 'attribute-object)))
+ (call-next-method)
+ (slot-definition-attribute-object slotd)))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *description-attributes* (make-hash-table)))
+
+
+
(defclass standard-description-class (description-access-class layered-class)
- ()
+ ((attributes :accessor description-class-attributes :initform (list)))
(:default-initargs :defining-metaclass 'description-access-class))
+
+
(defmethod validate-superclass
((class standard-description-class)
(superclass standard-class))
t)
-(defclass standard-description-object (standard-layer-object) ())
+(define-layered-class standard-description-object (standard-layer-object)
+ ((described-object :accessor described-object
+ :special t)))
(defun description-class-name (description-class)
(read-from-string (symbol-name (class-name description-class))))
+(defgeneric standard-description-p (description-candidate)
+ (:method (not-description)
+ NIL)
+ (:method ((description standard-description-object))
+ T))
+
+(defun compute-effective-attribute-objects (description)
+ (mapcar
+ (lambda (slot)
+ (or (find-attribute description
+ (slot-definition-name slot) nil)
+ (let* ((*init-time-description* description)
+ (attribute-class (or
+ (ignore-errors
+ (slot-value-using-class
+ (class-of description) description slot))
+ 'standard-attribute))
+ (attribute
+ (apply #'make-instance
+ attribute-class
+ :description description
+ :attribute-class attribute-class
+ (attribute-object-initargs slot))))
+ (setf (slot-definition-attribute-object slot) attribute))))
+ (remove 'described-object (class-slots (class-of description))
+ :key #'slot-definition-name)))
+
+(defmacro with-described-object ((object description &rest args)
+ &body body)
+ `(funcall-with-described-object
+ (lambda () ,@body)
+ ,object
+ ,description
+ ,@args))
+
+(defun initialize-effective-attribute-values-for-description-class (class description attribute-objects)
+
+ (loop
+ :for (layer class)
+ :on (partial-class-defining-classes class) :by #'cddr
+ :do (funcall-with-layer-context
+ (adjoin-layer (find-layer layer) (current-layer-context))
+ (lambda ()
+ (loop :for direct-slot :in (class-direct-slots class)
+ :do (let ((attribute
+ (find (slot-definition-name direct-slot)
+ attribute-objects
+ :key #'attribute-name)))
+ (let ((initargs
+ (prepare-initargs attribute (direct-attribute-properties direct-slot))))
+
+ (apply #'reinitialize-instance attribute
+ initargs )
+ (setf (slot-value description (attribute-name attribute))
+ (attribute-class attribute))
+ (apply #'change-class attribute (find-class (attribute-class attribute))
+ initargs))))
+ (when (slot-boundp class 'class-active-attributes-definition)
+ (with-described-object (nil description)
+ (setf (slot-value (find-attribute description 'active-attributes) 'value)
+ (slot-value class 'class-active-attributes-definition))))))))
+
(defun initialize-description-class (class)
- ;;; HACK: initialization does not happen properly
- ;;; when compiling and loading or something like that.
- ;;; Obviously i'm not sure why.
- ;;; So we're going to explicitly initialize things.
- ;;; For now. --drewc
+;;; HACK: initialization does not happ en properly
+;;; when compiling and loading or something like that.
+;;; Obviously i'm not sure why.
+;;; So we're going to explicitly initialize things.
+;;; For now. --drewc
(pushnew class *defined-descriptions*)
-
- ;;; ENDHACK.
+;;; ENDHACK.
+
(let* ((description (find-layer class))
- (attribute-objects (mapcar #'attribute-object (class-slots (class-of description))))
- (defining-classes (partial-class-defining-classes (class-of description))))
-
+ (attribute-objects
+ (setf (description-class-attributes (class-of description))
+ (compute-effective-attribute-objects description))))
+
+ (initialize-effective-attribute-values-for-description-class class description attribute-objects)
+))
+
-
- (loop
- :for (layer class)
- :on defining-classes :by #'cddr
- :do (funcall-with-layer-context
- (adjoin-layer (find-layer layer) (current-layer-context))
- (lambda ()
- (loop :for direct-slot :in (class-direct-slots class)
- :do (let ((attribute
- (find (slot-definition-name direct-slot)
- attribute-objects
- :key #'attribute-name)))
- (apply #'reinitialize-instance attribute
- (direct-attribute-properties direct-slot))
- (apply #'change-class attribute (attribute-class attribute) (direct-attribute-properties direct-slot))
-
- (setf (slot-value description (attribute-name attribute))
- attribute))))))))
;;;; HACK: run this at startup till we figure things out.
(defun initialize-descriptions ()
(print-unreadable-object (object stream :type t :identity t)
(princ (ignore-errors (description-print-name (find-layer object))) stream)))
-(defun find-description (name)
- (find-layer (find-class (defining-description name))))
+(defun find-description (name &optional (errorp t))
+ (let ((class (find-class (defining-description name) errorp)))
+ (when class (find-layer class))))
HCoop / clinton / lisp-on-lines.git / blobdiff