--- /dev/null
+
+(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
--- /dev/null
+(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
--- /dev/null
+(in-package :lisp-on-lines)
+
--- /dev/null
+(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))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
--- /dev/null
+(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)))))
+
--- /dev/null
+(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)))
+
+++ /dev/null
-(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))))
-
-
-
-
-
-
-
HCoop / clinton / lisp-on-lines.git / commitdiff