From 0a4b5ed03a31220bfc40feceb1d4f513ce4d923e Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 12 Aug 2005 13:17:30 +0000
Subject: [PATCH] Try to prevent circular entity-reference chains from
 occurring.

---
 v7/src/runtime/uproc.scm | 40 ++++++++++++++++++++++++++++++++++------
 1 file changed, 34 insertions(+), 6 deletions(-)

diff --git a/v7/src/runtime/uproc.scm b/v7/src/runtime/uproc.scm
index a70fa8608..61e4ff790 100644
--- a/v7/src/runtime/uproc.scm
+++ b/v7/src/runtime/uproc.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: uproc.scm,v 1.18 2005/04/16 04:22:35 cph Exp $
+$Id: uproc.scm,v 1.19 2005/08/12 13:17:30 cph Exp $
 
 Copyright 1990,1991,1992,1995,1996,2003 Massachusetts Institute of Technology
 Copyright 2005 Massachusetts Institute of Technology
@@ -346,7 +346,9 @@ USA.
 (define-integrable (entity-extra entity)
   (system-pair-cdr entity))
 
-(define-integrable (set-entity-procedure! entity procedure)
+(define (set-entity-procedure! entity procedure)
+  (if (procedure-chains-to procedure entity)
+      (error:bad-range-argument procedure 'SET-ENTITY-PROCEDURE!))
   (system-pair-set-car! entity procedure))
 
 (define-integrable (set-entity-extra! entity extra)
@@ -367,7 +369,7 @@ USA.
 (define (%entity-extra/apply-hook? extra)
   ;; The wabbit cares about this one.
   (and (object-type? (ucode-type hunk3) extra)
-       (eq? apply-hook-tag (system-hunk3-cxr0 extra))))
+       (eq? (system-hunk3-cxr0 extra) apply-hook-tag)))
 
 (define apply-hook-tag
   "apply-hook-tag")
@@ -378,12 +380,14 @@ USA.
 (define-integrable (apply-hook-extra apply-hook)
   (system-hunk3-cxr2 (entity-extra apply-hook)))
 
-(define-integrable (set-apply-hook-procedure! apply-hook procedure)
+(define (set-apply-hook-procedure! apply-hook procedure)
+  (if (procedure-chains-to procedure apply-hook)
+      (error:bad-range-argument procedure 'SET-APPLY-HOOK-PROCEDURE!))
   (system-hunk3-set-cxr1! (entity-extra apply-hook) procedure))
 
 (define-integrable (set-apply-hook-extra! apply-hook procedure)
   (system-hunk3-set-cxr2! (entity-extra apply-hook) procedure))
-
+
 ;;;; Arity dispatched entities
 
 (define (make-arity-dispatched-procedure default . dispatched-cases)
@@ -400,4 +404,28 @@ USA.
        (vector? (entity-extra object))
        (fix:< 0 (vector-length (entity-extra object)))
        (eq? (vector-ref (entity-extra object) 0)
-	    (fixed-objects-item 'ARITY-DISPATCHER-TAG))))
\ No newline at end of file
+	    (fixed-objects-item 'ARITY-DISPATCHER-TAG))))
+
+(define (procedure-chains-to p1 p2)
+  (let loop ((p1 p1))
+    (if (eq? p1 p2)
+	#t
+	(if (%entity? p1)
+	    (cond ((%entity-is-apply-hook? p1)
+		   (loop (apply-hook-procedure p1)))
+		  ((arity-dispatched-procedure? p1)
+		   (let ((v (entity-extra p1)))
+		     (let ((n (vector-length v)))
+		       (let per-arity ((i 1))
+			 (if (< i n)
+			     (if (let ((p (vector-ref v i)))
+				   (and p
+					(loop p)))
+				 #t
+				 (per-arity (fix:+ i 1)))
+			     #f)))))
+		  (else
+		   (loop (entity-procedure p1))))
+	    
+	    
+	    #f))))
\ No newline at end of file
-- 
2.25.1