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 ;;; HACK:
   8 ;;; Since i'm not using deflayer, ensure-layer etc,
   9 ;;; There are a few places where contextl gets confused
  10 ;;; trying to locate my description layers.
  11
  12 ;;; TODO: investigate switching to deflayer!
  13
  14 (defun contextl::prepare-layer (layer)
  15   (if (symbolp layer)
  16       (if (eq (symbol-package layer)
  17           (find-package :description-definers))
  18           layer
  19           (contextl::defining-layer layer))
  20
  21       layer))
  22
  23 (defmethod find-layer-class :around ((layer symbol) &optional errorp environment)
  24   (if (eq (symbol-package layer)
  25           (find-package :description-definers))
  26       (find-class layer)
  27       (call-next-method)))
  28
  29 ;;; #+HACK
  30 ;;; I'm having some 'issues' with
  31 ;;; compiled code and my initialization.
  32 ;;; So this hack initializes the world.
  33 (eval-when (:compile-toplevel :load-toplevel :execute)
  34   (defparameter *defined-descriptions* nil))
  35
  36 (define-layered-class description-access-class (standard-layer-class contextl::special-layered-access-class )
  37   ((defined-in-descriptions :initarg :in-description)
  38    (mixin-class-p :initarg :mixinp)))
  39
  40 (defmethod direct-slot-definition-class
  41            ((class description-access-class) &key &allow-other-keys)
  42   (find-class 'direct-attribute-definition-class))
  43
  44 (defmethod effective-slot-definition-class
  45            ((class description-access-class) &key &allow-other-keys)
  46   (find-class 'effective-attribute-definition-class))
  47
  48 (defmethod compute-effective-slot-definition
  49            ((class description-access-class) name direct-slot-definitions)
  50   (declare (ignore name))
  51   (let ((attribute (call-next-method)))
  52     (setf (attribute-direct-attributes attribute) direct-slot-definitions)
  53     (setf (attribute-object-initargs attribute)
  54           ;; This plist will be used to init the attribute object
  55           ;; Once the description itself is properly initiated.
  56           (list :name name
  57                 'effective-attribute attribute))
  58     attribute))
  59
  60 (defmethod slot-value-using-class ((class description-access-class) object slotd)
  61   (if (or
  62        (eq (slot-definition-name slotd) 'described-object)
  63        (not (slot-boundp slotd 'attribute-object)))
  64       (call-next-method)
  65       (slot-definition-attribute-object slotd)))
  66
  67
  68 (defclass standard-description-class (description-access-class layered-class)
  69   ()
  70   (:default-initargs :defining-metaclass 'description-access-class))
  71
  72 (defmethod validate-superclass
  73            ((class standard-description-class)
  74             (superclass standard-class))
  75   t)
  76
  77 (define-layered-class standard-description-object (standard-layer-object)
  78   ((described-object :accessor described-object
  79                      :special t)))
  80
  81 (defun description-class-name  (description-class)
  82     (read-from-string (symbol-name (class-name description-class))))
  83
  84 (defun initialize-description-class (class)
  85
  86 ;;; HACK: initialization does not happ   en properly
  87 ;;; when compiling and loading or something like that.
  88 ;;; Obviously i'm not sure why.
  89 ;;; So we're going to explicitly initialize things.
  90 ;;; For now. --drewc
  91
  92   (pushnew class *defined-descriptions*)
  93
  94 ;;; ENDHACK.
  95
  96   (let* ((description (find-layer class))
  97          (attribute-objects
  98           (mapcar
  99            (lambda (slot)
 100              (let* ((*init-time-description* description)
 101                           (attribute                 (apply #'make-instance
 102                             'standard-attribute
 103                             :description description
 104                             (attribute-object-initargs slot))))
 105
 106
 107                (setf (slot-definition-attribute-object slot) attribute)))
 108            (remove 'described-object (class-slots (class-of description))
 109                    :key #'slot-definition-name)))
 110          (defining-classes (partial-class-defining-classes (class-of description))))
 111
 112     (loop
 113        :for (layer class)
 114        :on  defining-classes :by #'cddr
 115        :do (funcall-with-layer-context
 116             (adjoin-layer (find-layer layer) (current-layer-context))
 117             (lambda ()
 118               (loop :for direct-slot :in (class-direct-slots class)
 119                  :do (let ((attribute
 120                             (find (slot-definition-name direct-slot)
 121                                   attribute-objects
 122                                   :key #'attribute-name)))
 123                        (let ((initargs
 124                               (prepare-initargs attribute (direct-attribute-properties direct-slot))))
 125
 126                          (apply #'reinitialize-instance attribute
 127                                 initargs )
 128                          (when (not (eq (find-class (attribute-class attribute))
 129                                         (class-of attribute)))
 130
 131                            (apply #'change-class attribute  (attribute-class attribute)
 132                                   initargs)))
 133
 134
 135                        )))))))
 136
 137 ;;;; HACK: run this at startup till we figure things out.
 138 (defun initialize-descriptions ()
 139   (map nil #'initialize-description-class
 140        (setf *defined-descriptions*
 141              (remove-duplicates *defined-descriptions*))))
 142
 143 (defmethod initialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '()))
 144   (declare (dynamic-extent initargs))
 145   (prog1
 146       (if (loop for direct-superclass in direct-superclasses
 147                 thereis (ignore-errors (subtypep direct-superclass 'standard-description-object)))
 148         (call-next-method)
 149         (apply #'call-next-method
 150                class
 151                :direct-superclasses
 152                (append direct-superclasses
 153                        (list (find-class 'standard-description-object)))
 154                initargs))
 155     (initialize-description-class class)))
 156
 157
 158 (defmethod reinitialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
 159   (declare (dynamic-extent initargs))
 160 ;  (warn "CLASS ~A ARGS ~A:" class initargs)
 161   (prog1
 162       (if (or (not direct-superclasses-p)
 163                 (loop for direct-superclass in direct-superclasses
 164                       thereis (ignore-errors (subtypep direct-superclass 'standard-description-object))))
 165           (call-next-method)
 166           (apply #'call-next-method
 167                  class
 168                  :direct-superclasses
 169                  (append direct-superclasses
 170                          (list (find-class 'standard-description-object)))
 171                  initargs))
 172     (initialize-description-class class)))
 173
 174
 175 (defmethod print-object ((object standard-description-object) stream)
 176   (print-unreadable-object (object stream :type nil :identity t)
 177     (format stream "DESCRIPTION ~A" (ignore-errors (description-print-name object)))))
 178
 179 (defmethod print-object ((object standard-description-class) stream)
 180   (print-unreadable-object (object stream :type t :identity t)
 181     (princ  (ignore-errors (description-print-name (find-layer object))) stream)))
 182
 183 (defun find-description (name)
 184   (find-layer (find-class (defining-description name))))
 185
 186
 187
 188
 189
 190