diff --git a/contrib/psgraph/psgraph.catalog b/contrib/psgraph/psgraph.catalog
index 2703a4a8757bbb9b3dc3d91bfadab1e25c3e40d4..4406e9e56c9bdac670ba2beb3b2b33c7795c7228 100644
--- a/contrib/psgraph/psgraph.catalog
+++ b/contrib/psgraph/psgraph.catalog
@@ -6,9 +6,13 @@ Description:
 Postscript commands that display a directed acyclic graph.
 
 Author:
-   Joseph Bates.  Skef put the whole thing in the PSGRPAPH package and added
-functionality which allows the user to specify EQ, EQUAL, or EQUALP as the
-node equivalence function.  Bill made all exported symbols have stars on them.
+   Joseph Bates.  Skef put the whole thing in the PSGRPAPH package and
+added functionality which allows the user to specify EQ, EQUAL, or
+EQUALP as the node equivalence function.  Bill made all exported
+symbols have stars on them.  Douglas Crosher fixed the hash table
+usage, added the shrink :width option and the same-height optional
+argument, and cleaned up the source reducing special variables usage
+and adding declarations for CMUCL.
 
 Address:
    Carnegie-Mellon University
@@ -22,12 +26,10 @@ Copyright Status:
    Public Domain.
 
 Files:
-   psgraph.lisp, psgraph.fasl, psgraph.doc, psgraph.log, psgraph.catalog
+   psgraph.lisp, psgraph.doc, psgraph.catalog
 
 How to Get:
-   The following unix command will copy the pertinent files into directory
-<spec>.
-   cp /afs/cs.cmu.edu/project/clisp/library/psgraph/* <spec>
+   ftp://ftp2.cons.org/pub/languages/lisp/cmucl/src/contrib/psgraph/*
 
 Portability:
    Should run in any legal Common Lisp.  Requires Postscript for printing.
@@ -41,21 +43,4 @@ run through the output escaping any PS control characters.  For example, if
 node labels contain parentheses, your output PS file will not print.
 
 Examples:
-   Skef Wholey submitted this as a reasonable example:
-
-;;; I use this in my compiler so I can look at code trees without
-;;; crawling around them in the inspector.  The postsript previewer
-;;; groks the generated ps file, which is bitchin' marvy.
-
-   (defun code-graph-to-file (s file &optional shrink insert)
-     (let ((psgraph:*fontname* "Times-Roman")
-	   (psgraph:*fontsize* 8)
-	   (psgraph:*second-fontname* "Times-BoldItalic")
-	   (psgraph:*second-fontsize* 6)
-	   (psgraph:*boxgray* "0")
-	   (psgraph:*edgegray* "0")
-	   (psgraph:*extra-x-spacing* 30))
-       (with-open-file (*standard-output* file
-					  :direction :output
-					  :if-exists :supersede)
-	 (psgraph:psgraph s #'psg-children #'psg-info shrink insert #'eq))))
+   See psgraph.doc
diff --git a/contrib/psgraph/psgraph.doc b/contrib/psgraph/psgraph.doc
index e7b17692d06d8a4714eb3ee0a3268ef9b1cff85d..0f8a43e79f5f8410f9f310bb2df59a3505b093d8 100644
--- a/contrib/psgraph/psgraph.doc
+++ b/contrib/psgraph/psgraph.doc
@@ -1,57 +1,61 @@
 Here is a brief summary of how to use the PSgrapher.
 
 The PSgrapher is a set of Lisp routines that can be called to produce
-Postscript commands to display a directed acyclic graph.  It uses the same
-basic algorithm as the ISI Grapher.  It is slower than the ISI grapher, but
-produces much prettier output than using Xdump to copy an ISI Grapher screen
-image to a Postscript printer.  It also allows arbitrary information to be
-displayed with a node, and can print as many output pages as are necessary to
-accomodate large graphs (subject to Postscript printer limits, typically one or
-two thousand nodes).
-
-The PSgrapher is small enough and easy enough to use to be included in other
-systems without pain.  It is also free and not copyrighted.
-
-Copy the file /afs/cs/project/clisp/library/psgraph/psgraph.lisp to your
-directory.  It is written in Common Lisp, and has been tested on CMU Common
-Lisp on RTs and Lucid on SUNs.  All interfaces described below are exported
-from the "PSGRAPH" package.
-
-There are several useful global variables that can be modified and one function
-to be called.  The variables affect the style of the printed image, the
-function walks a graph and produces output.
-
-A graph is defined by a root node and a function for getting children of a
-node.  Nodes are named by Lisp objects, and these names are checked using a
-user-supplied test function (defaults to EQUAL) for purposes of walking the
-graph and topologically sorting it.  Typically one uses atoms to name nodes,
-for example in graphing an inheritence net one could use the class names as
-node names.
+Postscript commands to display a directed acyclic graph.  It uses the
+same basic algorithm as the ISI Grapher.  It is slower than the ISI
+grapher, but produces much prettier output than using Xdump to copy an
+ISI Grapher screen image to a Postscript printer.  It also allows
+arbitrary information to be displayed with a node, and can print as
+many output pages as are necessary to accomodate large graphs (subject
+to Postscript printer limits, typically one or two thousand nodes).
+
+The PSgrapher is small enough and easy enough to use to be included in
+other systems without pain.  It is also free and not copyrighted.
+
+It is written in Common Lisp, and has been tested on CMU Common Lisp 18
+All interfaces described below are exported from the "PSGRAPH" package.
+
+There are several useful global variables that can be modified and one
+function to be called.  The variables affect the style of the printed
+image, the function walks a graph and produces output.
+
+A graph is defined by a root node and a function for getting children
+of a node.  Nodes are named by Lisp objects, and these names are
+checked using a user-supplied test function (defaults to EQUAL) for
+purposes of walking the graph and topologically sorting it.  Typically
+one uses atoms to name nodes, for example in graphing an inheritence
+net one could use the class names as node names.
 
 To produce a graph call the function:
-    (psgraph:psgraph root-node-name
+    (psgraph:psgraph output-stream
+		     root-node-name
 		     child-function
 		     info-function
 		     &optional (shrink nil)
 		     &optional (insert nil)
-		     &optional (test #'equal))
+		     &optional (test #'equal)
+		     &optional (same-height nil))
 
-Root-node-name is a Lisp object naming the root of the graph (there must be
-exactly one root).
+Output-stream is the stream that the postscript is output to.
+
+Root-node-name is a Lisp object naming the root of the graph (there
+must be exactly one root).
 
 Child-function takes a node name and returns a list of node names.
 
-Info-function takes a node name and returns a list of strings.  Each string
-shows up as one line in the printed form of the node, with the first string
-displayed in one font (determined by variables *fontname*, *fontsize*) and the
-others in another font (determined by variables *second-fontname*,
-*second-fontsize*).  Typically the first string is just the name of the node,
-eg, (string node-name).
+Info-function takes a node name and returns a list of strings.  Each
+string shows up as one line in the printed form of the node, with the
+first string displayed in one font (determined by variables
+*fontname*, *fontsize*) and the others in another font (determined by
+variables *second-fontname*, *second-fontsize*).  Typically the first
+string is just the name of the node, eg, (string node-name).
 
-Shrink is a boolean.  It defaults to nil, and in this case the graph
-prints on as many pages as are needed to show the whole thing.  If shrink
-is t then the entire graph is squashed appropriately to fit on one page
-of output.
+Shrink may be NIL, T of :WIDTH.  It defaults to nil, and in this case
+the graph prints on as many pages as are needed to show the whole
+thing.  If shrink is T then the entire graph is squashed appropriately
+to fit on one page of output. If shrink is :width then the width of
+the graph is shrunk appropriately to fit across one page of output but
+print on as many pages as necessary to show the full height of the graph.
 
 Insert is a boolean.  It defaults to nil, and in this case the generated
 Postscript file contains commands to print the output.  If insert is t
@@ -61,14 +65,22 @@ in Scribe files, for example, and Scribe can decide when to print the page.
 
 Test is a function that return whether two nodes are the same.
 
-After loading psgraph, one can play with the various global variables, all of
-which have string values (except for the two font size variables).  *fontname*,
-*fontsize*, *second-fontname*, *second-fontsize* are as described above.  They
-default to "Helvetica" in 10 point and "Helvetica-Oblique" in 8 point,
-respectively.  *boxgray* and *boxkind* determine how the boxes around nodes
-look.  *boxkind* is either "fill" or "stroke", for solid or outline boxes, and
-*boxgray* is "0" for solid black, "1" for solid white, or in between.  These
-default to ".2" and "stroke".
+Same-height is a boolean.  It defaults to Nil, and in this case the
+height of the node no large that necessary. If same-height is T the
+same height is used for all the nodes which can improve the balance of
+tree graphs.
+
+-=-
+
+After loading psgraph, one can play with the various global variables,
+all of which have string values (except for the two font size
+variables).  *fontname*, *fontsize*, *second-fontname*,
+*second-fontsize* are as described above.  They default to "Helvetica"
+in 10 point and "Helvetica-Oblique" in 8 point, respectively.
+*boxgray* and *boxkind* determine how the boxes around nodes look.
+*boxkind* is either "fill" or "stroke", for solid or outline boxes,
+and *boxgray* is "0" for solid black, "1" for solid white, or in
+between.  These default to ".2" and "stroke".
 
 Other variables:
    *max-psnodes*
@@ -85,21 +97,16 @@ Other variables:
    *chunksize*
 
 
-Psgraph sends its output to *standard-output*, so typically it is called
-from within (with-open-file  ....).  For example, one might use it like this:
+Psgraph sends its output to the output-stream, so typically it is
+called from within (with-open-file ....).  For example, one might use
+it like this:
 
-   (load "psgraph.fasl")
+   (load "psgraph")
    (setf psgraph:*boxkind* "fill")
    (setf psgraph:*boxgray* ".8")
    (setf psgraph:*fontsize* 8)
    (setf psgraph:*second-fontsize* 6)
 
-   (defun graph (&optional (shrink t))
-     (with-open-file (*standard-output* "g.ps"
-		      :direction :output
-		      :if-exists :supersede)
-	  (psgraph:psgraph 'A #'children #'info shrink nil #'eq)))
-
    (defun children (x)
       (cond ((eq x 'A) '(B C D))
 	    ((member x '(B C D)) '(E F G))
@@ -109,6 +116,12 @@ from within (with-open-file  ....).  For example, one might use it like this:
    (defun info (x)
       (list (string x)))
 
+   (defun graph (&optional (shrink t))
+     (with-open-file (output-stream "g.ps"
+		      :direction :output
+		      :if-exists :supersede)
+       (psgraph:psgraph output-stream 'A #'children #'info shrink nil #'eq)))
+
 
 Another example:
    (defun code-graph-to-file (s file &optional shrink insert)
@@ -119,7 +132,7 @@ Another example:
 	   (psgraph:*boxgray* "0")
 	   (psgraph:*edgegray* "0")
 	   (psgraph:*extra-x-spacing* 30))
-       (with-open-file (*standard-output* file
-					  :direction :output
-					  :if-exists :supersede)
+       (with-open-file (output-stream file
+				      :direction :output
+				      :if-exists :supersede)
 	 (psgraph:psgraph s #'psg-children #'psg-info shrink insert #'eq))))
diff --git a/contrib/psgraph/psgraph.lisp b/contrib/psgraph/psgraph.lisp
index 09e37bbcf1871f09e96468e385606260f77bc3e4..057464aadfae1b8977ab90e699ebbbd4fbe83efd 100644
--- a/contrib/psgraph/psgraph.lisp
+++ b/contrib/psgraph/psgraph.lisp
@@ -1,33 +1,61 @@
-;;; -*- Mode: Lisp; Package: PSGRAPH; Log: psgraph.log -*-
+;;; -*- Mode: Lisp; Package: PSGRAPH -*-
 ;;;
-;;; PostScript DAG Grapher  -- Joseph Bates, CMU CSD, March 1988
+;;; ****************************************************************
+;;; PostScript DAG Grapher *****************************************
+;;; ****************************************************************
+;;; Written by Joseph Bates, CMU CSD, March 1988. jbates+@cs.cmu.edu
 ;;;
-;;; See psgraph.log for other modifiers.
+;;; The PSGrapher is a set of Lisp routines that can be called to produce
+;;; PostScript commands that display a directed acyclic graph.
 ;;;
-(in-package "PSGRAPH")
-
-(export '(*max-psnodes* *extra-x-spacing* *extra-y-spacing* *fontname*
-	  *fontsize* *second-fontname* *second-fontsize* *boxgray* *boxkind*
-	  *edgewidth* *edgegray* *edgecap* *textgray* *pageheight* *pagewidth*
-	  *boxradius* *boxedge* *chunksize*
-
-	  psgraph))
+;;; Modifications History:
+;;;
+;;; AUG 97    dtc     Added declarations to help the CMUCL compiler.
+;;;		      Only the *psnode-index* hash should use the user
+;;;		      supplied hash test, all the others are internal.
+;;;		      Make the output stream a required argument rather
+;;;		      than sending output to *standard-output*.
+;;;		      Add a shrink :width optional to scale the graph to
+;;;		      fit across one page.
+;;;		      Add optional same-height argument to allocate the same
+;;;		      height for each node - can give nicer graphs.
+;;;		      Misc. style changes: less use of special variables, etc.
+;;; JAN 92    mkant   Modified to be package compatible with CLtL2 lisps.
+;;; JULY 90   mkant   Fixed shrink mode so that it scales x and y
+;;;                   axes uniformly (e.g., aspect ratio = 1).
+;;; MAY 90    Chiles  Made exported specials have stars.
+;;; APR 90    Skef    Now lives in PSGRAPH package (instead of USER,
+;;;                   or *package*...) with user-tweakable stuff exported.
+;;;                   Node equivalence function can now be specified as
+;;;                   EQ, EQUAL, or EQUALP.
+;;; DEC 88    Bates   Modified to include optional insert parameter to psgraph.
+;;; MAR 88    Bates   File created.
+;;;
+(eval-when (compile load eval)
+  (defpackage "PSGRAPH"
+    (:use "COMMON-LISP")
+    (:export "*EXTRA-X-SPACING*" "*EXTRA-Y-SPACING*" "*FONTNAME*"
+	     "*FONTSIZE*" "*SECOND-FONTNAME*" "*SECOND-FONTSIZE*"
+	     "*BOXGRAY*" "*BOXKIND*" "*EDGEWIDTH*" "*EDGEGRAY*"
+	     "*EDGECAP*"  "*TEXTGRAY*" "*PAGEHEIGHT*" "*PAGEWIDTH*"
+	     "*BOXRADIUS*" "*BOXEDGE*" "*CHUNKSIZE*" "PSGRAPH")))
 
+(in-package "PSGRAPH")
 
 (defstruct psnode
   name
-  info
-  children
-  parents
-  appears-in-top-sort
-  children-appear-in-top-sort
-  yvalue
-  height
-)
-
-(defvar *max-psnodes* 5000)
+  (info '() :type list)
+  (children '() :type list)
+  (parents '() :type list)
+  (appears-in-top-sort nil :type (member nil t))
+  (children-appear-in-top-sort nil :type (member nil t))
+  (yvalue 0 :type fixnum)
+  (height 0 :type fixnum))
+
+(declaim (fixnum *extra-x-spacing* *extra-y-spacing*))
 (defvar *extra-x-spacing* 20)
 (defvar *extra-y-spacing* 6)
+(declaim (fixnum *fontsize* *second-fontsize*))
 (defvar *fontname* "Helvetica")
 (defvar *fontsize* 10)
 (defvar *second-fontname* "Helvetica-Oblique")
@@ -38,469 +66,504 @@
 (defvar *edgegray* ".2")     ;; dark, but not solid black, lines
 (defvar *edgecap* "1")       ;; round the line caps
 (defvar *textgray* "0")      ;; solid black text
+(declaim (fixnum *pageheight* *pagewidth*))
 (defvar *pageheight* 720)
 (defvar *pagewidth* (+ (* 7 72) 36))
+(declaim (fixnum *boxradius* *boxedge*))
 (defvar *boxradius* (floor *fontsize* 2))
 (defvar *boxedge* (floor *fontsize* 4))
+(declaim (fixnum *chunksize*))
 (defvar *chunksize* 400)
 
-(defvar num-psnodes)
-(defvar narray)
-(defvar psnode-index)
-(defvar child-function)
-(defvar info-function)
-(defvar top-sort)
-(defvar maximum-y)
-(defvar minimum-y)
-(defvar rows)
-(defvar y-offset)
-(defvar psnodes-at-y)
-(defvar ancestor-cache)
-
-(defun psgraph (root childf infof &optional (shrink nil) (insert nil) (test #'equal))
+(declaim (fixnum *num-psnodes*))
+(defvar *num-psnodes* 0)
+(declaim (type (simple-array t (*)) *narray*))
+(defvar *narray*)
+(defvar *psnode-index*)
+(defvar *top-sort*)
+(defvar *ancestor-cache*)
+
+(defun psgraph (stream root childf infof
+		&optional (shrink nil) (insert nil) (test #'equal)
+		(same-height nil))
+  (declare (stream stream)
+	   (function childf infof)
+	   (type (or symbol function) test))
   (unless (member test (list 'eq 'equal 'equalp #'eq #'equal #'equalp))
     (error "Test must be a function suitable to hand to Make-Hash-Table."))
-  (when insert (setf shrink t))
-  (setq narray (make-array *max-psnodes*))
-  (setq num-psnodes 0)
-  (setq psnode-index (make-hash-table :test test
-				      :size 500
-				      :rehash-size 2.0))
-  (setq child-function childf)
-  (setq info-function infof)
-  (setq ancestor-cache (make-hash-table :test test
-					:size 1000
-					:rehash-size 2.0))
-
-  ;;; walk the graph computing node info
-  (walk-graph root)
-  (dotimes (index num-psnodes)
-    (setf (psnode-parents (aref narray index))
-	  (nreverse (psnode-parents (aref narray index))))
-    (setf (psnode-children (aref narray index))
-	  (nreverse (psnode-children (aref narray index)))))
-
-  ;;; topological sort the graph
-  (setq top-sort nil)
-  (top-sort-node 0)
-  (setq top-sort (nreverse top-sort))
-
-  ;;; declare this as a PostScript file
-  (format t "%!PS-Adobe-1.0~%")
-
-  ;;; this is required for the Apple LaserWriter (it likes to know the page
-  ;;; ordering so that it can print pages upside down).  It is best not to
-  ;;; confuse the LaserWriter when inserting things into a other documents.
-  (when (not insert)
-    (format t "%%Page: ? ?~%"))
-
-  ;;; define global functions
-  (dolist (line '(
-
-     "/max {2 copy lt {exch} if pop} def"
-
-     "/min {2 copy gt {exch} if pop} def"
-
-     "/inch {72 mul} def"
-
-     "/drawbox"
-     " {/height exch def"
-     "  /width exch def"
-     "  /y exch def"
-     "  /x exch def"
-     "  gsave newpath"
-     "  x y boxradius add moveto"
-     "  x y height add x width add y height add boxradius arcto pop pop pop pop"
-     "  x width add y height add x width add y boxradius arcto pop pop pop pop"
-     "  x width add y x y boxradius arcto pop pop pop pop"
-     "  x y x y height add boxradius arcto pop pop pop pop"
-     "  boxgray setgray boxkind grestore"
-     " } def"
-
-     "/printposter"
-     " {/rows exch def"
-     "  /columns exch def"
-     "  /bigpictureproc exch def"
-     "  newpath"
-     "    leftmargin botmargin moveto"
-     "    0 pageheight rlineto"
-     "    pagewidth 0 rlineto"
-     "    0 pageheight neg rlineto"
-     "  closepath clip"
-     "  leftmargin botmargin translate"
-     "  0 1 rows 1 sub"
-     "   {/rowcount exch def"
-     "    0 1 columns 1 sub"
-     "     {/colcount exch def"
-     "      gsave"
-     "       pagewidth colcount mul neg"
-     "       pageheight rowcount mul neg"
-     "       translate"
-     "       bigpictureproc"
-     "       gsave showpage grestore"
-     "      grestore"
-     "     } for"
-     "   } for"
-     " } def"
-
-   )) (format t "~A~%" line))
-
-  ;;; declare arrays
-  (format t "/xarray ~D array def~%" num-psnodes)
-  (format t "/widtharray ~D array def~%" num-psnodes)
-
-  ;;; define global settings
-  (format t "/leftmargin 36 def~%")
-  (format t "/botmargin 36 def~%")
-  (format t "/pagewidth ~D def~%" *pagewidth*)
-  (format t "/pageheight ~D def~%" *pageheight*)
-  (format t "/boxradius ~D def ~%" *boxradius*)
-  (format t "/boxedge ~D def ~%" *boxedge*)
-  (format t "/boxgray ~A def ~%" *boxgray*)
-  (format t "/boxkind {~A} def~%" *boxkind*)
-
-  ;;; compute width and height of each node
-  (format t "/~A findfont ~D scalefont setfont~%" *fontname* *fontsize*)
-  (dotimes (index num-psnodes)
-    (format t "widtharray ~D (~A) stringwidth pop put~%"
-	    index
-	    (car (psnode-info (aref narray index)))))
-  (format t "/~A findfont ~D scalefont setfont~%"
-	  *second-fontname* *second-fontsize*)
-  (dotimes (index num-psnodes)
-    (format t "widtharray ~D get~%" index)
-    (dolist (info (cdr (psnode-info (aref narray index))))
-       (format t "(~A) stringwidth pop max~%" info))
-    (format t "~D add widtharray exch ~D exch put~%"
- 	    (* 2 *boxedge*)
-	    index))
-  (dotimes (index num-psnodes)
-    (setf (psnode-height (aref narray index))
-	  (+ (* 2 *boxedge*)
-	     *extra-y-spacing*
-	     *fontsize*
-	     (* (- (length (psnode-info (aref narray index))) 1)
-		*second-fontsize*))))
-
-  ;;; compute x location of each node
-  (format t "xarray 0 0 put~%")
-  (dolist (index (cdr top-sort))
-    (let ((parents (psnode-parents (aref narray index))))
-      (format t "xarray ~D get widtharray ~D get add~%"
-	      (car parents) (car parents))
-      (dolist (parent (cdr parents))
-	  (format t "xarray ~D get widtharray ~D get add max~%"
+  (let ((maximum-y 0)
+	(minimum-y 0)
+	psnodes-at-y
+	(*narray* (make-array 5000 :element-type 'psnode))
+	(*num-psnodes* 0)
+	(*psnode-index*
+	 (make-hash-table :test test :size 500 :rehash-size 2.0))
+	(*ancestor-cache*
+	 (make-hash-table :test #'equal :size 1000 :rehash-size 2.0))
+	(*top-sort* nil))
+    (declare (fixnum maximum-y minimum-y))
+    
+    (when insert (setf shrink t))
+    
+    ;; walk the graph computing node info
+    (walk-graph root childf infof)
+    (dotimes (index *num-psnodes*)
+      (declare (fixnum index))
+      (let ((psnode (aref *narray* index)))
+	(setf (psnode-parents psnode) (nreverse (psnode-parents psnode)))
+	(setf (psnode-children psnode) (nreverse (psnode-children psnode)))))
+  
+    ;; topological sort the graph
+    (top-sort-node 0)
+    (setq *top-sort* (nreverse *top-sort*))
+
+    ;; declare this as a PostScript file
+    (format stream "%!PS-Adobe-1.0~%")
+
+    ;; this is required for the Apple LaserWriter (it likes to know
+    ;; the page ordering so that it can print pages upside down).  It
+    ;; is best not to confuse the LaserWriter when inserting things
+    ;; into a other documents.
+    (when (not insert)
+      (format stream "%%Page: ? ?~%"))
+
+    ;; define global functions
+    (format stream
+     "/max {2 copy lt {exch} if pop} def~@
+      /min {2 copy gt {exch} if pop} def~@
+      /inch {72 mul} def~@
+      /drawbox~@
+       {/height exch def~@
+        /width exch def~@
+        /y exch def~@
+        /x exch def~@
+        gsave newpath~@
+        x y boxradius add moveto~@
+        x y height add x width add y height add boxradius arcto pop pop pop pop~@
+        x width add y height add x width add y boxradius arcto pop pop pop pop~@
+        x width add y x y boxradius arcto pop pop pop pop~@
+        x y x y height add boxradius arcto pop pop pop pop~@
+        boxgray setgray boxkind grestore~@
+       } def~%")
+    
+    ;; declare arrays
+    (format stream "/xarray ~D array def~%" *num-psnodes*)
+    (format stream "/widtharray ~D array def~%" *num-psnodes*)
+
+    ;; define global settings
+    (format stream "/leftmargin 36 def~@
+                    /botmargin 36 def~%")
+    (format stream "/pagewidth ~D def~%" *pagewidth*)
+    (format stream "/pageheight ~D def~%" *pageheight*)
+    (format stream "/boxradius ~D def ~%" *boxradius*)
+    (format stream "/boxedge ~D def ~%" *boxedge*)
+    (format stream "/boxgray ~A def ~%" *boxgray*)
+    (format stream "/boxkind {~A} def~%" *boxkind*)
+
+    ;; compute width of each node
+    (format stream "/~A findfont ~D scalefont setfont~%" *fontname* *fontsize*)
+    (dotimes (index *num-psnodes*)
+      (declare (fixnum index))
+      (format stream "widtharray ~D (~A) stringwidth pop put~%"
+	      index (car (psnode-info (aref *narray* index)))))
+    (format stream "/~A findfont ~D scalefont setfont~%"
+	    *second-fontname* *second-fontsize*)
+    (dotimes (index *num-psnodes*)
+      (declare (fixnum index))
+      (format stream "widtharray ~D get~%" index)
+      (dolist (info (cdr (psnode-info (aref *narray* index))))
+	(format stream "(~A) stringwidth pop max~%" info))
+      (format stream "~D add widtharray exch ~D exch put~%"
+	      (* 2 *boxedge*) index))
+    ;; compute x location of each node
+    (format stream "xarray 0 0 put~%")
+    (dolist (index (cdr *top-sort*))
+      (let ((parents (psnode-parents (aref *narray* index))))
+	(format stream "xarray ~D get widtharray ~D get add~%"
+		(car parents) (car parents))
+	(dolist (parent (cdr parents))
+	  (format stream "xarray ~D get widtharray ~D get add max~%"
 		  parent parent))
-      (format t "~D add xarray exch ~D exch put~%" *extra-x-spacing* index)))
-
-  ;;; compute maximum x used
-  (format t "/maximum-x 0~%")
-  (dotimes (index num-psnodes)
-     (format t "xarray ~D get widtharray ~D get add max~%"
-	     index index))
-  (format t "def~%")
-
-  ;;; compute y location of each node and maximum and minimum y used
-  (setq maximum-y 0)
-  (setq minimum-y 0)
-  (setq psnodes-at-y (make-hash-table :test test
-				      :size (* num-psnodes *fontsize*)
-				      :rehash-size 2.0))
-  (let ((currenty 0))
-    (dolist (index (reverse top-sort))
-       (let (desired-y)
-	 (cond ((null (psnode-children (aref narray index)))
-	          (setf desired-y currenty)
-		  (setf currenty (+ currenty (psnode-height
-					      (aref narray index)))))
-	       (t
-		 (let ((children (psnode-children (aref narray index)))
-		       (ysum 0))
-		   (dolist (child children)
-		      (setf ysum (+ ysum (psnode-yvalue (aref narray child)))))
-		   (setq desired-y (floor ysum (length children))))))
-
-	 ;;; We may not be able to put the node at the desired y.
-	 ;;; If there is another node that overlaps in the y direction
-	 ;;; and that node is neither a parent* nor child* (hence its x
-	 ;;; location may overlap this one) then we have to choose
-         ;;; another y value -- we choose the nearest (up or down)
-	 ;;; location so that there is no possible overlap in y or x.
-	 (let ((height (psnode-height (aref narray index)))
-	       (related (make-hash-table :test test
-					 :size (+ 50 num-psnodes)
-					 :rehash-size 2.0))
-	       collision
-	       upward-bot
-	       upward-top
-	       downward-bot
-	       downward-top)
-	   (setq upward-bot desired-y)
-	   (setq upward-top upward-bot)
-	   (setq downward-top (- (+ desired-y height) 1))
-	   (setq downward-bot downward-top)
-	   (loop
-	      ;;; check upward-top for collision
-	     (setq collision nil)
-	     (dolist (n (gethash upward-top psnodes-at-y))
-		(let ((r (gethash n related)))
-		  (when (null r)
-			(setf r (related-classes n index))
-			(setf (gethash n related) r))
-		  (when (eql r 'no)
-			(setq collision t)
-			(return))))
-				 
-	     ;;; if no collision and big enough space then we win
-	     (incf upward-top)
-	     (when (and (not collision) (= (- upward-top upward-bot) height))
-		   (setf desired-y upward-bot)
-		   (return))
-
-	     (when collision
-		   (setf upward-bot upward-top))
-
-	     ;;; check downward-bot for collision
-	     (setq collision nil)
-	     (dolist (n (gethash downward-bot psnodes-at-y))
-		(let ((r (gethash n related)))
-		  (when (null r)
-			(setf r (related-classes n index))
-			(setf (gethash n related) r))
-		  (when (eql r 'no)
-			(setq collision t)
-			(return))))
-
-	      ;;; if no collision and big enough space then we win
-	     (decf downward-bot)
-	     (when (and (not collision) (= (- downward-top downward-bot) height))
-		   (setf desired-y (+ 1 downward-bot))
-		   (return))
+	(format stream "~D add xarray exch ~D exch put~%"
+		*extra-x-spacing* index)))
+    ;; compute maximum x used
+    (format stream "/maximum-x 0~@
+		    0 1 ~d~@
+		     {/i exch def~@
+                      xarray i get widtharray i get add max~@
+		     } for~@
+		    def~%"
+	    (1- *num-psnodes*))
+    
+    ;; compute height of each node, and the maximum height.
+    (let ((max-height 0))
+      (dotimes (index *num-psnodes*)
+	(declare (fixnum index))
+	(let* ((psnode (aref *narray* index))
+	       (height (+ (* 2 *boxedge*) *extra-y-spacing* *fontsize*
+			  (* (- (length (psnode-info psnode)) 1)
+			     *second-fontsize*))))
+	  (setf (psnode-height psnode) height)
+	  (when (> height max-height)
+	    (setf max-height height))))
+      
+      ;; compute y location of each node and maximum and minimum y used
+      (setq psnodes-at-y (make-hash-table :test #'eql
+					  :size (* *num-psnodes* *fontsize*)
+					  :rehash-size 2.0))
+      (let ((currenty 0))
+	(declare (fixnum currenty))
+	(dolist (index (reverse *top-sort*))
+	  (let ((desired-y 0))
+	    (declare (fixnum desired-y))
+	    (cond ((null (psnode-children (aref *narray* index)))
+		   (setf desired-y currenty)
+		   (incf currenty (if same-height
+				      max-height
+				      (psnode-height (aref *narray* index)))))
+		  (t
+		   (let ((children (psnode-children (aref *narray* index)))
+			 (ysum 0))
+		     (declare (fixnum ysum))
+		     (dolist (child children)
+		       (incf ysum (psnode-yvalue (aref *narray* child))))
+		     (setq desired-y (floor ysum (length children))))))
+	    ;; We may not be able to put the node at the desired y.  If
+	    ;; there is another node that overlaps in the y direction
+	    ;; and that node is neither a parent* nor child* (hence its
+	    ;; x location may overlap this one) then we have to choose
+	    ;; another y value -- we choose the nearest (up or down)
+	    ;; location so that there is no possible overlap in y or x.
+	    (let* ((height (if same-height
+			       max-height
+			       (psnode-height (aref *narray* index))))
+		   (related (make-hash-table :test #'equal
+					     :size (+ 50 *num-psnodes*)
+					     :rehash-size 2.0))
+		   collision
+		   (upward-bot desired-y)
+		   (upward-top upward-bot)
+		   (downward-top (- (+ desired-y height) 1))
+		   (downward-bot downward-top))
+	      (declare (fixnum upward-bot upward-top
+			       downward-top downward-bot))
+	      (loop
+	       ;; check upward-top for collision
+	       (setq collision nil)
+	       (dolist (n (gethash upward-top psnodes-at-y))
+		 (let ((r (gethash n related)))
+		   (when (null r)
+		     (setf r (related-classes n index))
+		     (setf (gethash n related) r))
+		   (when (eql r 'no)
+		     (setq collision t)
+		     (return))))
 	     
-	     (when collision
-		   (setf downward-top downward-bot))
-	   )
-	   ;;; add our name to psnodes-at-y table
-	   (dotimes (i height)
-	      (push index (gethash (+ i desired-y) psnodes-at-y)))
-
-	   (setf (psnode-yvalue (aref narray index)) desired-y)
-	 )
-
-	 (setf minimum-y (min minimum-y (psnode-yvalue (aref narray index))))
-	 (setf maximum-y
-	       (max maximum-y (+ (psnode-yvalue (aref narray index))
-				 (psnode-height (aref narray index))))))))
-		       
-  ;;; compute y-offset to center graph vertically
-  (setq rows (ceiling (- maximum-y minimum-y) *pageheight*))
-  (setq y-offset (- (floor (- (* rows *pageheight*) (- maximum-y minimum-y)) 2)
-		    minimum-y))
-  (when shrink (setq y-offset (- 0 minimum-y)))
-
-  ;;; create dictionary big enough to hold all the
-  ;;; procedures defined below and make it a current dictionary
-  (format t "~D dict begin~%"
-	  (+ (* 4 (+ num-psnodes (ceiling num-psnodes *chunksize*))) 50))
-
-  ;;; define procedures to display the background box for each node
-  (dotimes (index num-psnodes)
-     (format t "/box~D {~%" index)
-     (format t "xarray ~D get ~D widtharray ~D get ~D drawbox~%"
-	     index
-	     (+ y-offset 
-		(psnode-yvalue (aref narray index))
-                (floor *extra-y-spacing* 2))
-	     index
-	     (- (psnode-height (aref narray index)) *extra-y-spacing*))
-     (format t "} def~%"))
-
-  ;;; define procedures to display the text info for each node
-  (dotimes (index num-psnodes)
-     (let ((yvalue (+ y-offset
-		      (floor *extra-y-spacing* 2)
-		      (floor *fontsize* 5)
-                      *boxedge*
-		      (psnode-yvalue (aref narray index))
-		      (* *second-fontsize*
-			 (- (length (psnode-info (aref narray index))) 1)))))
-       (format t "/text~D {xarray ~D get boxedge add ~D moveto (~A) show} def~%"
-	       index
-	       index
-	       yvalue
-	       (car (psnode-info (aref narray index))))
-       (when (not (null (cdr (psnode-info (aref narray index)))))
-	   (format t "/secondtext~D {~%" index)
-	   (dolist (info (cdr (psnode-info (aref narray index))))
+	       ;; if no collision and big enough space then we win
+	       (incf upward-top)
+	       (when (and (not collision) (= (- upward-top upward-bot) height))
+		 (setf desired-y upward-bot)
+		 (return))
+	       
+	       (when collision
+		 (setf upward-bot upward-top))
+	       
+	       ;; check downward-bot for collision
+	       (setq collision nil)
+	       (dolist (n (gethash downward-bot psnodes-at-y))
+		 (let ((r (gethash n related)))
+		   (when (null r)
+		     (setf r (related-classes n index))
+		     (setf (gethash n related) r))
+		   (when (eql r 'no)
+		     (setq collision t)
+		     (return))))
+	       
+	       ;; if no collision and big enough space then we win
+	       (decf downward-bot)
+	       (when (and (not collision)
+			  (= (- downward-top downward-bot) height))
+		 (setf desired-y (+ 1 downward-bot))
+		 (return))
+	       
+	       (when collision
+		 (setf downward-top downward-bot)))
+	      
+	      ;; add our name to psnodes-at-y table
+	      (dotimes (i height)
+		(declare (fixnum i))
+		(push index (gethash (+ i desired-y) psnodes-at-y)))
+	      
+	      (setf (psnode-yvalue (aref *narray* index)) desired-y))
+	    
+	    (setf minimum-y (min minimum-y
+				 (psnode-yvalue (aref *narray* index))))
+	    (setf maximum-y
+		  (max maximum-y (+ (psnode-yvalue (aref *narray* index))
+				    (if same-height
+					max-height
+					(psnode-height (aref *narray* index)))))))))
+      (when same-height
+	;; Centre nodes vertically within the allocated max-height.
+	(dotimes (index *num-psnodes*)
+	  (declare (fixnum index))
+	  (let* ((psnode (aref *narray* index))
+		 (height (psnode-height psnode)))
+	    (incf (psnode-yvalue psnode)
+		  (- (floor max-height 2) (floor height 2)))))))
+
+    ;; compute y-offset to center graph vertically
+    (let* ((rows (ceiling (- maximum-y minimum-y) *pageheight*))
+	   (y-offset
+	    (if shrink
+		(- 0 minimum-y)
+		(- (floor (- (the fixnum (* rows *pageheight*))
+			     (- maximum-y minimum-y)) 2)
+		   minimum-y))))
+      (declare (fixnum rows y-offset))
+
+      ;; create dictionary big enough to hold all the procedures
+      ;; defined below and make it a current dictionary
+      (format stream "~D dict begin~%"
+	      (+ (* 4 (+ *num-psnodes* (ceiling *num-psnodes*
+						*chunksize*))) 50))
+      
+      ;; define procedures to display the background box for each node
+      (dotimes (index *num-psnodes*)
+	(format stream "/box~D {~%" index)
+	(format stream "xarray ~D get ~D widtharray ~D get ~D drawbox~%"
+		index
+		(+ y-offset (psnode-yvalue (aref *narray* index))
+		   (floor *extra-y-spacing* 2))
+		index
+		(- (psnode-height (aref *narray* index)) *extra-y-spacing*))
+	(format stream "} def~%"))
+
+      ;; define procedures to display the text info for each node
+      (dotimes (index *num-psnodes*)
+	(declare (fixnum index))
+	(let ((yvalue (+ y-offset (floor *extra-y-spacing* 2)
+			 (floor *fontsize* 5) *boxedge*
+			 (psnode-yvalue (aref *narray* index))
+			 (the fixnum
+			      (* *second-fontsize*
+				 (- (length (psnode-info
+					     (aref *narray* index))) 1))))))
+	  (declare (fixnum yvalue))
+	  (format stream "/text~D {xarray ~D get boxedge add ~
+			  ~D moveto (~A) show} def~%"
+		  index index yvalue (car (psnode-info (aref *narray* index))))
+	  (when (not (null (cdr (psnode-info (aref *narray* index)))))
+	    (format stream "/secondtext~D {~%" index)
+	    (dolist (info (cdr (psnode-info (aref *narray* index))))
 	      (setq yvalue (- yvalue *second-fontsize*))
-	      (format t "xarray ~D get boxedge add ~D moveto (~A) show~%"
-		      index
-		      yvalue
-		      info))
-	   (format t "} def~%"))))
-
-  ;;; define procedures to display the edges leading into each node
-  (dotimes (index num-psnodes)
-     (format t "/edge~D {newpath~%" index)
-     (dolist (parent (psnode-parents (aref narray index)))
-        (format t "xarray ~D get widtharray ~D get add ~D moveto~%"
-		parent
-		parent
-		(+ (psnode-yvalue (aref narray parent))
-		   (floor (psnode-height (aref narray parent)) 2)
+	      (format stream "xarray ~D get boxedge add ~D moveto (~A) show~%"
+		      index yvalue info))
+	    (format stream "} def~%"))))
+      
+      ;; define procedures to display the edges leading into each node
+      (dotimes (index *num-psnodes*)
+	(format stream "/edge~D {newpath~%" index)
+	(dolist (parent (psnode-parents (aref *narray* index)))
+	  (format stream "xarray ~D get widtharray ~D get add ~D moveto~%"
+		parent parent
+		(+ (psnode-yvalue (aref *narray* parent))
+		   (floor (psnode-height (aref *narray* parent)) 2)
 		   y-offset))
-	(format t "xarray ~D get ~D lineto~%"
-		index
-		(+ (psnode-yvalue (aref narray index))
-		   (floor (psnode-height (aref narray index)) 2)
-		   y-offset)))
-     (format t "stroke } def~%"))
-
-  ;;; Define procedures to display chunks of boxes, text, and edges.
-  ;;; We limit each chunk to at most *chunksize* calls, to avoid overflowing
-  ;;; the Postscript operand stack.
-  (dotimes (index num-psnodes)
-     (when (eql (mod index *chunksize*) 0)
-	   (format t "/boxchunk~D {~%" (floor index *chunksize*)))
-     (format t "box~D~%" index)
-     (when (or (eql (mod index *chunksize*) (- *chunksize* 1))
-	       (eql index (- num-psnodes 1)))
-	   (format t "} def~%")))
-  (dotimes (index num-psnodes)
-     (when (eql (mod index *chunksize*) 0)
-	   (format t "/textchunk~D {~%" (floor index *chunksize*)))
-     (format t "text~D~%" index)
-     (when (or (eql (mod index *chunksize*) (- *chunksize* 1))
-	       (eql index (- num-psnodes 1)))
-	   (format t "} def~%")))
-  (dotimes (index num-psnodes)
-     (when (eql (mod index *chunksize*) 0)
-	   (format t "/secondtextchunk~D {~%" (floor index *chunksize*)))
-     (when (not (null (cdr (psnode-info (aref narray index)))))
-	   (format t "secondtext~D~%" index))
-     (when (or (eql (mod index *chunksize*) (- *chunksize* 1))
-	       (eql index (- num-psnodes 1)))
-	   (format t "} def~%")))
-  (dotimes (index num-psnodes)
-     (when (eql (mod index *chunksize*) 0)
-	   (format t "/edgechunk~D {~%" (floor index *chunksize*)))
-     (format t "edge~D~%" index)
-     (when (or (eql (mod index *chunksize*) (- *chunksize* 1))
-	       (eql index (- num-psnodes 1)))
-	   (format t "} def~%")))
-
-  ;;; Define procedure to display entire graph.
-  ;;; First do the boxes, then the edges, then the text.
-  (format t "/drawgraph { gsave~%")
-  (dotimes (i (ceiling num-psnodes *chunksize*))
-     (format t "boxchunk~D~%" i))
-  (format t "~A setlinewidth~%" *edgewidth*)
-  (format t "~A setlinecap~%" *edgecap*)
-  (format t "~A setgray~%" *edgegray*)
-  (dotimes (i (ceiling num-psnodes *chunksize*))
-     (format t "edgechunk~D~%" i))
-  (format t "~A setgray~%" *textgray*)
-  (format t "/~A findfont ~D scalefont setfont~%" *fontname* *fontsize*)
-  (dotimes (i (ceiling num-psnodes *chunksize*))
-     (format t "textchunk~D~%" i))
-  (format t "/~A findfont ~D scalefont setfont~%" *second-fontname* *second-fontsize*)
-  (dotimes (i (ceiling num-psnodes *chunksize*))
-     (format t "secondtextchunk~D~%" i))
-  (format t "grestore } def~%")
-
-  ;;; show the virtual page in as many actual pages as needed
-  (cond (shrink
-          ;;; shrink the output to fit on one page
-	  (format t "leftmargin botmargin translate~%")
-	  (format t "pagewidth dup maximum-x max div pageheight dup ~D max ~
-	             div min dup scale~%"
-		  (- maximum-y minimum-y))
-	  (if insert
-	      (format t "drawgraph end~%")
-	      (format t "drawgraph showpage end~%")))
-	(t
-	  (format t "{drawgraph} maximum-x pagewidth div ceiling ~
-	             ~D printposter end~%"
-		  rows)))
-  
-)
-
-
-(defun walk-graph (root)
-  (when (eql num-psnodes *max-psnodes*)
-	(error "More than ~D nodes in graph.  Graphing aborted."))
-  (let ((root-index num-psnodes)
-	(child-names (apply child-function (list root))))
-    (incf num-psnodes)
-    (setf (gethash root psnode-index) root-index)
-    (setf (aref narray root-index) (make-psnode))
-    (setf (psnode-name (aref narray root-index)) root)
-    (setf (psnode-info (aref narray root-index))
-	  (apply info-function (list root)))
-    (setf (psnode-children (aref narray root-index)) nil)
-    (setf (psnode-parents (aref narray root-index)) nil)
-    (setf (psnode-appears-in-top-sort (aref narray root-index)) nil)
-    (setf (psnode-children-appear-in-top-sort (aref narray root-index)) nil)
+	  (format stream "xarray ~D get ~D lineto~%"
+		  index
+		  (+ (psnode-yvalue (aref *narray* index))
+		     (floor (psnode-height (aref *narray* index)) 2)
+		     y-offset)))
+	(format stream "stroke } def~%"))
+
+      ;; Define procedures to display chunks of boxes, text, and
+      ;; edges.  We limit each chunk to at most *chunksize* calls, to
+      ;; avoid overflowing the Postscript operand stack.
+      (dotimes (index *num-psnodes*)
+	(declare (fixnum index))
+	(when (zerop (mod index *chunksize*))
+	  (format stream "/boxchunk~D {~%" (floor index *chunksize*)))
+	(format stream "box~D~%" index)
+	(when (or (= (mod index *chunksize*) (- *chunksize* 1))
+		  (= index (- *num-psnodes* 1)))
+	  (format stream "} def~%")))
+      (dotimes (index *num-psnodes*)
+	(declare (fixnum index))
+	(when (zerop (mod index *chunksize*))
+	  (format stream "/textchunk~D {~%" (floor index *chunksize*)))
+	(format stream "text~D~%" index)
+	(when (or (= (mod index *chunksize*) (- *chunksize* 1))
+		  (= index (- *num-psnodes* 1)))
+	  (format stream "} def~%")))
+      (dotimes (index *num-psnodes*)
+	(declare (fixnum index))
+	(when (zerop (mod index *chunksize*))
+	  (format stream "/secondtextchunk~D {~%" (floor index *chunksize*)))
+	(when (cdr (psnode-info (aref *narray* index)))
+	  (format stream "secondtext~D~%" index))
+	(when (or (= (mod index *chunksize*) (- *chunksize* 1))
+		  (= index (- *num-psnodes* 1)))
+	  (format stream "} def~%")))
+      (dotimes (index *num-psnodes*)
+	(declare (fixnum index))
+	(when (zerop (mod index *chunksize*))
+	  (format stream "/edgechunk~D {~%" (floor index *chunksize*)))
+	(format stream "edge~D~%" index)
+	(when (or (= (mod index *chunksize*) (- *chunksize* 1))
+		  (= index (- *num-psnodes* 1)))
+	  (format stream "} def~%")))
+
+      ;; Define procedure to display entire graph.  First do the
+      ;; boxes, then the edges, then the text.
+      (format stream "/drawgraph { gsave~%")
+      (dotimes (i (ceiling *num-psnodes* *chunksize*))
+	(declare (fixnum i))
+	(format stream "boxchunk~D~%" i))
+      (format stream "~A setlinewidth~%" *edgewidth*)
+      (format stream "~A setlinecap~%" *edgecap*)
+      (format stream "~A setgray~%" *edgegray*)
+      (dotimes (i (ceiling *num-psnodes* *chunksize*))
+	(declare (fixnum i))
+	(format stream "edgechunk~D~%" i))
+      (format stream "~A setgray~%" *textgray*)
+      (format stream "/~A findfont ~D scalefont setfont~%"
+	      *fontname* *fontsize*)
+      (dotimes (i (ceiling *num-psnodes* *chunksize*))
+	(declare (fixnum i))
+	(format stream "textchunk~D~%" i))
+      (format stream "/~A findfont ~D scalefont setfont~%"
+	      *second-fontname* *second-fontsize*)
+      (dotimes (i (ceiling *num-psnodes* *chunksize*))
+	(declare (fixnum i))
+	(format stream "secondtextchunk~D~%" i))
+      (format stream "grestore } def~%")
+      
+      ;; show the virtual page in as many actual pages as needed
+      (cond ((eq shrink :width)
+	     ;; shrink the width to fit on a page.
+	     (format stream
+		     "newpath~@
+		        leftmargin botmargin moveto~@
+		        0 pageheight rlineto~@
+		        pagewidth 0 rlineto~@
+		        0 pageheight neg rlineto~@
+		      closepath clip~@
+		      leftmargin botmargin translate~@
+		      0 1 ~d~@
+		       {/rowcount exch def~@
+		         gsave~@
+		         0 pageheight rowcount mul neg translate~@
+			 pagewidth dup maximum-x max div dup 1 scale~@
+		         drawgraph~@
+	                 0.5 1 scale~@
+		         gsave showpage grestore~@
+		         grestore~@
+		       } for~@
+                      end~%"
+		     (1- rows)))
+	    (shrink
+	     ;; shrink the output to fit on one page
+	     (format stream "leftmargin botmargin translate~@
+			     pagewidth dup maximum-x max div ~
+			     pageheight dup ~D max div min dup scale~%"
+		     (- maximum-y minimum-y))
+	     (if insert
+		 (format stream "drawgraph end~%")
+		 (format stream "drawgraph showpage end~%")))
+	    (t
+	     (format stream
+		     "/printposter~@
+		       {/rows exch def~@
+		        /columns exch def~@
+		        newpath~@
+		          leftmargin botmargin moveto~@
+		          0 pageheight rlineto~@
+		          pagewidth 0 rlineto~@
+		          0 pageheight neg rlineto~@
+		        closepath clip~@
+		        leftmargin botmargin translate~@
+		        0 1 rows 1 sub~@
+		         {/rowcount exch def~@
+		          0 1 columns 1 sub~@
+		           {/colcount exch def~@
+		            gsave~@
+		             pagewidth colcount mul neg~@
+		             pageheight rowcount mul neg~@
+		             translate~@
+		             drawgraph~@
+		             gsave showpage grestore~@
+		            grestore~@
+		           } for~@
+		         } for~@
+		       } def~%")
+	     (format stream "maximum-x pagewidth div ceiling ~
+                             ~D printposter end~%"
+		     rows))))))
+
+(defun walk-graph (root child-function info-function)
+  (declare (function child-function info-function))
+  (let ((root-index *num-psnodes*)
+	(child-names (funcall child-function root))
+	(psnode (make-psnode :name root :info (funcall info-function root))))
+    (incf *num-psnodes*)
+    (setf (gethash root *psnode-index*) root-index)
+    ;; Grow *narray* if necessary.
+    (when (>= root-index (length *narray*))
+      (setf *narray* (adjust-array *narray* (ceiling (* *num-psnodes* 1.5))
+				   :element-type t)))
+    (setf (aref *narray* root-index) psnode)
     (dolist (child child-names)
-	    (let ((child-index (gethash child psnode-index)))
-	      (cond (child-index
-		      (push child-index
-			    (psnode-children (aref narray root-index)))
-		      (push root-index
-			    (psnode-parents (aref narray child-index))))
-		    (t
-		      (let ((child-index (walk-graph child)))
-			(push child-index
-			      (psnode-children (aref narray root-index)))
-			(push root-index
-			      (psnode-parents (aref narray child-index))))))))
-    root-index)
-)
-	  
-(defun top-sort-node (index)
-  (when (not (psnode-appears-in-top-sort (aref narray index)))
-
-	;;; make sure the parents are processed
-	(dolist (parent (psnode-parents (aref narray index)))
-		(top-sort-parent parent))
-
-	;;; add this node to top-sort
-	(push index top-sort)
-	(setf (psnode-appears-in-top-sort (aref narray index)) t))
-
-  (when (not (psnode-children-appear-in-top-sort (aref narray index)))
-	(dolist (child (psnode-children (aref narray index)))
-		(top-sort-node child))
-	(setf (psnode-children-appear-in-top-sort (aref narray index)) t))
-)
+      (let ((child-index (gethash child *psnode-index*)))
+	(cond (child-index
+	       (push child-index (psnode-children psnode))
+	       (push root-index (psnode-parents (aref *narray* child-index))))
+	      (t
+	       (let ((child-index
+		      (walk-graph child child-function info-function)))
+		 (push child-index (psnode-children psnode))
+		 (push root-index
+		       (psnode-parents (aref *narray* child-index))))))))
+    root-index))
 
+(defun top-sort-node (index)
+  (let ((psnode (aref *narray* index)))
+    (unless (psnode-appears-in-top-sort psnode)
+      ;; make sure the parents are processed
+      (dolist (parent (psnode-parents psnode))
+	(top-sort-parent parent))
+      ;; add this node to *top-sort*
+      (push index *top-sort*)
+      (setf (psnode-appears-in-top-sort psnode) t))
+    (unless (psnode-children-appear-in-top-sort psnode)
+      (dolist (child (psnode-children psnode))
+	(top-sort-node child))
+      (setf (psnode-children-appear-in-top-sort psnode) t))))
+  
 (defun top-sort-parent (index)
-  (when (not (psnode-appears-in-top-sort (aref narray index)))
-
-	;;; make sure the parents are processed
-	(dolist (parent (psnode-parents (aref narray index)))
-		(top-sort-parent parent))
+  (let ((psnode (aref *narray* index)))
+    (unless (psnode-appears-in-top-sort psnode)
+      ;; make sure the parents are processed
+      (dolist (parent (psnode-parents psnode))
+	(top-sort-parent parent))
+      ;; add this node to *top-sort*
+      (push index *top-sort*)
+      (setf (psnode-appears-in-top-sort psnode) t))))
 
-	;;; add this node to top-sort
-	(push index top-sort)
-	(setf (psnode-appears-in-top-sort (aref narray index)) t))
-)
 
 (defun related-classes (x y)
   (cond ((ancestor x y) 'yes)
 	((ancestor y x) 'yes)
-	(t 'no))
-)
+	(t 'no)))
 
 (defun ancestor (x y)
-  (let ((cached-value (gethash (list x y) ancestor-cache)))
+  (let ((cached-value (gethash (list x y) *ancestor-cache*)))
     (cond (cached-value (car cached-value))
 	  (t
-	    (setq cached-value
-		  (cond ((equal x y) t)
-			(t
-			  (some #'(lambda (child) (ancestor child y))
-				(psnode-children (aref narray x))))))
-	    (setf (gethash (list x y) ancestor-cache) (list cached-value))
-	    cached-value)))
-)
+	   (setq cached-value
+		 (if (equal x y)
+		     t
+		     (some #'(lambda (child) (ancestor child y))
+			   (psnode-children (aref *narray* x)))))
+	   (setf (gethash (list x y) *ancestor-cache*) (list cached-value))
+	   cached-value))))
diff --git a/contrib/psgraph/psgraph.log b/contrib/psgraph/psgraph.log
deleted file mode 100644
index 2214c46483006730ea5c185b074b31324f2678ef..0000000000000000000000000000000000000000
--- a/contrib/psgraph/psgraph.log
+++ /dev/null
@@ -1,18 +0,0 @@
-/usr1/chiles/work/psgraph.lisp, Jul-90 10:59:13, Edit by Mkant.
-  Fixed shrink mode so that it scales x and y axes uniformly (e.g., aspect
-  ratio = 1).
-
-/usr1/chiles/work/psgraph.lisp, 01-May-90 10:59:13, Edit by Chiles.
-  Made exported specials have stars.
-
-/usr1/chiles/work/psgraph.lisp, APR 90, Edit by Skef Wholey.
-  ;;;     -- Now lives in the PSGRAPH package (instead of USER, or *package*...)
-  ;;;        with user-tweakable stuff exported.
-  ;;;     -- Node equivalence function can now be specified as EQ, EQUAL,
-  ;;;        or EQUALP.
-
-/usr1/chiles/work/psgraph.lisp, DEC 88, Edit by Joseph Bates
-  Modified to include optional insert parameter to psgraph.
-
-/usr1/chiles/work/psgraph.lisp, MAR 88, Edit by Joseph Bates
-  File created.