src/attribute.lisp

   1 (in-package :lisp-on-lines)
   2
   3 (define-layered-class direct-attribute-definition-class
   4  (special-layered-direct-slot-definition contextl::singleton-direct-slot-definition)
   5   ((attribute-properties :accessor direct-attribute-properties
   6                      :documentation "This is an plist to hold the values of the attribute's properties as described by this direct attrbiute definition.")))
   7
   8 (defmethod initialize-instance :after ((attribute direct-attribute-definition-class) &rest initargs)
   9   (setf (direct-attribute-properties attribute) initargs))
  10
  11 (define-layered-class effective-attribute-definition-class (special-layered-effective-slot-definition)
  12   ((direct-attributes :accessor attribute-direct-attributes)
  13    (attribute-object :accessor attribute-object
  14                      :documentation "")
  15    (attribute-object-initargs :accessor attribute-object-initargs)))
  16
  17
  18 (define-layered-function attribute-value (object attribute))
  19
  20 (define-layered-method attribute-value (object attribute)
  21
  22  (let ((fn (handler-case (attribute-function attribute)
  23              (unbound-slot () nil))))
  24    (if fn
  25        (funcall fn object)
  26        (%attribute-value attribute))))
  27
  28 (defmethod attribute-description (attribute)
  29   ;(break "description for ~A is (slot-value attribute 'description-name)")
  30   (find-layer (slot-value attribute 'description-class))
  31 #+nil  (let ((name (slot-value attribute 'description-name)))
  32     (when name
  33       (find-description name))))
  34
  35
  36 (define-layered-class standard-attribute ()
  37
  38   ((effective-attribute-definition :initarg effective-attribute
  39                                    :accessor attribute-effective-attribute-definition)
  40    (description-name)
  41    (description-class :initarg description-class)
  42    (initfunctions :initform nil)
  43    (attribute-class :accessor attribute-class
  44                     :initarg :attribute-class
  45                     :initform 'standard-attribute)
  46    (name :layered-accessor attribute-name
  47           :initarg :name)
  48    (label :layered-accessor attribute-label
  49           :initarg :label
  50           :initform nil
  51           :layered t
  52           ;:special t
  53           )
  54    (function
  55     :initarg :function
  56     :layered-accessor attribute-function
  57     :layered t)
  58    (value :layered-accessor %attribute-value
  59           :initarg :value
  60           :layered t)))
  61
  62
  63
  64 (defmethod print-object ((object standard-attribute) stream)
  65   (print-unreadable-object (object stream :type nil :identity t)
  66     (format stream "ATTRIBUTE ~A" (or (ignore-errors (attribute-name object)) "+unnamed-attribute+"))))
  67
  68 (defvar *bypass-property-layered-function* nil)
  69
  70 (define-layered-function property-layered-function (description attribute-name property-name)
  71   (:method  (description attribute-name property-name)
  72     ;(dprint "First Time PLFunction for ~A ~A ~A" description attribute-name property-name)
  73     (ensure-layered-function
  74      (defining-description (intern (format nil "~A-~A-~A"
  75                     (description-print-name description)
  76                      attribute-name
  77                      property-name)))
  78
  79      :lambda-list '(description))))
  80
  81 (define-layered-method (setf slot-value-using-layer)
  82   :in-layer (context t)
  83   (new-value class (attribute standard-attribute) property writer)
  84
  85   (when (or *bypass-property-layered-function*
  86             (not (slot-definition-layeredp property)))
  87     (return-from slot-value-using-layer (call-next-method)))
  88
  89
  90   ;;FIXME: this is wrong for so many reasons.
  91   (let ((layer
  92          (find-layer (first (remove nil (closer-mop::class-precedence-list (class-of context))
  93                      :key #'class-name)))))
  94
  95
  96     (flet ((do-set-slot()
  97
  98              (let ((fn
  99               (let ((*bypass-property-layered-function* t))
 100                 (if (slot-boundp-using-class class attribute property)
 101                     (slot-value-using-class class attribute property)
 102                     (setf (slot-value-using-class class attribute property)
 103                           (property-layered-function
 104                            (attribute-description attribute)
 105                            (attribute-name attribute)
 106                            (closer-mop:slot-definition-name property)))))))
 107          ;(dprint "We are setting the fn ~A " fn)
 108          (when (not (generic-function-methods fn))
 109           ; (dprint "... there are no methods on it ever")
 110            ;; * This slot has never been set before.
 111            ;; create a method on property-layered-function
 112            ;; so subclasses can see this new property.
 113            (ensure-layered-method
 114             (layered-function-definer 'property-layered-function)
 115             `(lambda (description attribute property)
 116                (declare (ignore description attribute property))
 117                ,fn)
 118             :in-layer layer
 119             :specializers
 120             (list (class-of
 121                    (attribute-description attribute))
 122                   (closer-mop:intern-eql-specializer
 123                    (attribute-name attribute))
 124                   (closer-mop:intern-eql-specializer
 125                    (closer-mop:slot-definition-name property)))))
 126
 127
 128          ;; finally, specialize this property to this description.
 129          (ensure-layered-method
 130           fn
 131           `(lambda (description)
 132              ,new-value)
 133           :in-layer layer
 134           :specializers (list (class-of (attribute-description attribute)
 135                                        ))))))
 136
 137       (if (slot-boundp attribute 'description-class)
 138           (do-set-slot)
 139           (push (lambda () (do-set-slot))
 140                 (slot-value attribute 'initfunctions))))))
 141
 142
 143 (define-layered-method slot-value-using-layer
 144   :in-layer (layer t)
 145   :around (class (attribute standard-attribute) property reader)
 146
 147   ;;  (dprint "Getting the slot value of ~A" property)
 148
 149   ;; We do some magic in here and i thought it
 150   ;; would be called magically in call-next-method.
 151   ;; This explicit call is good enough for now.
 152
 153   (unless (slot-boundp-using-class class attribute property)
 154     (slot-unbound class attribute (slot-definition-name property)))
 155
 156   (if (and
 157        (contextl::slot-definition-layeredp property)
 158        (not *bypass-property-layered-function*))
 159       (let ((fn (call-next-method)))
 160         ;(dprint "... using fn ~A to get value" fn)
 161       (funcall fn layer  (attribute-description attribute)))
 162       (call-next-method)))
 163
 164 (defmacro define-bypass-function (name function-name)
 165   `(defun ,name (&rest args)
 166      (let ((*bypass-property-layered-function* t))
 167        (apply (function ,function-name) args))))
 168
 169 (define-bypass-function real-slot-boundp-using-class slot-boundp-using-class)
 170 (define-bypass-function real-slot-value-using-class slot-value-using-class)
 171 (define-bypass-function (setf real-slot-value-using-class) (setf slot-value-using-class))
 172
 173 (defun slot-boundp-using-property-layered-function (class attribute property)
 174   (dprint "plf boundp:")
 175   (let* ((really-bound-p
 176           (real-slot-boundp-using-class class attribute property))
 177          (fn (if really-bound-p
 178                  (real-slot-value-using-class class attribute property)
 179                  (setf (real-slot-value-using-class class attribute property)
 180                        (property-layered-function
 181                         (attribute-description attribute)
 182                         (attribute-name attribute)
 183                         (closer-mop:slot-definition-name property))))))
 184     (dprint "Slot was bound? ~A" really-bound-p)
 185     ;; If the slot is unbound, we search for its layered-function
 186       (if (generic-function-methods fn)
 187           T
 188           NIL)))
 189
 190 (define-layered-method slot-boundp-using-layer
 191   :in-layer (layer t)
 192   :around (class (attribute standard-attribute) property reader)
 193   (if *bypass-property-layered-function*
 194       (call-next-method)
 195       (slot-boundp-using-property-layered-function class attribute property)))
 196
 197 (defun attribute-value* (attribute)
 198   (attribute-value *object* attribute))
 199
 200 (defmacro with-attributes (names description &body body)
 201   `(with-slots ,names ,description ,@body))
 202
 203 (defun display-attribute (attribute)
 204   (display-using-description attribute *display* *object*))
 205
 206 (define-layered-method display-using-description
 207   ((attribute standard-attribute) display object &rest args)
 208   (declare (ignore args))
 209   (when (attribute-label attribute)
 210     (format display "~A " (attribute-label attribute)))
 211   (format display "~A" (attribute-value object attribute)))
 212
 213
 214
 215
 216
 217
 218
 219
 220
 221
 222