X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/4867c86f7dce578458c4130d9a8cfbf1041f7c4a..c29b2d2dda5ab82f7458666c154094693bfe9f1b:/src/description-class.lisp diff --git a/src/description-class.lisp b/src/description-class.lisp dissimilarity index 97% index 9bf31e0..fb6e7ff 100644 --- a/src/description-class.lisp +++ b/src/description-class.lisp @@ -1,122 +1,242 @@ -(in-package :lisp-on-lines) - -;;; * The Description Meta-Meta-Super class. - -(defclass description-special-layered-access-class - (contextl::special-layered-access-class) - ((original-name :initarg original-name) - (description-layer :initarg description-layer) - (instance))) - -(defmethod closer-mop:direct-slot-definition-class - ((class description-special-layered-access-class) - &key &allow-other-keys) - (find-class 'attribute-special-layered-direct-slot-definition)) - -(defmethod closer-mop:effective-slot-definition-class - ((class description-special-layered-access-class) - &key name &allow-other-keys) - (declare (ignore name)) - (find-class 'standard-attribute)) - -(defmethod closer-mop:compute-effective-slot-definition :around - ((class description-special-layered-access-class) name direct-slot-definitions) - (declare (ignore name)) - (let ((slotd (call-next-method))) - (setf (slot-value slotd 'direct-slots) direct-slot-definitions) - - (apply #'shared-initialize slotd nil (slot-value - (find t direct-slot-definitions - :test #'eq - :key #'slot-definition-layer ) - 'initargs)) - - slotd)) - -;;; * The Description Meta-Meta class. -(defclass description-class (description-special-layered-access-class layered-class) - () - (:default-initargs :defining-metaclass 'description-special-layered-access-class)) - -(defun initialize-description-class (class) - (let ((description (make-instance class))) - (setf (slot-value class 'instance) description) - (dolist (slotd (closer-mop:class-slots class)) - (setf (slot-value slotd 'description) description) - (dolist (slot (slot-value slotd 'direct-slots)) - (setf (slot-value slot 'initargs) - (loop - :for (initarg value) - :on (slot-value slot 'initargs) - :by #'cddr - :nconc (list initarg - (if (eval-attribute-initarg slotd initarg) - (eval value) - value)))) - (ensure-layered-method - 'special-slot-values - `(lambda (description attribute) - (list ,@(loop - :for (initarg value) - :on (slot-value slot 'initargs) - :by #'cddr - :nconc (list (list 'quote (or (find-slot-name-from-initarg - (class-of slotd) initarg) initarg)) - - value)))) - :in-layer (slot-definition-layer slot) - :qualifiers '(append) - :specializers (list class (closer-mop:intern-eql-specializer (closer-mop:slot-definition-name slotd)))))))) - -(defmethod closer-mop:finalize-inheritance :after ((class description-class)) - (initialize-description-class class)) - -(define-layered-class description () - ((identity :function #'identity)) - (:metaclass description-class) - (description-layer t)) - -(eval-when (:load-toplevel :execute) - (closer-mop:finalize-inheritance (find-class 'description))) - -;;; The layer itself. -#+nil(deflayer description () - () - (:metaclass description)) - -#+nil (defmethod print-object ((object description) stream) - (call-next-method)) - -(defgeneric find-description-class (name &optional errorp) - ;; !-- Sometimes it gets inited, sometimes it don't. - (:method :around (name &optional errorp) - (let ((class (call-next-method))) - (unless (slot-boundp class 'instance) - (initialize-description-class class)) - class)) - (:method ((name (eql t)) &optional errorp) - (declare (ignore errorp)) - (find-class 'description t)) - (:method ((name symbol) &optional errorp) - (or (find-class (defining-description name) errorp) - (find-description-class t))) - (:method ((description description) &optional errorp) - (declare (ignore errorp)) - (class-of description))) - -;;; A handy macro. -(defmacro define-description (name &optional superdescriptions &body options) - (let ((description-name (defining-description name))) - - (destructuring-bind (&optional slots &rest options) options - `(prog1 - (defclass ,description-name ,(append (mapcar #'defining-description superdescriptions) '(description)) - ,(if slots slots '()) - ,@options - ,@(unless (assoc :metaclass options) - '((:metaclass description-class))) - (original-name . ,name)) - (initialize-description-class (find-description-class ',description-name)))))) - - - +(in-package :lisp-on-lines) + +;;;; * DESCRIPTIONS +;;;; A description is an object which is used +;;;; to describe another object. + + +;;; #+HACK +;;; I'm having some 'issues' with +;;; compiled code and my initialization. +;;; So this hack initializes the world. +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *defined-descriptions* nil)) + +(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))) + +(defmethod direct-slot-definition-class + ((class description-access-class) &key &allow-other-keys) + (find-class 'direct-attribute-definition-class)) + +(defmethod effective-slot-definition-class + ((class description-access-class) &key &allow-other-keys) + (find-class 'effective-attribute-definition-class)) + +(defmethod compute-effective-slot-definition + ((class description-access-class) name direct-slot-definitions) + (declare (ignore name)) + (let ((attribute (call-next-method))) + (setf (attribute-direct-attributes attribute) direct-slot-definitions) + (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) + +(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 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) + (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))) + (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 () + (map nil #'initialize-description-class + (setf *defined-descriptions* + (remove-duplicates *defined-descriptions*)))) + +(defmethod initialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '())) + (declare (dynamic-extent initargs)) + (prog1 + (if (loop for direct-superclass in direct-superclasses + thereis (ignore-errors (subtypep direct-superclass 'standard-description-object))) + (call-next-method) + (apply #'call-next-method + class + :direct-superclasses + (append direct-superclasses + (list (find-class 'standard-description-object))) + initargs)) + (initialize-description-class class))) + + +(defmethod reinitialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p)) + (declare (dynamic-extent initargs)) +; (warn "CLASS ~A ARGS ~A:" class initargs) + (prog1 + (if (or (not direct-superclasses-p) + (loop for direct-superclass in direct-superclasses + thereis (ignore-errors (subtypep direct-superclass 'standard-description-object)))) + (call-next-method) + (apply #'call-next-method + class + :direct-superclasses + (append direct-superclasses + (list (find-class 'standard-description-object))) + initargs)) + (initialize-description-class class))) + + +(defmethod print-object ((object standard-description-object) stream) + (print-unreadable-object (object stream :type nil :identity t) + (format stream "DESCRIPTION ~A" (ignore-errors (description-print-name object))))) + +(defmethod print-object ((object standard-description-class) stream) + (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)))) + + + + + +