src/new-description.lisp

   1 (in-package :lisp-on-lines)
   2
   3 ;;;; A simpler implementation of descriptions based on plists
   4
   5 (setf (find-class 'simple-attribute nil) nil)
   6
   7 (define-layered-class simple-attribute ()
   8   ((%property-access-function
   9     :initarg property-access-function)
  10    (%initial-slot-values-plist)))
  11
  12 (defun ensure-property-access-function (attribute)
  13   (if (slot-boundp attribute '%property-access-function)
  14       (slot-value attribute '%property-access-function)
  15       (let ((fn-name (gensym)))
  16         (ensure-layered-function fn-name :lambda-list '() :method-combination '(append))
  17         (setf (slot-value attribute '%property-access-function) fn-name))))
  18
  19 (defconstant +property-not-found+ '=lisp-on-lines-property-not-found-indicator=)
  20
  21 (define-layered-method
  22     contextl:slot-value-using-layer (class (attribute simple-attribute) slotd reader)
  23   (if (or contextl:*symbol-access*
  24           (not (slot-definition-layeredp slotd)))
  25       (call-next-method)
  26       (let ((value (getf (funcall (ensure-property-access-function attribute))
  27                          (slot-definition-name slotd)
  28                          +property-not-found+)))
  29         (if (eq value +property-not-found+)
  30             (call-next-method)
  31             value))))
  32
  33 (define-layered-method
  34     contextl:slot-value-using-layer (class (attribute simple-attribute) slotd reader)
  35   (if (or contextl:*symbol-access*
  36           (not (slot-definition-layeredp slotd))
  37           (dynamic-symbol-boundp (with-symbol-access (call-next-method))))
  38       (call-next-method)
  39       (let ((value (getf (ignore-errors (funcall (ensure-property-access-function attribute)))
  40                          (slot-definition-name slotd)
  41                          +property-not-found+)))
  42         (if (eq value +property-not-found+)
  43             (let ((value (get (ensure-property-access-function attribute)
  44                               (slot-definition-name slotd)
  45                               +property-not-found+)))
  46                 (if (eq value +property-not-found+)
  47                     (call-next-method)
  48                     value))
  49             value))))
  50
  51 (define-layered-method
  52     (setf contextl:slot-value-using-layer) (value class (attribute simple-attribute) slotd reader)
  53  (if (and (not contextl:*symbol-access*)
  54           (slot-definition-layeredp slotd))
  55      (setf (get (ensure-property-access-function attribute) (slot-definition-name slotd))
  56            value)
  57      (call-next-method)))
  58
  59 (defmethod initialize-attribute-for-layer (attribute layer-name &rest args)
  60   (let* ((class (class-of attribute))
  61          (slotds (class-slots class)))
  62     (ensure-layered-method
  63      (ensure-property-access-function attribute)
  64      `(lambda ()
  65         ',(loop
  66              :for (key val) :on args :by #'cddr
  67              :nconc (list
  68                      (loop
  69                         :for slotd :in slotds
  70                         :do (when (find key (slot-definition-initargs slotd))
  71                               (return  (slot-definition-name slotd))))
  72                      val)))
  73      :qualifiers '(append)
  74      :in-layer layer-name)))
  75
  76
  77 (define-layered-class direct-attribute-slot-definition-class
  78   (special-layered-direct-slot-definition
  79    contextl::singleton-direct-slot-definition)
  80   ((attribuite-properties
  81     :accessor slot-definition-attribute-properties
  82     :documentation "Holds the initargs passed to the slotd")))
  83
  84 (defmethod initialize-instance
  85     :after ((slotd direct-attribute-slot-definition-class)
  86             &rest initargs)
  87   (setf (slot-definition-attribute-properties slotd) initargs))
  88
  89 (defmethod reinitialize-instance
  90     :after ((slotd direct-attribute-slot-definition-class)
  91             &rest initargs)
  92   (setf (slot-definition-attribute-properties slotd) initargs))
  93
  94 (define-layered-class effective-attribute-slot-definition-class
  95     (special-layered-effective-slot-definition)
  96     ((attribute-object
  97       :accessor slot-definition-attribute-object)))
  98
  99 (define-layered-class description-access-class (standard-layer-class contextl::special-layered-access-class)
 100   ((defined-in-descriptions :initarg :in-description)
 101    (class-active-attributes-definition :initarg :attributes)
 102    (mixin-class-p :initarg :mixinp)))
 103
 104 (defmethod direct-slot-definition-class
 105            ((class description-access-class) &key &allow-other-keys)
 106   (find-class 'direct-attribute-slot-definition-class))
 107
 108 (defmethod effective-slot-definition-class
 109            ((class description-access-class) &key &allow-other-keys)
 110   (find-class 'effective-attribute-slot-definition-class))
 111 (fmakunbound 'initialize-slot-definition-attribute)
 112
 113 (defmethod initialize-slot-definition-attribute ((slotd effective-attribute-slot-definition-class) name direct-slot-definitions)
 114   (let ((tbl (make-hash-table))
 115         (attribute (make-instance 'simple-standard-attribute :name name)))
 116     (loop for ds in direct-slot-definitions
 117          :when (typep ds 'direct-attribute-slot-definition-class)
 118        :do (setf (gethash (slot-definition-layer ds) tbl)
 119                  (append (gethash (slot-definition-layer ds) tbl '())
 120                          (slot-definition-attribute-properties ds))))
 121     (maphash (lambda (layer properties)
 122                (apply #'initialize-attribute-for-layer attribute layer properties))
 123              tbl)
 124     (setf (slot-definition-attribute-object slotd) attribute)))
 125
 126 (defmethod compute-effective-slot-definition
 127            ((class description-access-class) name direct-slot-definitions)
 128   (declare (ignore name))
 129   (let ((slotd (call-next-method)))
 130     (initialize-slot-definition-attribute slotd name direct-slot-definitions)
 131     slotd))
 132
 133 (defclass standard-description-class (description-access-class layered-class)
 134   ((attributes :accessor description-class-attributes :initform (list)))
 135   (:default-initargs :defining-metaclass 'description-access-class))
 136
 137 (defmethod validate-superclass
 138            ((class standard-description-class)
 139             (superclass standard-class))
 140   t)
 141
 142 (define-layered-class standard-description-object (standard-layer-object)
 143   ((described-object :accessor described-object
 144                      :special t)))
 145
 146 (defmethod initialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '()))
 147   (declare (dynamic-extent initargs))
 148   (prog1
 149       (if (loop for direct-superclass in direct-superclasses
 150                 thereis (ignore-errors (subtypep direct-superclass 'standard-description-object)))
 151         (call-next-method)
 152         (apply #'call-next-method
 153                class
 154                :direct-superclasses
 155                (append direct-superclasses
 156                        (list (find-class 'standard-description-object)))
 157                initargs))))
 158
 159
 160 (defmethod reinitialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
 161   (declare (dynamic-extent initargs))
 162 ;  (warn "CLASS ~A ARGS ~A:" class initargs)
 163   (prog1
 164       (if (or (not direct-superclasses-p)
 165                 (loop for direct-superclass in direct-superclasses
 166                       thereis (ignore-errors (subtypep direct-superclass 'standard-description-object))))
 167           (call-next-method)
 168           (apply #'call-next-method
 169                  class
 170                  :direct-superclasses
 171                  (append direct-superclasses
 172                          (list (find-class 'standard-description-object)))
 173                  initargs))))
 174
 175
 176
 177
 178
 179
 180