Massive patch to compile with modern versions of the libraries. This is only 1/2...

[clinton/lisp-on-lines.git] / src / defdisplay.lisp

diff --git a/src/defdisplay.lisp b/src/defdisplay.lisp
index 8dac5be..e86bbf6 100644 (file)
--- a/src/defdisplay.lisp
+++ b/src/defdisplay.lisp
@@ -1,7 +1,6 @@
 (in-package :lisp-on-lines)
 
 (define-layered-function display-using-description (description object component)
-;  (:argument-precedence-order )
   (:method-combination wrapping-standard)
   (:documentation
    "Render the object in component, 
@@ -11,18 +10,40 @@
     display-using-description (d o c)
     (<:as-html "default :" o))
 
-(defmethod find-layer-for-type (type)
-  type)
-
+(defun make-display-function (component object
+                             &rest properties
+                             &key type (line #'line-in)
+                             &allow-other-keys)
+  "returns a function that expects a 3 argument function as its argument
+
+The function (which is usually display-using-description) will be called with the proper environment for display all set up nice n pretty like."
+
+  (lambda (function)
+    (let* ((description (find-occurence object)))
+
+      (if description
+         (dletf (((description-type description) type)
+                 ((attributes description) (or
+                                            (attributes description)
+                                            (list-attributes description))))
+           ;; apply the default line to the description
+           (funcall-with-description
+            description
+            (funcall line object)
+            ;; apply the passed in arguments and call display-using-description
+            #'(lambda ()                
+                (funcall-with-description
+                 description
+                 properties
+                 function description object component))))
+         (error "no description for ~A" object)))))
 
 (define-layered-function display (component object &rest args)
   (:documentation
    "Displays OBJECT in COMPONENT."))
 
 (define-layered-method display ((component t) (object t)
-                               &rest properties
-                               &key type (line #'line-in)
-                               &allow-other-keys)
+                               &rest properties)
   " The default display dispatch method
 
   DISPLAY takes two required arguments, 
@@ -33,25 +54,8 @@
   that is to say the parameters that come together to create the output.
 
 The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESCRIPTION method."
-
-  (let* ((description (find-occurence object)))
-
-    (if description
-       (dletf (((description.type description) type)
-               ((attributes description) (or
-                                          (attributes description)
-                                          (list-slots object))))
-         ;; apply the default line to the description
-         (funcall-with-description
-          description
-          (funcall line object)
-          ;; apply the passed in arguments and call display-using-description
-          #'(lambda ()          
-              (funcall-with-description
-               description
-               properties
-               #'display-using-description description object component))))
-       (error "no description for ~A" object))))
+  (funcall (apply 'make-display-function component object properties)
+          'display-using-description))
 
 ;;;;; Macros
 
@@ -59,16 +63,16 @@ The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESC
 (defun funcall-with-description (description properties function &rest args)
   
   (if description
-      (dletf* (((description.type description) (or
+      (dletf* (((description-type description) (or
                                                (getf properties :type)
-                                               (description.type description)))
+                                               (description-type description)))
            
-              ((description.layers description) (append 
-                                                        (description.layers description)
+              ((description-layers description) (append 
+                                                        (description-layers description)
                                                         (getf properties :layers)))
-              ((description.properties description) (append (description.properties description) properties)))
+              ((description-properties description) (append (description-properties description) properties)))
        (funcall-with-layers 
-        (description.layers description)
+        (description-layers description)
         #'(lambda ()
             (contextl::funcall-with-special-initargs
              (list (cons description properties))
@@ -76,8 +80,6 @@ The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESC
                  (apply function args))))))
       (apply function args)))
 
-
-
 (defmacro with-description ((description &rest properties) &body body)
   `(funcall-with-description ,description (if ',(cdr properties)
                                               (list ,@properties)
@@ -116,7 +118,8 @@ The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESC
     (declare (ignorable self))
     (flet ((display* (thing &rest args)
             (apply #'display ,component thing args))
-          (display-attribute (attribute obj &optional props)
+          (display-attribute (attribute obj &rest
+                                        props)
             (if props
                 (funcall-with-description
                  attribute props
@@ -164,7 +167,7 @@ The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESC
                      component)
                     (t
                      (setf c component)
-                     `(,c component))))
+                     `(,c t))))
                  (with-component (,c)  
                         ,@(cdr tail)))))))))