The Trunk: System-nice.158.mcz

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

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

Name: System-nice.158
Author: nice
Time: 21 October 2009, 1:11:44 am
UUID: a7b58788-0a89-49c1-9119-9399b7dc53e8
Ancestors: System-nice.157

Use #keys rather than #fasterKeys
Note that pattern (x keys asArray sort) could as well be written (x keys sort) now that keys returns an Array...
This #asArray is here solely for cross-dialect/fork compatibility.

=============== Diff against System-nice.157 ===============

Item was changed:
  ----- Method: SystemDictionary>>inspectGlobals (in category 'ui') -----
  inspectGlobals
  "Smalltalk  inspectGlobals"
 
  | associations aDict |
+ associations := ((self  keys reject: [:aKey | ((self  at: aKey) isKindOf: Class)]) asArray sort collect:[:aKey | self associationAt: aKey]).
- associations := ((self  fasterKeys select: [:aKey | ((self  at: aKey) isKindOf: Class) not]) sort collect:[:aKey | self associationAt: aKey]).
  aDict := IdentityDictionary new.
  associations do: [:as | aDict add: as].
  aDict inspectWithLabel: 'The Globals'!

Item was changed:
  ----- Method: ResourceManager class>>lookupOriginalResourceCacheEntry:for: (in category 'resource caching') -----
  lookupOriginalResourceCacheEntry: resourceFileName for: resourceUrl
  "See if we have cached the resource described by the given url in an earlier version of the same project on the same server. In that case we don't need to upload it again but rather link to it."
  | resourceBase resourceMatch matchingUrls |
 
  CachedResources ifNil:[^nil].
 
  "Strip the version number from the resource url"
  resourceBase := resourceUrl copyFrom: 1 to: (resourceUrl lastIndexOf: $.) .
  "Now collect all urls that have the same resource base"
  resourceMatch := resourceBase , '*/' , resourceFileName.
+ matchingUrls := self resourceCache keys
- matchingUrls := self resourceCache fasterKeys
  select: [:entry | (resourceMatch match: entry) and: [(entry beginsWith: resourceUrl) not]].
  matchingUrls isEmpty
  ifTrue: [^nil].
+ matchingUrls asArray sort do: [:entry | | candidates |
- matchingUrls sort do: [:entry | | candidates |
  candidates := (self resourceCache at: entry).
  candidates isEmptyOrNil
  ifFalse: [candidates do: [:candidate |
  candidate = resourceFileName
  ifTrue: [^entry]]]].
  ^nil!

Item was changed:
  ----- Method: SystemDictionary>>removeNormalCruft (in category 'shrinking') -----
  removeNormalCruft
  "Remove various graphics, uniclasses, references. Caution: see
  comment at bottom of method"
  "Smalltalk removeNormalCruft"
  ScriptingSystem stripGraphicsForExternalRelease.
  ScriptingSystem spaceReclaimed.
+ References keys
- References fasterKeys
  do: [:k | References removeKey: k].
  self classNames
  do: [:cName | #('Player' 'CardPlayer' 'Component' 'WonderlandActor' 'MorphicModel' 'PlayWithMe' )
  do: [:superName | ((cName ~= superName
  and: [cName beginsWith: superName])
  and: [(cName allButFirst: superName size)
  allSatisfy: [:ch | ch isDigit]])
  ifTrue: [self removeClassNamed: cName]]].
  self
  at: #Wonderland
  ifPresent: [:cls | cls removeActorPrototypesFromSystem].
  ChangeSet current clear
  "Caution: if any worlds in the image happen to have uniclass
  players associated with them, running this method would
  likely compromise their functioning and could cause errors,
  especially if the uniclass player of the current world had any
  scripts set to ticking. If that happens to you somehow, you will
  probably want to find a way to reset the offending world's
  player to be an UnscriptedCardPlayer, or perhaps nil"!

Item was changed:
  ----- Method: NaturalLanguageTranslator>>fileOutOn:keys: (in category 'fileIn/fileOut') -----
  fileOutOn: aStream keys: keys
  "self current fileOutOn: Transcript. Transcript endEntry"
  (keys
+ ifNil: [generics keys asArray sort])
- ifNil: [generics fasterKeys sort])
  do: [:key | self
  nextChunkPut: (generics associationAt: key)
  on: aStream].
  keys
  ifNil: [self untranslated
  do: [:each | self nextChunkPut: each -> '' on: aStream]].
  aStream nextPut: $!!;
  cr!

Item was changed:
  ----- Method: ResourceCollector>>forgetObsolete (in category 'initialize') -----
  forgetObsolete
  "Forget obsolete locators, e.g., those that haven't been referenced and not been stored on a file."
+ locatorMap keys "copy" do:[:k|
- locatorMap fasterKeys do:[:k|
  (locatorMap at: k) localFileName ifNil:[locatorMap removeKey: k]].!

Item was changed:
  ----- Method: NaturalLanguageTranslator class>>cleanUpCache (in category 'private') -----
  cleanUpCache
  "NaturalLanguageTranslator cleanUpCache"
 
+ self cachedTranslations keys do: [:key |
- self cachedTranslations fasterKeys do: [:key |
  key isoLanguage size > 2 ifTrue: [self cachedTranslations removeKey: key]]!

Item was changed:
  ----- Method: ResourceManager>>fixJISX0208Resource (in category 'private') -----
  fixJISX0208Resource
+ resourceMap keys do: [:key |
- resourceMap fasterKeys do: [:key |
  | value url |
  value := resourceMap at: key.
  url := key urlString copy.
  url isOctetString not ifTrue: [url mutateJISX0208StringToUnicode].
  resourceMap removeKey: key.
  key urlString: url.
  resourceMap at: key put: value.
  ].
  !

Item was changed:
  ----- Method: ResourceManager>>loaderProcess (in category 'loading') -----
  loaderProcess
  | loader requests req locator resource stream |
  loader := HTTPLoader default.
  requests := Dictionary new.
  self prioritizedUnloadedResources do:[:loc|
  req := HTTPLoader httpRequestClass for: (self hackURL: loc urlString) in: loader.
  loader addRequest: req.
  requests at: req put: loc].
  [stopFlag or:[requests isEmpty]] whileFalse:[
  stopSemaphore waitTimeoutMSecs: 500.
+ requests keys "need a copy" do:[:r|
- requests fasterKeys "need a copy" do:[:r|
  r isSemaphoreSignaled ifTrue:[
  locator := requests at: r.
  requests removeKey: r.
  stream := r contentStream.
  resource := resourceMap at: locator ifAbsent:[nil].
  self class cacheResource: locator urlString stream: stream.
  self installResource: resource
  from: stream
  locator: locator.
  (resource isForm) ifTrue:[
  WorldState addDeferredUIMessage: self formChangedReminder]
  ifFalse: [self halt].
  ].
  ].
  ].
  "Either done downloading or terminating process"
  stopFlag ifTrue:[loader abort].
  loaderProcess := nil.
  stopSemaphore := nil.!

Item was changed:
  ----- Method: ResourceManager>>abandonResourcesThat: (in category 'private') -----
  abandonResourcesThat: matchBlock
  "Private. Forget resources that match the given argument block"
+ resourceMap keys "need copy" do:[:loc|
- resourceMap fasterKeys "need copy" do:[:loc|
  (matchBlock value: loc) ifTrue:[
  resourceMap removeKey: loc ifAbsent:[].
  loaded remove: loc ifAbsent:[].
  unloaded remove: loc ifAbsent:[].
  ].
  ].!

Item was changed:
  ----- Method: SpaceTally>>compareTallyIn:to: (in category 'fileOut') -----
  compareTallyIn: beforeFileName to: afterFileName
  "SpaceTally new compareTallyIn: 'tally' to: 'tally2'"
 
  | answer s beforeDict a afterDict allKeys |
  beforeDict := Dictionary new.
  s := FileDirectory default fileNamed: beforeFileName.
  [s atEnd] whileFalse: [
  a := Array readFrom: s nextLine.
  beforeDict at: a first put: a allButFirst.
  ].
  s close.
  afterDict := Dictionary new.
  s := FileDirectory default fileNamed: afterFileName.
  [s atEnd] whileFalse: [
  a := Array readFrom: s nextLine.
  afterDict at: a first put: a allButFirst.
  ].
  s close.
  answer := WriteStream on: String new.
+ allKeys := (Set new addAll: beforeDict keys; addAll: afterDict keys; yourself) asSortedCollection.
- allKeys := (Set new addAll: beforeDict fasterKeys; addAll: afterDict fasterKeys; yourself) asSortedCollection.
  allKeys do: [ :each |
  | before after diff |
  before := beforeDict at: each ifAbsent: [#(0 0 0)].
  after := afterDict at: each ifAbsent: [#(0 0 0)].
  diff := before with: after collect: [ :vBefore :vAfter | vAfter - vBefore].
  diff = #(0 0 0) ifFalse: [
  answer nextPutAll: each,'  ',diff printString; cr.
  ].
  ].
  StringHolder new contents: answer contents; openLabel: 'space diffs'.
 
 
 
  !

Item was changed:
  ----- Method: ResourceCollector>>removeLocator: (in category 'accessing') -----
  removeLocator: loc
+ locatorMap keys "copy" do:[:k|
- locatorMap fasterKeys do:[:k|
  (locatorMap at: k) = loc ifTrue:[locatorMap removeKey: k]].!

Item was changed:
  ----- Method: SystemDictionary>>cleanUpUndoCommands (in category 'shrinking') -----
  cleanUpUndoCommands
  "Smalltalk cleanUpUndoCommands"  "<== print this to get classes involved"
 
  | classes i p |
  classes := Bag new.
  'Ferreting out obsolete undo commands'
  displayProgressAt: Sensor cursorPoint
  from: 0 to: Morph withAllSubclasses size
  during:
  [:bar | i := 0.
  Morph withAllSubclassesDo:
  [:c | bar value: (i := i+1).
  c allInstancesDo:
  [:m | (p := m otherProperties) ifNotNil:
+ [p keys do:
- [p fasterKeys do:
  [:k | (p at: k) class == Command ifTrue:
  [classes add: c name.
  m removeProperty: k]]]]]].
  ^ classes!

Item was changed:
  ----- Method: ObjectScanner>>clear (in category 'initialize-release') -----
  clear
  "remove all old class vars.  They were UniClasses being remapped to aviod a name conflict."
 
+ self class classPool keys do: [:key |
- self class classPool fasterKeys do: [:key |
  self class classPool removeKey: key]. "brute force"!

Item was changed:
  ----- Method: SystemDictionary>>poolUsers (in category 'retrieving') -----
  poolUsers
  "Answer a dictionary of pool name -> classes that refer to it.
  Also includes any globally know dictionaries (such as
  Smalltalk, Undeclared etc) which although not strictly
  accurate is potentially useful information"
  "Smalltalk poolUsers"
  | poolUsers |
  poolUsers := Dictionary new.
+ self keys
- self fasterKeys
  do: [:k | "yes, using isKindOf: is tacky but for reflective code like
  this it is very useful. If you really object you can:-
  a) go boil your head.
  b) provide a better answer.
  your choice."
  | pool refs |
  (((pool := self at: k) isKindOf: Dictionary)
  or: [pool isKindOf: SharedPool class])
  ifTrue: [refs := self systemNavigation allClasses
  select: [:c | c sharedPools identityIncludes: pool]
  thenCollect: [:c | c name].
  refs
  add: (self systemNavigation
  allCallsOn: (self associationAt: k)).
  poolUsers at: k put: refs]].
  ^ poolUsers!

Item was changed:
  ----- Method: DeepCopier>>mapUniClasses (in category 'like fullCopy') -----
  mapUniClasses
  "For new Uniclasses, map their class vars to the new objects.  And their additional class instance vars.  (scripts slotInfo) and cross references like (player321)."
  "Players also refer to each other using associations in the References dictionary.  Search the methods of our Players for those.  Make new entries in References and point to them."
  | pp oldPlayer newKey newAssoc oldSelList newSelList |
 
  newUniClasses ifFalse: [^ self]. "All will be siblings.  uniClasses is empty"
  "Uniclasses use class vars to hold onto siblings who are referred to in code"
  pp := Player class superclass instSize.
  uniClasses do: [:playersClass | "values = new ones"
  playersClass classPool associationsDo: [:assoc |
  assoc value: (assoc value veryDeepCopyWith: self)].
  playersClass scripts: (playersClass privateScripts veryDeepCopyWith: self). "pp+1"
  "(pp+2) slotInfo was deepCopied in copyUniClass and that's all it needs"
  pp+3 to: playersClass class instSize do: [:ii |
  playersClass instVarAt: ii put:
  ((playersClass instVarAt: ii) veryDeepCopyWith: self)].
  ].
 
  "Make new entries in References and point to them."
+ References keys "copy" do: [:playerName |
- References fasterKeys do: [:playerName |
  oldPlayer := References at: playerName.
  (references includesKey: oldPlayer) ifTrue: [
  newKey := (references at: oldPlayer) "new player" uniqueNameForReference.
  "now installed in References"
  (references at: oldPlayer) renameTo: newKey]].
  uniClasses "values" do: [:newClass |
  oldSelList := OrderedCollection new.   newSelList := OrderedCollection new.
  newClass selectorsDo: [:sel |
  (newClass compiledMethodAt: sel) literals do: [:assoc |
  assoc isVariableBinding ifTrue: [
  (References associationAt: assoc key ifAbsent: [nil]) == assoc ifTrue: [
  newKey := (references at: assoc value ifAbsent: [assoc value])
  externalName asSymbol.
  (assoc key ~= newKey) & (References includesKey: newKey) ifTrue: [
  newAssoc := References associationAt: newKey.
  newClass methodDictionary at: sel put:
  (newClass compiledMethodAt: sel) clone. "were sharing it"
  (newClass compiledMethodAt: sel)
  literalAt: ((newClass compiledMethodAt: sel) literals indexOf: assoc)
  put: newAssoc.
  (oldSelList includes: assoc key) ifFalse: [
  oldSelList add: assoc key.  newSelList add: newKey]]]]]].
  oldSelList with: newSelList do: [:old :new |
  newClass replaceSilently: old to: new]]. "This is text replacement and can be wrong"!

Item was changed:
  ----- Method: ImageSegment>>smartFillRoots: (in category 'read/write segment') -----
  smartFillRoots: dummy
  | refs known ours ww blockers |
  "Put all traced objects into my arrayOfRoots.  Remove some
  that want to be in outPointers.  Return blockers, an
  IdentityDictionary of objects to replace in outPointers."
 
  blockers := dummy blockers.
  known := (refs := dummy references) size.
+ refs keys do: [:obj | "copy keys to be OK with removing items"
- refs fasterKeys do: [:obj | "copy keys to be OK with removing items"
  (obj isSymbol) ifTrue: [refs removeKey: obj.
  known := known-1].
  (obj class == PasteUpMorph) ifTrue: [
  obj isWorldMorph & (obj owner == nil) ifTrue: [
  obj == dummy project world ifFalse: [
  refs removeKey: obj.  known := known-1.
  blockers at: obj put:
  (StringMorph
  contents: 'The worldMorph of a different world')]]].
  "Make a ProjectViewMorph here"
  "obj class == Project ifTrue: [Transcript show: obj; cr]."
  (blockers includesKey: obj) ifTrue: [
  refs removeKey: obj ifAbsent: [known :=
  known+1].  known := known-1].
  ].
  ours := dummy project world.
  refs keysDo: [:obj |
  obj isMorph ifTrue: [
  ww := obj world.
  (ww == ours) | (ww == nil) ifFalse: [
  refs removeKey: obj.  known := known-1.
  blockers at: obj put:
  (StringMorph contents:
  obj
  printString, ' from another world')]]].
  "keep original roots on the front of the list"
  (dummy rootObject) do: [:rr | refs removeKey: rr ifAbsent: []].
+ ^ dummy rootObject, refs keys asArray.
- ^ dummy rootObject, refs fasterKeys asArray.
 
  !

Item was changed:
  ----- Method: EventManager class>>flushEvents (in category 'initialize-release') -----
  flushEvents
  "Object flushEvents"
  | msgSet |
  self actionMaps keysAndValuesDo:[:rcvr :evtDict| rcvr ifNotNil:[
  "make sure we don't modify evtDict while enumerating"
+ evtDict keys do:[:evtName|
- evtDict fasterKeys do:[:evtName|
  msgSet := evtDict at: evtName ifAbsent:[nil].
  (msgSet == nil) ifTrue:[rcvr removeActionsForEvent: evtName]]]].
  EventManager actionMaps finalizeValues. !

Item was changed:
  ----- Method: ResourceManager>>registerUnloadedResources (in category 'loading') -----
  registerUnloadedResources
+ resourceMap keys do: [:newLoc |
- resourceMap fasterKeys do: [:newLoc |
  unloaded add: newLoc]
  !

Item was changed:
  ----- Method: ImageSegment class>>swapOutInactiveClasses (in category 'testing') -----
  swapOutInactiveClasses  "ImageSegment swapOutInactiveClasses"  
  "Make up segments by grouping unused classes by system category.
  Read about, and execute discoverActiveClasses, and THEN execute this one."
 
  | unused groups i roots |
  ImageSegment recoverFromMDFault.
  ImageSegmentRootStub recoverFromMDFault.
  unused := Smalltalk allClasses select: [:c | (c instVarNamed: 'methodDict') == nil].
  unused do: [:c | c recoverFromMDFault].
  groups := Dictionary new.
  SystemOrganization categories do:
  [:cat |
  i := (cat findLast: [:c | c = $-]) - 1.
  i <= 0 ifTrue: [i := cat size].
  groups at: (cat copyFrom: 1 to: i)
  put: (groups at: (cat copyFrom: 1 to: i) ifAbsent: [Array new]) ,
  ((SystemOrganization superclassOrder: cat) select: [:c |
  unused includes: c]) asArray].
+ groups keys do:
- groups fasterKeys do:
  [:cat | roots := groups at: cat.
  Transcript cr; cr; show: cat; cr; print: roots; endEntry.
  roots := roots , (roots collect: [:c | c class]).
  (cat beginsWith: 'Sys' "something here breaks") ifFalse:
  [(ImageSegment new copyFromRoots: roots sizeHint: 0) extract;
  writeToFile: cat].
  Transcript cr; print: Smalltalk garbageCollect; endEntry]!

Item was changed:
  ----- Method: ImageSegment>>comeFullyUpOnReload: (in category 'fileIn/Out') -----
  comeFullyUpOnReload: smartRefStream
  "fix up the objects in the segment that changed size.  An
  object in the segment is the wrong size for the modern version of the
  class.  Construct a fake class that is the old size.  Replace the
  modern class with the old one in outPointers.  Load the segment.
  Traverse the instances, making new instances by copying fields, and
  running conversion messages.  Keep the new instances.  Bulk forward
  become the old to the new.  Let go of the fake objects and classes.
  After the install (below), arrayOfRoots is filled in.
  Globalize new classes.  Caller may want to do some special install on
  certain objects in arrayOfRoots.
  May want to write the segment out to disk in its new form."
 
  | mapFakeClassesToReal ccFixups receiverClasses
  rootsToUnhiberhate myProject existing |
 
  RecentlyRenamedClasses := nil. "in case old data
  hanging around"
  mapFakeClassesToReal := smartRefStream reshapedClassesIn: outPointers.
  "Dictionary of just the ones that change shape.
  Substitute them in outPointers."
  ccFixups := self remapCompactClasses: mapFakeClassesToReal
  refStrm: smartRefStream.
  ccFixups ifFalse: [^ self error: 'A class in the file is not
  compatible'].
  endMarker := segment nextObject. "for enumeration of objects"
  endMarker == 0 ifTrue: [endMarker := 'End' clone].
  self fixCapitalizationOfSymbols.
  arrayOfRoots := self loadSegmentFrom: segment outPointers: outPointers.
  "Can't use install.  Not ready for rehashSets"
  mapFakeClassesToReal isEmpty ifFalse: [
  self reshapeClasses: mapFakeClassesToReal refStream:
  smartRefStream
  ].
  "When a Project is stored, arrayOfRoots has all objects in
  the project, except those in outPointers"
  arrayOfRoots do: [:importedObject |
  ((importedObject isMemberOf: WideString) or: [importedObject isMemberOf: WideSymbol]) ifTrue: [
  importedObject mutateJISX0208StringToUnicode.
  importedObject class = WideSymbol ifTrue: [
  "self halt."
  Symbol hasInterned:
  importedObject asString ifTrue: [:multiSymbol |
  multiSymbol == importedObject
  ifFalse: [
  importedObject
  becomeForward: multiSymbol.
  ].
  ].
  ].
  ].
  (importedObject isKindOf: TTCFontSet) ifTrue: [
  existing := TTCFontSet familyName:
  importedObject familyName
  pointSize:
  importedObject pointSize. "supplies default"
  existing == importedObject ifFalse:
  [importedObject becomeForward: existing].
  ].
  ].
  "Smalltalk garbageCollect.   MultiSymbol rehash.  These take
  time and are not urgent, so don't to them.  In the normal case, no
  bad MultiSymbols will be found."
 
  receiverClasses := self restoreEndianness. "rehash sets"
  smartRefStream checkFatalReshape: receiverClasses.
 
  "Classes in this segment."
  arrayOfRoots do: [:importedObject |
  importedObject class class == Metaclass ifTrue: [self
  declare: importedObject]].
  arrayOfRoots do: [:importedObject |
  (importedObject isKindOf: CompiledMethod) ifTrue: [
  importedObject sourcePointer > 0 ifTrue:
  [importedObject zapSourcePointer]].
  (importedObject isKindOf: Project) ifTrue: [
  myProject := importedObject.
  importedObject ensureChangeSetNameUnique.
  Project addingProject: importedObject.
  importedObject restoreReferences.
  self dependentsRestore: importedObject.
  ScriptEditorMorph writingUniversalTiles:
  ((importedObject projectPreferenceAt:
  #universalTiles) ifNil: [false])]].
 
  rootsToUnhiberhate := arrayOfRoots select: [:importedObject |
  importedObject respondsTo: #unhibernate
  "ScriptEditors and ViewerFlapTabs"
  ].
  myProject ifNotNil: [
  myProject world setProperty: #thingsToUnhibernate
  toValue: rootsToUnhiberhate
  ].
 
  mapFakeClassesToReal isEmpty ifFalse: [
+ mapFakeClassesToReal keys do: [:aFake |
- mapFakeClassesToReal fasterKeys do: [:aFake |
  aFake indexIfCompact > 0 ifTrue: [aFake
  becomeUncompact].
  aFake removeFromSystemUnlogged].
  SystemOrganization removeEmptyCategories].
  "^ self"
  !