Context.st
changeset 16078 3e2d43a9c517
parent 16077 1e7e8e26f49f
child 16223 fa218a6b1caf
--- a/Context.st	Wed Feb 19 21:19:59 2014 +0100
+++ b/Context.st	Wed Feb 19 21:24:28 2014 +0100
@@ -2528,6 +2528,44 @@
     ^ true
 !
 
+isReallyRecursive
+    "return true, if this context is one of a recursive send of the same
+     selector AND same argument(s) to the same receiver before.
+     Here, different arguments are NOT ignored"
+
+    |c count "{Class: SmallInteger }" sameArgs|
+
+    count := 0.
+
+    c := self findNextContextWithSelector:selector or:nil or:nil.
+    [c notNil] whileTrue:[
+        (c receiver == receiver) ifTrue:[
+            c method == self method ifTrue:[
+                sameArgs := true.
+                1 to:self numArgs do:[:i |
+                    (c argAt:1) ~~ (self argAt:i)ifTrue:[
+                        sameArgs := false
+                    ]
+                ].
+                sameArgs ifTrue:[^ true].
+            ]
+        ].
+        c := c findNextContextWithSelector:selector or:nil or:nil.
+
+        "
+         this special test was added to get out after a while
+         if the sender chain is corrupt - this gives us at least
+         a chance to find those errors.
+        "
+        count := count + 1.
+        count >= 100000 ifTrue:[
+            'Context [warning]: bad context chain' errorPrintCR.
+            ^ true
+        ]
+    ].
+    ^ false
+!
+
 isRecursive
     "return true, if this context is one of a recursive send of the same
      selector to the same receiver before.
@@ -2535,7 +2573,7 @@
      counts for recursiveness.
      Used to detect recursive errors or recursive printing - for example."
 
-    |c count "{Class: SmallInteger }" myMethodsClass|
+    |c count "{Class: SmallInteger }"|
 
     count := 0.
 
@@ -2576,11 +2614,11 @@
 !Context class methodsFor:'documentation'!
 
 version
-    ^ '$Header: /cvs/stx/stx/libbasic/Context.st,v 1.196 2014-02-19 20:19:59 cg Exp $'
+    ^ '$Header: /cvs/stx/stx/libbasic/Context.st,v 1.197 2014-02-19 20:24:28 cg Exp $'
 !
 
 version_CVS
-    ^ '$Header: /cvs/stx/stx/libbasic/Context.st,v 1.196 2014-02-19 20:19:59 cg Exp $'
+    ^ '$Header: /cvs/stx/stx/libbasic/Context.st,v 1.197 2014-02-19 20:24:28 cg Exp $'
 !
 
 version_HG