Mercurial Mercurial > hg > stx-libbasic3 / changeset
summary | shortlog | changelog | graph | tags | bookmarks | branches | files | changeset | raw | zip | gz | bz2 | help
Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
*** empty log message ***
authorclaus
Wed, 23 Nov 1994 00:07:44 +0100
changeset 13 e416e7aa11e1
parent 12 2bfc13a2b95a
child 14 530bf06f9c78
*** empty log message ***
MessageTracer.st file | annotate | diff | comparison | revisions
MsgTracer.st file | annotate | diff | comparison | revisions 
--- a/MessageTracer.st	Mon Nov 21 17:40:42 1994 +0100
+++ b/MessageTracer.st	Wed Nov 23 00:07:44 1994 +0100
@@ -12,7 +12,7 @@
 
 Object subclass:#MessageTracer
        instanceVariableNames:'traceHow'
-       classVariableNames:'BreakpointSignal'
+       classVariableNames:'BreakpointSignal CallingLevel'
        poolDictionaries:''
        category:'System-Support'
 !
@@ -21,7 +21,7 @@
 COPYRIGHT (c) 1994 by Claus Gittinger
 	      All Rights Reserved
 
-$Header: /cvs/stx/stx/libbasic3/MessageTracer.st,v 1.5 1994-11-21 16:40:42 claus Exp $
+$Header: /cvs/stx/stx/libbasic3/MessageTracer.st,v 1.6 1994-11-22 23:07:44 claus Exp $
 '!
 
 !MessageTracer class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
 
 version
 "
-$Header: /cvs/stx/stx/libbasic3/MessageTracer.st,v 1.5 1994-11-21 16:40:42 claus Exp $
+$Header: /cvs/stx/stx/libbasic3/MessageTracer.st,v 1.6 1994-11-22 23:07:44 claus Exp $
 "
 !
 
@@ -263,31 +263,43 @@
 
 !MessageTracer class methodsFor:'helpers '!
 
-printEntryFull:aContext
-    'enter ' errorPrint. aContext receiver class name errorPrint.
-    '>>' errorPrint.
+printEntryFull:aContext level:lvl
+    (String new:lvl) errorPrint.
+    'enter ' errorPrint. 
+    aContext methodClass name errorPrint.
+    ' ' errorPrint.
     aContext selector errorPrint. 
-    ' receiver=' errorPrint. 
-    aContext receiver printString errorPrint.
+    ' rcvr=' errorPrint. 
+    aContext receiver "printString" errorPrint.
     ' args=' errorPrint. 
-    (aContext args) printString errorPrint.
+    (aContext args) "printString" errorPrint.
     ' from:' errorPrint. aContext sender errorPrintNL.
 !
 
+printEntryFull:aContext
+    self printEntryFull:aContext level:0
+!
+
 printEntrySender:aContext
-    aContext receiver class name errorPrint.
-    '>>' errorPrint. aContext selector errorPrint. 
+    aContext methodClass name errorPrint.
+    ' ' errorPrint. aContext selector errorPrint. 
     ' from ' errorPrint.
     aContext sender errorPrintNL.  
 !
 
-printExit:aContext with:retVal
-    'leave ' errorPrint. aContext receiver class name errorPrint. 
-    '>>' errorPrint.
+printExit:aContext with:retVal level:lvl
+    (String new:lvl) errorPrint.
+    'leave ' errorPrint. 
+    aContext methodClass name errorPrint.
+    ' ' errorPrint.
     aContext selector errorPrint. 
-    ' receiver=' errorPrint. 
-    aContext receiver printString errorPrint.
-    ' returning:' errorPrint. retVal printString errorPrintNL.
+    ' rcvr=' errorPrint. 
+    aContext receiver "printString" errorPrint.
+    ' return:' errorPrint. retVal "printString" errorPrintNL.
+!
+
+printExit:aContext with:retVal
+    self printExit:aContext with:retVal level:0
 ! !
 
 !MessageTracer class methodsFor:'object wrapping'!
@@ -453,12 +465,14 @@
 wrapMethod:aMethod onEntry:entryBlock onExit:exitBlock 
     "arrange for the two blocks entryBlock and exitBlock to be evaluated whenever
      aMethod is evaluated. 
-     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 
+     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."
 
     |selector class trapMethod s spec lits src idx|
 
+    CallingLevel := 0.
+
     "
      create a new method, which calls the original one,
      but only if not already being trapped.
@@ -512,6 +526,9 @@
 			    silent:true.
     trapMethod changeClassTo:WrappedMethod.
 
+    "
+     raising our eyebrows here ...
+    "
     lits := trapMethod basicLiterals.
     entryBlock notNil ifTrue:[
 	lits at:(lits indexOf:#entryBlock) put:entryBlock.
@@ -596,7 +613,9 @@
 
     |selector class originalMethod idx|
 
-    (aMethod isNil or:[aMethod isWrapped]) ifFalse:[
+    CallingLevel := 0.
+
+    (aMethod isNil or:[aMethod isWrapped not]) ifTrue:[
 	^ aMethod
     ].
 
@@ -1028,6 +1047,22 @@
 
 !MessageTracer class methodsFor:'object tracing'!
 
+traceAll:anObject from:aClass
+    "trace all messages defined in aClass sent to anObject"
+
+    self trace:anObject selectors:aClass selectorArray
+
+    "
+     trace all methods in Display, which are implemented
+     in the DisplayWorkstation class.
+    "
+
+    "
+     MessageTracer traceAll:Display from:XWorkstation
+     MessageTracer untrace:Display
+    "
+!
+
 trace:anObject selectors:aCollection
     aCollection do:[:aSelector |
 	self trace:anObject selector:aSelector
@@ -1152,26 +1187,52 @@
     "arrange for a trace message to be output on Stderr, when aMethod is executed.
      Use unwrapMethod to remove this."
 
+    |lvl inside|
+
     ^ self wrapMethod:aMethod
-	 onEntry:[:con | MessageTracer printEntryFull:con]
-	 onExit:[:con :retVal | MessageTracer printExit:con with:retVal]
+	 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.
+			    inside := nil
+			]
+		 ]
+	 onExit:[:con :retVal |
+			inside isNil ifTrue:[
+			    inside := true.
+			    MessageTracer printExit:con with:retVal level:lvl.
+			    CallingLevel := lvl := lvl - 1.
+			    inside := nil
+			]
+		]
 
     "
      MessageTracer traceMethod:(Integer compiledMethodAt:#factorial).
      5 factorial.
-     MessageTracer unwrapMethod:(Integer compiledMethodAt:#factorial) 
+     MessageTracer untraceMethod:(Integer compiledMethodAt:#factorial) 
     "
     "
      MessageTracer traceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
      #(6 1 9 66 2 17) copy sort.
-     MessageTracer unwrapMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:). 
+     MessageTracer untraceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:). 
+    "
+    "
+     dont do this:
     "
     "
-     MessageTracer traceMethod:(Array compiledMethodAt:#at:).
-     MessageTracer traceMethod:(Array compiledMethodAt:#at:put:).
+     MessageTracer traceMethod:(Object compiledMethodAt:#at:).
+     MessageTracer traceMethod:(Object compiledMethodAt:#at:put:).
      #(6 1 9 66 2 17) copy sort.
-     MessageTracer unwrapMethod:(Array compiledMethodAt:#at:).
-     MessageTracer unwrapMethod:(Array compiledMethodAt:#at:put:).
+     MessageTracer untraceMethod:(Object compiledMethodAt:#at:).
+     MessageTracer untraceMethod:(Object compiledMethodAt:#at:put:).
     "
 !
 
@@ -1200,10 +1261,7 @@
     "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 wrapMethod:(aClass compiledMethodAt:aSelector)
-	 onEntry:[:con | MessageTracer printEntryFull:con]
-	 onExit:[:con :retVal | MessageTracer printExit:con with:retVal]
-
+    self traceMethod:(aClass compiledMethodAt:aSelector)
 
     "
      MessageTracer traceClass:Integer selector:#factorial.
--- a/MsgTracer.st	Mon Nov 21 17:40:42 1994 +0100
+++ b/MsgTracer.st	Wed Nov 23 00:07:44 1994 +0100
@@ -12,7 +12,7 @@
 
 Object subclass:#MessageTracer
        instanceVariableNames:'traceHow'
-       classVariableNames:'BreakpointSignal'
+       classVariableNames:'BreakpointSignal CallingLevel'
        poolDictionaries:''
        category:'System-Support'
 !
@@ -21,7 +21,7 @@
 COPYRIGHT (c) 1994 by Claus Gittinger
 	      All Rights Reserved
 
-$Header: /cvs/stx/stx/libbasic3/Attic/MsgTracer.st,v 1.5 1994-11-21 16:40:42 claus Exp $
+$Header: /cvs/stx/stx/libbasic3/Attic/MsgTracer.st,v 1.6 1994-11-22 23:07:44 claus Exp $
 '!
 
 !MessageTracer class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
 
 version
 "
-$Header: /cvs/stx/stx/libbasic3/Attic/MsgTracer.st,v 1.5 1994-11-21 16:40:42 claus Exp $
+$Header: /cvs/stx/stx/libbasic3/Attic/MsgTracer.st,v 1.6 1994-11-22 23:07:44 claus Exp $
 "
 !
 
@@ -263,31 +263,43 @@
 
 !MessageTracer class methodsFor:'helpers '!
 
-printEntryFull:aContext
-    'enter ' errorPrint. aContext receiver class name errorPrint.
-    '>>' errorPrint.
+printEntryFull:aContext level:lvl
+    (String new:lvl) errorPrint.
+    'enter ' errorPrint. 
+    aContext methodClass name errorPrint.
+    ' ' errorPrint.
     aContext selector errorPrint. 
-    ' receiver=' errorPrint. 
-    aContext receiver printString errorPrint.
+    ' rcvr=' errorPrint. 
+    aContext receiver "printString" errorPrint.
     ' args=' errorPrint. 
-    (aContext args) printString errorPrint.
+    (aContext args) "printString" errorPrint.
     ' from:' errorPrint. aContext sender errorPrintNL.
 !
 
+printEntryFull:aContext
+    self printEntryFull:aContext level:0
+!
+
 printEntrySender:aContext
-    aContext receiver class name errorPrint.
-    '>>' errorPrint. aContext selector errorPrint. 
+    aContext methodClass name errorPrint.
+    ' ' errorPrint. aContext selector errorPrint. 
     ' from ' errorPrint.
     aContext sender errorPrintNL.  
 !
 
-printExit:aContext with:retVal
-    'leave ' errorPrint. aContext receiver class name errorPrint. 
-    '>>' errorPrint.
+printExit:aContext with:retVal level:lvl
+    (String new:lvl) errorPrint.
+    'leave ' errorPrint. 
+    aContext methodClass name errorPrint.
+    ' ' errorPrint.
     aContext selector errorPrint. 
-    ' receiver=' errorPrint. 
-    aContext receiver printString errorPrint.
-    ' returning:' errorPrint. retVal printString errorPrintNL.
+    ' rcvr=' errorPrint. 
+    aContext receiver "printString" errorPrint.
+    ' return:' errorPrint. retVal "printString" errorPrintNL.
+!
+
+printExit:aContext with:retVal
+    self printExit:aContext with:retVal level:0
 ! !
 
 !MessageTracer class methodsFor:'object wrapping'!
@@ -453,12 +465,14 @@
 wrapMethod:aMethod onEntry:entryBlock onExit:exitBlock 
     "arrange for the two blocks entryBlock and exitBlock to be evaluated whenever
      aMethod is evaluated. 
-     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 
+     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."
 
     |selector class trapMethod s spec lits src idx|
 
+    CallingLevel := 0.
+
     "
      create a new method, which calls the original one,
      but only if not already being trapped.
@@ -512,6 +526,9 @@
 			    silent:true.
     trapMethod changeClassTo:WrappedMethod.
 
+    "
+     raising our eyebrows here ...
+    "
     lits := trapMethod basicLiterals.
     entryBlock notNil ifTrue:[
 	lits at:(lits indexOf:#entryBlock) put:entryBlock.
@@ -596,7 +613,9 @@
 
     |selector class originalMethod idx|
 
-    (aMethod isNil or:[aMethod isWrapped]) ifFalse:[
+    CallingLevel := 0.
+
+    (aMethod isNil or:[aMethod isWrapped not]) ifTrue:[
 	^ aMethod
     ].
 
@@ -1028,6 +1047,22 @@
 
 !MessageTracer class methodsFor:'object tracing'!
 
+traceAll:anObject from:aClass
+    "trace all messages defined in aClass sent to anObject"
+
+    self trace:anObject selectors:aClass selectorArray
+
+    "
+     trace all methods in Display, which are implemented
+     in the DisplayWorkstation class.
+    "
+
+    "
+     MessageTracer traceAll:Display from:XWorkstation
+     MessageTracer untrace:Display
+    "
+!
+
 trace:anObject selectors:aCollection
     aCollection do:[:aSelector |
 	self trace:anObject selector:aSelector
@@ -1152,26 +1187,52 @@
     "arrange for a trace message to be output on Stderr, when aMethod is executed.
      Use unwrapMethod to remove this."
 
+    |lvl inside|
+
     ^ self wrapMethod:aMethod
-	 onEntry:[:con | MessageTracer printEntryFull:con]
-	 onExit:[:con :retVal | MessageTracer printExit:con with:retVal]
+	 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.
+			    inside := nil
+			]
+		 ]
+	 onExit:[:con :retVal |
+			inside isNil ifTrue:[
+			    inside := true.
+			    MessageTracer printExit:con with:retVal level:lvl.
+			    CallingLevel := lvl := lvl - 1.
+			    inside := nil
+			]
+		]
 
     "
      MessageTracer traceMethod:(Integer compiledMethodAt:#factorial).
      5 factorial.
-     MessageTracer unwrapMethod:(Integer compiledMethodAt:#factorial) 
+     MessageTracer untraceMethod:(Integer compiledMethodAt:#factorial) 
     "
     "
      MessageTracer traceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
      #(6 1 9 66 2 17) copy sort.
-     MessageTracer unwrapMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:). 
+     MessageTracer untraceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:). 
+    "
+    "
+     dont do this:
     "
     "
-     MessageTracer traceMethod:(Array compiledMethodAt:#at:).
-     MessageTracer traceMethod:(Array compiledMethodAt:#at:put:).
+     MessageTracer traceMethod:(Object compiledMethodAt:#at:).
+     MessageTracer traceMethod:(Object compiledMethodAt:#at:put:).
      #(6 1 9 66 2 17) copy sort.
-     MessageTracer unwrapMethod:(Array compiledMethodAt:#at:).
-     MessageTracer unwrapMethod:(Array compiledMethodAt:#at:put:).
+     MessageTracer untraceMethod:(Object compiledMethodAt:#at:).
+     MessageTracer untraceMethod:(Object compiledMethodAt:#at:put:).
     "
 !
 
@@ -1200,10 +1261,7 @@
     "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 wrapMethod:(aClass compiledMethodAt:aSelector)
-	 onEntry:[:con | MessageTracer printEntryFull:con]
-	 onExit:[:con :retVal | MessageTracer printExit:con with:retVal]
-
+    self traceMethod:(aClass compiledMethodAt:aSelector)
 
     "
      MessageTracer traceClass:Integer selector:#factorial.
hg/stx-libbasic3