The Trunk: Tools-fbs.461.mcz

Frank Shearar uploaded a new version of Tools to project The Trunk:
http://source.squeak.org/trunk/Tools-fbs.461.mcz

==================== Summary ====================

Name: Tools-fbs.461
Author: fbs
Time: 30 April 2013, 9:46:27.007 am
UUID: 6b338c44-87ea-4b4a-9059-833bcd2545ed
Ancestors: Tools-fbs.460

Clean up the "JIT development" flow. On hitting the "create" button in response to a MessageNotUnderstood, NotYetImplemented or SubclassResponsibility,
* a MNU prompts the user for a class and category, pushes a stub method onto the call stack and debugs it;
* a NYI debugs the context with the #notYetImplemented/#shouldBeImplemented;
* a SR prompts the user for a class (between and including the receiver class and the superclass whose method has the #subclassResponsibility), categorises the new method the same as the superclass's, pushes a stub onto the call stack and debugs that stub.

In all cases, resumption lets methods _return_ values down the stack.

=============== Diff against Tools-fbs.460 ===============

Item was added:
+ ----- Method: Debugger>>askForSuperclassOf:upTo:toImplement:ifCancel: (in category 'private') -----
+ askForSuperclassOf: aClass upTo: superclass toImplement: aSelector ifCancel: cancelBlock
+ | classes chosenClassIndex |
+ classes := aClass withAllSuperclasses reject: [:cls | aClass isKindOf: cls].
+ chosenClassIndex := UIManager default
+ chooseFrom: (classes collect: [:c | c name])
+ title: 'Define #', aSelector, ' in which class?'.
+ chosenClassIndex = 0 ifTrue: [^ cancelBlock value].
+ ^ classes at: chosenClassIndex!

Item was changed:
  ----- Method: Debugger>>buildNotifierWith:label:message: (in category 'toolbuilder') -----
  buildNotifierWith: builder label: label message: messageString
  | windowSpec listSpec textSpec panelSpec quads |
  windowSpec := builder pluggableWindowSpec new.
  windowSpec model: self.
  windowSpec extent: 450 @ 156. "nice and wide to show plenty of the error msg"
  windowSpec label: label.
  windowSpec children: OrderedCollection new.
 
  panelSpec := builder pluggablePanelSpec new.
  panelSpec children: OrderedCollection new.
  quads := self preDebugButtonQuads.
+ (self interruptedContext selector == #doesNotUnderstand:) ifTrue: [
- (#(#notYetImplemented #shouldBeImplemented #doesNotUnderstand:) includes: self interruptedContext selector) ifTrue: [
  quads := quads copyWith:
  { 'Create'. #createMethod. #magenta. 'create the missing method' }
  ].
+ (#(#notYetImplemented #shouldBeImplemented) includes: self interruptedContext selector) ifTrue: [
+ quads := quads copyWith:
+ { 'Create'. #createImplementingMethod. #magenta. 'implement the marked method' }
+ ].
  (self interruptedContext selector == #subclassResponsibility) ifTrue: [
  quads := quads copyWith:
  { 'Create'. #createOverridingMethod. #magenta. 'create the missing overriding method' }
  ].
  quads do:[:spec| | buttonSpec |
  buttonSpec := builder pluggableButtonSpec new.
  buttonSpec model: self.
  buttonSpec label: spec first.
  buttonSpec action: spec second.
  buttonSpec help: spec fourth.
  buttonSpec frame: self preDebugButtonQuadFrame.
  panelSpec children add: buttonSpec.
  ].
  panelSpec layout: #horizontal. "buttons"
  panelSpec frame: self preDebugButtonQuadFrame.
  windowSpec children add: panelSpec.
 
  Preferences eToyFriendly | messageString notNil ifFalse:[
  listSpec := builder pluggableListSpec new.
  listSpec
  model: self;
  list: #contextStackList;
  getIndex: #contextStackIndex;
  setIndex: #debugAt:;
  frame: self contextStackFrame.
  windowSpec children add: listSpec.
  ] ifTrue:[
  message := messageString.
  textSpec := builder pluggableTextSpec new.
  textSpec
  model: self;
  getText: #preDebugMessageString;
  setText: nil;
  selection: nil;
  menu: #debugProceedMenu:;
  frame: self contextStackFrame.
  windowSpec children add: textSpec.
  ].
 
  ^windowSpec!

Item was changed:
  ----- Method: Debugger>>contents:notifying: (in category 'accessing') -----
  contents: aText notifying: aController
  "The retrieved information has changed and its source must now be updated.
  In this case, the retrieved information is the method of the selected context."
  | result selector classOfMethod category h ctxt newMethod |
  contextStackIndex = 0 ifTrue:
  [^false].
  self selectedContext isExecutingBlock ifTrue:
  [h := self selectedContext activeHome.
  h ifNil:
  [self inform: 'Method for block not found on stack, can''t edit and continue'.
  ^false].
  (self confirm: 'I will have to revert to the method from\which this block originated.  Is that OK?' withCRs) ifFalse:
  [^false].
  self resetContext: h changeContents: false.
  "N.B. Only reset the contents if the compilation succeeds.  If contents are reset
  when compilation fails both compiler error message and modifications are lost."
  (result := self contents: aText notifying: aController) ifTrue:
  [self contentsChanged].
  ^result].
 
  classOfMethod := self selectedClass.
  category := self selectedMessageCategoryName.
  selector := self selectedClass newParser parseSelector: aText.
  (selector == self selectedMessageName
  or: [(self selectedMessageName beginsWith: 'DoIt')
  and: [selector numArgs = self selectedMessageName numArgs]]) ifFalse:
  [self inform: 'can''t change selector'.
  ^false].
  selector := classOfMethod
  compile: aText
  classified: category
  notifying: aController.
  selector ifNil: [^false]. "compile cancelled"
  contents := aText.
  newMethod := classOfMethod compiledMethodAt: selector.
  newMethod isQuick ifTrue:
  [self down.
  self selectedContext jump: (self selectedContext previousPc - self selectedContext pc)].
  ctxt := interruptedProcess popTo: self selectedContext.
  ctxt == self selectedContext
  ifFalse:
  [self inform: 'Method saved, but current context unchanged\because of unwind error. Click OK to see error' withCRs]
  ifTrue:
  [newMethod isQuick ifFalse:
  [interruptedProcess
  restartTopWith: newMethod;
  stepToSendOrReturn].
  contextVariablesInspector object: nil].
  self resetContext: ctxt.
  Smalltalk isMorphic ifTrue:
  [World
  addAlarm: #changed:
  withArguments: #(contentsSelection)
  for: self
  at: (Time millisecondClockValue + 200)].
  ^true!

Item was added:
+ ----- Method: Debugger>>createImplementingMethod (in category 'private') -----
+ createImplementingMethod
+ "Should only be called when this Debugger was created in response to a
+ NotYetImplemented exception. All we need to do is pop the signalling context off the stack and open the #notYetImplemented method."
+ | signallingContext |
+ signallingContext := self selectedContext sender.
+ "Pop the signalling context off the stack"
+ self resetContext: signallingContext.
+ self debug.!

Item was changed:
  ----- Method: Debugger>>createMethod (in category 'private') -----
  createMethod
  "Should only be called when this Debugger was created in response to a
  MessageNotUnderstood exception. Create a stub for the method that was
  missing and proceed into it."
 
  | msg chosenClass |
  msg := self contextStackTop exceptionMessage.
  chosenClass := self
  askForSuperclassOf: self contextStackTop receiver class
  toImplement: msg selector
  ifCancel: [^self].
+ self implementMissingMethod: msg inClass: chosenClass.!
- self implement: msg inClass: chosenClass.!

Item was changed:
  ----- Method: Debugger>>createOverridingMethod (in category 'private') -----
  createOverridingMethod
  "Should only be called when this Debugger was created in response to a
+ SubclassResponsibility exception. Create a stub for the method that needs
+ overriding and proceed into it. Let the user only select a class in the
+ inheritance chain between the actual class and the class declaring the
+ subclassResponsibility."
+ | chosenClass msg category |
- SubclassResponsibility exception. Create a stub for the method that was
- missing and proceed into it."
- | msg |
  msg := self contextStackTop exceptionMessage.
+ chosenClass := self
+ askForSuperclassOf: self contextStackTop receiver class
+ upTo: self contextStackTop sender method methodClass
+ toImplement: msg selector
+ ifCancel: [^self].
+ "Use the same category as the marker method."
+ category := self contextStackTop sender selectorCategory.
+ self implementOverridingMethod: msg inClass: chosenClass inCategory: category.!
- self implement: msg inClass: self contextStackTop receiver class inCategory: self contextStackTop selectorCategory.!

Item was removed:
- ----- Method: Debugger>>implement:inClass: (in category 'context stack menu') -----
- implement: aMessage inClass: aClass
- ^ self
- implement: aMessage
- inClass: aClass
- inCategory: (self askForCategoryIn: aClass default: 'as yet unclassified').!

Item was removed:
- ----- Method: Debugger>>implement:inClass:inCategory: (in category 'context stack menu') -----
- implement: aMessage inClass: aClass inCategory: aSymbol
- aClass
- compile: aMessage createStubMethod
- classified: aSymbol.
- self setContentsToForceRefetch.
- self selectedContext privRefreshWith: (aClass lookupSelector: aMessage selector).
- aMessage numArgs > 0 ifTrue:
- [aMessage arguments withIndexDo:
- [:arg :index|
- self selectedContext tempAt: index put: arg]].
-
- "Snip out of the call stack the context that raised the debugger. - the #notYetImplemented send, for example."
- self selectedContext privSender: self selectedContext sender sender.
- self resetContext: self selectedContext.
- self debug.!

Item was added:
+ ----- Method: Debugger>>implementMissingMethod:inClass: (in category 'context stack menu') -----
+ implementMissingMethod: aMessage inClass: aClass
+ ^ self
+ implementMissingMethod: aMessage
+ inClass: aClass
+ inCategory: (self askForCategoryIn: aClass default: 'as yet unclassified').!

Item was added:
+ ----- Method: Debugger>>implementMissingMethod:inClass:inCategory: (in category 'context stack menu') -----
+ implementMissingMethod: aMessage inClass: aClass inCategory: aSymbol
+ "Create a stub implementation of the missing message and sew it onto the top of the stack, ensuring the context's arguments are set correctly. Debug the new context."
+ self pushStubMethodOnStack: aMessage inClass: aClass inCategory: aSymbol.
+
+ "Cut out the sender context. This is the context that signalled the MessageNotUnderstood."
+ self selectedContext privSender: self selectedContext sender.
+ self resetContext: self selectedContext.
+ self debug.!

Item was added:
+ ----- Method: Debugger>>implementOverridingMethod:inClass:inCategory: (in category 'context stack menu') -----
+ implementOverridingMethod: aMessage inClass: aClass inCategory: aSymbol
+ "Create a stub implementation of the overriding message and sew it onto the top of the stack, ensuring the context's arguments are set correctly. Debug the new context."
+ self pushStubMethodOnStack: aMessage inClass: aClass inCategory: aSymbol.
+
+ "Cut out the sender context. This is the context that signalled the SubclassResponsibility."
+ self selectedContext privSender: self selectedContext sender sender.
+ self resetContext: self selectedContext.
+ self debug.!

Item was changed:
  ----- Method: Debugger>>populateImplementInMenu: (in category 'context stack menu') -----
  populateImplementInMenu: aMenu
 
  | msg |
  msg := self selectedContext at: 1.
  self selectedContext receiver class withAllSuperclasses do:
  [:each |
+ aMenu add: each name target: self selector: #implementMissingMethod:inClass: argumentList: (Array with: msg with: each)].
- aMenu add: each name target: self selector: #implement:inClass: argumentList: (Array with: msg with: each)].
  ^ aMenu
 
  !

Item was added:
+ ----- Method: Debugger>>pushStubMethodOnStack:inClass:inCategory: (in category 'private') -----
+ pushStubMethodOnStack: aMessage inClass: aClass inCategory: aSymbol
+ "Create a stub implementation of the message and sew it onto the top of the stack, ensuring the context's arguments are set correctly."
+ aClass
+ compile: aMessage createStubMethod
+ classified: aSymbol.
+ self setContentsToForceRefetch.
+ self selectedContext privRefreshWith: (aClass lookupSelector: aMessage selector).
+ aMessage numArgs > 0 ifTrue:
+ [aMessage arguments withIndexDo:
+ [:arg :index|
+ self selectedContext tempAt: index put: arg]].!

Item was added:
+ ----- Method: PreDebugWindow>>createImplementingMethod (in category '*Tools-Debugger') -----
+ createImplementingMethod
+ model createImplementingMethod.!

Item was added:
+ ----- Method: PreDebugWindow>>createMethod (in category '*Tools-Debugger') -----
+ createMethod
+ model createMethod!

Item was added:
+ ----- Method: PreDebugWindow>>createOverridingMethod (in category '*Tools-Debugger') -----
+ createOverridingMethod
+ model createOverridingMethod!