X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/4867c86f7dce578458c4130d9a8cfbf1041f7c4a..f2ff8a16385c1c4bc677c703a0b48d0255046456:/src/attribute.lisp

diff --git a/src/attribute.lisp b/src/attribute.lisp
dissimilarity index 82%
index 5c8b03a..ba012b7 100644
--- a/src/attribute.lisp
+++ b/src/attribute.lisp
@@ -1,88 +1,231 @@
-(in-package :lisp-on-lines)
-
-
-(define-layered-class attribute ()
-  ())
-
-(defgeneric eval-attribute-initarg (attribute initarg)
-  (:method (a i)
-    nil))
-
-(defmethod eval-attribute-initarg (attribute (initarg (eql :function)))
-  t)
-(define-layered-function attribute-value (object attribute))
-
-
-	       
-(deflayer LISP-ON-LINES)
-(ensure-active-layer 'lisp-on-lines)
-
-(defvar *standard-direct-slot-initarg-symbols*
-    '(:layered :class :in-layer :name :readers :writers :initargs :allow-other-keys :special))
-
-(define-layered-function special-slot-values (description slot-name)
-  (:method-combination append))
-
-(define-layered-class attribute-special-layered-direct-slot-definition 
-  (attribute contextl::special-layered-direct-slot-definition) 
-  (initargs))
-
-(defmethod shared-initialize :around ((instance attribute-special-layered-direct-slot-definition) slots &rest initargs )
-  (setf (slot-value instance 'initargs) 
-	(apply #'arnesi:remove-keywords initargs *standard-direct-slot-initarg-symbols*))
-  (call-next-method))
-
-(define-layered-class standard-attribute 
-  (attribute contextl::layered-effective-slot-definition-in-layers) 
-  ((direct-slots)
-   (description 
-    :layered-accessor description-of)
-   (label 
-    :initarg :label 
-    :layered-accessor attribute-label
-    :layered t
-    :initform nil)
-   (function 
-    :initarg :function 
-    :layered-accessor attribute-function
-    :layered t)
-   (value 
-    :initarg :value
-    :layered t)))
-
-(define-layered-method attribute-value (object attribute)
- (funcall (attribute-function attribute) object))
-
-(defmethod shared-initialize :around ((attribute standard-attribute) slots &rest initargs)
-  (declare (ignore initargs))
-    (setf (attribute-function attribute) 
-	(lambda (object)
-	  (slot-value attribute 'value)))
-  (call-next-method))
-
-(defun attribute-name (attribute)
-  (closer-mop:slot-definition-name attribute))
-
-(define-layered-method slot-value-using-layer 
-;  :in-layer lisp-on-lines
-  :around (class (attribute standard-attribute) slot reader)
-  (loop for (key var) on (special-slot-values (slot-value attribute 'description) 
-						     (attribute-name attribute))
-	      :if (eq (closer-mop:slot-definition-name slot) key)
-	      :do (return-from slot-value-using-layer var))
-  (call-next-method))
-	
-(define-layered-method display-using-description 
-  ((attribute standard-attribute) display object &rest args)
- (declare (ignore args))
- (format display "~@[~A ~]~A" (attribute-label attribute) 
-	 (attribute-value object attribute)))
-
-
-
-
-
-		       
-	
-
-
+(in-package :lisp-on-lines)
+
+(define-layered-class direct-attribute-definition-class 
+ (special-layered-direct-slot-definition contextl::singleton-direct-slot-definition)
+  ((attribute-properties :accessor direct-attribute-properties
+		     :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))
+
+(define-layered-class effective-attribute-definition-class (special-layered-effective-slot-definition) 
+  ((direct-attributes :accessor attribute-direct-attributes)
+   (attribute-object :accessor attribute-object
+		     :documentation "")
+   (attribute-object-initargs :accessor attribute-object-initargs)))
+
+
+(define-layered-function attribute-value (object attribute))
+
+(define-layered-method attribute-value (object attribute)
+		       
+ (let ((fn (handler-case (attribute-function attribute)
+	     (unbound-slot () nil))))
+   (if fn 
+       (funcall fn object)
+       (%attribute-value attribute))))
+
+(defmethod attribute-description (attribute)
+  ;(break "description for ~A is (slot-value attribute 'description-name)")
+  (find-layer (slot-value attribute 'description-class))
+#+nil  (let ((name (slot-value attribute 'description-name)))
+    (when name 
+      (find-description name))))
+
+
+(define-layered-class standard-attribute ()
+		      
+  ((effective-attribute-definition :initarg effective-attribute
+				   :accessor attribute-effective-attribute-definition)
+   (description-name)
+   (description-class :initarg description-class)
+   (initfunctions :initform nil)
+   (attribute-class :accessor attribute-class 
+		    :initarg :attribute-class 
+		    :initform 'standard-attribute)
+   (name :layered-accessor attribute-name 
+	  :initarg :name)
+   (label :layered-accessor attribute-label 
+	  :initarg :label
+	  :initform nil
+	  :layered t
+	  ;:special t
+	  )
+   (function 
+    :initarg :function 
+    :layered-accessor attribute-function
+    :layered t)
+   (value :layered-accessor %attribute-value 
+	  :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+"))))
+
+(defvar *bypass-property-layered-function* nil)
+
+(define-layered-function property-layered-function (description attribute-name property-name)
+  (:method  (description attribute-name property-name)
+    ;(dprint "First Time PLFunction for ~A ~A ~A" description attribute-name property-name)
+    (ensure-layered-function 
+     (defining-description (intern (format nil "~A-~A-~A" 
+		    (description-print-name description)
+		     attribute-name
+		     property-name)))
+
+     :lambda-list '(description))))
+
+(define-layered-method (setf slot-value-using-layer)
+  :in-layer (context t)
+  (new-value class (attribute standard-attribute) property writer)
+
+  (when (or *bypass-property-layered-function*
+	    (not (slot-definition-layeredp property)))
+    (return-from slot-value-using-layer (call-next-method)))
+
+  
+  ;;FIXME: this is wrong for so many reasons.
+  (let ((layer
+	 (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))))))
+
+
+(define-layered-method slot-value-using-layer 
+  :in-layer (layer t)
+  :around (class (attribute standard-attribute) property reader)
+  ;(dprint "Getting the slot value of ~A" property)
+  
+  (when (not (slot-boundp-using-class class attribute property))
+    ;; If the slot is unbound, we search for its layered-function
+    
+    (let ((fn (property-layered-function 
+	       (attribute-description attribute)
+
+			(attribute-name attribute)
+			(closer-mop:slot-definition-name property))))
+      (dprint ".. not bound yet, have function ~A" fn)
+      (if (generic-function-methods fn)
+	  (let ((*bypass-property-layered-function* t))
+	   ; (dprint " This shit has been bound!. We gona set the _real_ slot to the generic function like.")
+	    (setf (slot-value-using-class class attribute property) fn))
+	  (progn 
+	    ;(dprint "This shit aint never been bound nowhere! checking for initfunction...")
+	    (when (slot-definition-initfunction property)
+	      ;(dprint "At least we have an initfunction. sweeet")
+	      (let ((*bypass-property-layered-function* nil))
+		(setf (slot-value attribute (slot-definition-name property)) 
+		    (funcall (slot-definition-initfunction property)))))))))
+
+  ;(dprint "If we're here, the slot should be bound")
+  
+    
+   (if (and 
+       (contextl::slot-definition-layeredp property)
+       (not *bypass-property-layered-function*))
+      (let ((fn (call-next-method)))
+	;(dprint "... using fn ~A to get value" fn)
+      (funcall fn layer  (attribute-description attribute)))
+      (call-next-method)))
+
+
+
+
+(defun slot-boundp-using-property-layered-function (class attribute property)
+  (when (not 
+	 (let ((*bypass-property-layered-function* t))
+	   (slot-boundp-using-class class attribute property)))
+    ;; If the slot is unbound, we search for its layered-function
+
+    (let ((fn (property-layered-function 
+	       (attribute-description attribute)
+
+			(attribute-name attribute)
+			(closer-mop:slot-definition-name property))))
+      (if (generic-function-methods fn)
+	  (let ((*bypass-property-layered-function* t))
+	    (setf (slot-value-using-class class attribute property) fn))
+	  NIL))))
+    
+#+nil(define-layered-method slot-boundp-using-layer  
+  :in-layer (layer t)
+  :around (class (attribute standard-attribute) property reader)
+  (if *bypass-property-layered-function*
+      (call-next-method)
+      (slot-boundp-using-property-layered-function class attribute property)))
+        
+(defun attribute-value* (attribute)
+  (attribute-value *object* attribute))
+
+(defmacro with-attributes (names description &body body)
+  `(with-slots ,names ,description ,@body))  
+
+(defun display-attribute (attribute)
+  (display-using-description attribute *display* *object*))
+
+(define-layered-method display-using-description 
+  ((attribute standard-attribute) display object &rest args)
+  (declare (ignore args))
+  (when (attribute-label attribute)
+    (format display "~A " (attribute-label attribute)))
+  (format display "~A" (attribute-value object attribute)))
+
+
+
+
+
+
+
+		       
+	
+
+