'From Squeak3.7alpha of ''11 September 2003'' [latest update: #5548] on 18 November 2003 at 3:03:33 pm'! "Change Set: BreakpointSupport Date: 18 November 2003 Author: Ernest Micklei, Brent Vukmer, Marcus Denker Simple BreakPoints, implemented by Ernest Micklei. md: I just added Brent's fix, recategorized some methods, put the classes in Tools-Debugger and added a class comment to BreakPoint. Known issues: - currently, only break-on-entry type of breakpoints are supported - emphasis change not implemented for MVC browsers - uninstalling the breakpoint doesn't auto-update other browsers - uninstalling a breakpoint while debugging should restart-simulate the current method Ernest Micklei, 2002 Send comments to emicklei@philemonworks.com This changeset contains this fix: Change Set: Breakpoint-Telnet-bkv Date: 1 July 2003 Author: Brent Vukmer The Telnet package is unhappy because #Break is already defined in the system. This changeset renames the class Break to BreakPoint and edits Object >> break so that it referenced BreakPoint, allowed Telnet to install."! Halt subclass: #BreakPoint instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-Debugger'! !BreakPoint commentStamp: 'md 11/18/2003 09:32' prior: 0! This exception is raised on executing a breakpoint. "BreakPoint signal" is called from "Object>>break".! Object subclass: #BreakpointManager instanceVariableNames: '' classVariableNames: 'Installed ' poolDictionaries: '' category: 'Tools-Debugger'! !BreakpointManager commentStamp: 'emm 5/30/2002 14:20' prior: 0! This class manages methods that include breakpoints. It has several class methods to install and uninstall breakpoints. Evaluating "BreakpointManager clear" will remove all installed breakpoints in the system. Known issues: - currently, only break-on-entry type of breakpoints are supported - emphasis change not implemented for MVC browsers - uninstalling the breakpoint doesn't auto-update other browsers - uninstalling a breakpoint while debugging should restart-simulate the current method Ernest Micklei, 2002 Send comments to emicklei@philemonworks.com! !Object methodsFor: 'Breakpoint' stamp: 'bkv 7/1/2003 12:33'! break "This is a simple message to use for inserting breakpoints during debugging. The debugger is opened by sending a signal. This gives a chance to restore invariants related to multiple processes." BreakPoint signal. "nil break."! ! !BreakpointManager class methodsFor: 'install-uninstall' stamp: 'emm 5/30/2002 09:37'! installInClass: aClass selector: aSymbol "Install a new method containing a breakpoint. The receiver will remember this for unstalling it later" | breakMethod | breakMethod _ self compilePrototype: aSymbol in: aClass. breakMethod isNil ifTrue: [^ nil]. self installed at: breakMethod put: aClass >> aSymbol. "old method" aClass methodDictionary at: aSymbol put: breakMethod.! ! !BreakpointManager class methodsFor: 'install-uninstall' stamp: 'emm 4/24/2002 23:24'! unInstall: breakMethod | who oldMethod | oldMethod _ self installed at: breakMethod ifAbsent:[^self]. who _ breakMethod who. (who first methodDictionary at: who last) == breakMethod ifTrue:[ who first methodDictionary at: who last put: oldMethod]. self installed removeKey: breakMethod! ! !BreakpointManager class methodsFor: 'private' stamp: 'emm 5/30/2002 09:36'! breakpointMethodSourceFor: aSymbol in: aClass "Compose new source containing a break statement (currently it will be the first, later we want to insert it in any place)" | oldSource methodNode breakOnlyMethodNode sendBreakMessageNode | oldSource := aClass sourceCodeAt: aSymbol. methodNode := aClass compilerClass new compile: oldSource in: aClass notifying: nil ifFail: [self error: '[breakpoint] unable to install breakpoint']. breakOnlyMethodNode := aClass compilerClass new compile: 'temporaryMethodSelectorForBreakpoint self break. ^self' in: aClass notifying: nil ifFail: [self error: '[breakpoint] unable to install breakpoint']. sendBreakMessageNode := breakOnlyMethodNode block statements first. methodNode block statements addFirst: sendBreakMessageNode. ^methodNode printString ! ! !BreakpointManager class methodsFor: 'private' stamp: 'emm 5/30/2002 09:33'! compilePrototype: aSymbol in: aClass "Compile and return a new method containing a break statement" | source node method | source := self breakpointMethodSourceFor: aSymbol in: aClass. node := aClass compilerClass new compile: source in: aClass notifying: nil ifFail: [self error: '[breakpoint] unable to install breakpoint']. node isNil ifTrue: [^nil]. "dunno what the arguments mean..." method := node generate: #(0 0 0 0). ^method! ! !BreakpointManager class methodsFor: 'private' stamp: 'emm 4/24/2002 23:24'! installed Installed isNil ifTrue:[Installed := IdentityDictionary new]. ^Installed! ! !BreakpointManager class methodsFor: 'intialization-release' stamp: 'emm 5/30/2002 09:08'! clear "BreakpointManager clear" self installed copy keysDo:[ :breakMethod | self unInstall: breakMethod]. ! ! !BreakpointManager class methodsFor: 'testing' stamp: 'emm 5/30/2002 09:22'! methodHasBreakpoint: aMethod ^self installed includesKey: aMethod! ! !BreakpointManager class methodsFor: 'examples' stamp: 'emm 5/30/2002 14:12'! testBreakpoint "In the menu of the methodList, click on -toggle break on entry- and evaluate the following:" "BreakpointManager testBreakpoint" Transcript cr; show: 'Breakpoint test'! ! !Browser methodsFor: 'message category functions' stamp: 'emm 5/30/2002 09:20'! highlightMessageList: list with: morphList "Changed by emm to add emphasis in case of breakpoint" morphList do:[:each | | classOrNil methodOrNil | classOrNil := self selectedClassOrMetaClass. methodOrNil := classOrNil isNil ifTrue:[nil] ifFalse:[classOrNil methodDictionary at: each contents ifAbsent:[]]. (methodOrNil notNil and:[methodOrNil hasBreakpoint]) ifTrue:[each contents: ((each contents ,' [break]') asText allBold)]]! ! !Browser methodsFor: 'message functions' stamp: 'emm 5/30/2002 10:25'! messageListMenu: aMenu shifted: shifted "Answer the message-list menu" "Changed by emm to include menu-item for breakpoints" shifted ifTrue: [^ self shiftedMessageListMenu: aMenu]. aMenu addList:#( ('what to show...' offerWhatToShowMenu) ('toggle break on entry' toggleBreakOnEntry) - ('browse full (b)' browseMethodFull) ('browse hierarchy (h)' classHierarchy) ('browse method (O)' openSingleMessageBrowser) ('browse protocol (p)' browseFullProtocol) - ('fileOut' fileOutMessage) ('printOut' printOutMessage) - ('senders of... (n)' browseSendersOfMessages) ('implementors of... (m)' browseMessages) ('inheritance (i)' methodHierarchy) ('tile scriptor' openSyntaxView) ('versions (v)' browseVersions) - ('inst var refs...' browseInstVarRefs) ('inst var defs...' browseInstVarDefs) ('class var refs...' browseClassVarRefs) ('class variables' browseClassVariables) ('class refs (N)' browseClassRefs) - ('remove method (x)' removeMessage) - ('more...' shiftedYellowButtonActivity)). ^ aMenu ! ! !Browser methodsFor: 'breakpoints' stamp: 'emm 5/30/2002 09:23'! toggleBreakOnEntry "Install or uninstall a halt-on-entry breakpoint" | selectedMethod | self selectedClassOrMetaClass isNil ifTrue:[^self]. selectedMethod := self selectedClassOrMetaClass >> self selectedMessageName. selectedMethod hasBreakpoint ifTrue: [BreakpointManager unInstall: selectedMethod] ifFalse: [BreakpointManager installInClass: self selectedClassOrMetaClass selector: self selectedMessageName]. self changed: #messageList ! ! !CompiledMethod methodsFor: 'breakpoints' stamp: 'emm 5/30/2002 09:22'! hasBreakpoint ^BreakpointManager methodHasBreakpoint: self! ! !Debugger methodsFor: 'context stack menu' stamp: 'emm 5/30/2002 10:14'! contextStackMenu: aMenu shifted: shifted "Set up the menu appropriately for the context-stack-list, either shifted or unshifted as per the parameter provided" ^ shifted ifFalse: [aMenu labels: 'fullStack (f) restart (r) proceed (p) step (t) step through (T) send (e) where (w) peel to first like this toggle break on entry senders of... (n) implementors of... (m) inheritance (i) versions (v) inst var refs... inst var defs... class var refs... class variables class refs (N) browse full (b) file out mail out bug report more...' lines: #(8 9 13 15 18 21) selections: #(fullStack restart proceed doStep stepIntoBlock send where peelToFirst toggleBreakOnEntry browseSendersOfMessages browseMessages methodHierarchy browseVersions browseInstVarRefs browseInstVarDefs browseClassVarRefs browseClassVariables browseClassRefs browseMethodFull fileOutMessage mailOutBugReport shiftedYellowButtonActivity)] ifTrue: [aMenu labels: 'browse class hierarchy browse class browse method (O) implementors of sent messages change sets with this method inspect instances inspect subinstances revert to previous version remove from current change set revert & remove from changes more...' lines: #(5 7 10) selections: #(classHierarchy browseClass openSingleMessageBrowser browseAllMessages findMethodInChangeSets inspectInstances inspectSubInstances revertToPreviousVersion removeFromCurrentChanges revertAndForget unshiftedYellowButtonActivity)] ! ! !Debugger methodsFor: 'breakpoints' stamp: 'emm 5/30/2002 10:08'! toggleBreakOnEntry "Install or uninstall a halt-on-entry breakpoint" | selectedMethod | self selectedClassOrMetaClass isNil ifTrue:[^self]. selectedMethod := self selectedClassOrMetaClass >> self selectedMessageName. selectedMethod hasBreakpoint ifTrue: [BreakpointManager unInstall: selectedMethod] ifFalse: [BreakpointManager installInClass: self selectedClassOrMetaClass selector: self selectedMessageName].! ! !MethodContext methodsFor: 'printing' stamp: 'emm 5/30/2002 14:07'! printString "Answer an emphasized string in case of a breakpoint method" ^self method hasBreakpoint ifTrue:[(super printString , ' [break]') asText allBold] ifFalse:[super printString]! ! !MethodContext reorganize! ('initialize-release' privRefresh privRefreshWith:) ('accessing' blockHome finalBlockHome hasInstVarRef home isExecutingBlock isMethodContext method methodNode receiver removeSelf tempAt: tempAt:put:) ('private' instVarAt:put: setSender:receiver:method:arguments: startpc) ('private-exceptions' cannotReturn: isHandlerContext isUnwindContext receiver: restartWithNewReceiver: swapReceiver:) ('controlling' answer:) ('private-debugger' cachedStackTop cachesStack hideFromDebugger) ('printing' printDetails: printOn: printString who) ('closure support' contextTag) ! !Debugger reorganize! ('initialize' buildMVCDebuggerViewLabel:minSize: buildMVCNotifierButtonView buildMVCNotifierViewLabel:message:minSize: buildMVCOptionalButtonsButtonsView buttonRowForPreDebugWindow: customButtonRow customButtonSpecs debugAt: errorWasInUIProcess: initialExtent notifierButtonHeight openFullMorphicLabel: openFullNoSuspendLabel: openNotifierContents:label: optionalAnnotationHeight optionalButtonHeight optionalButtonPairs optionalButtonRow preDebugButtonQuads preDebugNotifierContentsFrom: release wantsOptionalButtons windowIsClosing) ('accessing' contents contents:notifying: contextVariablesInspector doNothing: interruptedContext interruptedProcess isNotifier labelString labelString: proceedValue proceedValue: receiver receiverInspector) ('notifier menu' debug) ('context stack (message list)' contextStackIndex contextStackList expandStack fullyExpandStack messageListIndex selectedMessage selectedMessageName toggleContextStackIndex:) ('context stack menu' abandon abandon: browseMessages browseSendersOfMessages browseVersions buildMessageBrowser buildMorphicNotifierLabelled:message: close: contextStackKey:from: contextStackMenu:shifted: debugProceedMenu: doStep down fullStack implement:inClass: mailOutBugReport messageListMenu:shifted: peelToFirst populateImplementInMenu: proceed proceed: restart selectPC send stepIntoBlock up where) ('code pane' contentsSelection createSyntaxMorph doItContext doItReceiver pc pcRange toggleSyntaxMorph) ('code pane menu' perform:orSendTo:) ('message category list' selectedMessageCategoryName) ('class list' selectedClass selectedClassOrMetaClass) ('dependents access' step updateInspectors wantsSteps) ('private' askForSuperclassOf:toImplement:ifCancel: checkContextSelection contextStackIndex:oldContextWas: createMethod externalInterrupt: isolationRecoveryAdvice lowSpaceChoices newStack: process:controller:context: process:controller:context:isolationHead: resetContext: resumeProcess: selectedContext) ('controls' addOptionalButtonsTo:at:plus:) ('as yet unclassified' codePaneMenu:shifted: runToSelection:) ('*Refactory-RBExternalBrowserReferences') ('breakpoints' toggleBreakOnEntry) ! !CompiledMethod reorganize! ('initialize-release' copyWithTrailerBytes: needsFrameSize:) ('accessing' defaultSelector endPC flag flushCache frameSize initialPC numArgs numLiterals numTemps primitive returnField selector trailer) ('comparing' =) ('testing' hasReportableSlip isQuick isReturnField isReturnSelf isReturnSpecial) ('printing' dateMethodLastSubmitted decompileString longPrintOn: longPrintOn:indent: printOn: printOnStream: printPrimitiveOn: storeLiteralsOn:forClass: storeOn: symbolic timeStamp who) ('literals' hasLiteral: hasLiteralSuchThat: hasLiteralThorough: header literalAt: literalAt:put: literalStrings literals objectAt: objectAt:put:) ('scanning' messages readsField: readsRef: scanFor: scanLongLoad: scanLongStore: scanVeryLongLoad:offset: scanVeryLongStore:offset: sendsToSuper writesField: writesRef:) ('source code management' cacheTempNames: checkOKToAdd:at: copyWithTempNames: fileIndex filePosition getSourceFor:in: getSourceFromFile holdsTempNames putSource:fromParseNode:class:category:inFile:priorMethod: putSource:fromParseNode:class:category:withStamp:inFile:priorMethod: putSource:fromParseNode:inFile:withPreamble: qCompress: qDecompress: setSourcePointer: setSourcePosition:inFile: setTempNamesIfCached: sourceClass sourceFileStream sourcePointer sourceSelector tempNames) ('file in/out' readDataFrom:size: storeDataOn: veryDeepCopyWith: zapSourcePointer) ('evaluating' valueWithReceiver:arguments:) ('decompiling' blockNode blockNodeIn: decompile decompileClass:selector: decompilerClass isClosureCompiled methodNode methodNodeDecompileClass:selector: parserClass) ('*Refactory-RBAddonsReasonable') ('*Refactory-RBAddonsProblem') ('breakpoints' hasBreakpoint) ! !Browser reorganize! ('accessing' contents contents:notifying: contentsSelection couldBrowseAnyClass doItReceiver editSelection editSelection: noteSelectionIndex:for: request:initialAnswer: spawn: suggestCategoryToSpawnedBrowser:) ('class functions' addAllMethodsToCurrentChangeSet buildClassBrowser classListMenu: classListMenu:shifted: copyClass createInstVarAccessors defineClass:notifying: editClass editComment explainSpecial: fetchClassDocPane fileOutClass findMethod hierarchy makeNewSubclass plusButtonHit printOutClass removeClass renameClass shiftedClassListMenu:) ('class list' classList classListIndex classListIndex: classListSingleton recent selectClass: selectedClass selectedClassName toggleClassListIndex:) ('code pane' compileMessage:notifying: showBytecodes) ('copying' veryDeepInner:) ('drag and drop' acceptDroppingMorph:event:inMorph: acceptMethod:dstMessageCategory:srcMessageCategory:dstClass:dstClassOrMeta:srcClassOrMeta:internal:copySemantic: acceptMethod:messageCategory:class:atListMorph:internal:copy: changeCategoryForClass:srcSystemCategory:atListMorph:internal:copy: changeMessageCategoryForMethod:dstMessageCategory:srcMessageCategory:insideClassOrMeta:internal:copySemantic: codeTextMorph dragAnimationFor:transferMorph: dragPassengerFor:inMorph: dragTransferTypeForMorph: dstCategoryDstListMorph: dstClassDstListMorph: dstMessageCategoryDstListMorph: message:compileInClass:fromClass:dstMessageCategory:srcMessageCategory:internal:copySemantic: overwriteDialogHierarchyChange:higher:sourceClassName:destinationClassName:methodSelector: wantsDroppedMorph:event:inMorph:) ('initialize-release' addAListPane:to:at:plus: addClassAndSwitchesTo:at:plus: addMorphicSwitchesTo:at: browserWindowActivated buildClassSwitchView buildCommentSwitchView buildInstanceClassSwitchView buildInstanceSwitchView buildMorphicClassList buildMorphicMessageCatList buildMorphicMessageList buildMorphicSwitches buildMorphicSystemCatList buildOptionalButtonsView defaultBrowserTitle highlightClassList:with: highlightMessageCategoryList:with: highlightSystemCategoryList:with: labelString methodCategoryChanged openAsMorphClassEditing: openAsMorphEditing: openAsMorphMessageEditing: openAsMorphMsgCatEditing: openAsMorphSysCatEditing: openEditString: openMessageCatEditString: openMessageEditString: openOnClassWithEditString: openSystemCatEditString: optionalAnnotationHeight optionalButtonHeight setClass:selector: setSelector: systemCatSingletonKey:from: systemOrganizer:) ('message category functions' addCategory alphabetizeMessageCategories buildMessageCategoryBrowser buildMessageCategoryBrowserEditString: canShowMultipleMessageCategories categoryOfCurrentMethod changeMessageCategories: editMessageCategories fileOutMessageCategories highlightMessageList:with: messageCategoryMenu: printOutMessageCategories removeEmptyCategories removeMessageCategory renameCategory showHomeCategory) ('message category list' categorizeAllUncategorizedMethods messageCatListSingleton messageCategoryList messageCategoryListIndex messageCategoryListIndex: messageCategoryListSelection rawMessageCategoryList selectMessageCategoryNamed: selectOriginalCategoryForCurrentMethod selectedMessageCategoryName setOriginalCategoryIndexForCurrentMethod toggleMessageCategoryListIndex:) ('message functions' addExtraShiftedItemsTo: buildMessageBrowser buildMessageBrowserEditString: defineMessage:notifying: defineMessageFrom:notifying: inspectInstances inspectSubInstances messageListMenu:shifted: removeMessage removeMessageFromBrowser shiftedMessageListMenu:) ('message list' messageList messageListIndex messageListIndex: messageListSingleton reformulateList selectedMessage selectedMessageName selectedMessageName: toggleMessageListIndex:) ('metaclass' classCommentIndicated classMessagesIndicated classOrMetaClassOrganizer indicateClassMessages indicateInstanceMessages instanceMessagesIndicated metaClassIndicated metaClassIndicated: selectedClassOrMetaClass selectedClassOrMetaClassName setClassOrganizer) ('system category functions' addSystemCategory alphabetizeSystemCategories browseAllClasses buildSystemCategoryBrowser buildSystemCategoryBrowserEditString: changeSystemCategories: classNotFound editSystemCategories fileOutSystemCategory findClass potentialClassNames printOutSystemCategory removeSystemCategory renameSystemCategory systemCatSingletonMenu: systemCategoryMenu: updateSystemCategories) ('system category list' indexIsOne indexIsOne: selectCategoryForClass: selectedEnvironment selectedSystemCategoryName systemCategoryList systemCategoryListIndex systemCategoryListIndex: systemCategorySingleton toggleSystemCategoryListIndex:) ('annotation' annotation) ('breakpoints' toggleBreakOnEntry) !