MessageTracer.st
author Claus Gittinger <cg@exept.de>
Mon, 27 Apr 1998 19:53:15 +0200
changeset 668 7cd41a86e7b2
parent 667 62df9b9b7664
child 691 17c3c522f1dc
permissions -rw-r--r--
renamed min/max - bad names on NeXT

"
 COPYRIGHT (c) 1994 by Claus Gittinger
	      All Rights Reserved

 This software is furnished under a license and may be used
 only in accordance with the terms of that license and with the
 inclusion of the above copyright notice.   This software may not
 be provided or otherwise made available to, or used by, any
 other person.  No title to or ownership of the software is
 hereby transferred.
"

Object subclass:#MessageTracer
	instanceVariableNames:'traceDetail'
	classVariableNames:'BreakpointSignal CallingLevel BreakBlock TraceSenderBlock
		TraceSenderBlock2 LeaveBreakBlock LeaveTraceBlock MethodCounts
		MethodMemoryUsage MethodTiming TraceFullBlock TraceFullBlock2
		ObjectWrittenBreakpointSignal ObjectCopyHolders'
	poolDictionaries:''
	category:'System-Debugging-Support'
!

!MessageTracer class methodsFor:'documentation'!

copyright
"
 COPYRIGHT (c) 1994 by Claus Gittinger
	      All Rights Reserved

 This software is furnished under a license and may be used
 only in accordance with the terms of that license and with the
 inclusion of the above copyright notice.   This software may not
 be provided or otherwise made available to, or used by, any
 other person.  No title to or ownership of the software is
 hereby transferred.
"
!

documentation
"
    This class provides a common home for the tracing
    facilities (originally, they where in Object, but have been moved to
    allow easier separation of development vs. runtime configurations.

    tracing execution of a block:

        MessageTracer trace:[ ... ]

        MessageTracer traceFull:[ ... ]

        (for system developper only:)

        MessageTracer debugTrace:[ ... ]


    trapping sends to a specific object:

        MessageTracer trap:anObject selector:aSelector
        ...
        MessageTracer untrap:anObject selector:aSelector
        or:
        MessageTracer untrap:anObject



    trapping some messages sent to a specific object:

        MessageTracer trap:anObject selectors:aCollectionOfSelectors
        ...
        MessageTracer untrap:anObject



    trapping any message sent to a specific object:

        MessageTracer trapAll:anObject
        ...
        MessageTracer untrap:anObject



    trapping evaluation of a specific method:

        MessageTracer trapMethod:aMethod
        ...
        MessageTracer unwrapMethod:aMethod



    trapping evaluation of a specific method with
    receiver being an instance of some class:

        MessageTracer trapMethod:aMethod forInstancesOf:aClass
        ...
        MessageTracer unwrapMethod:aMethod



    tracing sends to a specific object:

        MessageTracer trace:anObject selector:aSelector
        ...
        MessageTracer untrace:anObject selector:aSelector
        or:
        MessageTracer untrace:anObject



    tracing sender only:

        MessageTracer traceSender:anObject selector:aSelector
        ...
        MessageTracer untrace:anObject selector:aSelector
        or:
        MessageTracer untrace:anObject



    tracing evaluation of a specific method:

        MessageTracer traceMethod:aMethod
        ...
        MessageTracer unwrapmethod:aMethod

  see more in examples and in method comments.

    [author:]
        Claus Gittinger
"
!

examples
"
  For the common cases, you will find a menu entry in the SystemBrowser.
  Howeever, more special cases (especially with condition checks) can be
  set up by evaluating the lower level entries.


  trapping specific methods:
  (by class/selector):
                                                                        [exBegin]
     MessageTracer trapClass:Collection selector:#select:.
     Dictionary new select:[:e | ].       'not caught - Dictionary has its own select'.
     (Array new:10) select:[:e | ].       'not caught - SeqColl has its own select'.
     Set new select:[:e | ].              'caught - Set inherits this from Collection'.
     MessageTracer untrapClass:Collection 
                                                                        [exEnd]

  (by method):
                                                                        [exBegin]
     MessageTracer trapMethod:(Collection compiledMethodAt:#select:).
     Dictionary new select:[:e | ].       'not caught - Dictionary has its own select'.
     (Array new:10) select:[:e | ].       'not caught - SeqColl has its own select'.
     Set new select:[:e | ].              'caught - Set inherits this from Collection'.
     MessageTracer unwrapMethod:(Collection compiledMethodAt:#select:).
                                                                        [exEnd]

  (by method & instance class):
                                                                        [exBegin]
     MessageTracer trapMethod:(SequenceableCollection compiledMethodAt:#select:)
                   forInstancesOf:SortedCollection.
     Dictionary new select:[:e | ].       'not caught - Dictionary has its own select'.
     (Array new:10) select:[:e | ].       'not caught - not a SortedCollection'.
     OrderedCollection new select:[:e | ]. 'not caught - not a SortedCollection'.
     SortedCollection new select:[:e | ].  'caught - Set inherits this from Collection'.
     MessageTracer unwrapMethod:(SequenceableCollection compiledMethodAt:#select:).
                                                                        [exEnd]

  tracing specific methods:
  (by class/selector):
                                                                        [exBegin]
     MessageTracer traceClass:SequenceableCollection selector:#quickSortFrom:to:.
     #(6 1 9 66 2 17) copy sort.
     MessageTracer untraceClass:SequenceableCollection 
                                                                        [exEnd]

  (by method):
                                                                        [exBegin]
     MessageTracer traceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
     #(6 1 9 66 2 17) copy sort.
     MessageTracer unwrapMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:). 
                                                                        [exEnd]

  object trapping:
                                                                        [exBegin]
     |o|

     o := OrderedCollection new.
     MessageTracer trapAll:o.
     o collect:[:el | el].
                                                                        [exEnd]

  trapping modifications to an objects instVars:
									[exBegin]
     |o|

     o := Point new.
     MessageTracer trapModificationsIn:o.
     o x:1.
     o y:2.
     o x:1.
     o y:2.
     MessageTracer untrap:o
									[exEnd]

  trapping modifications of a particular instVar:
                                                                        [exBegin]
     |o|

     o := Point new.
     MessageTracer trapModificationsIn:o filter:[:old :new | old x ~~ new x].
     o x:1.
     o y:2.
     o x:1.
     o y:2.
     MessageTracer untrap:o
                                                                        [exEnd]
"
! !

!MessageTracer class methodsFor:'Signal constants'!

breakpointSignal
    ^ BreakpointSignal
!

objectWrittenBreakpointSignal
    ^ ObjectWrittenBreakpointSignal

    "Created: / 21.4.1998 / 14:38:49 / cg"
! !

!MessageTracer class methodsFor:'class initialization'!

initialize
    BreakpointSignal isNil ifTrue:[
        BreakpointSignal := HaltSignal newSignalMayProceed:true.
        BreakpointSignal nameClass:self message:#breakpointSignal.
        BreakpointSignal notifierString:'breakpoint encountered'.

        ObjectWrittenBreakpointSignal := BreakpointSignal newSignalMayProceed:true.
        ObjectWrittenBreakpointSignal nameClass:self message:#objectWrittenBreakpointSignal.
        ObjectWrittenBreakpointSignal notifierString:'object modified'.

        BreakBlock       := [:con | BreakpointSignal raiseIn:con].
        TraceSenderBlock  := [:con | MessageTracer printEntrySender:con on:(Smalltalk at:#Stderr)     ].
        TraceSenderBlock2 := [:con | MessageTracer printEntrySender:con on:(Smalltalk at:#Transcript) ].
        TraceFullBlock    := [:con | con fullPrintAllOn:(Smalltalk at:#Stderr)    ].
        TraceFullBlock2   := [:con | con fullPrintAllOn:(Smalltalk at:#Transcript)].
        LeaveBreakBlock  := [:con :retVal | ].
        LeaveTraceBlock  := [:con :retVal | ].
    ]

    "
     BreakpointSignal := nil.
     MessageTracer initialize
    "

    "Modified: / 21.4.1998 / 14:38:35 / cg"
! !

!MessageTracer class methodsFor:'class tracing'!

untraceAllClasses
    "remove all traces of messages sent to any class"

    "just a rename for your convenience - the same basic mechanism is used for all of these
     trace facilities ..."

    ^ self untrapAllClasses
!

untraceClass:aClass
    "remove all traces of messages sent to instances of aClass"

    "just a rename for your convenience - the same basic mechanism is used for all of these
     trace facilities ..."

    ^ self untrapClass:aClass
! !

!MessageTracer class methodsFor:'class wrapping'!

wrapClass:orgClass selector:aSelector onEntry:entryBlock onExit:exitBlock 
    "arrange for the two blocks entryBlock and exitBlock to be evaluated whenever
     aSelector is sent to instances of orgClass or subclasses. 
     EntryBlock will be called on entry, and get the current context passed as argument. 
     ExitBlock will be called, when the method is left, and get context and the methods return value as arguments.
    "

    |myMetaclass trapMethod s spec implClass newClass save dict|

    WrappedMethod autoload.     "/ just to make sure ...

    "
     create a new method, which calls the original one,
     but only if not already being trapped.
    "
    spec := Parser methodSpecificationForSelector:aSelector.

    s := WriteStream on:String new.
    s nextPutAll:spec.
    s cr.
    s nextPutAll:'|retVal stubClass|'; cr.
    entryBlock notNil ifTrue:[
        s nextPutAll:'#literal1 yourself value:thisContext.'; cr.
    ].
    s nextPutAll:('retVal := #originalMethod. ').    "/ just to get a literal to be replaced by theoriginal method
    s nextPutAll:('retVal := super ' , spec , '.'); cr.
    exitBlock notNil ifTrue:[
        s nextPutAll:'#literal2 yourself value:thisContext value:retVal.'; cr.
    ].
    s nextPutAll:'^ retVal'; cr.

    save := Compiler stcCompilation.
    Compiler stcCompilation:#never.
    [
        Class withoutUpdatingChangesDo:[
            trapMethod := Compiler compile:s contents 
                              forClass:orgClass 
                            inCategory:'trapping'
                             notifying:nil
                               install:false
                            skipIfSame:false
                                silent:true.
        ]
    ] valueNowOrOnUnwindDo:[
        Compiler stcCompilation:save
    ].

    implClass := orgClass whichClassIncludesSelector:aSelector.
    implClass isNil ifTrue:[
        Transcript showCR:aSelector , ' is not understood by ' , orgClass name.
    ] ifFalse:[
        trapMethod changeLiteral:#originalMethod to:(implClass compiledMethodAt:aSelector).
    ].
    entryBlock notNil ifTrue:[
        trapMethod changeLiteral:#literal1 to:entryBlock.
    ].
    exitBlock notNil ifTrue:[
        trapMethod changeLiteral:#literal2 to:exitBlock.
    ].

    "
     change the source of this new method
     (to avoid confusion in the debugger ...)
    "
    trapMethod source:'this is a wrapper method - not the real one'.
    trapMethod changeClassTo:WrappedMethod.

    dict := orgClass methodDictionary.

    "
     if not already trapping, create a new class
    "
    orgClass category == #'* trapping *' ifTrue:[
        dict at:aSelector put:trapMethod.
        orgClass methodDictionary:dict.
        newClass := orgClass superclass.
    ] ifFalse:[
        myMetaclass := orgClass class.

        newClass := myMetaclass copy new.
        newClass setSuperclass:orgClass superclass.
        newClass instSize:orgClass instSize.
        newClass flags:orgClass flags.
        newClass setClassVariableString:orgClass classVariableString.
        newClass setInstanceVariableString:orgClass instanceVariableString.
        newClass setName:orgClass name.
        newClass category:orgClass category.
        newClass methodDictionary:dict.      

        orgClass setSuperclass:newClass.
        orgClass setClassVariableString:''.
        orgClass setInstanceVariableString:''.
        orgClass category:#'* trapping *'.

        dict := MethodDictionary new:1.
        dict at:aSelector put:trapMethod.
        orgClass methodDictionary:dict.
    ].
    trapMethod changeLiteral:(newClass superclass) to:newClass.

    ObjectMemory flushCaches.

    "
     MessageTracer 
                wrapClass:Point
                 selector:#scaleBy:
                   onEntry:nil
                    onExit:[:con :retVal |
                               Transcript show:'leave Point>>scaleBy:; returning:'.
                               Transcript showCR:retVal printString.
                               Transcript endEntry
                           ].
     (1@2) scaleBy:5.   
     MessageTracer untrapClass:Point selector:#scaleBy:.  
     (1@2) scaleBy:5.         
    "
    "
     MessageTracer 
                wrapClass:Integer
                 selector:#factorial
                   onEntry:[:con |
                               Transcript showCR:('entering ' , con receiver printString , '>>factorial').
                           ]
                    onExit:[:con :retVal |
                               Transcript show:'leave Integer>>factorial; returning:'.
                               Transcript showCR:retVal printString.
                               Transcript endEntry
                           ].
     Transcript showCR:'5 factorial traced'.
     5 factorial.   
     MessageTracer untrapClass:Integer selector:#factorial.  
     Transcript showCR:'5 factorial normal'.
     5 factorial.         
    "
    "
     |lvl|

     lvl := 0.
     MessageTracer 
                wrapClass:Integer 
                 selector:#factorial 
                   onEntry:[:con |
                               Transcript spaces:lvl. lvl := lvl + 2.
                               Transcript showCR:('entering ' , con receiver printString , '>>factorial').
                           ]
                    onExit:[:con :retVal |
                               lvl := lvl - 2. Transcript spaces:lvl.
                               Transcript show:('leave ' , con receiver printString , '>>factorial; returning:').
                               Transcript showCR:retVal printString.
                               Transcript endEntry
                           ].
     Transcript showCR:'5 factorial traced'.
     5 factorial.   
     MessageTracer untrapClass:Integer selector:#factorial.  
     Transcript showCR:'5 factorial normal'.
     5 factorial.         
    "

    "Modified: 25.6.1996 / 22:01:05 / stefan"
    "Modified: 10.9.1996 / 20:07:01 / cg"
! !

!MessageTracer class methodsFor:'cleanup'!

cleanup
    "if you forgot which classes/methods where wrapped and/or trapped,
     this cleans up everything ..."

    self untrapAllClasses.
    self unwrapAllMethods

    "
     MessageTracer cleanup
    "
! !

!MessageTracer class methodsFor:'execution trace '!

debugTrace:aBlock
    "trace execution of aBlock. This is for system debugging only"

    Smalltalk sendTraceOn.
    ^ aBlock valueNowOrOnUnwindDo:[
        Smalltalk sendTraceOff.
    ]

    "
     MessageTracer debugTrace:[#(6 5 4 3 2 1) sort]
    "

    "Modified: 18.3.1996 / 19:49:36 / cg"
!

trace:aBlock
    "evaluate aBlock sending trace information to stdout.
     Return the value of the block."

    ^ self new trace:aBlock detail:false.

    "
     MessageTracer trace:[#(6 5 4 3 2 1) sort]
    "
!

traceFull:aBlock
    "evaluate aBlock sending trace information to stdout.
     Return the value of the block.
     The trace information is more detailed."

     ^ self new trace:aBlock detail:true.

    "
     MessageTracer traceFull:[#(6 5 4 3 2 1) sort]
    "
! !

!MessageTracer class methodsFor:'method breakpointing'!

trapClass:aClass selector:aSelector
    "arrange for the debugger to be entered when a message with aSelector is 
     sent to instances of aClass (or subclass instances). Use untrapClass to remove this trap.
     Be careful, to not place a trap on code needed in the debugger (i.e. on scrollBars etc.);
     if there is a need to trap those, use the low-level wrap-methods, and put a check into the
     entry/leave blocks."

    self trapMethod:(aClass compiledMethodAt:aSelector)

    "
     MessageTracer trapClass:Collection selector:#select:.
     Dictionary new select:[:e | ].       'not caught - Dictionary has its own select'.
     (Array new:10) select:[:e | ].       'not caught - SeqColl has its own select'.
     Set new select:[:e | ].              'caught - Set inherits this from Collection'.
     MessageTracer untrapClass:Collection 
    "
!

trapMethod:aMethod
    "arrange for the debugger to be entered when aMethod is about to be executed.
     The trap is enabled for any process - see #trapMethodInCurrentProcess: for a more
     selective breakPoint.
     Use unwrapMethod or untrapClass to remove this trap.
     Be careful, to not place a trap on code needed in the debugger (i.e. on scrollBars etc.);
     if there is a need to trap those, use the low-level wrap-methods, and put a check into the
     entry/leave blocks."

    ^ self wrapMethod:aMethod
              onEntry:BreakBlock
               onExit:LeaveBreakBlock.

    "
     MessageTracer trapMethod:(Collection compiledMethodAt:#select:).
     Dictionary new select:[:e | ].       'not caught - Dictionary has its own select'.
     (Array new:10) select:[:e | ].       'not caught - SeqColl has its own select'.
     Set new select:[:e | ].              'caught - Set inherits this from Collection'.
     MessageTracer unwrapMethod:(Collection compiledMethodAt:#select:).
    "

    "Modified: 22.10.1996 / 17:39:58 / cg"
!

trapMethod:aMethod forInstancesOf:aClass
    "arrange for the debugger to be entered when aMethod is about to be executed
     for an instance of aClass.
     Use unwrapMethod or untrapClass to remove this trap.
     Be careful, to not place a trap on code needed in the debugger (i.e. on scrollBars etc.);
     if there is a need to trap those, use the low-level wrap-methods, and put a check into the
     entry/leave blocks."

    ^ self wrapMethod:aMethod
              onEntry:[:context |
                         (context receiver isMemberOf:aClass) ifTrue:[
                             BreakpointSignal raiseIn:context
                         ]
                      ]
               onExit:LeaveBreakBlock.

    "
     MessageTracer trapMethod:(View compiledMethodAt:#redraw) forInstancesOf:myView.
    "

    "Modified: 22.10.1996 / 17:40:03 / cg"
!

trapMethod:aMethod inProcess:aProcess
    "arrange for the debugger to be entered when aMethod is about to be executed,
     but only, if executed in the current process.
     This allows for breakpoints to be set on system-critical code.
     The trap is enabled for any process.
     Use unwrapMethod or untrapClass to remove this trap.
     Be careful, to not place a trap on code needed in the debugger (i.e. on scrollBars etc.);
     if there is a need to trap those, use the low-level wrap-methods, and put a check into the
     entry/leave blocks."

    ^ self wrapMethod:aMethod
              onEntry:[:con | (Processor activeProcess == aProcess)
                              ifTrue:[
                                BreakpointSignal raiseIn:con
                              ]  
                      ]
               onExit:LeaveBreakBlock.

    "Created: 14.10.1996 / 15:38:46 / cg"
    "Modified: 22.10.1996 / 17:40:06 / cg"
!

untrapAllClasses
    "remove any traps on any class"

    Smalltalk allBehaviorsDo:[:aClass |
	self untrapClass:aClass
    ]

    "
     MessageTracer untrapAllClasses
    "
!

untrapClass:aClass
    "remove any traps on aClass"

    "this is done by just patching the class back to the original"

    |orgClass|

    aClass category == #'* trapping *' ifFalse:[
        ^ self
    ].
    orgClass := aClass superclass.

    aClass setSuperclass:orgClass superclass.
    aClass setClassVariableString:orgClass classVariableString.
    aClass setInstanceVariableString:orgClass instanceVariableString.
    aClass category:orgClass category.
    aClass methodDictionary:orgClass methodDictionary.

    ObjectMemory flushCaches.

    "
     MessageTracer untrapClass:Point
    "

    "Modified: 5.6.1996 / 13:57:39 / stefan"
    "Modified: 10.9.1996 / 20:06:23 / cg"
!

untrapClass:aClass selector:aSelector
    "remove trap of aSelector sent to aClass"

    |dict|

    aClass category == #'* trapping *' ifFalse:[
        ^ self
    ].

    dict := aClass methodDictionary.
    dict at:aSelector ifAbsent:[^ self].

    ObjectMemory flushCaches. "avoid calling the old trap method"

    dict size == 1 ifTrue:[
        "the last trapped method"
        ^ self untrapClass:aClass
    ].
    dict removeKey:aSelector.
    aClass methodDictionary:dict.

    "
     MessageTracer trapClass:Point selector:#copy.
     (1@2) copy.
     (1@2) deepCopy.
     MessageTracer trapClass:Point selector:#deepCopy.
     (1@2) copy.
     (1@2) deepCopy.
     MessageTracer untrapClass:Point selector:#copy.
     (1@2) copy.
     (1@2) deepCopy.
     MessageTracer untrapClass:Point selector:#deepCopy.
     (1@2) copy.
     (1@2) deepCopy.
    "

    "Modified: 5.6.1996 / 14:00:55 / stefan"
    "Modified: 10.9.1996 / 20:06:29 / cg"
!

untrapMethod:aMethod
    "remove break on aMethod"

    "just a rename for your convenience - the same basic mechanism is used for all of these
     trace facilities ..."

    ^ self unwrapMethod:aMethod
! !

!MessageTracer class methodsFor:'method counting'!

countMethod:aMethod
    "arrange for a aMethods execution to be counted.
     Use unwrapMethod to remove this."

    MethodCounts isNil ifTrue:[
	MethodCounts := IdentityDictionary new.
    ].
    MethodCounts at:aMethod put:0.

    ^ self wrapMethod:aMethod
	 onEntry:[:con |
			|cnt|

			cnt := MethodCounts at:aMethod ifAbsent:0.
			MethodCounts at:aMethod put:(cnt + 1).
		 ]
	 onExit:[:con :retVal |
		]

    "
     MessageTracer countMethod:(Integer compiledMethodAt:#factorial).
     5 factorial.
     MessageTracer executionCountOf:(Integer compiledMethodAt:#factorial) printNL. 
     MessageTracer stopCountingMethod:(Integer compiledMethodAt:#factorial) 
    "

    "Created: 15.12.1995 / 10:57:49 / cg"
    "Modified: 15.12.1995 / 15:46:41 / cg"
!

executionCountOfMethod:aMethod
    "return the current count"

    |count|

    MethodCounts isNil ifTrue:[^ 0].
    aMethod isWrapped ifTrue:[
	count := MethodCounts at:aMethod originalMethod ifAbsent:nil.
	count notNil ifTrue:[^ count].
    ].
    ^  MethodCounts at:aMethod ifAbsent:0

    "Created: 15.12.1995 / 11:01:56 / cg"
    "Modified: 15.12.1995 / 15:45:15 / cg"
!

stopCountingMethod:aMethod
    "remove counting of aMethod"

    ^ self unwrapMethod:aMethod

    "Modified: 15.12.1995 / 15:43:53 / cg"
! !

!MessageTracer class methodsFor:'method memory usage'!

countMemoryUsageOfMethod:aMethod
    "arrange for aMethods memory usage to be counted.
     Use unwrapMethod to remove this."

    |oldPriority oldScavengeCount oldNewUsed|

    MethodCounts isNil ifTrue:[
	MethodCounts := IdentityDictionary new.
    ].
    MethodMemoryUsage isNil ifTrue:[
	MethodMemoryUsage := IdentityDictionary new.
    ].

    MethodCounts at:aMethod put:0.
    MethodMemoryUsage at:aMethod put:0.

    ^ self wrapMethod:aMethod
	 onEntry:[:con |
			oldPriority := Processor activeProcess changePriority:(Processor userInterruptPriority).
			oldNewUsed := ObjectMemory newSpaceUsed.
			oldScavengeCount := ObjectMemory scavengeCount.
		 ]
	 onExit:[:con :retVal |
	     |cnt memUse scavenges|

	     memUse := ObjectMemory newSpaceUsed - oldNewUsed.
	     scavenges := ObjectMemory scavengeCount - oldScavengeCount.
	     scavenges ~= 0 ifTrue:[
		memUse := memUse + (ObjectMemory newSpaceSize * scavenges)
	     ].

	     MethodCounts notNil ifTrue:[
		 cnt := MethodCounts at:aMethod ifAbsent:0.
		 MethodCounts at:aMethod put:(cnt + 1).
	     ].
	     MethodMemoryUsage notNil ifTrue:[
		 cnt := MethodMemoryUsage at:aMethod ifAbsent:0.
		 MethodMemoryUsage at:aMethod put:(cnt + memUse).
	     ].
	     Processor activeProcess priority:oldPriority                
	 ]
	 onUnwind:[
	     oldPriority notNil ifTrue:[
		 Processor activeProcess priority:oldPriority
	     ]
	 ]

    "
     MessageTracer countMemoryUsageOfMethod:(Integer compiledMethodAt:#factorial).
     3 factorial.
     (MessageTracer memoryUsageOfMethod:(Integer compiledMethodAt:#factorial)) printNL. 
     MessageTracer stopCountingMemoryUsageOfMethod:(Integer compiledMethodAt:#factorial) 
    "

    "Created: 18.12.1995 / 15:41:27 / stefan"
    "Modified: 18.12.1995 / 21:46:48 / stefan"
!

isCountingMemoryUsage:aMethod
    "return true if aMethod is counting memoryUsage"

    MethodMemoryUsage isNil ifTrue:[^ false].
    (MethodMemoryUsage includesKey:aMethod) ifTrue:[^ true].
    aMethod isWrapped ifTrue:[
	^ MethodMemoryUsage includesKey:aMethod originalMethod
    ].
    ^ false

    "Created: 18.12.1995 / 15:51:49 / stefan"
!

memoryUsageOfMethod:aMethod
    "return the current count"

    |count memUse|

    (MethodCounts isNil or:[MethodMemoryUsage isNil]) ifTrue:[^ 0].
    aMethod isWrapped ifTrue:[
	count := MethodCounts at:aMethod originalMethod ifAbsent:nil.
	memUse := MethodMemoryUsage at:aMethod originalMethod ifAbsent:nil.
    ].
    memUse isNil ifTrue:[
	count := MethodCounts at:aMethod ifAbsent:0.
	memUse := MethodMemoryUsage at:aMethod ifAbsent:0.
    ].
    count = 0 ifTrue:[^ 0].
    ^ memUse//count

    "Modified: 18.12.1995 / 16:25:51 / stefan"
!

stopCountingMemoryUsageOfMethod:aMethod
    "remove counting memory of aMethod"

    ^ self unwrapMethod:aMethod

    "Modified: 18.12.1995 / 21:54:36 / stefan"
! !

!MessageTracer class methodsFor:'method timing'!

executionTimesOfMethod:aMethod
    "return the current times"

    |count info minT maxT avg ret|

    count := minT := maxT := avg := 0.
    MethodTiming notNil ifTrue:[
        aMethod isWrapped ifTrue:[
            info := MethodTiming at:aMethod originalMethod ifAbsent:nil.
            info notNil ifTrue:[
                count := info at:1.
                count ~~ 0 ifTrue:[
                    minT := info at:2.
                    maxT := info at:3.
                    avg := ((info at:4) / count) roundTo:0.01
                ]
            ].
        ].
    ].

    ret := IdentityDictionary new.
    ret at:#count put:count.
    ret at:#minTime put:minT.
    ret at:#maxTime put:maxT.
    ret at:#avgTime put:avg.
    ^ ret

    "Created: 17.6.1996 / 17:07:30 / cg"
    "Modified: 11.4.1997 / 17:16:11 / cg"
!

stopTimingMethod:aMethod
    "remove timing of aMethod"

    ^ self unwrapMethod:aMethod

    "Modified: 15.12.1995 / 15:43:53 / cg"
    "Created: 17.6.1996 / 17:04:03 / cg"
!

timeMethod:aMethod
    "arrange for a aMethods execution time to be measured.
     Use unwrapMethod to remove this."

    |t0|

    MethodTiming isNil ifTrue:[
        MethodTiming := IdentityDictionary new.
    ].
    MethodTiming removeKey:aMethod ifAbsent:nil.
    MethodTiming at:aMethod put:(Array with:0
                                       with:0
                                       with:0
                                       with:0).

    ^ self wrapMethod:aMethod
         onEntry:[:con |
                        t0 := OperatingSystem getMillisecondTime.
                 ]
         onExit:[:con :retVal |
                        |info t cnt minT maxT sumTimes|

                        t := OperatingSystem getMillisecondTime - t0.
                        info := MethodTiming at:aMethod ifAbsent:nil.
                        info isNil ifTrue:[
                            MethodTiming at:aMethod put:(Array with:1
                                                               with:t
                                                               with:t
                                                               with:t)
                        ] ifFalse:[
                            cnt := info at:1.
                            minT := info at:2.
                            maxT := info at:3.
                            sumTimes := info at:4.
                            t < minT ifTrue:[
                                info at:2 put:t
                            ] ifFalse:[
                                t > maxT ifTrue:[
                                    info at:3 put:t
                                ]
                            ].
                            info at:4 put:(sumTimes + t).
                            info at:1 put:cnt + 1
                        ].
                ]

    "
     MessageTracer timeMethod:(Integer compiledMethodAt:#factorial).
     5 factorial.
     5 factorial.
     5 factorial.
     (MessageTracer executionTimesOfMethod:(Integer compiledMethodAt:#factorial)) printCR. 
     MessageTracer stopTimingMethod:(Integer compiledMethodAt:#factorial) 
    "

    "Created: 17.6.1996 / 17:03:50 / cg"
    "Modified: 11.4.1997 / 17:15:29 / cg"
! !

!MessageTracer class methodsFor:'method tracing'!

traceClass:aClass selector:aSelector
    "arrange for a trace message to be output on Stderr, when a message with aSelector is
     sent to instances of aClass (or subclass instances). Use untraceClass to remove this."

    self traceClass:aClass selector:aSelector on:Stderr

    "
     MessageTracer traceClass:Integer selector:#factorial.
     5 factorial.
     MessageTracer untraceClass:Integer 
    "
    "
     MessageTracer traceClass:SequenceableCollection selector:#quickSortFrom:to:.
     #(6 1 9 66 2 17) copy sort.
     MessageTracer untraceClass:SequenceableCollection 
    "
    "
     MessageTracer traceClass:Array selector:#at:.
     MessageTracer traceClass:Array selector:#at:put:.
     #(6 1 9 66 2 17) copy sort.
     MessageTracer untraceClass:Array 
    "
!

traceClass:aClass selector:aSelector on:aStream
    "arrange for a trace message to be output on aStream, when a message with aSelector is
     sent to instances of aClass (or subclass instances). Use untraceClass to remove this."

    self traceMethod:(aClass compiledMethodAt:aSelector) on:aStream

    "
     MessageTracer traceClass:Integer selector:#factorial on:Transcript.
     5 factorial.
     MessageTracer untraceClass:Integer 
    "
    "
     MessageTracer traceClass:Integer selector:#factorialR on:Transcript.
     5 factorialR.
     MessageTracer untraceClass:Integer 
    "

!

traceMethod:aMethod
    "arrange for a trace message to be output on Stderr, 
     when aMethod is executed. Traces both entry and exit.
     Use unwrapMethod to remove this."

    ^ self traceMethod:aMethod on:Stderr

    "
     MessageTracer traceMethod:(Integer compiledMethodAt:#factorial).
     5 factorial.
     MessageTracer untraceMethod:(Integer compiledMethodAt:#factorial) 
    "
    "
     MessageTracer traceMethod:(Integer compiledMethodAt:#factorialR).
     5 factorialR.
     MessageTracer untraceMethod:(Integer compiledMethodAt:#factorialR) 
    "
    "
     MessageTracer traceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
     #(6 1 9 66 2 17) copy sort.
     MessageTracer untraceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:). 
    "
    "
     dont do this:
    "
    "
     MessageTracer traceMethod:(Object compiledMethodAt:#at:).
     MessageTracer traceMethod:(Object compiledMethodAt:#at:put:).
     #(6 1 9 66 2 17) copy sort.
     MessageTracer untraceMethod:(Object compiledMethodAt:#at:).
     MessageTracer untraceMethod:(Object compiledMethodAt:#at:put:).
    "
!

traceMethod:aMethod on:aStream
    "arrange for a trace message to be output on aStream, 
     when aMethod is executed. Traces both entry and exit.
     Use unwrapMethod to remove this."

    |lvl inside|

    ^ self wrapMethod:aMethod
         onEntry:[:con |
                        inside isNil ifTrue:[
                            inside := true.
                            CallingLevel isNil ifTrue:[
                                CallingLevel := 0.
                            ].
                            lvl notNil ifTrue:[
                                lvl := lvl + 1
                            ] ifFalse:[
                                CallingLevel := lvl := CallingLevel + 1.
                            ].
                            MessageTracer printEntryFull:con level:lvl on:aStream.
                            inside := nil
                        ]
                 ]
         onExit:[:con :retVal |
                        inside isNil ifTrue:[
                            inside := true.
                            MessageTracer printExit:con with:retVal level:lvl on:aStream.
                            CallingLevel := lvl := lvl - 1.
                            inside := nil
                        ]
                ]

    "
     MessageTracer traceMethod:(Integer compiledMethodAt:#factorial) on:Transcript.
     5 factorial.
     MessageTracer untraceMethod:(Integer compiledMethodAt:#factorial) 
    "
    "
     MessageTracer traceMethod:(Integer compiledMethodAt:#factorialR) on:Transcript.
     5 factorialR.
     MessageTracer untraceMethod:(Integer compiledMethodAt:#factorialR) 
    "
    "
     MessageTracer traceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:) on:Transcript.
     #(6 1 9 66 2 17) copy sort.
     MessageTracer untraceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:). 
    "
!

traceMethodAll:aMethod
    "arrange for a full trace message to be output on Stderr, when amethod is executed.
     Only the sender is traced on entry.
     Use untraceMethod to remove this trace."

    ^ self wrapMethod:aMethod
              onEntry:[:con | ObjectMemory flushCaches. Smalltalk sendTraceOn.] 
              onExit:[:con :val | Smalltalk sendTraceOff.]

    "Modified: 22.3.1997 / 17:02:04 / cg"
!

traceMethodEntry:aMethod
    "arrange for a trace message to be output on stdErr, 
     when aMethod is executed. Only entry is traced.
     Use unwrapMethod to remove this."

    ^ self traceMethodEntry:aMethod on:Stderr

    "
     MessageTracer traceMethodEntry:(Integer compiledMethodAt:#factorial).
     5 factorial.
     MessageTracer untraceMethod:(Integer compiledMethodAt:#factorial) 
    "
    "
     MessageTracer traceMethodEntry:(Integer compiledMethodAt:#factorialR).
     5 factorialR.
     MessageTracer untraceMethod:(Integer compiledMethodAt:#factorialR) 
    "
    "
     MessageTracer traceMethodEntry:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
     #(6 1 9 66 2 17) copy sort.
     MessageTracer untraceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:). 
    "
!

traceMethodEntry:aMethod on:aStream
    "arrange for a trace message to be output on aStream, 
     when aMethod is executed. Only entry is traced.
     Use unwrapMethod to remove this."

    |lvl inside|

    ^ self wrapMethod:aMethod
         onEntry:[:con |
                        inside isNil ifTrue:[
                            inside := true.
                            CallingLevel isNil ifTrue:[
                                CallingLevel := 0.
                            ].
                            lvl notNil ifTrue:[
                                lvl := lvl + 1
                            ] ifFalse:[
                                CallingLevel := lvl := CallingLevel + 1.
                            ].
                            MessageTracer printEntryFull:con level:lvl on:aStream.
                            inside := nil
                        ]
                 ]
         onExit:[:con :retVal |]

    "
     MessageTracer traceMethodEntry:(Integer compiledMethodAt:#factorial) on:Transcript.
     5 factorial.
     MessageTracer untraceMethod:(Integer compiledMethodAt:#factorial) 
    "
    "
     MessageTracer traceMethodEntry:(Integer compiledMethodAt:#factorialR) on:Transcript.
     5 factorialR.
     MessageTracer untraceMethod:(Integer compiledMethodAt:#factorialR) 
    "
    "
     MessageTracer traceMethodEntry:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:) on:Transcript.
     #(6 1 9 66 2 17) copy sort.
     MessageTracer untraceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:). 
    "
!

traceMethodFull:aMethod
    "arrange for a full trace message to be output on Stderr, when amethod is executed.
     Only the sender is traced on entry.
     Use untraceMethod to remove this trace."

    ^ self traceMethodFull:aMethod on:Stderr

    "Created: 15.12.1995 / 18:19:31 / cg"
    "Modified: 22.10.1996 / 17:39:28 / cg"
!

traceMethodFull:aMethod on:aStream
    "arrange for a full trace message to be output on Stderr, when aMethod is executed.
     Only the sender is traced on entry.
     Use untraceMethod to remove this trace."

    ^ self 
        wrapMethod:aMethod
        onEntry:(self traceFullBlockFor:aStream) 
        onExit:LeaveTraceBlock.

    "Created: 15.12.1995 / 18:19:31 / cg"
    "Modified: 22.10.1996 / 17:39:28 / cg"
!

traceMethodSender:aMethod
    "arrange for a trace message to be output on Stderr, 
     when amethod is executed.
     Only the sender is traced on entry.
     Use untraceMethod to remove this trace."

    ^ self traceMethodSender:aMethod on:Stderr
!

traceMethodSender:aMethod on:aStream
    "arrange for a trace message to be output on Stderr, when amethod is executed.
     Only the sender is traced on entry.
     Use untraceMethod to remove this trace."

    ^ self 
        wrapMethod:aMethod
        onEntry:(self traceSenderBlockFor:aStream) 
        onExit:LeaveTraceBlock.

    "Modified: 22.10.1996 / 17:39:33 / cg"
!

untraceMethod:aMethod
    "remove tracing of aMethod"

    "just a rename for your convenience - the same basic mechanism is used for all of these
     trace facilities ..."

    ^ self unwrapMethod:aMethod
! !

!MessageTracer class methodsFor:'method wrapping'!

unwrapAllMethods
    "just in case you dont know what methods have break/trace-points
     on them; this removes them all"

    WrappedMethod allInstancesDo:[:aMethod |
	self unwrapMethod:aMethod
    ]
!

unwrapMethod:aMethod 
    "remove any wrapper on aMethod"

    |selector class originalMethod dict mthd|

    MethodCounts notNil ifTrue:[
        aMethod isWrapped ifTrue:[
            MethodCounts removeKey:aMethod originalMethod ifAbsent:nil.
        ].
        MethodCounts removeKey:aMethod ifAbsent:nil.
        MethodCounts isEmpty ifTrue:[MethodCounts := nil].
    ].
    MethodMemoryUsage notNil ifTrue:[
        aMethod isWrapped ifTrue:[
            MethodMemoryUsage removeKey:aMethod originalMethod ifAbsent:nil.
        ].
        MethodMemoryUsage removeKey:aMethod ifAbsent:nil.
        MethodMemoryUsage isEmpty ifTrue:[MethodMemoryUsage := nil].
    ].
    MethodTiming notNil ifTrue:[
        aMethod isWrapped ifTrue:[
            MethodTiming removeKey:aMethod originalMethod ifAbsent:nil.
        ].
        MethodTiming removeKey:aMethod ifAbsent:nil.
        MethodTiming isEmpty ifTrue:[MethodTiming := nil].
    ].

    CallingLevel := 0.

    (aMethod isNil or:[aMethod isWrapped not]) ifTrue:[
        ^ aMethod
    ].

    "
     get class/selector
    "
    class := aMethod containingClass.
    class isNil ifTrue:[
        'MessageTracer [info]: no containing class for method found' infoPrintCR.
        ^ aMethod
    ].
    selector := class selectorAtMethod:aMethod.

    originalMethod := aMethod originalMethod.
    originalMethod isNil ifTrue:[
        self error:'oops, could not find original method'.
        ^ aMethod
    ].

    dict := class methodDictionary.
    mthd := dict at:selector ifAbsent:nil.
    mthd notNil ifTrue:[
        dict at:selector put:originalMethod.
        class methodDictionary:dict.
    ] ifFalse:[
        'MessageTracer [info]: no containing class for method found' infoPrintCR.
"/        self halt:'oops, unexpected error - cannot remove wrap'.
        aMethod becomeSameAs:originalMethod.
        ^ aMethod
    ].

    ObjectMemory flushCaches.
    class changed:#methodTrap with:selector. "/ tell browsers
    ^ originalMethod

    "Modified: 5.6.1996 / 14:08:08 / stefan"
    "Modified: 24.4.1997 / 18:20:49 / cg"
!

wrapMethod:aMethod onEntry:entryBlock onExit:exitBlock
    ^ self wrapMethod:aMethod onEntry:entryBlock onExit:exitBlock onUnwind:nil

    "Modified: 18.12.1995 / 15:58:12 / stefan"
!

wrapMethod:aMethod onEntry:entryBlock onExit:exitBlock onUnwind:unwindBlock
    "arrange for the two blocks entryBlock and exitBlock to be evaluated whenever
     aMethod is evaluated. 
     EntryBlock will be called on entry, and gets the current context passed as argument. 
     ExitBlock will be called, when the method is left, and gets the context and 
     the methods return value as arguments.
     UnwindBlock will be called when the contxt of aMethod is unwound.
     If there is an unwindBlock, the entry and exitBlocks will be called within the unwind block,
     because allocating the unwindBlock uses memory and some users want to count allocated memory.
    "

    |selector class trapMethod s spec src dict sel save|

    CallingLevel := 0.

    "
     create a new method, which calls the original one,
     but only if not already being trapped.
    "
    (aMethod isNil or:[aMethod isWrapped]) ifTrue:[
        ^ aMethod
    ].
    aMethod isLazyMethod ifTrue:[
        aMethod makeRealMethod
    ].

    "
     get class/selector
    "
    class := aMethod containingClass.
    class isNil ifTrue:[
        self error:'cannot place trap (no containing class found)'.
        ^ aMethod
    ].
    selector := class selectorAtMethod:aMethod.


    WrappedMethod autoload. "/ for small systems

    "
     get a new method-spec
    "
    spec := Parser methodSpecificationForSelector:selector.

    "
     create a method, executing the trap-blocks and the original method via a direct call
    "
    s := WriteStream on:String new.
    s nextPutAll:spec.
    s nextPutAll:' |retVal context| '.
    s nextPutAll:' context := thisContext.'.
    unwindBlock notNil ifTrue:[
        s nextPutAll:'['.
    ].
    entryBlock notNil ifTrue:[
        s nextPutAll:'#entryBlock yourself value:context. '.
    ].
    s nextPutAll:'retVal := #originalMethod yourself';
      nextPutAll:             ' valueWithReceiver:(context receiver)'; 
      nextPutAll:             ' arguments:(context args)';
      nextPutAll:             ' selector:(context selector)'; 
      nextPutAll:             ' search:(context searchClass)';
      nextPutAll:             ' sender:nil. '.

    exitBlock notNil ifTrue:[
        s nextPutAll:'#exitBlock yourself value:context value:retVal.'.
    ].
    unwindBlock notNil ifTrue:[
        s nextPutAll:'] valueOnUnwindDo:#unwindBlock yourself.'.
    ].
    s nextPutAll:'^ retVal'; cr.

    src := s contents.
    save := Compiler stcCompilation.
    Compiler stcCompilation:#never.
    [
        Class withoutUpdatingChangesDo:[
            trapMethod := Compiler compile:src 
                              forClass:UndefinedObject 
                            inCategory:aMethod category
                             notifying:nil
                               install:false
                            skipIfSame:false
                                silent:true.
        ]
    ] valueNowOrOnUnwindDo:[
        Compiler stcCompilation:save
    ].

    trapMethod changeClassTo:WrappedMethod.

    "
     raising our eyebrows here ...
    "
    entryBlock notNil ifTrue:[
        trapMethod changeLiteral:#entryBlock to:entryBlock.
    ].
    trapMethod changeLiteral:#originalMethod to:aMethod.
    exitBlock notNil ifTrue:[
        trapMethod changeLiteral:#exitBlock to:exitBlock.
    ].
    unwindBlock notNil ifTrue:[
        trapMethod changeLiteral:#unwindBlock to:unwindBlock.
    ].
    "
     change the source of this new method
     (to avoid confusion in the debugger ...)
    "
    trapMethod source:'this is a wrapper method - not the real one'.

    dict := class methodDictionary.
    sel := dict at:selector ifAbsent:[0].
    sel == 0 ifTrue:[
        self halt:'oops, unexpected error'.
        ^ aMethod
    ].

    dict at:selector put:trapMethod.
    class methodDictionary:dict.
    ObjectMemory flushCaches.
    ^ trapMethod

    "
     MessageTracer 
                wrapMethod:(Point compiledMethodAt:#scaleBy:) 
                   onEntry:nil
                    onExit:[:con :retVal |
                               Transcript show:'leave Point>>scaleBy:; returning:'.
                               Transcript showCR:retVal printString.
                               Transcript endEntry
                           ].
     (1@2) scaleBy:5.   
     MessageTracer unwrapMethod:(Point compiledMethodAt:#scaleBy:).  
     (1@2) scaleBy:5.         
    "
    "
     MessageTracer 
                wrapMethod:(Integer compiledMethodAt:#factorial) 
                   onEntry:[:con |
                               Transcript showCR:('entering ' , con receiver printString , '>>factorial').
                           ]
                    onExit:[:con :retVal |
                               Transcript show:'leave Integer>>factorial; returning:'.
                               Transcript showCR:retVal printString.
                               Transcript endEntry
                           ].
     Transcript showCR:'5 factorial traced'.
     5 factorial.   
     MessageTracer unwrapMethod:(Integer compiledMethodAt:#factorial).  
     Transcript showCR:'5 factorial normal'.
     5 factorial.         
    "
    "
     |lvl|

     lvl := 0.
     MessageTracer 
                wrapMethod:(Integer compiledMethodAt:#factorial) 
                   onEntry:[:con |
                               Transcript spaces:lvl. lvl := lvl + 2.
                               Transcript showCR:('entering ' , con receiver printString , '>>factorial').
                           ]
                    onExit:[:con :retVal |
                               lvl := lvl - 2. Transcript spaces:lvl.
                               Transcript show:('leave ' , con receiver printString , '>>factorial; returning:').
                               Transcript showCR:retVal printString.
                               Transcript endEntry
                           ].
     Transcript showCR:'5 factorial traced'.
     5 factorial.   
     MessageTracer unwrapMethod:(Integer compiledMethodAt:#factorial).  
     Transcript showCR:'5 factorial normal'.
     5 factorial.         
    "

    "Modified: 25.6.1996 / 22:04:51 / stefan"
    "Modified: 22.3.1997 / 17:00:43 / cg"
! !

!MessageTracer class methodsFor:'object breakpointing'!

objectHasWraps:anObject
    "return true, if anObject has any wraps"

    ^ anObject class category == #'* trapping *'
!

realClassOf:anObject
    "return anObjects real class"

    (anObject class category == #'* trapping *') ifFalse:[
        ^ anObject class
    ].
    ^ anObject class superclass
!

trap:anObject selector:aSelector
    "arrange for the debugger to be entered when a message with aSelector is 
     sent to anObject. Use untrap to remove this trap.
     The current implementation does not allow integers or nil to be trapped."

    self wrap:anObject
         selector:aSelector
         onEntry:BreakBlock
         onExit:LeaveBreakBlock.

    "
     |p|

     p := Point new.
     MessageTracer trap:p selector:#x:.
     p x:5
    "

    "Modified: 22.10.1996 / 17:39:41 / cg"
!

trap:anObject selectors:aCollection
    self wrap:anObject
         selectors:aCollection
         onEntry:BreakBlock
         onExit:LeaveBreakBlock.

    "Modified: 22.10.1996 / 17:39:50 / cg"
!

trapAll:anObject
    "trap on all messages which are understood by anObject"

    self wrapAll:anObject
         onEntry:BreakBlock
         onExit:LeaveBreakBlock.

    "Modified: 22.10.1996 / 17:39:54 / cg"
!

trapAll:anObject from:aClass
    "trap on all messages defined in aClass sent to anObject"

    self trap:anObject selectors:aClass selectors

    "Modified: 5.6.1996 / 13:46:06 / stefan"
!

untrap:anObject
    "remove any traps on anObject"

    "this is done by just patching the objects class back to the original"

    |orgClass|

    orgClass := anObject class.
    orgClass category == #'* trapping *' ifFalse:[
        ^ self
    ].

    anObject changeClassTo:orgClass superclass.
    ObjectCopyHolders notNil ifTrue:[
	ObjectCopyHolders removeKey:anObject ifAbsent:nil.
    ].

    "
     |p|

     p := Point new copy.
     MessageTracer trace:p selector:#x:.
     MessageTracer trace:p selector:#y:.
     p y:1.
     p x:2.
     MessageTracer untrap:p
     p y:2.
     p x:1.
    "

    "Modified: / 21.4.1998 / 15:43:33 / cg"
!

untrap:anObject selector:aSelector
    "remove trap on aSelector from anObject"

    |orgClass dict|

    orgClass := anObject class.
    orgClass category == #'* trapping *' ifFalse:[^ self].

    dict := orgClass methodDictionary.
    dict at:aSelector ifAbsent:[^ self].

    dict size == 1 ifTrue:[
        "the last trap got removed"
        anObject changeClassTo:orgClass superclass.
        ObjectCopyHolders notNil ifTrue:[
            ObjectCopyHolders removeKey:anObject ifAbsent:nil.
	].
        ^ self
    ].
    dict removeKey:aSelector.
    orgClass methodDictionary:dict.
    ObjectMemory flushCaches. "avoid calling the old trap method"

    "
     |p|

     p := Point new copy.
     MessageTracer trace:p selector:#x:.
     MessageTracer trace:p selector:#y:.
     'trace both ...' errorPrintNL.
     p x:2.
     p y:1.
     'trace only y ...' errorPrintNL.
     MessageTracer untrap:p selector:#x:.
     p x:2.
     p y:1.
     'trace none ...' errorPrintNL.
     MessageTracer untrap:p selector:#y:.
     p x:2.
     p y:1.
    "

    "Modified: / 5.6.1996 / 13:56:08 / stefan"
    "Modified: / 21.4.1998 / 15:43:55 / cg"
!

wrappedSelectorsOf:anObject
    "return the set of wrapped selectors (if any)"

    (anObject class category == #'* trapping *') ifFalse:[
        ^ #()
    ].
    ^ anObject class selectors
! !

!MessageTracer class methodsFor:'object modification traps'!

trapModificationsIn:anObject
    "trap modifications in anObject"

    anObject isNil ifTrue:[^ self].
    anObject isSymbol ifTrue:[^ self].
    anObject class == SmallInteger ifTrue:[^ self].
    anObject == true ifTrue:[^ self].
    anObject == false ifTrue:[^ self].

    self 
        trapModificationsIn:anObject filter:[:old :new | true]

    "
     |a|

     a := Array new:10.
     MessageTracer trapModificationsIn:a.

     a size.
     a at:1.
     a at:2 put:nil.
     a at:2 put:2.
     a at:2.
     a at:3.
     a at:2 put:2.
     a at:2 put:3.
     MessageTracer untrace:a.
     a at:3 put:5.
    "

    "Created: / 21.4.1998 / 14:32:34 / cg"
    "Modified: / 21.4.1998 / 14:58:24 / cg"
!

trapModificationsIn:anObject filter:aFilterBlock
    "trap modifications in anObject"

    |allSelectors|

    allSelectors := IdentitySet new.
    anObject class withAllSuperclasses do:[:aClass |
        aClass methodDictionary keys addAllTo:allSelectors
    ].
    allSelectors remove:#class.

    self trapModificationsIn:anObject selectors:allSelectors filter:aFilterBlock

    "trap if arrays 5th slot is modified:

     |a|

     a := Array new:10.
     MessageTracer trapModificationsIn:a filter:[:old :new | (old at:5) ~~ (new at:5)].

     a size.
     a at:1.
     a at:2 put:nil.
     a at:2 put:2.
     a at:2.
     a at:3.
     a at:2 put:2.
     a at:2 put:3.
     a at:5 put:3.
     a at:5 put:3.
     MessageTracer untrace:a.
     a at:3 put:5.
    "

    "Modified: / 21.4.1998 / 15:53:38 / cg"
!

trapModificationsIn:anObject selector:aSelector filter:aFilterBlock
    "install a trap for modifications in anObject by aSelector-messages.
     the filterBlock will be invoked (after a modification) with the old and
     new values as arguments and should return true, 
     if the debugger is really wanted."

    self
        trapModificationsIn:anObject 
        selectors:(Array with:aSelector)
        filter:aFilterBlock

    "Modified: / 21.4.1998 / 15:34:44 / cg"
!

trapModificationsIn:anObject selectors:aCollectionOfSelectors filter:aFilterBlock
    "install a trap for modifications in anObject by aSelector-messages.
     the filterBlock will be invoked (after a modification) with the old and
     new values as arguments and should return true, 
     if the debugger is really wanted."

    |copyHolder|

    ObjectCopyHolders isNil ifTrue:[
        ObjectCopyHolders := IdentityDictionary new.
    ].
    copyHolder := ObjectCopyHolders at:anObject ifAbsent:nil.
    copyHolder isNil ifTrue:[
        ObjectCopyHolders at:anObject put:(copyHolder := ValueHolder new).
    ].

    copyHolder value:(anObject shallowCopy).

    aCollectionOfSelectors do:[:aSelector |
        |methodName|

        methodName := anObject class name , '>>' , aSelector.
        self 
            wrap:anObject
            selector:aSelector 
            onEntry:[:con | ]
            onExit:[:con :retVal |
                        |oldValue|

                        oldValue :=  copyHolder value.

                        "/ compare with copy ...
                        (anObject sameContentsAs:oldValue) ifFalse:[
                            "/ see oldValue vs. anObject
                            (aFilterBlock value:oldValue value:anObject) ifTrue:[
                                copyHolder value:(anObject shallowCopy).
                                ObjectWrittenBreakpointSignal
                                    raiseRequestWith:(oldValue -> anObject) 
                                     errorString:('object was modififed in ' , methodName) 
                                    in:con sender
                            ]
                        ]
                   ]
            withOriginalClass:true
            flushCaches:false.
    ].
    ObjectMemory flushCaches

    "Created: / 21.4.1998 / 15:34:05 / cg"
    "Modified: / 21.4.1998 / 16:00:39 / cg"
! !

!MessageTracer class methodsFor:'object tracing'!

trace:anObject selector:aSelector
    "arrange for a trace message to be output on Stderr, when a message with 
     aSelector is sent to anObject. Both entry and exit are traced.
     Use untrap to remove this trace.
     The current implementation does not allow integers or nil to be traced."

    self trace:anObject selector:aSelector on:Stderr

    "
     |p|

     p := Point new.
     MessageTracer trace:p selector:#x:.
     p x:5.
     p y:1.
     p x:10.
     MessageTracer untrap:p.
     p x:7
    "
    "
     |a|

     a := #(6 1 9 66 2 17) copy.
     MessageTracer trace:a selector:#at:put:.
     MessageTracer trace:a selector:#at:.
     a sort.
    "

    "Modified: / 21.4.1998 / 15:37:05 / cg"
!

trace:anObject selector:aSelector on:aStream
    "arrange for a trace message to be output on Stderr, when a message with 
     aSelector is sent to anObject. Both entry and exit are traced.
     Use untrap to remove this trace.
     The current implementation does not allow integers or nil to be traced."

    self
        trace:anObject 
        selectors:(Array with:aSelector)
        on:aStream

    "
     |p|

     p := Point new.
     MessageTracer trace:p selector:#x: on:Stderr.
     p x:5.
     p y:1.
     p x:10.
     MessageTracer untrap:p.
     p x:7
    "
    "
     |a|

     a := #(6 1 9 66 2 17) copy.
     MessageTracer trace:a selector:#at:put: on:Stderr.
     MessageTracer trace:a selector:#at:.    on:Stderr
     a sort.
    "

    "Modified: / 21.4.1998 / 15:37:05 / cg"
!

trace:anObject selectors:aCollectionOfSelectors
    "arrange for a trace message to be output on Stderr, when any message 
     from aCollectionOfSelectors is sent to anObject. 
     Both entry and exit are traced.
     Use untrap:/untrace: to remove this trace.
     The current implementation does not allow integers or nil to be traced."

    self trace:anObject selectors:aCollectionOfSelectors on:Stderr

    "
     |p|

     p := Point new.
     MessageTracer trace:p selector:#x:.
     p x:5.
     p y:1.
     p x:10.
     MessageTracer untrap:p.
     p x:7
    "
    "
     |a|

     a := #(6 1 9 66 2 17) copy.
     MessageTracer trace:a selector:#at:put:.
     MessageTracer trace:a selector:#at:.
     a sort.
    "

    "Modified: / 21.4.1998 / 15:41:57 / cg"
!

trace:anObject selectors:aCollectionOfSelectors on:aStream
    "arrange for a trace message to be output on Stderr, when any message 
     from aCollectionOfSelectors is sent to anObject. 
     Both entry and exit are traced.
     Use untrap:/untrace: to remove this trace.
     The current implementation does not allow integers or nil to be traced."

    |methodName|

    aCollectionOfSelectors do:[:aSelector |
        methodName := anObject class name , '>>' , aSelector.
        self 
            wrap:anObject
            selector:aSelector 
            onEntry:[:con | 
                        aStream nextPutAll:'enter '; nextPutAll:methodName. 
                        aStream nextPutAll:' receiver='. 
                        con receiver printOn:aStream.
                        aStream nextPutAll:' args='. (con args) printOn:aStream.
                        aStream nextPutAll:' from:'. con sender printOn:aStream.
                        aStream cr; flush
                    ]
            onExit:[:con :retVal |
                        aStream nextPutAll:'leave '; nextPutAll:methodName. 
                        aStream nextPutAll:' receiver='. con receiver printOn:aStream.
                        aStream nextPutAll:' returning:'. retVal printOn:aStream.
                        aStream cr; flush
                   ]
            withOriginalClass:true
            flushCaches:false
    ].
    ObjectMemory flushCaches

    "
     |p|

     p := Point new.
     MessageTracer trace:p selectors:#(x:) on:Transcript.
     p x:5.
     p y:1.
     p x:10.
     MessageTracer untrap:p.
     p x:7
    "
    "
     |a|

     a := #(6 1 9 66 2 17) copy.
     MessageTracer trace:a selectors:#( at:put: at:) on:Transcript.
     a sort.
    "

    "Modified: / 21.4.1998 / 15:41:57 / cg"
!

traceAll:anObject
    "trace all messages which are understood by anObject"

    self traceAll:anObject on:Stderr

    "
     trace all (implemented) messages sent to Display
     (other messages lead to an error, anyway)
    "

    "
     MessageTracer traceAll:Display
     MessageTracer untrace:Display
    "

    "Modified: 5.6.1996 / 13:43:51 / stefan"
!

traceAll:anObject from:aClass
    "trace all messages defined in aClass sent to anObject"

    self traceAll:anObject from:aClass on:Stderr

    "
     trace all methods in Display, which are implemented
     in the DisplayWorkstation class.
    "

    "
     MessageTracer traceAll:Display from:XWorkstation
     MessageTracer untrace:Display
    "

    "Modified: 5.6.1996 / 13:45:37 / stefan"
!

traceAll:anObject from:aClass on:aStream
    "trace all messages defined in aClass sent to anObject"

    self trace:anObject selectors:aClass selectors on:aStream

    "
     trace all methods in Display, which are implemented
     in the DisplayWorkstation class.
    "

    "
     MessageTracer traceAll:Display from:XWorkstation on:Transcript
     MessageTracer untrace:Display
    "

    "Modified: 5.6.1996 / 13:45:37 / stefan"
!

traceAll:anObject on:aStream
    "trace all messages which are understood by anObject"

    |allSelectors|

    allSelectors := IdentitySet new.
    anObject class withAllSuperclasses do:[:aClass |
        aClass methodDictionary keys addAllTo:allSelectors
    ].
    self trace:anObject selectors:allSelectors on:aStream

    "
     trace all (implemented) messages sent to Display
     (other messages lead to an error, anyway)
    "

    "
     MessageTracer traceAll:Display on:Transcript
     MessageTracer untrace:Display
    "

    "Modified: 5.6.1996 / 13:43:51 / stefan"
!

traceEntry:anObject selectors:aCollectionOfSelectors on:aStream
    "arrange for a trace message to be output on Stderr, when any message 
     from aCollectionOfSelectors is sent to anObject. 
     Only entry is traced.
     Use untrap:/untrace: to remove this trace.
     The current implementation does not allow integers or nil to be traced."

    self
        traceEntry:anObject selectors:aCollectionOfSelectors on:Stderr

    "
     |p|

     p := Point new.
     MessageTracer traceEntry:p selectors:#(x:).
     p x:5.
     p y:1.
     p x:10.
     MessageTracer untrap:p.
     p x:7
    "
    "
     |a|

     a := #(6 1 9 66 2 17) copy.
     MessageTracer traceEntry:a selectors:#( at:put: at:).
     a sort.
    "

    "Modified: / 21.4.1998 / 15:41:57 / cg"
!

traceSender:anObject selector:aSelector
    "arrange for a trace message to be output on Stderr, when a message with 
     aSelector is sent to anObject. Only the sender is traced on entry.
     Use untrap to remove this trace.
     The current implementation does not allow integers or nil to be traced."

    ^ self traceSender:anObject selector:aSelector on:Stderr

    "
     |p|

     p := Point new.
     MessageTracer traceSender:p selector:#x:.
     p x:5.
     p y:1.
     p x:10.
     MessageTracer untrap:p.
     p x:7
    "
    "
     |a|

     a := #(6 1 9 66 2 17) copy.
     MessageTracer traceSender:a selector:#at:put:.
     MessageTracer traceSender:a selector:#at:.
     a sort.
    "

    "Modified: 10.1.1997 / 17:54:53 / cg"
!

traceSender:anObject selector:aSelector on:aStream
    "arrange for a trace message to be output on Stderr, when a message with 
     aSelector is sent to anObject. Only the sender is traced on entry.
     Use untrap to remove this trace.
     The current implementation does not allow integers or nil to be traced."

    |methodName|

    methodName := anObject class name , '>>' , aSelector.
    self wrap:anObject
         selector:aSelector 
         onEntry:[:con | 
                     aStream nextPutAll:methodName. 
                     aStream nextPutAll:' from '. 
                     con sender printOn:aStream.
                     aStream cr; flush.
                 ]
         onExit:LeaveTraceBlock.

    "
     |p|

     p := Point new.
     MessageTracer traceSender:p selector:#x: on:Transcript.
     p x:5.
     p y:1.
     p x:10.
     MessageTracer untrap:p.
     p x:7
    "
    "
     |a|

     a := #(6 1 9 66 2 17) copy.
     MessageTracer traceSender:a selector:#at:put: on:Transcript.
     MessageTracer traceSender:a selector:#at:.    on:Transcript
     a sort.
    "

    "Modified: 10.1.1997 / 17:54:53 / cg"
!

untrace:anObject
    "remove any traces on anObject"

    "just a rename for your convenience - the same basic mechanism is used for all of these
     trace facilities ..."

    ^ self untrap:anObject
!

untrace:anObject selector:aSelector
    "remove traces of aSelector sent to anObject"

    "just a rename for your convenience - the same basic mechanism is used for all of these
     trace facilities ..."

    ^ self untrap:anObject selector:aSelector
! !

!MessageTracer class methodsFor:'object wrapping'!

wrap:anObject selector:aSelector onEntry:entryBlock onExit:exitBlock
    "arrange for the two blocks entryBlock and exitBlock to be evaluated whenever
     a message with aSelector is sent to anObject. EntryBlock will be called on
     entry, and get the current context passed as argument. ExitBlock will be called,
     when the method is left, and get the context and the methods return value as arguments.
     The current implementation does not allow integers or nil to be wrapped."

    "I have not yet enough experience, if the wrapped original method should
     run as an instance of the original, or of the catching class; 
     The latter has the advantage of catching recursive and other sends, while
     it might lead into trouble when the message is sent from a debugger or a long
     return is done out of the original method ...
     Time will show, you can experiment by setting the withOriginalClass: flag to false
    "
    ^ self 
        wrap:anObject 
        selector:aSelector 
        onEntry:entryBlock 
        onExit:exitBlock 
        withOriginalClass:true
        flushCaches:true

    "Modified: / 21.4.1998 / 15:29:50 / cg"
!

wrap:anObject selector:aSelector onEntry:entryBlock onExit:exitBlock withOriginalClass:withOriginalClass flushCaches:flushCaches
    "arrange for the two blocks entryBlock and exitBlock to be evaluated whenever
     a message with aSelector is sent to anObject. EntryBlock will be called on
     entry, and get the current context passed as argument. ExitBlock will be called,
     when the method is left, and get the current context and the methods return value as argument.
     If withOriginalClass is true, the class of anObject will be set to its original class
     before the wrapped method will be called.
     NOTICE: The current implementation does not allow integers or nil to be wrapped."

    |newClass orgClass myMetaclass trapMethod s spec implClass save dict|

    "
     some are not allowed (otherwise we get into trouble ...)
    "
    (aSelector == #class 
    or:[aSelector == #changeClassTo:]) ifTrue:[
        Transcript showCR:'sorry, cannot place trap on: ' , aSelector.
        ^ self
    ].

    WrappedMethod autoload.     "/ just to make sure ...

    "
     create a new (anonymous) subclass of the receivers class
     but only if not already being trapped.
    "
    orgClass := anObject class.
    orgClass category == #'* trapping *' ifTrue:[
        newClass := orgClass
    ] ifFalse:[
        myMetaclass := orgClass class.

        newClass := myMetaclass copy new.
        newClass setSuperclass:orgClass.
        newClass instSize:orgClass instSize.
        newClass flags:orgClass flags.
        newClass isMeta ifFalse:[newClass setClassVariableString:''].
        newClass setInstanceVariableString:''.
        newClass setName:orgClass name.
        newClass category:#'* trapping *'.
        newClass methodDictionary:MethodDictionary new.
    ].

    "
     create a method, executing the trap-blocks and the original method via a super-send
    "
    spec := Parser methodSpecificationForSelector:aSelector.
    s := WriteStream on:String new.
    s nextPutAll:spec.
    s nextPutAll:' |retVal stubClass| '.
    withOriginalClass ifTrue:[
        s nextPutAll:'stubClass := self class. '.
        s nextPutAll:'self changeClassTo:(stubClass superclass). '.
    ].
    entryBlock notNil ifTrue:[
        s nextPutAll:'#literal1 yourself value:thisContext. '.
    ].
    s nextPutAll:('retVal := #originalMethod. ').    "/ just to get a place for the originalMethod
    s nextPutAll:('retVal := super ' , spec , '. ').
    exitBlock notNil ifTrue:[
        s nextPutAll:'#literal2 yourself value:thisContext value:retVal. '.
    ].
    withOriginalClass ifTrue:[
        s nextPutAll:'self changeClassTo:stubClass. '.
    ].
    s nextPutAll:'^ retVal'; cr.

    save := Compiler stcCompilation.
    Compiler stcCompilation:#never.
    [
        Class withoutUpdatingChangesDo:[
            trapMethod := Compiler compile:s contents 
                              forClass:newClass 
                            inCategory:'breakpointed'
                             notifying:nil
                               install:false
                            skipIfSame:false
                                silent:true.
        ]
    ] valueNowOrOnUnwindDo:[
        Compiler stcCompilation:save
    ].

    trapMethod == #Error ifTrue:[
        Transcript showCR:('cannot place trap on method: ' , aSelector).
        ^ self
    ].

    implClass := orgClass whichClassIncludesSelector:aSelector.
    implClass isNil ifTrue:[
        Transcript showCR:aSelector , ' is not understood by ' , orgClass name.
    ] ifFalse:[
        trapMethod changeLiteral:#originalMethod to:(implClass compiledMethodAt:aSelector).
    ].
    entryBlock notNil ifTrue:[
        trapMethod changeLiteral:#literal1 to:entryBlock.
    ].
    exitBlock notNil ifTrue:[
        trapMethod changeLiteral:#literal2 to:exitBlock.
    ].
    "
     change the source of this new method
     (to avoid confusion in the debugger ...)
    "
    trapMethod source:'this is a wrapper method - not the real one'.
    trapMethod changeClassTo:WrappedMethod.

    "
     install this new method
    "
    dict := newClass methodDictionary.
    dict := dict at:aSelector putOrAppend:trapMethod.
    flushCaches ifTrue:[
        newClass methodDictionary:dict.
    ] ifFalse:[
        newClass setMethodDictionary:dict.
    ].

    "
     and finally, the big trick:
    "
    newClass ~~ orgClass ifTrue:[
        anObject changeClassTo:newClass
    ].

    "
                                                                        [exBegin]
     |p|

     p := Point new copy.
     MessageTracer 
                wrap:p
            selector:#y: 
             onEntry:nil
              onExit:[:context :retVal |
                         Transcript show:'leave Point>>y:, returning:'.
                         Transcript showCR:retVal printString.
                         Transcript endEntry
                     ]
               withOriginalClass:true.
     Transcript showCR:'sending x: ...'.
     p x:1.
     Transcript showCR:'sending y: ...'.
     p y:2.
     MessageTracer untrap:p.
     Transcript showCR:'sending x: ...'.
     p x:2.
     Transcript showCR:'sending y: ...'.
     p y:1.
                                                                        [exEnd]
    "

    "
                                                                        [exBegin]
     |p|

     p := Point new copy.
     MessageTracer wrap:p
               selector:#y: 
                onEntry:[:context | self halt:'y: you are trapped']
                 onExit:nil
                  withOriginalClass:false.
     Transcript showCR:'sending x: ...'.
     p x:1.
     Transcript showCR:'sending y: ...'.
     p y:2.
     MessageTracer untrap:p.
     Transcript showCR:'sending x: ...'.
     p x:2.
     Transcript showCR:'sending y: ...'.
     p y:1.
                                                                        [exEnd]
    "

    "Modified: / 25.6.1996 / 22:11:21 / stefan"
    "Modified: / 6.2.1998 / 02:48:13 / cg"
    "Created: / 21.4.1998 / 15:30:27 / cg"
!

wrap:anObject selectors:aCollection onEntry:entryBlock onExit:exitBlock
    "install wrappers for anObject on all selectors from aCollection"

    aCollection do:[:aSelector |
        self 
            wrap:anObject selector:aSelector 
            onEntry:entryBlock onExit:exitBlock
            withOriginalClass:true
            flushCaches:false
    ].
    ObjectMemory flushCaches

    "Modified: / 21.4.1998 / 15:40:28 / cg"
!

wrapAll:anObject onEntry:entryBlock onExit:exitBlock
    "install wrappers for anObject on all implemented selectors"

    |allSelectors|

    allSelectors := IdentitySet new.
    anObject class withAllSuperclasses do:[:aClass |
        aClass methodDictionary keys addAllTo:allSelectors
    ].
    self wrap:anObject selectors:allSelectors onEntry:entryBlock onExit:exitBlock

    "Modified: 5.6.1996 / 14:50:07 / stefan"
! !

!MessageTracer class methodsFor:'queries'!

isCounting:aMethod
    "return true if aMethod is counted"

    MethodCounts isNil ifTrue:[^ false].
    (MethodCounts includesKey:aMethod) ifTrue:[^ true].
    aMethod isWrapped ifTrue:[
	^ MethodCounts includesKey:aMethod originalMethod
    ].
    ^ false

    "Created: 15.12.1995 / 11:07:58 / cg"
    "Modified: 15.12.1995 / 15:42:10 / cg"
!

isTiming:aMethod
    "return true if aMethod is timed"

    MethodTiming isNil ifTrue:[^ false].
    (MethodTiming includesKey:aMethod) ifTrue:[^ true].
    aMethod isWrapped ifTrue:[
        ^ MethodTiming includesKey:aMethod originalMethod
    ].
    ^ false

    "Modified: 15.12.1995 / 15:42:10 / cg"
    "Created: 17.6.1996 / 17:04:29 / cg"
!

isTrapped:aMethod
    "return true, if a breakpoint is set on aMethod.
     This only returns true for standard breakpoints (i.e. for user-wraps,
     this returns false)"

    aMethod isWrapped ifFalse:[^ false].
    ^ aMethod basicLiterals includesIdentical:LeaveBreakBlock

    "
     MessageTracer trapMethod:(Collection compiledMethodAt:#select:).
     Transcript showCR:(Collection compiledMethodAt:#select:) isWrapped.
     Transcript showCR:(MessageTracer isTrapped:(Collection compiledMethodAt:#select:)).
     MessageTracer unwrapMethod:(Collection compiledMethodAt:#select:).
    "

    "Modified: 22.10.1996 / 17:40:37 / cg"
! !

!MessageTracer class methodsFor:'trace helpers'!

printEntryFull:aContext
    self printEntryFull:aContext level:0 on:Stderr
!

printEntryFull:aContext level:lvl
    self printEntryFull:aContext level:lvl on:Stderr
!

printEntryFull:aContext level:lvl on:aStream
    |sender mClass mClassName|

    mClass := aContext methodClass.
    mClass isNil ifTrue:[
        mClassName := '???'
    ] ifFalse:[
        mClassName := mClass name
    ].

    aStream 
        spaces:lvl;
        nextPutAll:'enter ';
        nextPutAll:mClassName;
        space;
        bold;
        nextPutAll:aContext selector;
        normal;
        nextPutAll:' rec=['.

    aContext receiver printOn:aStream.
    aStream nextPutAll:'] '. 
    (aContext args) keysAndValuesDo:[:idx :arg |
        |s|

        s := arg printString.
        s > 20 ifTrue:[
            s := arg classNameWithArticle
        ].
        aStream nextPutAll:'arg'. idx printOn:aStream. aStream nextPutAll:'=['.
        s printOn:aStream.
        aStream nextPutAll:'] '.
    ].

    sender := aContext sender.
    sender notNil ifTrue:[
        (sender selector startsWith:'perform:') ifTrue:[
            sender := sender sender.
        ].
    ].

    aStream nextPutAll:'from:'. 
    sender printOn:aStream.
    aStream cr; flush.

    "Modified: 5.3.1997 / 12:40:55 / cg"
!

printEntryFull:aContext on:aStream
    self printEntryFull:aContext level:0 on:aStream
!

printEntrySender:aContext on:aStream
    |sender mClass mClassName|

    mClass := aContext methodClass.
    mClass isNil ifTrue:[
        mClassName := '???'
    ] ifFalse:[
        mClassName := mClass name
    ].
    aStream 
        nextPutAll:mClassName;
        space;
        bold;
        nextPutAll:aContext selector;
        normal;
        nextPutAll:' from '.

    sender := aContext sender.
    sender notNil ifTrue:[
        (sender selector startsWith:'perform:') ifTrue:[
            sender := sender sender.
        ].
    ].
    sender printOn:aStream.
    aStream cr; flush.

    "Modified: 5.3.1997 / 12:40:42 / cg"
!

printExit:aContext with:retVal
    self printExit:aContext with:retVal level:0 on:Stderr
!

printExit:aContext with:retVal level:lvl
    self printExit:aContext with:retVal level:lvl on:Stderr
!

printExit:aContext with:retVal level:lvl on:aStream
    |mClass mClassName|

    mClass := aContext methodClass.
    mClass isNil ifTrue:[
        mClassName := '???'
    ] ifFalse:[
        mClassName := mClass name
    ].
    aStream 
        spaces:lvl;
        nextPutAll:'leave ';  
        nextPutAll:mClassName;
        space;
        bold;
        nextPutAll:aContext selector; 
        normal;
        nextPutAll:' rec=['. 

    aContext receiver printOn:aStream.
    aStream nextPutAll:'] return: ['.
    retVal printOn:aStream.
    aStream nextPutAll:']'; cr; flush.
!

printExit:aContext with:retVal on:aStream
    self printExit:aContext with:retVal level:0 on:aStream
!

traceFullBlockFor:aStream
    "avoid generation of fullBlocks"

    aStream == Transcript ifTrue:[
        ^ TraceFullBlock2
    ].
    aStream == Stderr ifTrue:[
        ^ TraceFullBlock
    ].
    ^ [:con | con fullPrintAllOn:aStream]



!

traceSenderBlockFor:aStream
    "avoid generation of fullBlocks"

    aStream == Transcript ifTrue:[
        ^ TraceSenderBlock2
    ].
    aStream == Stderr ifTrue:[
        ^ TraceSenderBlock 
    ].
    ^ [:con | MessageTracer printEntrySender:con on:aStream]



! !

!MessageTracer methodsFor:'trace helpers '!

stepInterrupt
    "called for every send while tracing"

    |con|

    StepInterruptPending := nil.
    con := thisContext sender.
    con lineNumber == 1 ifTrue:[
        traceDetail == true ifTrue:[
            self class printEntryFull:con on:Stderr.
        ] ifFalse:[    
            con printOn:Stderr.
            Stderr cr.
        ]
    ].
    ObjectMemory flushInlineCaches.
    StepInterruptPending := 1.
    InterruptPending := 1.
    ^ self

    "Modified: 20.5.1996 / 10:28:20 / cg"
!

trace:aBlock detail:fullDetail
    "trace execution of aBlock."

    traceDetail := fullDetail.
    ObjectMemory stepInterruptHandler:self.
    ^ [
	ObjectMemory flushInlineCaches.
	StepInterruptPending := 1.
	InterruptPending := 1.
	aBlock value
    ] valueNowOrOnUnwindDo:[
	StepInterruptPending := nil.
	ObjectMemory stepInterruptHandler:nil.
    ]

    "
     MessageTracer trace:[#(6 5 4 3 2 1) sort] detail:false
     MessageTracer trace:[#(6 5 4 3 2 1) sort] detail:true 
    "
! !

!MessageTracer class methodsFor:'documentation'!

version
    ^ '$Header: /cvs/stx/stx/libbasic3/MessageTracer.st,v 1.66 1998-04-27 17:53:15 cg Exp $'
! !
MessageTracer initialize!