diff --git a/clim/graph-formatting.lisp b/clim/graph-formatting.lisp
index 7932f30b46fa6099f6162b871977b7b59b2ff522..2c58ad9e1566cc74f5931b891418a3487b62c64e 100644
--- a/clim/graph-formatting.lisp
+++ b/clim/graph-formatting.lisp
@@ -1,11 +1,79 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
-
+;; Allegro Common Lisp
+;;				-[Thu Nov 19 18:52:10 1992 by smh]-
+;;
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1992 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
 ;; $fiHeader: graph-formatting.lisp,v 1.18 92/11/06 18:59:45 cer Exp $
 
-(In-package :clim-internals)
 
 "Copyright (c) 1990, 1991, 1992 Symbolics Inc.  All rights reserved."
 
+
+(In-package :clim-internals)
+
+#|
+
+This file is smh's quick hacked version for improved digraph layout.
+
+The basic strategy is that each node appearing more than once in the
+graph is reliably assigned the maximum generation (ply) to which it
+belongs, instead of depending on which occurence was encountered
+first.  Then `filler' output records are inserted to fill in missing
+generations in any link.  These fillers then participate in regular
+node layout.  This results in some unnecessarily squiggley lines, but
+generally the behavior is reasonable.
+
+In graphs where a node with large "depth" is adjacent to a small depth
+node with large fanout connections there is still the possibly that a
+connector will overwrite a node.  This could be fixed with one of
+several strategies: Pad the short node's depth somehow, which moves a
+lot of complexity onto the arc-drawing functions; or add a whole
+generation of additional filler nodes, which would be laid out to
+constrain the set of children of each parent to lie within that
+parents breadth.  I'd draw a picture of it weren't so tedious...
+
+The unnecessary squiggles could be fixed without too much work by
+postprocessing the links, successively moving filler nodes when there
+is room to line them up with one of it's connections in the adjacent
+generation.
+
+Useful rfe: Enforce some limit on the maximum absolute value slope on
+a connection.  Extra inter-generation spacing would be adde to limit
+the slope, since high-slope lines are the most visually confusion,
+especially when many occur together.
+
+As an additional hack, the digraph grapher handles circularities by
+creating a pair of `offpage' connectors.  This isn't as elegant as
+plotting circular paths backwards, but the current hack results in a
+clear visual diagram with little effort.  The new
+offpage-connector-out-printer and offpage-connector-in-printer args to
+format-graph-from-roots are something of a crock -- perhaps we can
+avoid documenting them until better treatment of cyclic graphs is
+devised.  BTW, before this hack, a circular graph with no roots (i.e.
+all nodes have at least one parent) would blow the stack, so don't
+undertake a more ambitious fix for circular graphs without accounting
+for this case.
+
+|#
+
+
 (defvar *graph-type-record-type-alist* nil)
 
 (defmacro define-graph-type (graph-type class)
@@ -116,7 +184,7 @@
 ;; The basic graph node output record class
 (defclass standard-graph-node-output-record 
 	  (standard-sequence-output-record graph-node-output-record)
-    ((generation :accessor node-generation :initform 0)
+    ((generation :accessor graph-node-generation :initform 0)
      ;; The output records corresponding to this node's parents and children
      (node-children :accessor graph-node-children :initform nil)
      (node-parents :accessor graph-node-parents :initform nil))
@@ -175,7 +243,15 @@
 				       *default-generation-separation*)
 				     (within-generation-separation
 				       *default-within-generation-separation*)
-				     (move-cursor t))
+				     (move-cursor t)
+				     ;; These `offpage' connector print functions
+				     ;; should receive more useful id in addition
+				     ;; to an identification number, such as the
+				     ;; from and to nodes.
+				     (offpage-connector-out-printer
+				      #'(lambda (s n) (format s ">~d" n)))
+				     (offpage-connector-in-printer
+				      #'(lambda (s n) (format s "~d>" n))))
   (declare (dynamic-extent object-printer inferior-producer))
   (check-type cutoff-depth (or null integer))
   (check-type generation-separation real)
@@ -205,14 +281,17 @@
 			:within-generation-separation 
 			  (coordinate within-generation-separation)
 			:hash-table hash-table)
-		     (generate-graph-nodes graph-record stream
-					   root-objects object-printer inferior-producer
-					   :duplicate-key duplicate-key 
-					   :duplicate-test duplicate-test)
+		     (generate-graph-nodes
+		      graph-record stream
+		      root-objects object-printer inferior-producer
+		      :duplicate-key duplicate-key 
+		      :duplicate-test duplicate-test
+		      :offpage-connector-out-printer offpage-connector-out-printer
+		      :offpage-connector-in-printer  offpage-connector-in-printer)
 		     graph-record))))))
       (unwind-protect
 	  (progn
-	    (layout-graph-nodes graph-record stream)
+	    (layout-graph-nodes graph-record stream arc-drawer arc-drawing-options)
 	    (layout-graph-edges graph-record stream arc-drawer arc-drawing-options))
 	;; We're going to free the hash table as we exit, so make sure
 	;; there are no pointers to it
@@ -269,8 +348,12 @@
 
 (defmethod generate-graph-nodes ((graph tree-graph-output-record) stream
 				 root-objects object-printer inferior-producer
-				 &key duplicate-key duplicate-test)
-  (declare (ignore duplicate-key duplicate-test))
+				 &key duplicate-key duplicate-test
+				 offpage-connector-out-printer
+				 offpage-connector-in-printer)
+  (declare (ignore duplicate-key duplicate-test
+		   offpage-connector-out-printer
+		   offpage-connector-in-printer))
   (let ((cutoff-depth (slot-value graph 'cutoff-depth)))
     (labels ((format-node (object &optional (depth 1))
 	       (when (and cutoff-depth (> depth cutoff-depth))
@@ -290,12 +373,13 @@
 		   (dolist (child (graph-node-children this-node))
 		     (setf (graph-node-parents child) (list this-node)))
 		   this-node))))
-      (setf (graph-root-nodes graph) 
+      (setf (graph-root-nodes graph)
 	    (map 'list #'format-node root-objects))))
   graph)
 
-(defmethod layout-graph-nodes ((graph tree-graph-output-record) stream)
-  (declare (ignore stream))
+(defmethod layout-graph-nodes ((graph tree-graph-output-record)
+			       stream arc-drawer arc-drawing-options)
+  (declare (ignore stream arc-drawer arc-drawing-options))
   (with-slots (root-nodes orientation center-nodes
 	       generation-separation within-generation-separation) graph
     (let ((start-x (coordinate 0))
@@ -414,71 +498,115 @@
     ((n-generations :initform 0)))
 
 ;; For now, treat digraphs and DAGs the same way...
+;;
+;; With smh's hacks, cyclic digraphs get converted to dags automatically
+;; with the insertion of `offpage' connectors.
+;; This should be conditionalized, with options for also trying to thread
+;; the cycle path neatly backwards -- but it's too tricky for right now.
+;; Contact me for my thoughts on the matter. 19Nov92 -smh
+
 (define-graph-type :directed-graph directed-graph-output-record)
 (define-graph-type :digraph directed-graph-output-record)
 (define-graph-type :directed-acyclic-graph directed-graph-output-record)
 (define-graph-type :dag directed-graph-output-record)
 
-(defmethod generate-graph-nodes ((graph directed-graph-output-record) stream
+;; These implement the dummy nodes inserted when an arc must span
+;; more than one generation.
+(defclass graph-node-filler-output-record (standard-graph-node-output-record) ())
+(defclass graph-node-filler-output-record-1 (standard-graph-node-output-record) ())
+
+;; These implement the `offpage' connectors for cyclic graphs.
+(defclass graph-node-connector-output-record
+    (standard-graph-node-output-record)
+    ((id :accessor connector-id :initarg :connector-id)))
+(defclass graph-node-connector-in-output-record  (graph-node-connector-output-record) ())
+(defclass graph-node-connector-out-output-record (graph-node-connector-output-record) ())
+
+(defmethod generate-graph-nodes ((graph directed-graph-output-record)
+				 stream
 				 root-objects object-printer inferior-producer
-				 &key duplicate-key duplicate-test)
+				 &key duplicate-key duplicate-test
+				 offpage-connector-out-printer
+				 offpage-connector-in-printer)
   (declare (dynamic-extent object-printer inferior-producer))
   (declare (ignore duplicate-test))
   (let ((hash-table (slot-value graph 'hash-table))
 	(cutoff-depth (slot-value graph 'cutoff-depth))
-	(n-generations 0))
+	(root-nodes '())
+	(connectors-in '()))
     (labels ((inferior-mapper (function node)
 	       (map nil function (funcall inferior-producer node)))
 	     (new-node-function (parent-object parent-record child-object)
 	       (let ((child-record
-		       (with-stream-cursor-position-saved (stream)
-			 (with-new-output-record (stream 'standard-graph-node-output-record)
-			   (funcall object-printer child-object stream)))))
+		      (with-stream-cursor-position-saved (stream)
+		      (with-new-output-record
+			  (stream 'standard-graph-node-output-record)
+			(funcall object-printer child-object stream)))))
+		 ;; This guarantees that the next phase will have at least one node
+		 ;; from which to start.  Otherwise the entire graph gets lost.
+		 ;; If the first node isn't really a root, it will be deleted from
+		 ;; the set of roots when the cycle is detected.
+		 (when (null root-nodes)
+		   (push child-record root-nodes))
 		 (old-node-function parent-object parent-record child-object child-record)))
 	     (old-node-function (parent-object parent-record child-object child-record)
 	       (declare (ignore parent-object child-object))
-	       (let ((old-generation (node-generation child-record)))
-		 ;; Set the generation of this node to 1 greater than the parent,
-		 ;; and keep track of the highest generation encountered.
-		 (maxf n-generations
-		       (maxf (node-generation child-record)
-			     (if parent-record
-				 (1+ (node-generation parent-record))
-				 0)))
-		 ;; If the child-record got its generation adjusted, then we must
-		 ;; adjust the generation-number of already-processed children,
-		 ;; and their children, etc.
-		 (unless (eql (node-generation child-record) old-generation)
-		   (increment-generation child-record)))
 	       ;; Preserve the ordering of the nodes
+	       ;; Generation numbers are now computed later -smh.
 	       (when parent-record
 		 (unless (member parent-record (graph-node-parents child-record))
 		   (setf (graph-node-parents child-record)
-			 (nconc (graph-node-parents child-record)
-				(list parent-record))))
+		     (nconc (graph-node-parents child-record)
+			    (list parent-record))))
 		 (unless (member child-record (graph-node-children parent-record))
 		   (setf (graph-node-children parent-record)
-			 (nconc (graph-node-children parent-record)
-				(list child-record)))))
-	       child-record)
-	     (increment-generation (record)
-	       (let ((new-generation (1+ (node-generation record))))
-		 (dolist (child (graph-node-children record))
-		   ;; Remember which generation the child belonged to.
-		   (let ((old-generation (node-generation child)))
-		     (maxf n-generations
-			   (maxf (node-generation child)
-				 new-generation))
-		     ;; If it has changed, fix up the next generation recursively.
-		     (unless (eql (node-generation child) old-generation)
-		       (increment-generation child)))))))
-      (declare (dynamic-extent #'inferior-mapper #'increment-generation
-			       #'new-node-function #'old-node-function))
+		     (nconc (graph-node-children parent-record)
+			    (list child-record)))))
+	       child-record))
+      (declare (dynamic-extent #'inferior-mapper #'new-node-function #'old-node-function))
       (traverse-graph root-objects #'inferior-mapper
 		      hash-table duplicate-key
 		      #'new-node-function #'old-node-function
-		      cutoff-depth)
-      (setf (slot-value graph 'n-generations) n-generations))
+		      cutoff-depth))
+    (map-node-table #'(lambda (key node)
+			(declare (ignore key))
+			(when (and (typep node 'graph-node-output-record)
+				   (null (graph-node-parents node)))
+			  (pushnew node root-nodes)))
+		    hash-table)
+    (labels ((break-cycles (node &optional path)
+	       (do ((c (graph-node-children node) (cdr c)))
+		   ((null c))
+		 (let ((child (car c)))
+		   (if (member child path)
+		       (let* ((id (connector-id
+				   (or (find child connectors-in
+					     :key #'(lambda (x)
+						      (car (graph-node-children x))))
+				       (let* ((id (1+ (length connectors-in)))
+					      (rec (with-new-output-record
+						       (stream
+							'graph-node-connector-in-output-record
+							nil :connector-id id)
+						     (funcall offpage-connector-in-printer
+							      stream id))))
+					 (push rec connectors-in)
+					 (setf (graph-node-children rec) (list child))
+					 ;; What about ordering?
+					 (push rec (graph-node-parents child))
+					 (setf root-nodes (delete child root-nodes))
+					 rec)))))
+			 (setf (car c)
+			   (with-new-output-record
+			       (stream 'graph-node-connector-out-output-record nil
+				:connector-id id)
+			     (funcall offpage-connector-out-printer stream id))))
+		     (break-cycles child (cons node path)))))))
+      (declare (dynamic-extent #'break-cycles))
+      (map nil #'break-cycles (copy-list root-nodes)))
+    (setf (slot-value graph 'root-nodes) (nconc (nreverse connectors-in)
+						(nreverse root-nodes)))
+    #+never
     (let ((root-nodes nil))
       (flet ((find-roots (key node)
 	       (declare (ignore key))
@@ -488,8 +616,47 @@
 	(declare (dynamic-extent #'find-roots))
 	(map-node-table #'find-roots hash-table))
       (setf (graph-root-nodes graph) (nreverse root-nodes))))
+  (compute-graph-effective-generations graph)
+  (add-graph-filler-output-records graph stream)
   graph)
 
+(defmethod compute-graph-effective-generations ((graph directed-graph-output-record))
+  (with-slots (n-generations root-nodes) graph
+    (labels ((traverse (node ply)
+	       (with-slots (generation) node
+		 (maxf generation ply)
+		 (let ((children (graph-node-children node))
+		       (gen1 (1+ generation)))
+		   (if children		;Save time -- do one or the other.
+		       (dolist (child children)
+			 (traverse child gen1))
+		     (maxf n-generations generation))))))
+      (dolist (root root-nodes)
+	(traverse root 0)))))
+
+(defmethod add-graph-filler-output-records ((graph directed-graph-output-record) stream)
+  (with-slots (root-nodes) graph
+    (labels ((traverse (node)
+	       (let* ((gen (graph-node-generation node))
+		      (gen1 (1+ gen))
+		      (children (graph-node-children node)))
+		 (do ((c children (cdr c)))
+		     ((null c))
+		   (let ((child (car c)))
+		     (if (> (graph-node-generation child) gen1)
+			 (progn
+			   (let ((filler (with-new-output-record
+					     (stream 'graph-node-filler-output-record)
+					   nil)))
+			     (setf (graph-node-children filler) (list child)
+				   (graph-node-parents filler) (list node)
+				   (car c) filler
+				   (graph-node-generation filler) gen1)
+			     (traverse filler)))
+		       (traverse child)))))))
+      (dolist (root root-nodes)
+	(traverse root)))))
+
 (defstruct (generation-descriptor (:conc-name generation-) (:type list))
   generation				;generation number
   (breadth 0)				;sum of breadth of all nodes in this generation
@@ -502,8 +669,8 @@
   (edge-breadth-separation nil)		;margin whitespace
   (touched nil))			;if T, use inner breadth separation
 
-(defmethod layout-graph-nodes ((graph directed-graph-output-record) stream)
-  (declare (ignore stream))
+(defmethod layout-graph-nodes ((graph directed-graph-output-record)
+			       stream arc-drawer arc-drawing-options)
   (with-slots (orientation center-nodes
 	       generation-separation within-generation-separation n-generations
 	       root-nodes hash-table) graph
@@ -543,13 +710,45 @@
 		;; Determine the breadth and depth of each generation
 		(flet ((collect-node-size (p ph child-node)
 			 (declare (ignore p ph))
-			 (let ((descr (assoc (node-generation child-node)
+			 (let ((descr (assoc (graph-node-generation child-node)
 					     generation-descriptors)))
 			   (incf (generation-size descr))
 			   (incf (generation-breadth descr) (breadth child-node))
 			   (maxf (generation-depth descr) (depth child-node)))))
 		  (declare (dynamic-extent #'collect-node-size))
 		  (traverse #'collect-node-size))
+
+	      ;; Replace all filler nodes, giving them the max depth in their generation.
+	      (labels
+		  ((replace-filler-nodes (parent)
+		     (let ((children (graph-node-children parent)))
+		       (do ((c children (cdr c)))
+			   ((null c))
+			 (let ((node (car c)))
+			   (when (typep node 'graph-node-filler-output-record)
+			     (delete-output-record node graph)
+			     (let* ((depth (generation-depth
+					    (assoc (graph-node-generation node)
+						   generation-descriptors)))
+				    (new (with-output-to-output-record
+					     (stream 'graph-node-filler-output-record-1)
+					   (call-arc-drawer stream arc-drawer
+						    ;;--- Should be from- and to-node
+						    nil nil
+						    parent 0 0
+						    node depth 0
+						    arc-drawing-options)))
+				    (child (car (graph-node-children node))))
+			       (setf (graph-node-generation new) (graph-node-generation node)
+				     (graph-node-children new) (graph-node-children node)
+				     (graph-node-parents new) (graph-node-parents node)
+				     (graph-node-parents child) (list new)
+				     (car c) new)
+			       (add-output-record new graph)))))
+		       (map nil #'replace-filler-nodes children))))
+		(declare (dynamic-extent #'replace-filler-nodes))
+		(map nil #'replace-filler-nodes root-nodes))
+
 		;; Determine max-breadth and starting-depth
 		(loop with depth-so-far = start-depth
 		      for descr in generation-descriptors do
@@ -570,7 +769,7 @@
 		;; Place nodes
 		(flet ((place-node (p ph child-node)
 			 (declare (ignore p ph))
-			 (let ((descr (assoc (node-generation child-node)
+			 (let ((descr (assoc (graph-node-generation child-node)
 					     generation-descriptors)))
 			   (incf (generation-breadth-so-far descr)
 				 (if (generation-touched descr)
@@ -675,7 +874,7 @@
 	       (funcall new-node-function parent-object parent-hashval object)))
 	 (setf (get-node-table (funcall key object) hash-table) object-hashval)
 	 (when max-depth (decf max-depth))
-	 (unless (eq max-depth 0)
+	 (unless (eql max-depth 0)
 	   (flet ((traverse1 (child-object)
 		    (let ((child-key (funcall key child-object)))
 		      (multiple-value-bind (child-hashval found)