[mcclim-cvs] CVS mcclim/Apps/Listener

[ahefner]

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener
In directory clnet:/tmp/cvs-serv6324

Modified Files:
	dev-commands.lisp 
Log Message:
Fix copy-list/mapcan bug that causes Show Class Slots to sometimes 
loop infinitely.



--- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp	2008/01/31 11:06:40	1.48
+++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp	2008/02/03 12:08:51	1.49
@@ -532,7 +532,7 @@
 (defun direct-slot-definitions (class slot-name)
   (let ((cpl (reverse (clim-mop:class-precedence-list class)))
         (direct-slots nil))
-    (dolist (foo cpl)
+    (dolist (foo cpl)                   ; rewrite this
       (let ((dslots (clim-mop:class-direct-slots foo)))
         (dolist (slot dslots)
           (when (eq slot-name (clim-mop:slot-definition-name slot))
@@ -554,10 +554,10 @@
          (initargs (clim-mop:slot-definition-initargs slot))
          (initfunc (clim-mop:slot-definition-initfunction slot))
          (initform (clim-mop:slot-definition-initform slot))
-         (direct-slots (direct-slot-definitions class name))
-         (readers (mapcan #'clim-mop:slot-definition-readers direct-slots))
-         (writers (mapcan #'clim-mop:slot-definition-writers direct-slots))
-         (documentation (first (mapcan (lambda (x) (list (documentation x t))) direct-slots)))
+         (direct-slots (direct-slot-definitions class name))         
+         (readers (mapcan (lambda (x) (copy-list (clim-mop:slot-definition-readers x))) direct-slots))
+         (writers (mapcan (lambda (x) (copy-list (clim-mop:slot-definition-writers x))) direct-slots))
+         (documentation (first (remove nil (mapcar (lambda (x) (documentation x t)) direct-slots))))
          (*standard-output* stream))
 
   (macrolet ((with-ink ((var) &body body)
@@ -719,11 +719,10 @@
   (error "Sorry, not supported in your CL implementation. See the function X-SPECIALIZER-DIRECT-GENERIC-FUNCTION if you are interested in fixing this."))
 
 (defun class-funcs (class)
-  (let ((classes (remove-ignorable-classes (copy-list (clim-mop:class-precedence-list class))))
-        (gfs nil))
-    (dolist (x classes)
-      (setf gfs (append gfs (x-specializer-direct-generic-functions x))))
-    (remove-duplicates gfs)))
+  (remove-duplicates
+   (mapcan (lambda (class) 
+             (copy-list (x-specializer-direct-generic-functions class)))
+           (remove-ignorable-classes (clim-mop:class-precedence-list class)))))
 
 (defun slot-name-sortp (a b)
   (flet ((slot-name-symbol (x)
@@ -1164,8 +1163,7 @@
                                :printer (lambda (x stream)
                                           (declare (ignore stream))
                                           (pretty-pretty-pathname x *standard-output* :long-name full-names)))
-                 (goatee::reposition-stream-cursor *standard-output*)                 
-                 (vertical-gap t))
+                 (goatee::reposition-stream-cursor *standard-output*)) ; Hmm.
           (list (dolist (ent group)
                   (let ((ent (merge-pathnames ent pathname))) ;; This is for CMUCL, see above. (fixme!)
                                                               ;; And breaks some things for SBCL.. (mgr)