X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/81d7061052c90867a26b50e69e35f5d96b17686a..80fcd57c2870eac29dc3e21849d358b6b58adcf8:/src/attribute.lisp diff --git a/src/attribute.lisp b/src/attribute.lisp index 6d47657..e502859 100644 --- a/src/attribute.lisp +++ b/src/attribute.lisp @@ -6,7 +6,7 @@ :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) @@ -42,14 +42,15 @@ (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 @@ -59,12 +60,25 @@ :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) @@ -78,67 +92,57 @@ :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) @@ -152,14 +156,18 @@ (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) @@ -171,7 +179,7 @@ (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 @@ -181,16 +189,15 @@ (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)))