singer@spar.SPAR.SLB.COM (David Singer) (11/17/87)
It seems that circular structures can remain un-reclaimed by the garbage
collector even when you have discarded all pointers into them. I wrote this
slow, simple, piece of code to help find such circularities (and thus,
one hopes, work out how to remove them). It's written in LispScript, but
since the LispScript program isn't available generally, I've included the
generated postscript. Have fun.
;;
;; Routine to find circular structures in postscript. A top-level
;; structure is searched, with its children, to the specified depth.
;; Circular structures are reported by printing a description of them.
(defun circular-member (v ar depth k)
(let ((l (length ar))
(ans (false)))
(for (add depth 1) 1 (sub l 1)
(lambda (x)
(if (eq (get ar x) v)
(let ()
(printf "Circularity from key %:
" [ k ])
(for (add depth 1) 1 x
(lambda (y)
(printf " % %
" [ (get ar y) (typeof (get ar y)) ])))))
(setq ans (or ans (eq (get ar x) v)))))
ans))
(defun circular-follow (item depth ar v k)
(foreign circular-1 (item depth ar) ())
;;(pause)
(put ar depth v)
(if (and (not (circular-member v ar depth k))
(gt depth 0))
(circular-1 v (sub depth 1) ar)))
(defun circular-1 (item depth ar)
(if (eq (type item) 'arraytype)
(for 0 1 (sub (length item) 1)
(lambda (k)
(circular-follow item depth ar (get item k) k)))
(if (or* (eq (type item) 'dicttype)
(eq (type item) 'eventtype)
;;(eq (type item) 'canvastype)
)
(forall item
(lambda (k v)
(circular-follow item depth ar v k))))))
;;; Here's the user entry point. Item is any structured item (array, dict,
;;; event or canvas).
;;;
(defun circular (item depth)
(let ((ar (array (add 1 depth))))
(put ar depth item)
(circular-1 item (sub depth 1) ar)))
--------
%! Lispscript generated file
/circular-member { false 3 index length 3 index 1 add 1 2 index 1 sub { 5 index
1 index get 7 index eq { (Circularity from key %:\n) [ 5 index ] printf 4 index
1 add 1 2 index { ( % %\n) [ 8 index 3 index get 9 index 4 index get typeof ]
printf pop } for } if 2 index 6 index 2 index get 8 index eq or 4 -1 roll pop 3
1 roll pop } for pop mark 6 2 roll cleartomark } def /circular-follow { 2 index
4 index 3 index put 1 index 3 index 5 index 3 index circular-member not 4 index
0 gt and { 1 index 4 index 1 sub 4 index circular-1 } if 5 { pop } repeat } def
/circular-1 { 2 index type /arraytype eq { 0 1 4 index length 1 sub { 3 index 3
index 3 index 6 index 4 index get 4 index circular-follow pop } for } { 2 index
type /dicttype eq 3 index type /eventtype eq or { 2 index { 4 index 4 index 4
index 3 index 5 index circular-follow pop pop } forall } if } ifelse pop pop
pop } def /circular { 1 1 index add array dup 2 index 4 index put 2 index 2
index 1 sub 2 index circular-1 pop pop pop } def
%%