:documentation "This is an plist to hold the values of the attribute's properties as described by this direct attrbiute definition.")))
(defmethod initialize-instance :after ((attribute direct-attribute-definition-class) &rest initargs)
- (setf (direct-attribute-properties attribute) initargs))
+ (setf (direct-attribute-properties attribute) initargs))
(define-layered-class effective-attribute-definition-class (special-layered-effective-slot-definition)
((direct-attributes :accessor attribute-direct-attributes)
(initfunctions :initform nil)
(attribute-class :accessor attribute-class
:initarg :attribute-class
- :initform 'standard-attribute)
+ :initform 'standard-attribute
+ :layered t)
(name :layered-accessor attribute-name
:initarg :name)
(label :layered-accessor attribute-label
:initarg :label
:initform nil
:layered t
- ;:special t
+ :special t
)
(function
:initarg :function
:initarg :value
:layered t)))
-
-
(defmethod print-object ((object standard-attribute) stream)
(print-unreadable-object (object stream :type nil :identity t)
(format stream "ATTRIBUTE ~A" (or (ignore-errors (attribute-name object)) "+unnamed-attribute+"))))
+(defgeneric eval-property-initarg (att initarg)
+ (:method ((attribute standard-attribute) initarg)
+ nil)
+ (:method ((attribute standard-attribute) (initarg (eql :function)))
+ t))
+
+(defun prepare-initargs (att args)
+ (loop
+ :for (key arg)
+ :on args :by #'cddr
+ :nconc (list key
+ (if (eval-property-initarg att key)
+ (eval arg)
+ arg))))
+
(defvar *bypass-property-layered-function* nil)
(define-layered-function property-layered-function (description attribute-name property-name)
:lambda-list '(description))))
+
(define-layered-method (setf slot-value-using-layer)
:in-layer (context t)
+ :around
(new-value class (attribute standard-attribute) property writer)
- (when (or *bypass-property-layered-function*
- (not (slot-definition-layeredp property)))
+ (when (or *bypass-property-layered-function* )
+
(return-from slot-value-using-layer (call-next-method)))
-
- ;;FIXME: this is wrong for so many reasons.
(let ((layer
+ ;;FIXME: this is wrong for so many reasons
(find-layer (first (remove nil (closer-mop::class-precedence-list (class-of context))
- :key #'class-name)))))
-
-
- (flet ((do-set-slot()
-
- (let ((fn
- (let ((*bypass-property-layered-function* t))
- (if (slot-boundp-using-class class attribute property)
- (slot-value-using-class class attribute property)
- (setf (slot-value-using-class class attribute property)
- (property-layered-function
- (attribute-description attribute)
- (attribute-name attribute)
- (closer-mop:slot-definition-name property)))))))
- ;(dprint "We are setting the fn ~A " fn)
- (when (not (generic-function-methods fn))
- ; (dprint "... there are no methods on it ever")
- ;; * This slot has never been set before.
- ;; create a method on property-layered-function
- ;; so subclasses can see this new property.
- (ensure-layered-method
- (layered-function-definer 'property-layered-function)
- `(lambda (description attribute property)
- (declare (ignore description attribute property))
- ,fn)
- :in-layer layer
- :specializers
- (list (class-of
- (attribute-description attribute))
- (closer-mop:intern-eql-specializer
- (attribute-name attribute))
- (closer-mop:intern-eql-specializer
- (closer-mop:slot-definition-name property)))))
-
-
- ;; finally, specialize this property to this description.
- (ensure-layered-method
- fn
- `(lambda (description)
- ,new-value)
- :in-layer layer
- :specializers (list (class-of (attribute-description attribute)
- ))))))
-
- (if (slot-boundp attribute 'description-class)
- (do-set-slot)
- (push (lambda () (do-set-slot))
- (slot-value attribute 'initfunctions))))))
-
+ :key #'class-name))))
+ (boundp (slot-boundp-using-class class attribute property))
+ (val (real-slot-value-using-class class attribute property)))
+
+ (when (special-symbol-p val)
+ (return-from slot-value-using-layer (call-next-method)))
+
+ (when (not boundp)
+ ;; * This slot has never been set before.
+ ;; create a method on property-layered-function
+ ;; so subclasses can see this new property.
+ (ensure-layered-method
+ (layered-function-definer 'property-layered-function)
+ `(lambda (description attribute property)
+ (declare (ignore description attribute property))
+ ,val)
+ :in-layer layer
+ :specializers
+ (list (class-of
+ (attribute-description attribute))
+ (closer-mop:intern-eql-specializer
+ (attribute-name attribute))
+ (closer-mop:intern-eql-specializer
+ (closer-mop:slot-definition-name property)))))
+
+ ;; specialize this property to this description.
+
+ (ensure-layered-method
+ val
+ `(lambda (description)
+ (funcall ,(lambda()
+ new-value)))
+ :in-layer layer
+ :specializers (list (class-of (attribute-description attribute))))
+
+ ;; and return the set value as is custom
+ (slot-value-using-class class attribute property)))
+
(define-layered-method slot-value-using-layer
:in-layer (layer t)
(unless (slot-boundp-using-class class attribute property)
(slot-unbound class attribute (slot-definition-name property)))
-
+
+ (let ((val (print (call-next-method))))
+
(if (and
+ ;; Not special access
+ (not (symbolp val))
(contextl::slot-definition-layeredp property)
(not *bypass-property-layered-function*))
- (let ((fn (call-next-method)))
+ (let ((fn val))
;(dprint "... using fn ~A to get value" fn)
(funcall fn layer (attribute-description attribute)))
- (call-next-method)))
+ val)))
(defmacro define-bypass-function (name function-name)
`(defun ,name (&rest args)
(define-bypass-function (setf real-slot-value-using-class) (setf slot-value-using-class))
(defun slot-boundp-using-property-layered-function (class attribute property)
- (dprint "plf boundp:")
+ ;(dprint "plf boundp:")
(let* ((really-bound-p
(real-slot-boundp-using-class class attribute property))
(fn (if really-bound-p
(attribute-description attribute)
(attribute-name attribute)
(closer-mop:slot-definition-name property))))))
- (dprint "Slot was bound? ~A" really-bound-p)
- ;; If the slot is unbound, we search for its layered-function
- (if (generic-function-methods fn)
- T
- NIL)))
+
+ (if (generic-function-methods fn)
+ T
+ NIL)))
(define-layered-method slot-boundp-using-layer
:in-layer (layer t)
:around (class (attribute standard-attribute) property reader)
- (if *bypass-property-layered-function*
+ (if (or *bypass-property-layered-function* *symbol-access*)
(call-next-method)
(slot-boundp-using-property-layered-function class attribute property)))
HCoop / clinton / lisp-on-lines.git / blobdiff