From 6d0aa5eb12e458b11041b5bce3c80e9378dd34dc Mon Sep 17 00:00:00 2001 From: drewc Date: Sun, 20 Dec 2009 14:52:07 -0800 Subject: [PATCH] More new description code, still broken darcs-hash:20091220225207-39164-5ffb465797e1bf9227736d2b4552a60eed54457a.gz --- src/mao/attribute.lisp | 95 +++++++++++++++ src/mao/description-class.lisp | 181 ++++++++++++++++++++++++++++ src/mao/description-protocol.lisp | 2 + src/mao/description.lisp | 132 ++++++++++++++++++++ src/mao/mao-tests.lisp | 51 ++++++++ src/mao/simple-plist-attribute.lisp | 120 ++++++++++++++++++ src/new-description.lisp | 180 --------------------------- 7 files changed, 581 insertions(+), 180 deletions(-) create mode 100644 src/mao/attribute.lisp create mode 100644 src/mao/description-class.lisp create mode 100644 src/mao/description-protocol.lisp create mode 100644 src/mao/description.lisp create mode 100644 src/mao/mao-tests.lisp create mode 100644 src/mao/simple-plist-attribute.lisp delete mode 100644 src/new-description.lisp diff --git a/src/mao/attribute.lisp b/src/mao/attribute.lisp new file mode 100644 index 0000000..9a1ea50 --- /dev/null +++ b/src/mao/attribute.lisp @@ -0,0 +1,95 @@ + +(in-package :lisp-on-lines) + +(define-layered-class attribute () + ()) + +(define-layered-class standard-attribute (simple-plist-attribute) + ((attribute-layers :accessor attribute-layers :initform nil) + (name + :layered-accessor attribute-name + :initarg :name) + (effective-attribute-definition + :initarg effective-attribute + :accessor attribute-effective-attribute-definition) +#+nil (attribute-class + :accessor attribute-class + :initarg :attribute-class + :initform 'standard-attribute) + (keyword + :layered-accessor attribute-keyword + :initarg :keyword + :initform nil + :layered t) + (activep + :layered-accessor attribute-active-p + :initarg :activep ;deprecated + :initarg :active + :initform t + :layered t + :special t + :documentation + "Can be T, NIL or :WHEN. In the latter case, attribute is only active if the attribute value is non-null.") + (value + :layered-accessor attribute-value + :initarg :value + :layered t + :special t) + (function + :initarg :function + :layered-accessor attribute-function + :layered t + :special t) + (active-attributes :layered-accessor attribute-active-attributes + :initarg :attributes + :layered t + :special t) + (active-descriptions :layered-accessor attribute-active-descriptions + :initarg :activate + :initform nil + :layered t + :special t) + (inactive-descriptions :layered-accessor attribute-inactive-descriptions + :initarg :deactivate + :initform nil + :layered t + :special t) + )) + +(defmethod attribute-description ((attribute standard-attribute)) + (find-layer (attribute-description-class attribute))) + +(define-layered-function attribute-object (attribute)) +(define-layered-method attribute-active-p :around (attribute) + (let ((active? (call-next-method))) + (if (eq :when active?) + (not (null (attribute-value attribute))) + active?))) + + +(define-layered-method attribute-object ((attribute standard-attribute)) + (described-object (dynamic description))) + +(define-layered-function attribute-value-using-object (object attribute)) +(define-layered-function (setf attribute-value-using-object) (value object attribute)) + +(define-layered-method attribute-value ((attribute standard-attribute)) + (attribute-value-using-object (attribute-object attribute) attribute)) + +(define-layered-method attribute-value-using-object (object attribute) + (let ((fn (handler-case (attribute-function attribute) + (unbound-slot () nil)))) + (if fn + (funcall fn object) + (slot-value attribute 'value)))) + +(define-layered-method (setf attribute-value) (value (attribute standard-attribute)) + (setf (attribute-value-using-object (attribute-object attribute) attribute) value)) + +(define-layered-method (setf attribute-value-using-object) (value object attribute) + (error "No (SETF ATTRIBUTE-VALUE-USING-OBJECT) for ~A ~A and we are not editable" + object attribute)) + +(defmethod print-object ((object standard-attribute) stream) + (print-unreadable-object (object stream :type nil :identity t) + (format stream "ATTRIBUTE ~A" (or (ignore-errors (attribute-name object)) "+unnamed-attribute+")))) \ No newline at end of file diff --git a/src/mao/description-class.lisp b/src/mao/description-class.lisp new file mode 100644 index 0000000..1dbc902 --- /dev/null +++ b/src/mao/description-class.lisp @@ -0,0 +1,181 @@ +(in-package :lisp-on-lines) + +;;;; SLOT-DEFINITION META-OBJECTS +(define-layered-class direct-attribute-slot-definition-class + (special-layered-direct-slot-definition + contextl::singleton-direct-slot-definition) + ((attribuite-properties + :accessor slot-definition-attribute-properties + :documentation "Holds the initargs passed to the slotd"))) + +(defmethod initialize-instance + :after ((slotd direct-attribute-slot-definition-class) + &rest initargs) + (setf (slot-definition-attribute-properties slotd) initargs)) + +(defmethod reinitialize-instance + :after ((slotd direct-attribute-slot-definition-class) + &rest initargs) + (setf (slot-definition-attribute-properties slotd) initargs)) + +(define-layered-class effective-attribute-slot-definition-class + (special-layered-effective-slot-definition) + ((direct-slots :accessor slot-definition-direct-slots) + (attribute-object + :accessor slot-definition-attribute-object))) + +;;;; DESCRIPTION-ACCESS-CLASS, the PARTIAL-CLASS defining class for DESCRIPTIONs +(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) + (description-name :initarg original-name + :initform nil + :reader description-original-name))) + +(defmethod direct-slot-definition-class + ((class description-access-class) &key &allow-other-keys) + (find-class 'direct-attribute-slot-definition-class)) + +(defmethod effective-slot-definition-class + ((class description-access-class) &key &allow-other-keys) + (find-class 'effective-attribute-slot-definition-class)) + + +;;;;STANDARD-DESCRIPTION +(defclass standard-description-class (description-access-class layered-class) + ((attributes :accessor description-class-attributes :initform (make-hash-table :test #'eq))) + (:default-initargs :defining-metaclass 'description-access-class)) + +(defclass standard-description-object + (standard-layer-object) + ((described-object :accessor described-object + :special t + :function 'identity) + (ACTIVE-ATTRIBUTES :LABEL "Attributes" :VALUE NIL :ACTIVEP NIL + :KEYWORD :ATTRIBUTES) + (ACTIVE-DESCRIPTIONS :LABEL "Active Descriptions" :VALUE NIL + :ACTIVEP NIL :KEYWORD :ACTIVATE) + (INACTIVE-DESCRIPTIONS :LABEL "Inactive Descriptions" :VALUE NIL + :ACTIVEP NIL :KEYWORD :DEACTIVATE)) + (:METACLASS description-access-class) + (ORIGINAL-NAME . STANDARD-DESCRIPTION-OBJECT)) + + +(defgeneric find-attribute (description-designator attribute-name &optional errorp) + (:method ((description standard-description-class) attribute-name &optional (errorp t)) + (or (gethash attribute-name (description-class-attributes description)) + (when errorp + (when errorp (error "No attribute named ~A found in class ~A" attribute-name description))))) + (:method ((description standard-description-object) attribute-name &optional (errorp t)) + (find-attribute (class-of description) attribute-name errorp)) + (:method ((description symbol) attribute-name &optional (errorp t)) + (find-attribute (find-description description) attribute-name errorp))) + +(defgeneric (setf find-attribute) (value description attribute-name) + (:method (value (description standard-description-class) attribute-name) + (setf (gethash attribute-name (description-class-attributes description)) value))) + +(defmethod description-class-attribute-class (description) + 'standard-attribute) + +(defmethod initialize-slot-definition-attribute + (class (slotd effective-attribute-slot-definition-class) + name direct-slot-definitions) + (let ((tbl (make-hash-table))) + (loop for ds in direct-slot-definitions + :when (typep ds 'direct-attribute-slot-definition-class) + :do (setf (gethash (slot-definition-layer ds) tbl) + (append (gethash (slot-definition-layer ds) tbl '()) + (slot-definition-attribute-properties ds)))) + + (let* ((attribute-class (or (getf (gethash t tbl) :attribute-class) + (description-class-attribute-class class))) + (attribute (apply #'make-instance attribute-class :name name 'description-class class (gethash t tbl)))) + (maphash (lambda (layer properties) + (pushnew layer (attribute-layers attribute)) + (apply #'initialize-attribute-for-description class attribute layer properties)) + tbl) + (setf (slot-definition-attribute-object slotd) attribute) + (setf (find-attribute class name) attribute)))) + +(defmethod compute-effective-slot-definition + ((class standard-description-class) name direct-slot-definitions) + (declare (ignore name)) + (let ((slotd (call-next-method))) + (setf (slot-definition-direct-slots slotd) direct-slot-definitions) + (when (class-finalized-p class) + (initialize-slot-definition-attribute class slotd name direct-slot-definitions)) + slotd)) + +(defmethod finalize-inheritance :after ((class standard-description-class)) + (dolist (slotd (compute-slots class)) + (initialize-slot-definition-attribute class slotd (slot-definition-name slotd) (slot-definition-direct-slots slotd)))) + +(defmethod validate-superclass + ((class standard-description-class) + (superclass standard-class)) + t) + +(defmacro defdescription (name &optional superdescriptions &body options) + (destructuring-bind (&optional slots &rest options) options + `(let ((description-name ',name)) + (declare (special description-name)) + (deflayer ,(defining-description name) ,(mapcar #'defining-description superdescriptions) + ,(if slots slots '()) + ,@options + ,@(unless (assoc :metaclass options) + '((:metaclass standard-description-class))) + ,@(let ((in-description (assoc :in-description options))) + (when in-description + `((:in-layer . ,(defining-description (cadr in-description)))))) + + (original-name . ,name))))) + + + +(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)))) + +(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)))) + +(defun find-description (name &optional (errorp t)) + (find-layer (defining-description name) errorp)) + +(defun description-class-name (description-class) + (ignore-errors (description-original-name (first (class-direct-superclasses description-class))))) + +(defmethod print-object ((class standard-description-class) stream) + (print-unreadable-object (class stream :type nil :identity t) + (format stream "DESCRIPTION-CLASS ~A" (description-class-name class)))) + +(defun description-name (description) + (description-class-name (class-of description))) + +(defmethod print-object ((object standard-description-object) stream) + (print-unreadable-object (object stream :type nil :identity t) + (format stream "DESCRIPTION ~A" (description-name object)))) \ No newline at end of file diff --git a/src/mao/description-protocol.lisp b/src/mao/description-protocol.lisp new file mode 100644 index 0000000..9aeef6e --- /dev/null +++ b/src/mao/description-protocol.lisp @@ -0,0 +1,2 @@ +(in-package :lisp-on-lines) + diff --git a/src/mao/description.lisp b/src/mao/description.lisp new file mode 100644 index 0000000..8f7348d --- /dev/null +++ b/src/mao/description.lisp @@ -0,0 +1,132 @@ +(in-package :lisp-on-lines) + +(defdynamic described-object nil) +(defdynamic description nil) + +;;backwards-compat hacks +(define-symbol-macro *object* (dynamic described-object)) +(define-symbol-macro *description* (dynamic description)) + +;; forward compat hacks + +(defun current-description () + (dynamic description)) + +(define-layered-function description-of (thing) + (:method (thing) + (find-description 't))) + +(defun description-print-name (description) + (description-class-name (class-of description))) + +(defun description-attributes (description) + (alexandria:hash-table-values (description-class-attributes (class-of description)))) + +(defun description-current-attributes (description) + (remove-if-not + (lambda (attribute) + (and + (some #'layer-active-p + (mapcar #'find-layer + (slot-definition-layers + (attribute-effective-attribute-definition attribute)))))) + (description-attributes description))) + +(defun description-active-attributes (description) + (remove-if-not + #'attribute-active-p + (description-attributes description))) + + + +(define-layered-function description-active-descriptions (description) + (:method ((description t)) + (attribute-value (find-attribute description 'active-descriptions))) + (:method ((description attribute)) + (attribute-active-descriptions description))) + +(define-layered-function description-inactive-descriptions (description) + (:method ((description t)) + (attribute-value (find-attribute description 'inactive-descriptions))) + (:method ((description attribute)) + (attribute-inactive-descriptions description))) + +(define-layered-function attributes (description) + (:method (description) + (let* ((active-attributes + (find-attribute description 'active-attributes)) + (attributes (when active-attributes + (ignore-errors (attribute-value active-attributes))))) + (remove-if-not + (lambda (attribute) + (and attribute + (attribute-active-p attribute) + (some #'layer-active-p + (attribute-layers attribute)))) + (if attributes + (mapcar (lambda (spec) + (find-attribute + description + (if (listp spec) + (car spec) + spec))) + attributes) + (description-attributes description)))))) + +(defun funcall-with-described-object (function object description &rest args) + (setf description (or description (description-of object))) + (dynamic-let ((description description) + (object object)) + (dletf (((described-object description) object)) + (funcall-with-layer-context + (modify-layer-context (adjoin-layer description (current-layer-context)) + :activate (description-active-descriptions description) + :deactivate (description-inactive-descriptions description)) + (lambda () + (with-special-symbol-access + (contextl::funcall-with-special-initargs + (without-special-symbol-access + (loop + :for (key val) :on args :by #'cddr + :collect (list (find key (description-attributes description) + :key #'attribute-keyword) + :value val))) + (lambda () + (contextl::funcall-with-special-initargs + (without-special-symbol-access + (let ((attribute (ignore-errors (find-attribute description 'active-attributes)))) + (when attribute + (loop for spec in (attribute-value attribute) + if (listp spec) + collect (cons (or + (find-attribute description (car spec)) + (error "No attribute matching ~A" (car spec))) + (cdr spec)))))) + (lambda () + (without-special-symbol-access + (funcall function)))))))))))) + +(defmacro with-described-object ((object &optional (description `(description-of ,object))) + &body body) + `(funcall-with-described-object (lambda (),@body) ,object ,description)) + + + + + + + + + + + + + + + + + + + + + diff --git a/src/mao/mao-tests.lisp b/src/mao/mao-tests.lisp new file mode 100644 index 0000000..fcfbfb0 --- /dev/null +++ b/src/mao/mao-tests.lisp @@ -0,0 +1,51 @@ +(in-package :lol-test) + +(defsuite :mao) +(in-suite :mao) + +(defdescription test-empty-description ()) + +(defdescription property-speed-test () + ((attribute :value t))) + +(defdescription property-speed-test () + ((attribute :value t)) + (:in-description test-empty-description)) + +(defdescription property-speed-test-many-attributes () + ((attribute :value t) + (attribute2 :value t) + (attribute3 :value t) + (attribute4 :value t) + (attribute5 :value t) + (attribute6 :value t) + (attribute7 :value t) + (attribute8 :value t) + (attribute9 :value t) + (attributea :value t) + (attributeb :value t) + (attributec :value t) + (attributed :value t) + (attributee :value t) + (attributef :value t) + (attributeg :value t) + (attributeh :value t) + (attributei :value t) + (attributej :value t) + (attributek :value t) + (attributel :value t) + (attributem :value t) + (attributen :value t) + (attributeo :value t) + ) + ) + + + + +(defun attribute-property-speed-test (n &optional (description 'property-speed-test) (attribute 'attribute)) + (with-described-object (nil (find-description description)) + (let ((attribute (find-attribute (current-description) 'attributeo))) + + (loop repeat n do (attribute-value attribute))))) + diff --git a/src/mao/simple-plist-attribute.lisp b/src/mao/simple-plist-attribute.lisp new file mode 100644 index 0000000..35144e5 --- /dev/null +++ b/src/mao/simple-plist-attribute.lisp @@ -0,0 +1,120 @@ +(in-package :lisp-on-lines) + +(define-layered-class simple-plist-attribute () + (%property-access-function + (description-class :initarg description-class + :accessor attribute-description-class)) + (:documentation "A very simple implementation of ATTRIBUTEs based on + simple plists. + +To implement layered slot values, we use an anonymous layered function +with a combination of APPEND. Methods on different layers return a +plist (which is APPENDed), from which we simply GETF for the slot +value. + +This is ineffecient, of course, but is easy to understand. Caching and +performance hacks are implemented in subclasses that extend the simple +protocol we define here.")) + +(defstruct static-attribute-slot value) + +(defmethod ensure-property-access-function ((attribute simple-plist-attribute)) + "return the PROPERTY-ACCESS-FUNCTION of this attribute. FUNCALLing +the returned symbol will return the plist of slot values." + (if (slot-boundp attribute '%property-access-function) + (slot-value attribute '%property-access-function) + (let ((fn-name (gensym))) + (ensure-layered-function fn-name :lambda-list '(description) :method-combination '(append)) + (setf (slot-value attribute '%property-access-function) fn-name)))) + +(defun property-access-value (attribute) + (ignore-errors (funcall (ensure-property-access-function attribute) (attribute-description attribute)))) + +(defconstant +property-not-found+ '=lisp-on-lines-property-not-found-indicator= + "A default value for GETF to return.") + +(defvar *special-symbol-access* nil) + +(defun special-symbol-access-p () + *special-symbol-access*) + +(defmacro with-special-symbol-access (&body body) + `(let ((*special-symbol-access* t)) + ,@body)) + +(defmacro without-special-symbol-access (&body body) + `(let ((*special-symbol-access* nil)) + ,@body)) + +(define-layered-method + contextl:slot-value-using-layer (class (attribute simple-plist-attribute) slotd reader) () + "Only layered slots that are not currently dynamically rebound are looked up via the plist. +Initial slot values are stored in the PLIST of the symbol ENSURE-PROPERTY-ACCESS-FUNCTION returns." + + (if (or contextl:*symbol-access* + (special-symbol-access-p) + (not (slot-definition-layeredp slotd))) + (call-next-method) + (multiple-value-bind (value boundp) + (handler-case (values (call-next-method) t) + (unbound-slot () (values nil nil))) + + (when (and boundp (not (static-attribute-slot-p value))) + (return-from slot-value-using-layer value)) + + (let ((dynamic-value + (getf (ignore-errors (funcall (ensure-property-access-function attribute) + (find-layer (slot-value attribute 'description-class)))) + + (slot-definition-name slotd) + +property-not-found+))) + + (if (eq dynamic-value +property-not-found+) + (if boundp + (static-attribute-slot-value value) + (call-next-method)) + dynamic-value))))) + +(defun set-property-value-for-layer (attribute property value layer) + (let ((vals (property-access-value attribute))) + (ensure-layered-method + (ensure-property-access-function attribute) + `(lambda (description-class) + ',(append (list property value) (alexandria:remove-from-plist vals property))) + :specializers (list (class-of (attribute-description attribute))) + :qualifiers '(append) + :in-layer layer))) + +(define-layered-method + (setf contextl:slot-value-using-layer) :around (value class (attribute simple-plist-attribute) slotd writer) +"This might not be here" + (if (and (not contextl:*symbol-access*) + (not (special-symbol-access-p)) + (slot-definition-layeredp slotd)) + (with-special-symbol-access (setf (slot-value-using-layer class attribute slotd writer) (make-static-attribute-slot :value value))) + (call-next-method)) +) + +(defmethod initialize-attribute-for-description (description-class (attribute simple-plist-attribute) layer-name &rest args) + "Define a method on the PROPERTY-ACCESS-FUNCTION to associate +slots (named by their :initarg) with values in layer LAYER-NAME." + (let* ((class (class-of attribute)) + (slotds (class-slots class))) + (setf (slot-value attribute 'description-class) description-class) + (ensure-layered-method + (ensure-property-access-function attribute) + `(lambda (description-class) + ',(alexandria:remove-from-plist + (loop + :for (key val) :on args :by #'cddr + :nconc (list + (loop + :for slotd :in slotds + :do (when (find key (slot-definition-initargs slotd)) + (return (slot-definition-name slotd)))) + val)) + nil)) + :specializers (list description-class) + :qualifiers '(append) + :in-layer layer-name))) + diff --git a/src/new-description.lisp b/src/new-description.lisp deleted file mode 100644 index 1475ef7..0000000 --- a/src/new-description.lisp +++ /dev/null @@ -1,180 +0,0 @@ -(in-package :lisp-on-lines) - -;;;; A simpler implementation of descriptions based on plists - -(setf (find-class 'simple-attribute nil) nil) - -(define-layered-class simple-attribute () - ((%property-access-function - :initarg property-access-function) - (%initial-slot-values-plist))) - -(defun ensure-property-access-function (attribute) - (if (slot-boundp attribute '%property-access-function) - (slot-value attribute '%property-access-function) - (let ((fn-name (gensym))) - (ensure-layered-function fn-name :lambda-list '() :method-combination '(append)) - (setf (slot-value attribute '%property-access-function) fn-name)))) - -(defconstant +property-not-found+ '=lisp-on-lines-property-not-found-indicator=) - -(define-layered-method - contextl:slot-value-using-layer (class (attribute simple-attribute) slotd reader) - (if (or contextl:*symbol-access* - (not (slot-definition-layeredp slotd))) - (call-next-method) - (let ((value (getf (funcall (ensure-property-access-function attribute)) - (slot-definition-name slotd) - +property-not-found+))) - (if (eq value +property-not-found+) - (call-next-method) - value)))) - -(define-layered-method - contextl:slot-value-using-layer (class (attribute simple-attribute) slotd reader) - (if (or contextl:*symbol-access* - (not (slot-definition-layeredp slotd)) - (dynamic-symbol-boundp (with-symbol-access (call-next-method)))) - (call-next-method) - (let ((value (getf (ignore-errors (funcall (ensure-property-access-function attribute))) - (slot-definition-name slotd) - +property-not-found+))) - (if (eq value +property-not-found+) - (let ((value (get (ensure-property-access-function attribute) - (slot-definition-name slotd) - +property-not-found+))) - (if (eq value +property-not-found+) - (call-next-method) - value)) - value)))) - -(define-layered-method - (setf contextl:slot-value-using-layer) (value class (attribute simple-attribute) slotd reader) - (if (and (not contextl:*symbol-access*) - (slot-definition-layeredp slotd)) - (setf (get (ensure-property-access-function attribute) (slot-definition-name slotd)) - value) - (call-next-method))) - -(defmethod initialize-attribute-for-layer (attribute layer-name &rest args) - (let* ((class (class-of attribute)) - (slotds (class-slots class))) - (ensure-layered-method - (ensure-property-access-function attribute) - `(lambda () - ',(loop - :for (key val) :on args :by #'cddr - :nconc (list - (loop - :for slotd :in slotds - :do (when (find key (slot-definition-initargs slotd)) - (return (slot-definition-name slotd)))) - val))) - :qualifiers '(append) - :in-layer layer-name))) - - -(define-layered-class direct-attribute-slot-definition-class - (special-layered-direct-slot-definition - contextl::singleton-direct-slot-definition) - ((attribuite-properties - :accessor slot-definition-attribute-properties - :documentation "Holds the initargs passed to the slotd"))) - -(defmethod initialize-instance - :after ((slotd direct-attribute-slot-definition-class) - &rest initargs) - (setf (slot-definition-attribute-properties slotd) initargs)) - -(defmethod reinitialize-instance - :after ((slotd direct-attribute-slot-definition-class) - &rest initargs) - (setf (slot-definition-attribute-properties slotd) initargs)) - -(define-layered-class effective-attribute-slot-definition-class - (special-layered-effective-slot-definition) - ((attribute-object - :accessor slot-definition-attribute-object))) - -(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 - ((class description-access-class) &key &allow-other-keys) - (find-class 'direct-attribute-slot-definition-class)) - -(defmethod effective-slot-definition-class - ((class description-access-class) &key &allow-other-keys) - (find-class 'effective-attribute-slot-definition-class)) -(fmakunbound 'initialize-slot-definition-attribute) - -(defmethod initialize-slot-definition-attribute ((slotd effective-attribute-slot-definition-class) name direct-slot-definitions) - (let ((tbl (make-hash-table)) - (attribute (make-instance 'simple-standard-attribute :name name))) - (loop for ds in direct-slot-definitions - :when (typep ds 'direct-attribute-slot-definition-class) - :do (setf (gethash (slot-definition-layer ds) tbl) - (append (gethash (slot-definition-layer ds) tbl '()) - (slot-definition-attribute-properties ds)))) - (maphash (lambda (layer properties) - (apply #'initialize-attribute-for-layer attribute layer properties)) - tbl) - (setf (slot-definition-attribute-object slotd) attribute))) - -(defmethod compute-effective-slot-definition - ((class description-access-class) name direct-slot-definitions) - (declare (ignore name)) - (let ((slotd (call-next-method))) - (initialize-slot-definition-attribute slotd name direct-slot-definitions) - slotd)) - -(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))) - -(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)))) - - -(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)))) - - - - - - - -- 2.20.1