X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/4358148e6c67fcc2ae24050c54d8050b4dc03f9d..b7657b86f85f575d5776dc6b626b1dc258d1fa47:/src/description-class.lisp diff --git a/src/description-class.lisp b/src/description-class.lisp index f43beca..fb6e7ff 100644 --- a/src/description-class.lisp +++ b/src/description-class.lisp @@ -4,27 +4,6 @@ ;;;; 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 @@ -33,7 +12,7 @@ (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) (mixin-class-p :initarg :mixinp))) @@ -50,63 +29,162 @@ (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 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 + (setf (description-class-attributes (class-of description)) + (mapcar + (lambda (slot) + (or (find-attribute description + (slot-definition-name slot)) + (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)))) + (defining-classes + (partial-class-defining-classes class))) + + (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))) + (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 (attribute-class attribute) + initargs))))))))) + + +#+old(defun initialize-description-class (class) + +;;; 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. (let* ((description (find-layer class)) - (attribute-objects (mapcar #'attribute-object (class-slots (class-of description)))) + (attribute-objects + (mapcar + (lambda (slot) + (let* ((*init-time-description* description) + (attribute + (apply #'make-instance + 'standard-attribute + :description description + (attribute-object-initargs slot)))) + + + (setf (slot-definition-attribute-object slot) attribute))) + (remove 'described-object (class-slots (class-of description)) + :key #'slot-definition-name))) (defining-classes (partial-class-defining-classes (class-of description)))) - - (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)))))))) + (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 ) + (warn "Attribute class for ~A is ~A" attribute (attribute-class attribute)) + (when (not (eq (find-class (attribute-class attribute)) + (class-of attribute))) + (warn "~%CHANGING CLASS~%") + + (apply #'change-class attribute (attribute-class attribute) + initargs)))))))))) ;;;; HACK: run this at startup till we figure things out. (defun initialize-descriptions ()