'From Squeak3.1alpha of 7 March 2001 [latest update: #4081] on 18 July 2001 at 10:20:19 pm'! "Change Set: BetterDebugger Date: 18 July 2001 Author: Hans-Martin Mosner Modifies the Parser and Debugger to enhance the debugging experience: 1. Debugger inspector panes are updated on every step. 2. PC highlighting is improved for loops, blocks, variable assignments. 3. Fast step method executes the message using perform:, not by simulation. 4. Exceptions caught within stepped methods are properly displayed in the debugger. 5. nonlocal returns are caught. Report any unusual behavior (aka bugs) to me." ! CodeHolder subclass: #Debugger instanceVariableNames: 'interruptedProcess interruptedController contextStack contextStackTop contextStackIndex contextStackList receiverInspector contextVariablesInspector externalInterrupt proceedValue selectingPC sourceMap tempNames savedCursor isolationHead failedProject errorWasInUIProcess labelString ' classVariableNames: 'ContextStackKeystrokes ErrorRecursion ' poolDictionaries: '' category: 'Tools-Debugger'! InstructionStream subclass: #ContextPart instanceVariableNames: 'stackp ' classVariableNames: 'PrimitiveFailToken QuickStep ' poolDictionaries: '' category: 'Kernel-Methods'! ParseNode subclass: #MessageNode instanceVariableNames: 'receiver selector precedence special arguments sizes equalNode caseErrorNode ' classVariableNames: 'MacroEmitters MacroPrinters MacroSelectors MacroSizers MacroTransformers StdTypers ThenFlag ' poolDictionaries: '' category: 'System-Compiler'! ParseNode subclass: #ReturnNode instanceVariableNames: 'expr ' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! Object subclass: #ParseNode instanceVariableNames: 'comment pc ' classVariableNames: 'Bfp BtpLong CodeBases CodeLimits DblExtDoAll Dup EndMethod EndRemote Jmp JmpLimit JmpLong LdFalse LdInstLong LdInstType LdLitIndType LdLitType LdMinus1 LdNil LdSelf LdSuper LdTempType LdThisContext LdTrue LoadLong LongLongDoAll NodeFalse NodeNil NodeSelf NodeSuper NodeThisContext NodeTrue Pop Send SendLimit SendLong SendLong2 SendPlus SendType ShortStoP StdLiterals StdSelectors StdVariables Store StorePop ' poolDictionaries: '' category: 'System-Compiler'! Scanner subclass: #Parser instanceVariableNames: 'here hereType hereMark prevToken prevMark encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag prevEnd hereEnd ' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! !Debugger methodsFor: 'accessing' stamp: 'hmm 7/16/2001 21:54'! labelString ^labelString! ! !Debugger methodsFor: 'accessing' stamp: 'hmm 7/16/2001 21:54'! labelString: aString labelString _ aString. self changed: #relabel! ! !Debugger methodsFor: 'context stack menu' stamp: 'hmm 7/16/2001 21:57'! doStep "Send the selected message in the accessed method, and regain control after the invoked method returns." | currentContext newContext | self okToChange ifFalse: [^ self]. self checkContextSelection. externalInterrupt ifFalse: [contextStackTop push: proceedValue]. externalInterrupt _ true. "simulation leaves same state as interrupting" currentContext _ self selectedContext. self contextStackIndex > 1 ifTrue: [currentContext completeCallee: contextStackTop. self resetContext: currentContext] ifFalse: [currentContext stepToSendOrReturn. newContext _ currentContext quickStep. newContext == currentContext ifTrue: [ currentContext stepToSendOrReturn. self changed: #contentsSelection. self updateInspectors] ifFalse: [self resetContext: newContext]]! ! !Debugger methodsFor: 'context stack menu' stamp: 'hmm 7/18/2001 21:28'! send "Send the selected message in the accessed method, and take control in the method invoked to allow further step or send." | currentContext | Sensor leftShiftDown ifTrue: [self halt]. self okToChange ifFalse: [^ self]. self checkContextSelection. externalInterrupt ifFalse: [contextStackTop push: proceedValue]. externalInterrupt _ true. "simulation leaves same state as interrupting" currentContext _ self selectedContext. currentContext stepToSendOrReturn. self contextStackIndex > 1 | currentContext willReturn ifTrue: [self changed: #notChanged] ifFalse: [currentContext _ currentContext step. currentContext stepToSendOrReturn. self resetContext: currentContext]! ! !Debugger methodsFor: 'code pane' stamp: 'hmm 7/17/2001 20:46'! pcRange "Answer the indices in the source code for the method corresponding to the selected context's program counter value." | i methodNode pc end | (selectingPC and: [contextStackIndex ~= 0]) ifFalse: [^1 to: 0]. sourceMap == nil ifTrue: [methodNode _ self selectedClass compilerClass new parse: contents in: self selectedClass notifying: nil dialect: true. sourceMap _ methodNode sourceMap. tempNames _ methodNode tempNames. self selectedContext method cacheTempNames: tempNames]. sourceMap size = 0 ifTrue: [^1 to: 0]. pc_ self selectedContext pc - (("externalInterrupt" true and: [contextStackIndex=1]) ifTrue: [1] ifFalse: [2]). i _ sourceMap indexForInserting: (Association key: pc value: nil). i < 1 ifTrue: [^1 to: 0]. i > sourceMap size ifTrue: [end _ sourceMap inject: 0 into: [:prev :this | prev max: this value last]. ^ end+1 to: end]. ^(sourceMap at: i) value! ! !Debugger methodsFor: 'dependents access' stamp: 'hmm 7/15/2001 19:48'! updateInspectors "Update the inspectors on the receiver's variables." receiverInspector == nil ifFalse: [receiverInspector update]. contextVariablesInspector == nil ifFalse: [contextVariablesInspector update]! ! !Debugger class methodsFor: 'class initialization' stamp: 'hmm 7/16/2001 21:44'! openContext: aContext label: aString contents: contentsString | isolationHead | "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." "Simulation guard" ErrorRecursion not & Preferences logDebuggerStackToFile ifTrue: [Smalltalk logError: aString inContext: aContext to: 'SqueakDebug.log']. ErrorRecursion ifTrue: [ErrorRecursion _ false. (isolationHead _ CurrentProjectRefactoring currentIsolationHead) ifNil: [self primitiveError: aString] ifNotNil: [isolationHead revoke]]. ErrorRecursion _ true. self informExistingDebugger: aContext label: aString. (Debugger context: aContext isolationHead: isolationHead) openNotifierContents: contentsString label: aString. ErrorRecursion _ false. Processor activeProcess suspend. ! ! !Debugger class methodsFor: 'opening' stamp: 'hmm 7/18/2001 22:10'! informExistingDebugger: aContext label: aString "Walking the context chain, we try to find out if we're in a debugger stepping situation. If we find the relevant contexts, we must rearrange them so they look just like they would if the methods were excuted outside of the debugger." | ctx quickStepMethod oldSender baseContext | ctx _ aContext. quickStepMethod _ ContextPart compiledMethodAt: #quickSend:to:with:super:. [ctx sender == nil or: [ctx sender method == quickStepMethod]] whileFalse: [ctx _ ctx sender]. ctx sender == nil ifTrue: [^self]. baseContext _ ctx. "baseContext is now the context created by the #quickSend... method." oldSender _ ctx _ ctx sender home sender. "oldSender is the context which originally sent the #quickSend... method" [ctx == nil or: [ctx receiver isKindOf: self]] whileFalse: [ctx _ ctx sender]. ctx == nil ifTrue: [^self]. "ctx is the context of the Debugger method #doStep" ctx receiver labelString: aString. ctx receiver externalInterrupt: false. baseContext swapSender: baseContext sender sender sender. "remove intervening contexts" thisContext swapSender: oldSender. "make myself return to debugger" ErrorRecursion _ false. ^aContext! ! !Inspector methodsFor: 'accessing' stamp: 'hmm 7/12/2001 20:35'! update "Reshow contents, assuming selected value may have changed." selectionIndex = 0 ifFalse: [self contentsIsString ifTrue: [contents _ self selection] ifFalse: [contents _ self selectionPrintString]. self changed: #contents. self changed: #selection. self changed: #selectionIndex]! ! !InstructionStream methodsFor: 'testing' stamp: 'hmm 7/15/2001 22:00'! willStore "Answer whether the next bytecode is a store or store-pop" | byte | byte _ self method at: pc. ^(byte between: 96 and: 132) and: [ byte <= 111 or: [byte >= 129 and: [ byte <= 130 or: [byte = 132 and: [ (self method at: pc+1) >= 160]]]]]! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'hmm 7/17/2001 20:52'! send: selector super: superFlag numArgs: numArgs "Simulate the action of bytecodes that send a message with selector, selector. The argument, superFlag, tells whether the receiver of the message was specified with 'super' in the source method. The arguments of the message are found in the top numArgs locations on the stack and the receiver just below them." | receiver arguments answer | arguments _ Array new: numArgs. numArgs to: 1 by: -1 do: [ :i | arguments at: i put: self pop]. receiver _ self pop. selector == #doPrimitive:method:receiver:args: ifTrue: [answer _ receiver doPrimitive: (arguments at: 1) method: (arguments at: 2) receiver: (arguments at: 3) args: (arguments at: 4). self push: answer. ^self]. QuickStep == self ifTrue: [ QuickStep _ nil. ^self quickSend: selector to: receiver with: arguments super: superFlag]. ^self send: selector to: receiver with: arguments super: superFlag! ! !ContextPart methodsFor: 'controlling' stamp: 'hmm 7/17/2001 20:57'! quickSend: selector to: receiver with: arguments super: superFlag "Send the given selector with arguments in an environment which closely resembles the non-simulating environment, with an interjected unwind-protected block to catch nonlocal returns. Attention: don't get lost!!" | oldSender contextToReturnTo result lookupClass | contextToReturnTo _ self. lookupClass _ superFlag ifTrue: [(self method literalAt: self method numLiterals) value superclass] ifFalse: [receiver class]. [oldSender _ thisContext sender swapSender: self. result _ receiver perform: selector withArguments: arguments inSuperclass: lookupClass. thisContext sender swapSender: oldSender] ifCurtailed: [ contextToReturnTo _ thisContext sender receiver. "The block context returning nonlocally" contextToReturnTo jump: -1. "skip to front of return bytecode causing this unwind" contextToReturnTo nextByte = 16r7C ifTrue: [ "If it was a returnTop, push the value to be returned. Otherwise the value is implicit in the bytecode" contextToReturnTo push: (thisContext sender tempAt: 1)]. thisContext swapSender: thisContext home sender. "Make this block return to the method's sender" contextToReturnTo]. contextToReturnTo push: result. ^contextToReturnTo! ! !ContextPart methodsFor: 'system simulation' stamp: 'hmm 7/15/2001 20:58'! quickStep "If the next instruction is a send, just perform it. Otherwise, do a normal step." self willReallySend ifTrue: [QuickStep _ self]. ^self step! ! !ContextPart methodsFor: 'system simulation' stamp: 'hmm 7/15/2001 21:59'! stepToSendOrReturn "Simulate the execution of bytecodes until either sending a message or returning a value to the receiver (that is, until switching contexts)." [self willReallySend | self willReturn | self willStore] whileFalse: [self step]! ! !ParseNode methodsFor: 'code generation' stamp: 'hmm 7/15/2001 21:34'! pc "Used by encoder source mapping." pc==nil ifTrue: [^0] ifFalse: [^pc]! ! !AssignmentNode methodsFor: 'initialize-release' stamp: 'hmm 7/15/2001 21:17'! variable: aVariable value: expression from: encoder sourceRange: range encoder noteSourceRange: range forNode: self. ^self variable: aVariable value: expression from: encoder! ! !AssignmentNode methodsFor: 'code generation' stamp: 'hmm 7/15/2001 21:33'! emitForEffect: stack on: aStream value emitForValue: stack on: aStream. variable emitStorePop: stack on: aStream. pc _ aStream position! ! !AssignmentNode methodsFor: 'code generation' stamp: 'hmm 7/15/2001 21:33'! emitForValue: stack on: aStream value emitForValue: stack on: aStream. variable emitStore: stack on: aStream. pc _ aStream position! ! !BlockNode methodsFor: 'initialize-release' stamp: 'hmm 7/15/2001 22:23'! arguments: argNodes statements: statementsCollection returns: returnBool from: encoder sourceRange: range "Compile." encoder noteSourceRange: range forNode: self. ^self arguments: argNodes statements: statementsCollection returns: returnBool from: encoder! ! !BlockNode methodsFor: 'code generation' stamp: 'hmm 7/17/2001 21:02'! emitForValue: stack on: aStream aStream nextPut: LdThisContext. stack push: 1. nArgsNode emitForValue: stack on: aStream. remoteCopyNode emit: stack args: 1 on: aStream. "Force a two byte jump." self emitLong: size code: JmpLong on: aStream. stack push: arguments size. arguments reverseDo: [:arg | arg emitStorePop: stack on: aStream]. self emitForEvaluatedValue: stack on: aStream. self returns ifFalse: [ aStream nextPut: EndRemote. pc _ aStream position. ]. stack pop: 1! ! !MessageNode methodsFor: 'macro transformations' stamp: 'hmm 7/15/2001 22:22'! transformToDo: encoder " var _ rcvr. L1: [var <= arg1] Bfp(L2) [block body. var _ var + inc] Jmp(L1) L2: " | limit increment block initStmt test incStmt limitInit blockVar myRange blockRange | "First check for valid arguments" ((arguments last isMemberOf: BlockNode) and: [arguments last numberOfArguments = 1]) ifFalse: [^ false]. arguments last firstArgument isVariableReference ifFalse: [^ false]. "As with debugger remote vars" arguments size = 3 ifTrue: [increment _ arguments at: 2. (increment isConstantNumber and: [increment literalValue ~= 0]) ifFalse: [^ false]] ifFalse: [increment _ encoder encodeLiteral: 1]. arguments size < 3 ifTrue: "transform to full form" [selector _ SelectorNode new key: #to:by:do: code: #macro]. "Now generate auxiliary structures" myRange _ encoder rawSourceRanges at: self ifAbsent: [1 to: 0]. block _ arguments last. blockRange _ encoder rawSourceRanges at: block ifAbsent: [1 to: 0]. blockVar _ block firstArgument. initStmt _ AssignmentNode new variable: blockVar value: receiver. limit _ arguments at: 1. limit isVariableReference | limit isConstantNumber ifTrue: [limitInit _ nil] ifFalse: "Need to store limit in a var" [limit _ encoder autoBind: blockVar key , 'LimiT'. limit scope: -2. "Already done parsing block" limitInit _ AssignmentNode new variable: limit value: (arguments at: 1)]. test _ MessageNode new receiver: blockVar selector: (increment key > 0 ifTrue: [#<=] ifFalse: [#>=]) arguments: (Array with: limit) precedence: precedence from: encoder sourceRange: (myRange first to: blockRange first). incStmt _ AssignmentNode new variable: blockVar value: (MessageNode new receiver: blockVar selector: #+ arguments: (Array with: increment) precedence: precedence from: encoder) from: encoder sourceRange: (myRange last to: myRange last). arguments _ (Array with: limit with: increment with: block) , (Array with: initStmt with: test with: incStmt with: limitInit). ^ true! ! !Project class methodsFor: 'utilities' stamp: 'hmm 7/15/2001 17:56'! interruptName: labelString "Create a Notifier on the active scheduling process with the given label." | suspendingList projectProcess | Smalltalk isMorphic ifFalse: [^ ScheduledControllers interruptName: labelString]. ActiveHand ifNotNil:[ActiveHand interrupted]. ActiveWorld _ World. "reinstall active globals" ActiveHand _ World primaryHand. ActiveHand interrupted. "make sure this one's interrupted too" ActiveEvent _ nil. projectProcess _ self uiProcess. "we still need the accessor for a while" (suspendingList _ projectProcess suspendingList) == nil ifTrue: [projectProcess == Processor activeProcess ifTrue: [projectProcess suspend]] ifFalse: [suspendingList remove: projectProcess ifAbsent: []. projectProcess offList]. Debugger openInterrupt: labelString onProcess: projectProcess ! ! !Scanner methodsFor: 'multi-character scans' stamp: 'hmm 7/18/2001 21:55'! xLitQuote "Symbols and vectors: #(1 (4 5) 2 3) #ifTrue:ifFalse: #'abc'." | start | start _ mark. self step. "litQuote" self scanToken. tokenType = #leftParenthesis ifTrue: [self scanToken; scanLitVec. mark _ start+1. tokenType == #doIt ifTrue: [self offEnd: 'Unmatched parenthesis']] ifFalse: [(#(word keyword colon ) includes: tokenType) ifTrue: [self scanLitWord] ifFalse: [(tokenType==#literal) ifTrue: [(token isMemberOf: Symbol) ifTrue: "##word" [token _ token "May want to move toward ANSI here"]] ifFalse: [tokenType==#string ifTrue: [token _ token asSymbol]]]]. mark _ start. tokenType _ #literal " #(Pen) #Pen #'Pen' ##Pen ###Pen "! ! !Parser methodsFor: 'scanning' stamp: 'hmm 7/16/2001 19:23'! endOfLastToken ^ prevEnd ifNil: [mark]! ! !Parser methodsFor: 'expression types' stamp: 'hmm 7/16/2001 18:47'! assignment: varNode " var '_' expression => AssignmentNode." | loc start | (loc _ varNode assignmentCheck: encoder at: prevMark + requestorOffset) >= 0 ifTrue: [^self notify: 'Cannot store into' at: loc]. start _ self startOfNextToken. varNode nowHasDef. self advance. self expression ifFalse: [^self expected: 'Expression']. parseNode _ AssignmentNode new variable: varNode value: parseNode from: encoder sourceRange: (start to: self endOfLastToken). ^true! ! !Parser methodsFor: 'expression types' stamp: 'hmm 7/17/2001 21:03'! blockExpression "[ ({:var} |) (| {temps} |) (statements) ] => BlockNode." | variableNodes temporaryBlockVariables start | variableNodes _ OrderedCollection new. start _ prevMark + requestorOffset. "Gather parameters." [self match: #colon] whileTrue: [variableNodes addLast: (encoder autoBind: self argumentName)]. (variableNodes size > 0 & (hereType ~~ #rightBracket) and: [(self match: #verticalBar) not]) ifTrue: [^self expected: 'Vertical bar']. temporaryBlockVariables _ self temporaryBlockVariables. self statements: variableNodes innerBlock: true. parseNode temporaries: temporaryBlockVariables. (self match: #rightBracket) ifFalse: [^self expected: 'Period or right bracket']. encoder noteSourceRange: (self endOfLastToken to: self endOfLastToken) forNode: parseNode. "The scope of the parameters and temporary block variables is no longer active." temporaryBlockVariables do: [:variable | variable scope: -1]. variableNodes do: [:variable | variable scope: -1]! ! !Parser methodsFor: 'scanning' stamp: 'hmm 7/16/2001 20:12'! advance | this | prevMark _ hereMark. prevEnd _ hereEnd. this _ here. here _ token. hereType _ tokenType. hereMark _ mark. hereEnd _ source position - (source atEnd ifTrue: [hereChar == 30 asCharacter ifTrue: [0] ifFalse: [1]] ifFalse: [2]). self scanToken. "Transcript show: 'here: ', here printString, ' mark: ', hereMark printString, ' end: ', hereEnd printString; cr." ^this! ! !Parser methodsFor: 'expression types' stamp: 'hmm 7/16/2001 20:09'! temporaries " [ '|' (variable)* '|' ]" | vars theActualText | (self match: #verticalBar) ifFalse: ["no temps" doitFlag ifTrue: [requestor ifNil: [tempsMark _ 1] ifNotNil: [tempsMark _ requestor selectionInterval first]. ^ #()]. tempsMark _ (prevEnd ifNil: [0])+1. tempsMark > 0 ifTrue: [theActualText _ source contents. [tempsMark < theActualText size and: [(theActualText at: tempsMark) isSeparator]] whileTrue: [tempsMark _ tempsMark + 1]]. ^ #()]. vars _ OrderedCollection new. [hereType == #word] whileTrue: [vars addLast: (encoder bindTemp: self advance)]. (self match: #verticalBar) ifTrue: [tempsMark _ prevMark. ^ vars]. ^ self expected: 'Vertical bar'! ! !Parser methodsFor: 'error handling' stamp: 'hmm 7/18/2001 21:45'! expected: aString "Notify a problem at token 'here'." tokenType == #doIt ifTrue: [hereMark _ hereMark + 1]. hereType == #doIt ifTrue: [hereMark _ hereMark + 1]. ^ self notify: aString , ' expected' at: hereMark + requestorOffset! ! !DialectParser methodsFor: 'as yet unclassified' stamp: 'hmm 7/16/2001 20:12'! messagePart: level repeat: repeat initialKeyword: kwdIfAny | start receiver selector args precedence words keywordStart | [receiver _ parseNode. (self matchKeyword and: [level >= 3]) ifTrue: [start _ self startOfNextToken. selector _ WriteStream on: (String new: 32). selector nextPutAll: kwdIfAny. args _ OrderedCollection new. words _ OrderedCollection new. [self matchKeyword] whileTrue: [keywordStart _ self startOfNextToken + requestorOffset. selector nextPutAll: self advance , ':'. words addLast: (keywordStart to: hereEnd + requestorOffset). self primaryExpression ifFalse: [^ self expected: 'Argument']. args addLast: parseNode]. (Symbol hasInterned: selector contents ifTrue: [ :sym | selector _ sym]) ifFalse: [ selector _ self correctSelector: selector contents wordIntervals: words exprInterval: (start to: self endOfLastToken) ifAbort: [ ^ self fail ] ]. precedence _ 3] ifFalse: [((hereType == #binary or: [hereType == #verticalBar]) and: [level >= 2]) ifTrue: [start _ self startOfNextToken. selector _ self advance asSymbol. self primaryExpression ifFalse: [^self expected: 'Argument']. self messagePart: 1 repeat: true. args _ Array with: parseNode. precedence _ 2] ifFalse: [(hereType == #word and: [(#(leftParenthesis leftBracket leftBrace) includes: tokenType) not]) ifTrue: [start _ self startOfNextToken. selector _ self advance. args _ #(). words _ OrderedCollection with: (start + requestorOffset to: self endOfLastToken + requestorOffset). (Symbol hasInterned: selector ifTrue: [ :sym | selector _ sym]) ifFalse: [ selector _ self correctSelector: selector wordIntervals: words exprInterval: (start to: self endOfLastToken) ifAbort: [ ^ self fail ] ]. precedence _ 1] ifFalse: [^args notNil]]]. parseNode _ MessageNode new receiver: receiver selector: selector arguments: args precedence: precedence from: encoder sourceRange: (start to: self endOfLastToken). repeat] whileTrue: []. ^true! ! !DialectParser methodsFor: 'as yet unclassified' stamp: 'hmm 7/16/2001 20:09'! temporaries " [ 'Use' (variable)* '.' ]" | vars theActualText | (self matchToken: #'Use') ifFalse: ["no temps" doitFlag ifTrue: [requestor ifNil: [tempsMark _ 1] ifNotNil: [tempsMark _ requestor selectionInterval first]. ^ #()]. tempsMark _ prevEnd+1. tempsMark > 0 ifTrue: [theActualText _ source contents. [tempsMark < theActualText size and: [(theActualText at: tempsMark) isSeparator]] whileTrue: [tempsMark _ tempsMark + 1]]. ^ #()]. vars _ OrderedCollection new. [hereType == #word] whileTrue: [vars addLast: (encoder bindTemp: self advance)]. (self match: #period) ifTrue: [tempsMark _ prevMark. ^ vars]. ^ self expected: 'Period'! ! Parser removeSelector: #previousTokenSize! Scanner subclass: #Parser instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag ' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! ParseNode subclass: #ReturnNode instanceVariableNames: 'expr ' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! ParseNode subclass: #MessageNode instanceVariableNames: 'receiver selector precedence special arguments sizes equalNode caseErrorNode ' classVariableNames: 'MacroEmitters MacroPrinters MacroSelectors MacroSizers MacroTransformers StdTypers ThenFlag ' poolDictionaries: '' category: 'System-Compiler'!