X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/f2ff8a16385c1c4bc677c703a0b48d0255046456..b7657b86f85f575d5776dc6b626b1dc258d1fa47:/src/description-class.lisp diff --git a/src/description-class.lisp b/src/description-class.lisp index ac05535..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))) @@ -54,46 +33,133 @@ ;; This plist will be used to init the attribute object ;; Once the description itself is properly initiated. (list :name name - 'effective-attribute attribute - 'description-class class)) + '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 +;;; 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 + (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 (lambda (slot) - (setf (attribute-object slot) - (apply #'make-instance - 'standard-attribute - (attribute-object-initargs slot)))) - (class-slots (class-of description)))) + (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 @@ -107,12 +173,18 @@ (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)))))))) + (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 ()