diff -r 1e7e8e26f49f -r 3e2d43a9c517 Context.st --- 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