From 4867c86f7dce578458c4130d9a8cfbf1041f7c4a Mon Sep 17 00:00:00 2001 From: drewc Date: Thu, 6 Sep 2007 20:47:38 -0700 Subject: [PATCH] Add missing file and fix initialzation darcs-hash:20070907034738-39164-cdd0d789c69492293c481653d39521721636d8e2.gz --- src/attribute.lisp | 2 - src/description-class.lisp | 122 +++++++++++++++++++++++++++++++++++++ src/description.lisp | 12 +--- 3 files changed, 123 insertions(+), 13 deletions(-) create mode 100644 src/description-class.lisp diff --git a/src/attribute.lisp b/src/attribute.lisp index 32279fe..5c8b03a 100644 --- a/src/attribute.lisp +++ b/src/attribute.lisp @@ -53,8 +53,6 @@ (define-layered-method attribute-value (object attribute) (funcall (attribute-function attribute) object)) - - (defmethod shared-initialize :around ((attribute standard-attribute) slots &rest initargs) (declare (ignore initargs)) (setf (attribute-function attribute) diff --git a/src/description-class.lisp b/src/description-class.lisp new file mode 100644 index 0000000..9bf31e0 --- /dev/null +++ b/src/description-class.lisp @@ -0,0 +1,122 @@ +(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)))))) + + + diff --git a/src/description.lisp b/src/description.lisp index 20362f8..4195bb2 100644 --- a/src/description.lisp +++ b/src/description.lisp @@ -2,17 +2,6 @@ (define-description description ()) -(defgeneric find-description-class (name &optional errorp) - (: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))) - (defun find-description (name) (slot-value (find-description-class name) 'instance)) @@ -36,6 +25,7 @@ (display-attribute attribute))) (attributes description)))) + (define-layered-method description-of (object) (find-description 't)) -- 2.20.1