src/attribute.lisp

   1 (in-package :lisp-on-lines)
   2
   3 (define-layered-class direct-attribute-definition-class
   4   (special-layered-direct-slot-definition
   5    contextl::singleton-direct-slot-definition)
   6   ((attribute-properties
   7     :accessor direct-attribute-properties
   8     :documentation "This is an plist to hold the values of
   9     the attribute's properties as described by this direct
  10     attribute definition.")))
  11
  12 (defmethod initialize-instance
  13     :after ((attribute direct-attribute-definition-class)
  14             &rest initargs)
  15   (setf (direct-attribute-properties attribute) initargs))
  16
  17 (define-layered-class effective-attribute-definition-class
  18     (special-layered-effective-slot-definition)
  19   ((direct-attributes
  20     :accessor attribute-direct-attributes)
  21    (attribute-object
  22     :accessor attribute-object)
  23    (attribute-object-initargs
  24     :accessor attribute-object-initargs)))
  25
  26 (defvar *function-access* nil
  27   "set/get a place's property function instead of its symbol value
  28    when this is set to a non-nil value")
  29
  30 (defmacro with-function-access (&body body)
  31   "executes body in an environment with *function-access* set to t"
  32   `(let ((*function-access* t))
  33      ,@body))
  34
  35 (defmacro without-function-access (&body body)
  36   "executes body in an environment with *function-access* set to nil"
  37   `(let ((*function-access* nil))
  38      ,@body))
  39
  40 (define-layered-function property-access-function (description attribute-name property-name)
  41   (:method  (description attribute-name property-name)
  42     (ensure-layered-function
  43      (defining-description
  44          (intern (format nil "~A-~A-~A"
  45                          (description-print-name description)
  46                          attribute-name
  47                          property-name)))
  48          :lambda-list '(description))))
  49
  50
  51 (define-layered-class standard-attribute ()
  52  ((description-class :initarg description-class)
  53   (name
  54    :layered-accessor attribute-name
  55    :initarg :name)
  56   (effective-attribute-definition
  57     :initarg effective-attribute
  58     :accessor attribute-effective-attribute-definition)
  59   (attribute-class
  60    :accessor attribute-class
  61    :initarg :attribute-class
  62    :initform 'standard-attribute
  63    :layered t)
  64   (label
  65    :layered-accessor attribute-label
  66    :initarg :label
  67    :initform nil
  68    :layered t
  69    :special t)
  70   (function
  71    :initarg :function
  72    :layered-accessor attribute-function
  73    :layered t
  74    :special t)
  75    (value
  76     :layered-accessor %attribute-value
  77     :initarg :value
  78     :layered t
  79     :special t)
  80   (activep
  81    :layered-accessor attribute-active-p
  82    :initarg :activep
  83    :initform t
  84    :layered t
  85    :special t)
  86   (keyword
  87    :layered-accessor attribute-keyword
  88    :initarg :keyword
  89    :initform nil
  90    :layered t)
  91 ))
  92
  93 (defun ensure-access-function (class attribute property)
  94   (with-function-access
  95     (if (slot-definition-specialp property)
  96         (let ((slot-symbol
  97                (with-symbol-access
  98                  (slot-value-using-class
  99                   class attribute property))))
 100           (if (fboundp slot-symbol)
 101               (symbol-function slot-symbol)
 102               (setf (symbol-function slot-symbol)
 103                     (property-access-function
 104                      (attribute-description attribute)
 105                      (attribute-name attribute)
 106                      (slot-definition-name property)))))
 107         (if (slot-boundp-using-class class attribute property)
 108             (slot-value-using-class class attribute property)
 109             (setf (slot-value-using-class class attribute property)
 110                   (property-access-function
 111                    (attribute-description attribute)
 112                    (attribute-name attribute)
 113                    (slot-definition-name property)))))))
 114
 115 (define-layered-method slot-boundp-using-layer
 116   :in-layer (layer t)
 117   :around (class (attribute standard-attribute) property reader)
 118
 119 ; (dprint "Checking boundp ~A ~A" (attribute-name attribute)
 120         ; (slot-definition-name property))
 121
 122   (if (or *symbol-access* *function-access*)
 123       (call-next-method)
 124       (or (when (slot-definition-specialp property)
 125             (with-function-access
 126            (slot-boundp-using-class class attribute property)))
 127           (if (generic-function-methods
 128                (ensure-access-function class attribute property))
 129               T
 130               NIL))))
 131
 132 (define-layered-method (setf slot-value-using-layer)
 133   :in-layer (context t)
 134   :around
 135   (new-value class (attribute standard-attribute) property writer)
 136
 137 ;;  (dprint "Setting ~A ~A to : ~A" attribute property new-value)
 138
 139   (if (or *symbol-access* *function-access*)
 140       (call-next-method)
 141
 142       (if (and (slot-definition-specialp property)
 143                (with-function-access
 144                  (without-symbol-access (slot-boundp-using-class class attribute property))))
 145           (with-function-access
 146             (call-next-method))
 147           (let ((layer
 148                  ;;FIXME: this is wrong for so many reasons
 149                  (find-layer (first (remove nil (closer-mop::class-precedence-list (class-of context))
 150                                             :key #'class-name))))
 151                 (boundp (slot-boundp-using-class class attribute property))
 152                 (fn  (ensure-access-function class attribute property)))
 153
 154             (when (not boundp)
 155               ;; * This slot has never been set before.
 156               ;; create a method on property-accessor-function
 157               ;; so subclasses can see this new property.
 158               (ensure-layered-method
 159                (layered-function-definer 'property-access-function)
 160                `(lambda (description attribute property)
 161                   (declare (ignore description attribute property))
 162                   ,fn)
 163                :in-layer layer
 164                :specializers
 165                (list (class-of
 166                       (attribute-description attribute))
 167                      (closer-mop:intern-eql-specializer
 168                       (attribute-name attribute))
 169                      (closer-mop:intern-eql-specializer
 170                       (closer-mop:slot-definition-name property)))))
 171
 172             ;; specialize this property to this description.
 173             ;;(dprint "actrually specializering")
 174             (ensure-layered-method
 175              fn
 176              `(lambda (description)
 177                 (funcall ,(lambda()
 178                                  new-value)))
 179              :in-layer layer
 180              :specializers (list (class-of (attribute-description attribute))))
 181
 182             ;;  and return the set value as is custom
 183             new-value))))
 184
 185 (define-layered-method slot-value-using-layer
 186   :in-layer (layer t)
 187   :around (class (attribute standard-attribute) property reader)
 188
 189 ;  ;(dprint "Getting the slot value of ~A" property)
 190   (if (or *symbol-access* *function-access*)
 191       (call-next-method)
 192       (let ((fn (ensure-access-function class attribute property)))
 193
 194         (unless (slot-boundp-using-class class attribute property)
 195           (slot-unbound class attribute (slot-definition-name property)))
 196
 197         (if (slot-definition-specialp property)
 198             (if (with-function-access
 199                   (slot-boundp-using-class class attribute property))
 200                 (with-function-access
 201                   (slot-value-using-class class attribute property))
 202                 (funcall fn layer (attribute-description attribute)))
 203             (funcall fn layer (attribute-description attribute))))))
 204
 205
 206
 207  (define-layered-function attribute-value (object attribute))
 208
 209  (define-layered-method attribute-value (object attribute)
 210
 211                            (let ((fn (handler-case (attribute-function attribute)
 212                                        (unbound-slot () nil))))
 213                              (if fn
 214                                  (funcall fn object)
 215                                  (%attribute-value attribute))))
 216
 217 (defmethod attribute-description (attribute)
 218                                         ;(break "description for ~A is (slot-value attribute 'description-name)")
 219       (find-layer (slot-value attribute 'description-class))
 220       #+nil  (let ((name (slot-value attribute 'description-name)))
 221                (when name
 222                  (find-description name))))
 223
 224
 225
 226 (defmethod print-object ((object standard-attribute) stream)
 227   (print-unreadable-object (object stream :type nil :identity t)
 228     (format stream "ATTRIBUTE ~A" (or (ignore-errors (attribute-name object)) "+unnamed-attribute+"))))
 229
 230 (defgeneric eval-property-initarg (att initarg)
 231   (:method ((attribute standard-attribute) initarg)
 232     nil)
 233   (:method ((attribute standard-attribute) (initarg (eql :function)))
 234     t))
 235
 236 (defun prepare-initargs (att args)
 237   (loop
 238      :for (key arg)
 239      :on args :by #'cddr
 240      :nconc (list key
 241                   (if (eval-property-initarg att key)
 242                       (eval arg)
 243                       arg))))
 244
 245
 246 (defun attribute-value* (attribute)
 247   (attribute-value *object* attribute))
 248
 249 (defmacro with-attributes (names description &body body)
 250   `(with-slots ,names ,description ,@body))
 251
 252 (define-layered-function display-attribute (object attribute)
 253   (:method (object attribute)
 254     (display-using-description attribute *display* object)))
 255
 256 (define-layered-function display-attribute-label (object attribute)
 257   (:method (object attribute)
 258         (format *display* "~A " (attribute-label attribute))
 259 ))
 260
 261 (define-layered-function display-attribute-value (object attribute)
 262   (:method (object attribute)
 263     (let ((val (attribute-value object attribute)))
 264       (if (eq val object)
 265           (format *display* "~A " val)
 266                   (with-active-descriptions (inline)
 267                     (display *display* val )
 268
 269                     )
 270           ))))
 271
 272 (define-layered-method display-using-description
 273   ((attribute standard-attribute) display object &rest args)
 274   (declare (ignore args))
 275   (when (attribute-label attribute)
 276     (display-attribute-label object attribute))
 277   (display-attribute-value object attribute))
 278
 279
 280
 281
 282
 283
 284
 285
 286
 287
 288