[elephant-cvs] CVS elephant/src

[rread]

Update of /project/elephant/cvsroot/elephant/src
In directory common-lisp:/tmp/cvs-serv22545

Added Files:
	openmcl-mop-patches.lisp 
Log Message:
Curses!  Finally adding.




--- /project/elephant/cvsroot/elephant/src/openmcl-mop-patches.lisp	2006/01/27 01:49:36	NONE
+++ /project/elephant/cvsroot/elephant/src/openmcl-mop-patches.lisp	2006/01/27 01:49:36	1.1
(in-package :CCL)

(let ((*warn-if-redefine-kernel* nil))
  (defun extract-instance-and-class-slotds (slotds)
    (collect ((instance-slots)
	      (shared-slots))
	     (dolist (s slotds (values (instance-slots) (shared-slots)))
	       (let ((alloc (%slot-definition-allocation s)))
		 (if (or (eq alloc :class)
			 (eq alloc :database))
		     (shared-slots s)
		   (instance-slots s)))))))

(defun extract-persistent-effective-slotds (class)
  (extract-slotds-with-allocation :database (%class-slots class)))

(in-package :inspector)

(defun standard-object-line-n (i n)
  (let* ((instance (inspector-object i))
         (class (class-of instance))
         (wrapper (ccl::standard-object-p instance))
	 (instance-start 2))
    (if (< n instance-start)
      (if (eql n 0)
	(values class "Class: " :normal)
	(values wrapper "Wrapper: " :static))
      (let* ((slotds (ccl::extract-instance-effective-slotds class))
             (instance-count (length slotds))
             (shared-start (+ instance-start instance-count
                              (if (eql 0 instance-count) 0 1))))
        (if (< n shared-start)
          (if (eql n instance-start)
            (values nil "Instance slots" :comment)
            (let ((slot-name (slot-definition-name
                              (elt slotds (- n instance-start 1)))))
              (values (slot-value-or-unbound instance slot-name)
                      slot-name
                      :colon)))
	  (let* ((slotds (ccl::extract-class-effective-slotds class))
                 (shared-count (length slotds))
                 (shared-end (+ shared-start shared-count
                                (if (eql shared-count 0) 0 1))))
            (if (< n shared-end)
              (if (eql n shared-start)
                (values nil "Class slots" :comment)
                (let ((slot-name (slot-definition-name 
                                  (elt slotds (- n shared-start 1)))))
                  (values (slot-value-or-unbound instance slot-name)
                           slot-name
                           :colon)))
	      (let* ((slotds (ccl::extract-persistent-effective-slotds class))
		     (persistent-count (length slotds))
		     (persistent-end (+ shared-end persistent-count
				       (if (eql persistent-count 0) 0 1))))
		(if (< n persistent-end)
		    (if (eql n shared-end)
			(values nil "Persistent slots" :comment)
		      (let ((slot-name (slot-definition-name 
					(elt slotds (- n shared-start 1)))))
			(values (slot-value-or-unbound instance slot-name)
				slot-name
				:colon)))
		  (if (and (eql 0 instance-count) (eql 0 shared-count) (eql n shared-end))
		      (values nil "No Slots" :comment)
		    (line-n-out-of-range i n)))))))))))