The Trunk: System-nice.157.mcz

Nicolas Cellier uploaded a new version of System to project The Trunk:
http://source.squeak.org/trunk/System-nice.157.mcz

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

Name: System-nice.157
Author: nice
Time: 20 October 2009, 10:24:12 am
UUID: c49326c7-8b6f-44a2-9a04-970b30fcd15a
Ancestors: System-nice.156

Track keys and selectors usage, use #includesSelector: #selectorsDo: and #asSet where due

+ make #classVarNames a sorted Array

=============== Diff against System-nice.156 ===============

Item was changed:
  ----- Method: SystemNavigation>>browseUncommentedMethodsWithInitials: (in category 'browse') -----
  browseUncommentedMethodsWithInitials: targetInitials
  "Browse uncommented methods whose initials (in the time-stamp, as logged to disk) match the given initials.  Present them in chronological order.  CAUTION: It will take several minutes for this to complete."
  "Time millisecondsToRun: [SystemNavigation default browseUncommentedMethodsWithInitials: 'jm']"
 
  | initials timeStamp methodReferences cm |
  methodReferences := OrderedCollection new.
  self  allBehaviorsDo:
+ [:aClass | aClass selectorsDo: [:sel |
- [:aClass | aClass selectors do: [:sel |
  cm := aClass compiledMethodAt: sel.
  timeStamp := Utilities timeStampForMethod: cm.
  timeStamp isEmpty ifFalse:
  [initials := timeStamp substrings first.
  initials first isDigit ifFalse:
  [((initials = targetInitials) and: [(aClass firstPrecodeCommentFor: sel) isNil])
  ifTrue:
  [methodReferences add: (MethodReference new
  setStandardClass: aClass
  methodSymbol: sel)]]]]].
 
  ToolSet
  browseMessageSet: methodReferences
  name: 'Uncommented methods with initials ', targetInitials
  autoSelect: nil!

Item was changed:
  ----- Method: ChangeSet>>methodsWithoutClassifications (in category 'testing') -----
  methodsWithoutClassifications
  "Return a collection representing methods in the receiver which have not been categorized"
 
  | slips notClassified aSelector |
 
  notClassified := {'as yet unclassified' asSymbol. #all}.
  slips := OrderedCollection new.
  self changedClasses do:
  [:aClass |
  (self methodChangesAtClass: aClass name) associationsDo:
+ [:mAssoc | (aClass includesSelector:  (aSelector := mAssoc key)) ifTrue:
- [:mAssoc | (aClass selectors includes:  (aSelector := mAssoc key)) ifTrue:
  [(notClassified includes: (aClass organization categoryOfElement: aSelector))
  ifTrue: [slips add: aClass name , ' ' , aSelector]]]].
  ^ slips
 
  "Smalltalk browseMessageList: (ChangeSet current methodsWithoutClassifications) name: 'unclassified methods'"!

Item was changed:
  ----- Method: SystemDictionary>>testFormatter2 (in category 'housekeeping') -----
  testFormatter2
  "Smalltalk testFormatter2"
 
  "Reformats the source for every method in the system, and
  then verifies that the order of source tokens is unchanged.
  The formatting used will be either classic monochrome or
  fancy polychrome, depending on the setting of the preference
  #colorWhenPrettyPrinting. "
 
  "Note: removed references to Preferences colorWhenPrettyPrinting and replaced them simply with false, as I've been removing this preference lately. --Ron Spengler 8/23/09"
 
  | newCodeString badOnes n oldCodeString oldTokens newTokens |
  badOnes := OrderedCollection new.
  self forgetDoIts.
  'Formatting all classes...'
  displayProgressAt: Sensor cursorPoint
  from: 0
  to: CompiledMethod instanceCount
  during:
  [:bar |
  n := 0.
  self systemNavigation allBehaviorsDo:
  [:cls |
  "Transcript cr; show: cls name."
 
+ cls selectorsDo:
- cls selectors do:
  [:selector |
  (n := n + 1) \\ 100 = 0 ifTrue: [bar value: n].
  oldCodeString := (cls sourceCodeAt: selector) asString.
  newCodeString := cls prettyPrinterClass
  format: oldCodeString
  in: cls
  notifying: nil
  decorated: false.
  oldTokens := oldCodeString findTokens: Character separators.
  newTokens := newCodeString findTokens: Character separators.
  oldTokens = newTokens
  ifFalse:
  [Transcript
  cr;
  show: '***' , cls name , ' ' , selector.
  badOnes add: cls name , ' ' , selector]]]].
  self systemNavigation browseMessageList: badOnes asSortedCollection
  name: 'Formatter Discrepancies'!

Item was changed:
  ----- Method: ChangeSet>>methodsWithoutComments (in category 'moving changes') -----
  methodsWithoutComments
  "Return a collection representing methods in the receiver which have no precode comments"
 
  | slips |
  slips := OrderedCollection new.
  self changedClasses do:
  [:aClass |
  (self methodChangesAtClass: aClass name) associationsDo:
  [:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse:
+ [(aClass includesSelector:  mAssoc key) ifTrue:
- [(aClass selectors includes:  mAssoc key) ifTrue:
  [(aClass firstPrecodeCommentFor: mAssoc key) isEmptyOrNil
  ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]].
  ^ slips
 
  "Smalltalk browseMessageList: (ChangeSet current methodsWithoutComments) name: 'methods lacking comments'"!

Item was changed:
  ----- Method: Utilities class>>initializeClosures (in category 'closure support') -----
  initializeClosures "Utilities initializeClosures"
  "Eliminate the prototype BlockContext from the specialObjectsArray.  The VM doesn't use it. This paves the way for removing BlockCOntext altogether and merging ContextPart and MethodContext into e.g. Context."
  (Smalltalk specialObjectsArray at: 38) class == BlockContext
  ifTrue:[Smalltalk specialObjectsArray at: 38 put: nil].
  "Remove unused class vars from CompiledMethod since we can't redefine its class definition directly. Add the new BlockClosure to the specialObjectsArray"
  (#( BlockNodeCache MethodProperties SpecialConstants)
+ intersection: CompiledMethod classPool keys asSet)
- intersection: CompiledMethod classPool keys)
  do:[:classVarName| CompiledMethod removeClassVarName: classVarName].
  Smalltalk recreateSpecialObjectsArray.
  "Recompile methods in ContextPart, superclasses and subclasses that access inst vars"
  ContextPart withAllSuperclasses, ContextPart allSubclasses asArray do:[:class|
  class instSize > 0 ifTrue:[
  class allInstVarNames do:[:ivn|
  (class whichSelectorsAccess: ivn) do:[:sel| class recompile: sel]]]]!

Item was changed:
  ----- Method: CodeLoader class>>exportCodeSegment:classes:keepSource: (in category 'utilities') -----
  exportCodeSegment: exportName classes: aClassList keepSource: keepSources
 
  "Code for writing out a specific category of classes as an external image segment.  Perhaps this should be a method."
 
  | is oldMethods newMethods classList symbolHolder fileName |
  keepSources
  ifTrue: [
  self confirm: 'We are going to abandon sources.
  Quit without saving after this has run.' orCancel: [^self]].
 
  classList := aClassList asArray.
 
  "Strong pointers to symbols"
  symbolHolder := Symbol allSymbols.
 
  oldMethods := OrderedCollection new: classList size * 150.
  newMethods := OrderedCollection new: classList size * 150.
  keepSources
  ifTrue: [
  classList do: [:cl |
+ cl selectorsDo:
- cl selectors do:
  [:selector | | m oldCodeString methodNode |
  m := cl compiledMethodAt: selector.
  m fileIndex > 0 ifTrue:
  [oldCodeString := cl sourceCodeAt: selector.
  methodNode := cl compilerClass new
  parse: oldCodeString in: cl notifying: nil.
  oldMethods addLast: m.
  newMethods addLast: (m copyWithTempsFromMethodNode: methodNode)]]]].
  oldMethods asArray elementsExchangeIdentityWith: newMethods asArray.
  oldMethods := newMethods := nil.
 
  Smalltalk garbageCollect.
  is := ImageSegment new copyFromRootsForExport: classList. "Classes and MetaClasses"
 
  fileName := FileDirectory fileName: exportName extension: ImageSegment fileExtension.
  is writeForExport: fileName.
  self compressFileNamed: fileName
 
  !

Item was changed:
  ----- Method: ImageSegment>>findRogueRootsRefStrm: (in category 'testing') -----
  findRogueRootsRefStrm: rootArray
  "This is a tool to track down unwanted pointers into the segment.  If we don't deal with these pointers, the segment turns out much smaller than it should.  These pointers keep a subtree of objects out of the segment.
  1) assemble all objects that should be in the segment by using SmartReference Stream and a dummyReference Stream.  Put in a Set.
  2) Remove the roots from this list.  Ask for senders of each.  Of the senders, forget the ones that are in the segment already.  Keep others.  The list is now all the 'incorrect' pointers into the segment."
 
  | dummy goodInSeg inSeg ok pointIn |
  dummy := ReferenceStream on: (DummyStream on: nil).
  "Write to a fake Stream, not a file"
  rootArray do:
  [:root |
  dummy rootObject: root. "inform him about the root"
  dummy nextPut: root].
+ inSeg := dummy references keys asSet.
- inSeg := dummy references keys.
  dummy := nil.
  Smalltalk garbageCollect. "dump refs dictionary"
  rootArray do: [:each | inSeg remove: each ifAbsent: []].
  "want them to be pointed at from outside"
  pointIn := IdentitySet new: 500.
  goodInSeg := IdentitySet new: 2000.
  inSeg do:
  [:obj |
  ok := obj class isPointers.
  obj class == Color ifTrue: [ok := false].
  obj class == TranslucentColor ifTrue: [ok := false].
  obj class == Array ifTrue: [obj size = 0 ifTrue: [ok := false]].
  "shared #() in submorphs of all Morphs"
  ok ifTrue: [goodInSeg add: obj]].
  goodInSeg
  do: [:ob | pointIn addAll: (Utilities pointersTo: ob except: #())].
  inSeg do: [:each | pointIn remove: each ifAbsent: []].
  rootArray do: [:each | pointIn remove: each ifAbsent: []].
  pointIn remove: inSeg array ifAbsent: [].
  pointIn remove: goodInSeg array ifAbsent: [].
  pointIn remove: pointIn array ifAbsent: [].
  self halt: 'Examine local variables pointIn and inSeg'.
  ^pointIn!

Item was changed:
  ----- Method: SystemNavigation>>browseClassVarRefs: (in category 'browse') -----
  browseClassVarRefs: aClass
  "Put up a menu offering all class variable names; if the user chooses one, open up a message-list browser on all methods
  that refer to the selected class variable"
 
  | lines labelStream vars allVars index owningClasses |
  lines := OrderedCollection new.
  allVars := OrderedCollection new.
  owningClasses := OrderedCollection new.
  labelStream := WriteStream on: (String new: 200).
  aClass withAllSuperclasses reverseDo:
  [:class |
+ vars := class classVarNames.
- vars := class classVarNames asSortedCollection.
  vars do:
  [:var |
  labelStream nextPutAll: var; cr.
  allVars add: var.
  owningClasses add: class].
  vars isEmpty ifFalse: [lines add: allVars size]].
  labelStream contents isEmpty ifTrue: [^Beeper beep]. "handle nil superclass better"
  labelStream skip: -1 "cut last CR".
  index := (UIManager default chooseFrom: (labelStream contents substrings) lines: lines).
  index = 0 ifTrue: [^ self].
  self browseAllCallsOn:
  ((owningClasses at: index) classPool associationAt: (allVars at: index))!

Item was changed:
  ----- Method: SystemDictionary>>abandonSources (in category 'shrinking') -----
  abandonSources
  "Smalltalk abandonSources"
  "Replaces every method by a copy with the 4-byte source pointer
  replaced by a string of all arg and temp names, followed by its
  length. These names can then be used to inform the decompiler."
  "wod 11/3/1998: zap the organization before rather than after
  condensing changes."
  "eem 7/1/2009 13:59 update for the closure schematic temp names regime"
  | oldMethods newMethods bTotal bCount |
  (self confirm: 'This method will preserve most temp names
  (up to about 15k characters of temporaries)
  while allowing the sources file to be discarded.
  -- CAUTION --
  If you have backed up your system and
  are prepared to face the consequences of
  abandoning source code files, choose Yes.
  If you have any doubts, you may choose No
  to back out with no harm done.')
  == true
  ifFalse: [^ self inform: 'Okay - no harm done'].
  self forgetDoIts.
  oldMethods := OrderedCollection new: CompiledMethod instanceCount.
  newMethods := OrderedCollection new: CompiledMethod instanceCount.
  bTotal := 0.
  bCount := 0.
  self systemNavigation allBehaviorsDo: [:b | bTotal := bTotal + 1].
  'Saving temp names for better decompilation...'
  displayProgressAt: Sensor cursorPoint
  from: 0
  to: bTotal
  during:
  [:bar |
  self systemNavigation allBehaviorsDo:
  [:cl |  "for test: (Array with: Arc with: Arc class) do:"
  bar value: (bCount := bCount + 1).
+ cl selectorsDo:
- cl selectors do:
  [:selector | | m oldCodeString methodNode |
  m := cl compiledMethodAt: selector.
  m fileIndex > 0 ifTrue:
  [oldCodeString := cl sourceCodeAt: selector.
  methodNode := cl compilerClass new
  parse: oldCodeString
  in: cl
  notifying: nil.
  oldMethods addLast: m.
  newMethods addLast: (m copyWithTempsFromMethodNode: methodNode)]]]].
  oldMethods asArray elementsExchangeIdentityWith: newMethods asArray.
  self systemNavigation allBehaviorsDo: [:b | b zapOrganization].
  self condenseChanges.
  Preferences disable: #warnIfNoSourcesFile!

Item was changed:
  ----- Method: ModifiedClassDefinitionEvent>>classVarNames (in category 'accessing') -----
  classVarNames
+ ^ item classVarNames!
- ^ item classVarNames asSet!

Item was changed:
  ----- Method: ModifiedClassDefinitionEvent>>oldClassVarNames (in category 'accessing') -----
  oldClassVarNames
+ ^ oldItem classVarNames!
- ^ oldItem classVarNames asSet!

Item was changed:
  ----- Method: FilePackage>>conflictsWithUpdatedMethods (in category 'conflict checker') -----
  conflictsWithUpdatedMethods
  "Check this package for conflicts with methods in the image which are in newer updates."
 
  | localFileName stream updateNumberString updateNumber imageUpdateNumber updateNumberChangeSet conflicts fileStream |
 
  localFileName := FileDirectory localNameFor: fullName.
  stream := ReadStream on: sourceSystem.
  stream upToAll: 'latest update: #'.
  updateNumberString := stream upTo: $].
  stream close.
 
  fileStream := FileStream readOnlyFileNamed: fullName.
  (fileStream contentsOfEntireFile includes: Character linefeed)
  ifTrue: [self notifyWithLabel:  'The changeset file ', localFileName, ' contains linefeeds.  Proceed if...
  you know that this is okay (e.g. the file contains raw binary data).'].
  fileStream close.
 
  updateNumberString isEmpty ifFalse: "remove prepended junk, if any"
  [updateNumberString := (updateNumberString findTokens: Character space) last].
  updateNumberString asInteger ifNil:
  [(self confirm: 'Error: ', localFileName, ' has no valid Latest Update number in its header.
  Do you want to enter an update number for this file?')
  ifFalse: [^ self]
  ifTrue: [updateNumberString := UIManager default
  request: 'Please enter the estimated update number (e.g. 4332).']].
  updateNumberString asInteger ifNil: [self inform: 'Conflict check cancelled.'. ^ self].
  updateNumber := updateNumberString asInteger.
 
  imageUpdateNumber := SystemVersion current highestUpdate.
  updateNumber > imageUpdateNumber ifTrue:
  [(self confirm: 'Warning: The update number for this file (#', updateNumberString, ')
  is greater than the highest update number for this image (#', imageUpdateNumber asString, ').
  This probably means you need to update your image.
  Should we proceed anyway as if the file update number is #', imageUpdateNumber asString, '?')
  ifTrue:
  [updateNumber := imageUpdateNumber.
  updateNumberString := imageUpdateNumber asString]
  ifFalse: [^ self]].
 
  updateNumberChangeSet := self findUpdateChangeSetMatching: updateNumber.
  updateNumberChangeSet ifNil: [^ self].
 
  Smalltalk isMorphic ifTrue: [self currentWorld findATranscript: self currentEvent].
  self class logCr; logCr; log: 'Checking ', localFileName, ' (#', updateNumberString, ') for method conflicts with changesets after ', updateNumberChangeSet name, ' ...'.
 
  conflicts := OrderedCollection new.
  self classes do: [:pseudoClass |
  (Array with: pseudoClass with: pseudoClass metaClass) do: [:classOrMeta |
+ classOrMeta selectorsDo: [:selector | | conflict |
- classOrMeta selectors do: [:selector | | conflict |
  conflict := self
  checkForMoreRecentUpdateThanChangeSet: updateNumberChangeSet
  pseudoClass: classOrMeta
  selector: selector.
  conflict ifNotNil: [conflicts add: conflict].
  ].
  ].
  ].
  self class logCr; log: conflicts size asString, (' conflict' asPluralBasedOn: conflicts), ' found.'; logCr.
  self class closeLog.
  ^ conflicts!

Item was changed:
  ----- Method: PseudoClass>>needsInitialize (in category 'testing') -----
  needsInitialize
  ^self hasMetaclass and:[
+ self metaClass includesSelector: #initialize]!
- self metaClass selectors includes: #initialize]!

Item was changed:
  ----- Method: SystemDictionary>>testFormatter (in category 'housekeeping') -----
  testFormatter
  "Smalltalk testFormatter"
 
  "Reformats the source for every method in the system, and
  then compiles that source and verifies that it generates
  identical code. The formatting used will be either classic
  monochrome or fancy polychrome, depending on the setting
  of the preference #colorWhenPrettyPrinting."
 
  "Note: removed references to Preferences colorWhenPrettyPrinting and replaced them simply with false, as I've been removing this preference lately. --Ron Spengler 8/23/09"
 
  | newCodeString methodNode oldMethod newMethod badOnes n |
  badOnes := OrderedCollection new.
  self forgetDoIts.
  'Formatting all classes...'
  displayProgressAt: Sensor cursorPoint
  from: 0
  to: CompiledMethod instanceCount
  during:
  [:bar |
  n := 0.
  self systemNavigation allBehaviorsDo:
  [:cls |
  "Transcript cr; show: cls name."
 
+ cls selectorsDo:
- cls selectors do:
  [:selector |
  (n := n + 1) \\ 100 = 0 ifTrue: [bar value: n].
  newCodeString := cls prettyPrinterClass
  format: (cls sourceCodeAt: selector)
  in: cls
  notifying: nil
  decorated: false.
  methodNode := cls compilerClass new
  compile: newCodeString
  in: cls
  notifying: nil
  ifFail: [].
  newMethod := methodNode generate: #(0 0 0 0).
  oldMethod := cls compiledMethodAt: selector.
  oldMethod = newMethod
  ifFalse:
  [Transcript
  cr;
  show: '***' , cls name , ' ' , selector.
  badOnes add: cls name , ' ' , selector]]]].
  self systemNavigation browseMessageList: badOnes asSortedCollection
  name: 'Formatter Discrepancies'!

Item was changed:
  ----- Method: SystemDictionary>>abandonTempNames (in category 'shrinking') -----
  abandonTempNames
  "Replaces every method by a copy with no source pointer or
  encoded temp names."
  "Smalltalk abandonTempNames"
  | continue oldMethods newMethods n m |
  continue := self confirm: '-- CAUTION --
  If you have backed up your system and
  are prepared to face the consequences of
  abandoning all source code, hit Yes.
  If you have any doubts, hit No,
  to back out with no harm done.'.
  continue
  ifFalse: [^ self inform: 'Okay - no harm done'].
  self forgetDoIts; garbageCollect.
  oldMethods := OrderedCollection new.
  newMethods := OrderedCollection new.
  n := 0.
  'Removing temp names to save space...'
  displayProgressAt: Sensor cursorPoint
  from: 0
  to: CompiledMethod instanceCount
  during: [:bar | self systemNavigation
+ allBehaviorsDo: [:cl | cl selectorsDo: [:sel |
- allBehaviorsDo: [:cl | cl selectors
- do: [:sel |
  bar value: (n := n + 1).
  m := cl compiledMethodAt: sel.
  oldMethods addLast: m.
  newMethods
  addLast: (m copyWithTrailerBytes: #(0 ))]]].
  oldMethods asArray elementsExchangeIdentityWith: newMethods asArray.
  SmalltalkImage current closeSourceFiles.
  self flag: #shouldUseAEnsureBlockToBeSureThatTheFileIsClosed.
  "sd: 17 April 2003"
  Preferences disable: #warnIfNoChangesFile.
  Preferences disable: #warnIfNoSourcesFile!