From: drewc <drewc@tech.coop>
Date: Tue, 30 May 2006 01:16:58 +0000 (-0700)
Subject: fixed up display mechanism
X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/commitdiff_plain/f9b119564f7d0c0d352fa1b13be5ef5b5fb8b872

fixed up display mechanism

darcs-hash:20060530011658-39164-3d2220d2e247f16250296bb7f21303835aa8a8db.gz
---

diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd
index 2e4eb26..99b9a69 100644
--- a/lisp-on-lines.asd
+++ b/lisp-on-lines.asd
@@ -19,7 +19,6 @@
 				     (:file "properties")				       
 				     (:file "mewa")
 				     (:file "validation")
-			       
 				     (:file "lisp-on-lines")  
 				     (:file "defdisplay")
 				     (:file "standard-display")
diff --git a/src/defdisplay.lisp b/src/defdisplay.lisp
index ae74b8c..8dac5be 100644
--- a/src/defdisplay.lisp
+++ b/src/defdisplay.lisp
@@ -2,6 +2,7 @@
 
 (define-layered-function display-using-description (description object component)
 ;  (:argument-precedence-order )
+  (:method-combination wrapping-standard)
   (:documentation
    "Render the object in component, 
     using DESCRIPTION, which is an occurence, an attribute, or something else entirely."))
@@ -33,13 +34,10 @@
 
 The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESCRIPTION method."
 
-  (let* ((occurence (find-occurence object))
-	 (description (or (find-display-attribute
-			   occurence
-			   (setf type (or type (description.type occurence))))
-			  occurence)))
+  (let* ((description (find-occurence object)))
+
     (if description
-	(dletf (((description.type occurence) type)
+	(dletf (((description.type description) type)
 		((attributes description) (or
 					   (attributes description)
 					   (list-slots object))))
@@ -87,18 +85,31 @@ The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESC
     #'(lambda ()
 	,@body)))
 
-(defmacro do-attributes ((var description &optional (attributes `(attributes ,description))) &body body)
+(define-layered-function find-do-attributes (desc))
+
+(define-layered-method find-do-attributes ((description description))
+
+  (loop
+     :for att
+     :in (attributes description)
+     :collect (let ((default (find (car (ensure-list att))
+				   (default-attributes description)
+				   :key #'car)))
+		(or default att))))
+
+(defmacro do-attributes ((var description &optional (attributes `(find-do-attributes ,description))) &body body)
   (with-unique-names (att properties type)
     `(dolist* (,att  ,attributes)
-      (let* ((,att (ensure-list ,att))
-                (,properties (rest ,att))
-                (,type (getf ,properties :type))
-                (,var (let ((a (find-attribute ,description (first ,att))))
-			(if ,type
-			    (apply #'make-attribute :name (first ,att) :type ,type ,properties)
-			    (if a a (make-attribute :name (first ,att) :slot-name (first ,att)))))))
-	(funcall-with-description ,var ,properties
-	  #'(lambda () ,@body))))))
+       (let* ((,att (ensure-list ,att))
+	      (,properties (rest ,att))
+	      (,type (getf ,properties :type))
+	      (,var (let ((a (find-attribute ,description (first ,att))))
+		      (if ,type
+			  (apply #'make-attribute :name (first ,att) :type ,type ,properties)
+			  (if a a (make-attribute :name (first ,att) :slot-name (first ,att)))))))
+	 (funcall-with-description ,var ,properties
+				   #'(lambda ()
+				       ,@body))))))
 
 (defmacro with-component ((component) &body body)
   `(let ((self ,component))
diff --git a/src/lines.lisp b/src/lines.lisp
index 8b26923..55763dd 100644
--- a/src/lines.lisp
+++ b/src/lines.lisp
@@ -1,12 +1,12 @@
 (in-package :lisp-on-lines)
 
+(define-layered-function line-in (name)
+  (:method-combination append)
+  (:method append (thing)
+    '()))
+
 (defmacro defline (name (specializer &rest layers-and-combination-keywords) &body docstring-and-body)
   `(progn
-    ,(eval-when
-      (:compile-toplevel :load-toplevel :execute)
-      (unless (fboundp (contextl::get-layered-function-definer-name name)) 
-	`(define-layered-function ,name (arg)
-	  (:method-combination append))))
     (define-layered-method
 	,name
       ,@layers-and-combination-keywords
@@ -21,16 +21,4 @@
 	
 	,(or (cdr docstring-and-body) (car docstring-and-body)))))
 
-(defun line-out (component object &rest args &key (line #'line-in) &allow-other-keys )
-  (apply #'display component object (append args (funcall line object))))
-
-(defline line-in (thing)
-  '())
-
-
-(defmacro call-line (from line &rest args)
-  (with-unique-names (lines object)
-    `(multiple-value-bind (,lines ,object)
-	 (funcall ,line)
-       (call-display-with-context ,from ,object nil (append ,args ,lines)))))