src/description-class.lisp

   1 (in-package :lisp-on-lines)
   2
   3 ;;;; * DESCRIPTIONS
   4 ;;;; A description is an object which is used
   5 ;;;; to describe another object.
   6
   7
   8 ;;; #+HACK
   9 ;;; I'm having some 'issues' with
  10 ;;; compiled code and my initialization.
  11 ;;; So this hack initializes the world.
  12 (eval-when (:compile-toplevel :load-toplevel :execute)
  13   (defparameter *defined-descriptions* nil))
  14
  15 (define-layered-class description-access-class (standard-layer-class contextl::special-layered-access-class )
  16   ((defined-in-descriptions :initarg :in-description)
  17    (class-active-attributes-definition :initarg :attributes)
  18    (mixin-class-p :initarg :mixinp)))
  19
  20 (defmethod direct-slot-definition-class
  21            ((class description-access-class) &key &allow-other-keys)
  22   (find-class 'direct-attribute-definition-class))
  23
  24 (defmethod effective-slot-definition-class
  25            ((class description-access-class) &key &allow-other-keys)
  26   (find-class 'effective-attribute-definition-class))
  27
  28 (defmethod compute-effective-slot-definition
  29            ((class description-access-class) name direct-slot-definitions)
  30   (declare (ignore name))
  31   (let ((attribute (call-next-method)))
  32     (setf (attribute-direct-attributes attribute) direct-slot-definitions)
  33     (setf (attribute-object-initargs attribute)
  34           ;; This plist will be used to init the attribute object
  35           ;; Once the description itself is properly initiated.
  36           (list :name name
  37                 'effective-attribute attribute))
  38     attribute))
  39
  40 (defmethod slot-value-using-class ((class description-access-class) object slotd)
  41         (call-next-method)
  42 #+nil  (if (or
  43        (eq (slot-definition-name slotd) 'described-object)
  44        (not (slot-boundp slotd 'attribute-object)))
  45       (call-next-method)
  46       (slot-definition-attribute-object slotd)))
  47
  48
  49 (eval-when (:compile-toplevel :load-toplevel :execute)
  50   (defparameter *description-attributes* (make-hash-table)))
  51
  52
  53
  54 (defclass standard-description-class (description-access-class layered-class)
  55   ((attributes :accessor description-class-attributes :initform (list)))
  56   (:default-initargs :defining-metaclass 'description-access-class))
  57
  58
  59
  60 (defmethod validate-superclass
  61            ((class standard-description-class)
  62             (superclass standard-class))
  63   t)
  64
  65 (define-layered-class standard-description-object (standard-layer-object)
  66   ((described-object :accessor described-object
  67                      :special t)))
  68
  69 (defun description-class-name  (description-class)
  70     (read-from-string (symbol-name (class-name description-class))))
  71
  72 (defgeneric standard-description-p (description-candidate)
  73   (:method (not-description)
  74     NIL)
  75   (:method ((description standard-description-object))
  76     T))
  77
  78 (defun compute-effective-attribute-objects (description)
  79   (mapcar
  80    (lambda (slot)
  81      (or (find-attribute description
  82                          (slot-definition-name slot) nil)
  83          (let* ((*init-time-description* description)
  84                 (attribute-class (or
  85                                   (ignore-errors
  86                                     (slot-value-using-class
  87                                      (class-of description) description slot))
  88                                   'standard-attribute))
  89                 (attribute
  90                  (apply #'make-instance
  91                         attribute-class
  92                         :description description
  93                         :attribute-class attribute-class
  94                         (attribute-object-initargs slot))))
  95            (setf (slot-definition-attribute-object slot) attribute))))
  96    (remove 'described-object (class-slots (class-of description))
  97            :key #'slot-definition-name)))
  98
  99 (defun initialize-effective-attribute-values-for-description-class (class description attribute-objects)
 100
 101     (loop
 102        :for (layer class)
 103        :on    (partial-class-defining-classes class) :by #'cddr
 104        :do (funcall-with-layer-context
 105             (adjoin-layer (find-layer layer) (current-layer-context))
 106             (lambda ()
 107               (loop :for direct-slot :in (class-direct-slots class)
 108                  :do (let ((attribute
 109                             (find (slot-definition-name direct-slot)
 110                                   attribute-objects
 111                                   :key #'attribute-name)))
 112                        (let ((initargs
 113                               (prepare-initargs attribute (direct-attribute-properties direct-slot))))
 114
 115                          (apply #'reinitialize-instance attribute
 116                                 initargs )
 117                          (setf (slot-value description (attribute-name attribute))
 118                                (attribute-class attribute))
 119                          (apply #'change-class attribute  (find-class (attribute-class attribute))
 120                                 initargs))))
 121               (when (slot-boundp  class 'class-active-attributes-definition)
 122               (with-described-object (nil description)
 123                 (setf (slot-value (find-attribute description 'active-attributes) 'value)
 124                       (slot-value class 'class-active-attributes-definition))))))))
 125
 126 (defun initialize-description-class (class)
 127
 128 ;;; HACK: initialization does not happ   en properly
 129 ;;; when compiling and loading or something like that.
 130 ;;; Obviously i'm not sure why.
 131 ;;; So we're going to explicitly initialize things.
 132 ;;; For now. --drewc
 133
 134   (pushnew class *defined-descriptions*)
 135
 136 ;;; ENDHACK.
 137
 138   (let* ((description (find-layer class))
 139          (attribute-objects
 140           (setf (description-class-attributes (class-of description))
 141                 (compute-effective-attribute-objects description))))
 142
 143     (initialize-effective-attribute-values-for-description-class class description attribute-objects)
 144 ))
 145
 146
 147 #+old(defun initialize-description-class (class)
 148
 149 ;;; HACK: initialization does not happ   en properly
 150 ;;; when compiling and loading or something like that.
 151 ;;; Obviously i'm not sure why.
 152 ;;; So we're going to explicitly initialize things.
 153 ;;; For now. --drewc
 154
 155   (pushnew class *defined-descriptions*)
 156
 157 ;;; ENDHACK.
 158
 159   (let* ((description (find-layer class))
 160          (attribute-objects
 161           (mapcar
 162            (lambda (slot)
 163              (let* ((*init-time-description* description)
 164                           (attribute
 165                            (apply #'make-instance
 166                             'standard-attribute
 167                             :description description
 168                             (attribute-object-initargs slot))))
 169
 170
 171                (setf (slot-definition-attribute-object slot) attribute)))
 172            (remove 'described-object (class-slots (class-of description))
 173                    :key #'slot-definition-name)))
 174          (defining-classes (partial-class-defining-classes (class-of description))))
 175
 176     (loop
 177        :for (layer class)
 178        :on  defining-classes :by #'cddr
 179        :do (funcall-with-layer-context
 180             (adjoin-layer (find-layer layer) (current-layer-context))
 181             (lambda ()
 182               (loop :for direct-slot :in (class-direct-slots class)
 183                  :do (let ((attribute
 184                             (find (slot-definition-name direct-slot)
 185                                   attribute-objects
 186                                   :key #'attribute-name)))
 187                        (let ((initargs
 188                               (prepare-initargs attribute (direct-attribute-properties direct-slot))))
 189
 190                          (apply #'reinitialize-instance attribute
 191                                 initargs )
 192                          (warn "Attribute class for ~A is ~A" attribute (attribute-class attribute))
 193                          (when (not (eq (find-class (attribute-class attribute))
 194                                         (class-of attribute)))
 195                            (warn "~%CHANGING CLASS~%")
 196
 197                            (apply #'change-class attribute  (attribute-class attribute)
 198                                   initargs))))))))))
 199
 200 ;;;; HACK: run this at startup till we figure things out.
 201 (defun initialize-descriptions ()
 202   (map nil #'initialize-description-class
 203        (setf *defined-descriptions*
 204              (remove-duplicates *defined-descriptions*))))
 205
 206 (defmethod initialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '()))
 207   (declare (dynamic-extent initargs))
 208   (prog1
 209       (if (loop for direct-superclass in direct-superclasses
 210                 thereis (ignore-errors (subtypep direct-superclass 'standard-description-object)))
 211         (call-next-method)
 212         (apply #'call-next-method
 213                class
 214                :direct-superclasses
 215                (append direct-superclasses
 216                        (list (find-class 'standard-description-object)))
 217                initargs))
 218     (initialize-description-class class)))
 219
 220
 221 (defmethod reinitialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
 222   (declare (dynamic-extent initargs))
 223 ;  (warn "CLASS ~A ARGS ~A:" class initargs)
 224   (prog1
 225       (if (or (not direct-superclasses-p)
 226                 (loop for direct-superclass in direct-superclasses
 227                       thereis (ignore-errors (subtypep direct-superclass 'standard-description-object))))
 228           (call-next-method)
 229           (apply #'call-next-method
 230                  class
 231                  :direct-superclasses
 232                  (append direct-superclasses
 233                          (list (find-class 'standard-description-object)))
 234                  initargs))
 235     (initialize-description-class class)))
 236
 237
 238 (defmethod print-object ((object standard-description-object) stream)
 239   (print-unreadable-object (object stream :type nil :identity t)
 240     (format stream "DESCRIPTION ~A" (ignore-errors (description-print-name object)))))
 241
 242 (defmethod print-object ((object standard-description-class) stream)
 243   (print-unreadable-object (object stream :type t :identity t)
 244     (princ  (ignore-errors (description-print-name (find-layer object))) stream)))
 245
 246 (defun find-description (name &optional (errorp t))
 247   (let ((class (find-class (defining-description name) errorp)))
 248     (when class (find-layer class))))
 249
 250
 251
 252
 253
 254