Printing CLOS class graphs
Thursday, August 26, 2004
I almost never use the commercial IDE's that come with Franz's ACL or Xanalys' LispWorks, instead preferring to use Emacs with SLIME when I program with either commercial or open source CL's. However, the commercial IDE's do provide some useful utilities (such as class graphers, profilers, steppers, etc). For example, when working with CLOS classes, it is nice to be able to see a "graphical" representation of the class hierarchy. However, you don't need the GUI IDE's to do this - James Anderson showed how to print out class graphs on c.l.l. a while back. His code is at the end of this posting; however, here's a sample repl session that illustrates how his code could be used:
CL-USER> (defclass person () ()) #James' print-class-tree code is pretty elegant - here it is (with one minor modification that I made to it so that it works with both ACL and LW):CL-USER> (defclass programmer (person) ()) # CL-USER> (defclass hacker (programmer) ()) # CL-USER> (defclass lisp-hacker (hacker) ()) # CL-USER> (defclass java-hacker (hacker) ()) # CL-USER> (print-class-tree 'person :metaclass (type-of (find-class 'person)))
PERSON PROGRAMMER HACKER JAVA-HACKER LISP-HACKER NIL CL-USER> (print-class-tree 't :metaclass (type-of (find-class t)))
T STREAM SEQUENCE VECTOR STRING SIMPLE-STRING SIMPLE-BASE-STRING SIMPLE-VECTOR BIT-VECTOR SIMPLE-BIT-VECTOR LIST NULL CONS NUMBER REAL RATIONAL RATIO INTEGER FIXNUM BIGNUM FLOAT DOUBLE-FLOAT SINGLE-FLOAT COMPLEX FUNCTION CHARACTER ARRAY VECTOR ... SIMPLE-ARRAY SIMPLE-VECTOR SIMPLE-STRING ... SIMPLE-BIT-VECTOR SYMBOL NULL NIL CL-USER>
(defgeneric print-class-tree (class &key package stream metaclass) (:method ((class-name symbol) &key (stream *standard-output*) (package (symbol-package class-name)) (metaclass t) &aux (class (find-class class-name nil)) (*print-class-list* nil) (*print-class-level* 0)) (declare (special *print-class-list* *print-class-level*)) (cond (class (print-class-tree class :stream stream :package package :metaclass metaclass)) (t (terpri stream) (dotimes (i *print-class-level*) (write-char #\Space stream)) (format stream "not found: ~s" class)))) (:method ((class class) &key (package (symbol-package (class-name class))) (stream *standard-output*) (metaclass t) &aux (name (class-name class))) (declare (special *print-class-list* *print-class-level*)) (terpri stream) (dotimes (i *print-class-level*) (write-char #\Space stream)) (prin1 name) (let ((subclasses (remove-if-not #'(lambda (class) (and (or (eq package t) (eq (symbol-package (class-name class)) package)) (typep class metaclass))) #+cmu (mop:class-direct-subclasses class) #+sbcl (sb-mop:class-direct-subclasses class) #+lispworks (clos:class-direct-subclasses class) #+allegro (aclmop:class-direct-subclasses class) #-(or cmu sbcl lispworks allegro) (class-direct-subclasses class)))) (when subclasses (cond ((find class *print-class-list*) (write-string " ..." stream) ) (t (push class *print-class-list*) (let ((*print-class-level* (+ *print-class-level* 1))) (declare (special *print-class-level*)) (dolist (subclass subclasses) (print-class-tree subclass :stream stream :package package)))))))))
