--- a/CallChain.st	Sun Jul 04 10:06:24 2010 +0200
+++ b/CallChain.st	Sun Jul 04 10:06:27 2010 +0200
@@ -9,7 +9,6 @@
  other person.  No title to or ownership of the software is
  hereby transferred.
 "
-
 "{ Package: 'stx:libbasic3' }"
 
 Object subclass:#CallChain
@@ -54,6 +53,83 @@
 "
 ! !
 
+!CallChain class methodsFor:'instance creation'!
+
+callChainTo:aContext stopAtCallerForWhich:aBlock
+    "entered whenever the probed block gets interrupted;
+     generate a chain of callInfo objects to aContext"
+
+    "{ Pragma: +optSpeed }"
+
+    |con chain info atEnd sender home
+     recClass selector mthdClass|
+
+    con := aContext.
+    con isNil ifTrue:[^ nil].
+
+    "/ skip any intermediate contexts
+    [con receiver == Processor] whileTrue:[
+        con := con sender
+    ].
+
+    "got it - collect info from contexts"
+
+    "walk up"
+
+    con isNil ifTrue:[^ nil].
+    (aBlock value:con) ifTrue:[^ nil].
+
+    atEnd := false.
+
+    [atEnd] whileFalse:[
+        con isNil ifTrue:[
+            atEnd := true
+        ] ifFalse:[
+            sender := con sender.
+            sender isNil ifTrue:[
+                atEnd := true
+            ] ifFalse:[
+                (aBlock value:sender) ifTrue:[
+                    atEnd := true
+"/                ] ifFalse:[
+"/                    (sender isBlockContext) ifTrue:[
+"/                        (aBlock value:sender sender) ifTrue:[
+"/                            atEnd := true
+"/                        ]
+"/                    ]
+                ]
+            ]
+        ].
+        atEnd ifFalse:[
+            info := self basicNew.
+            home := con methodHome.
+
+            home isNil ifTrue:[
+                recClass := UndefinedObject.
+                selector := 'optimized'.
+                mthdClass := UndefinedObject.
+            ] ifFalse:[
+                recClass := home receiver class.
+                selector := home selector.
+                mthdClass := home methodClass.
+            ].
+
+            info 
+                receiver:recClass
+                selector:selector
+                class:mthdClass
+                isBlock:(con isBlockContext).
+            info rest:chain.
+            chain := info.
+            con := sender
+        ]
+    ].
+
+    ^ chain
+
+    "Created: / 04-07-2010 / 09:43:27 / cg"
+! !
+
 !CallChain methodsFor:'accessing'!
 
 isBlock
@@ -151,5 +227,9 @@
 !CallChain class methodsFor:'documentation'!
 
 version
-    ^ '$Header: /cvs/stx/stx/libbasic3/CallChain.st,v 1.13 2000-08-19 11:26:10 cg Exp $'
+    ^ '$Header: /cvs/stx/stx/libbasic3/CallChain.st,v 1.14 2010-07-04 08:06:27 cg Exp $'
+!
+
+version_CVS
+    ^ '$Header: /cvs/stx/stx/libbasic3/CallChain.st,v 1.14 2010-07-04 08:06:27 cg Exp $'
 ! !