The Trunk: System-ar.219.mcz

Andreas Raab uploaded a new version of System to project The Trunk:
http://source.squeak.org/trunk/System-ar.219.mcz

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

Name: System-ar.219
Author: ar
Time: 4 January 2010, 12:51:12 pm
UUID: 5d0d6b0d-24fd-3b46-82a4-181f843ed52f
Ancestors: System-nice.216

Make Etoys unloadable: Guard against missing classes like Player, StackMorph etc.

=============== Diff against System-nice.216 ===============

Item was changed:
  ----- Method: SystemDictionary>>majorShrink (in category 'shrinking') -----
  majorShrink
  "Undertake a major shrinkage of the image.
  This method throws out lots of the system that is not needed
  for, eg, operation in a hand-held PC. majorShrink produces a
  999k image in Squeak 2.8
  Smalltalk majorShrink; abandonSources; lastRemoval"
  | oldDicts newDicts |
  self isMorphic
  ifTrue: [^ self error: 'You can only run majorShrink in MVC'].
  Project current isTopProject
  ifFalse: [^ self error: 'You can only run majorShrink in the top project'].
  (self confirm: 'All sub-projects will be deleted from this image.
  You should already have made a backup copy,
  or you must save with a different name after shrinking.
  Shall we proceed to discard most of the content in this image?')
  ifFalse: [^ self inform: 'No changes have been made.'].
  "Remove all projects but the current one. - saves 522k"
  ProjectView
  allInstancesDo: [:pv | pv controller closeAndUnscheduleNoTerminate].
  Project current setParent: Project current.
  self
  at: #Wonderland
  ifPresent: [:cls | cls removeActorPrototypesFromSystem].
+ Smalltalk at: #Player ifPresent:[:aClass| aClass freeUnreferencedSubclasses].
- Player freeUnreferencedSubclasses.
  MorphicModel removeUninstantiatedModels.
  Utilities classPool at: #ScrapsBook put: nil.
  Utilities zapUpdateDownloader.
  ProjectHistory currentHistory initialize.
  Project rebuildAllProjects.
  "Smalltalk discardVMConstruction."
  "755k"
  self discardSoundSynthesis.
  "544k"
  self discardOddsAndEnds.
  "227k"
  self discardNetworking.
  "234k"
  "Smalltalk discard3D."
  "407k"
  self discardFFI.
  "33k"
  self discardMorphic.
  "1372k"
  Symbol rehash.
  "40k"
  "Above by itself saves about 4,238k"
  "Remove references to a few classes to be deleted, so that they
  won't leave obsolete versions around."
  ChangeSet class compile: 'defaultName
  ^ ''Changes'' ' classified: 'initialization'.
  ScreenController removeSelector: #openChangeManager.
  ScreenController removeSelector: #exitProject.
  ScreenController removeSelector: #openProject.
  ScreenController removeSelector: #viewImageImports.
  "Now delete various other classes.."
  SystemOrganization removeSystemCategory: 'Graphics-Files'.
  SystemOrganization removeSystemCategory: 'System-Object Storage'.
  self removeClassNamed: #ProjectController.
  self removeClassNamed: #ProjectView.
  "Smalltalk removeClassNamed: #Project."
  self removeClassNamed: #Component1.
  self removeClassNamed: #FormSetFont.
  self removeClassNamed: #FontSet.
  self removeClassNamed: #InstructionPrinter.
  self removeClassNamed: #ChangeSorter.
  self removeClassNamed: #DualChangeSorter.
  self removeClassNamed: #EmphasizedMenu.
  self removeClassNamed: #MessageTally.
  StringHolder class removeSelector: #originalWorkspaceContents.
  CompiledMethod removeSelector: #symbolic.
  RemoteString removeSelector: #makeNewTextAttVersion.
  Utilities class removeSelector: #absorbUpdatesFromServer.
  self removeClassNamed: #PenPointRecorder.
  self removeClassNamed: #Path.
  self removeClassNamed: #Base64MimeConverter.
  "Smalltalk removeClassNamed: #EToySystem. Dont bother - its
  very small and used for timestamps etc"
  self removeClassNamed: #RWBinaryOrTextStream.
  self removeClassNamed: #AttributedTextStream.
  self removeClassNamed: #WordNet.
  self removeClassNamed: #SelectorBrowser.
  TextStyle
  allSubInstancesDo: [:ts | ts
  newFontArray: (ts fontArray
  copyFrom: 1
  to: (2 min: ts fontArray size))].
  #(ListParagraph PopUpMenu StandardSystemView) do:[:className|
  Smalltalk at: className ifPresent:[:aClass| aClass initialize].
  ].
  ChangeSet noChanges.
  ChangeSet classPool
  at: #AllChangeSets
  put: (OrderedCollection with: ChangeSet current).
  SystemDictionary removeSelector: #majorShrink.
  [self removeAllUnSentMessages > 0]
  whileTrue: [Smalltalk unusedClasses
  do: [:c | (Smalltalk at: c) removeFromSystem]].
  SystemOrganization removeEmptyCategories.
  self
  allClassesDo: [:c | c zapOrganization].
  self garbageCollect.
  'Rehashing method dictionaries . . .'
  displayProgressAt: Sensor cursorPoint
  from: 0
  to: MethodDictionary instanceCount
  during: [:bar |
  oldDicts := MethodDictionary allInstances.
  newDicts := Array new: oldDicts size.
  oldDicts
  withIndexDo: [:d :index |
  bar value: index.
  newDicts at: index put: d rehashWithoutBecome].
  oldDicts elementsExchangeIdentityWith: newDicts].
  oldDicts := newDicts := nil.
  Project rebuildAllProjects.
  ChangeSet current initialize.
  "seems to take more than one try to gc all the weak refs in
  SymbolTable "
  3
  timesRepeat: [self garbageCollect.
  Symbol compactSymbolTable]!

Item was changed:
  ----- Method: ImageSegment>>findStacks (in category 'read/write segment') -----
  findStacks
  "Return an array of all the StackMorphs in this project."
+ | guys stacks |
+ guys := IdentitySet new.
+ Smalltalk at: #StackMorph ifPresent:[:aClass|
+ guys addAll: aClass withAllSubclasses.
+ ].
+ stacks := OrderedCollection new.
+ arrayOfRoots do: [:obj |
+ (guys includes: obj class) ifTrue: [stacks add: obj]].
+ ^ stacks!
-
- | guys stacks |
- guys := StackMorph withAllSubclasses asIdentitySet.
- stacks := OrderedCollection new.
- arrayOfRoots do: [:obj |
- (guys includes: obj class) ifTrue: [stacks add: obj]].
- ^ stacks!

Item was changed:
  ----- Method: ProjectLauncher>>doEtoyLogin (in category 'eToy login') -----
  doEtoyLogin
  "Pop up the eToy login if we have a server that provides us with a known user list"
 
  "Find us a server who could do eToy authentification for us"
  eToyAuthentificationServer :=
  (ServerDirectory localProjectDirectories, ServerDirectory servers values)
  detect:[:any| any hasEToyUserList]
  ifNone:[nil].
  eToyAuthentificationServer "no server provides user information"
  ifNil:[^self startUpAfterLogin].
  self prepareForLogin.
+ (Smalltalk at: #EtoyLoginMorph ifAbsent:[^self cancelLogin])
+ loginAndDo:[:userName| self loginAs: userName]
+ ifCanceled:[self cancelLogin].
+ !
- EtoyLoginMorph
- loginAndDo:[:userName| self loginAs: userName]
- ifCanceled:[self cancelLogin].!

Item was changed:
  ----- Method: SmartRefStream>>restoreClassInstVars (in category 'read write') -----
  restoreClassInstVars
  "Install the values of the class instance variables of UniClasses
  (i.e. scripts slotInfo).  classInstVars is ((#Player25 scripts slotInfo)
  ...).  Thank you Mark Wai for the bug fix."
 
+ | normal trans classPlayer |
- | normal trans |
 
  self flag: #bobconv.
 
+ classPlayer := Smalltalk at: #Player ifAbsent:[^self].
 
  self moreObjects ifFalse: [^ self]. "are no UniClasses with class inst vars"
  classInstVars := super next. "Array of arrays"
  normal := Object class instSize. "might give trouble if Player class superclass changes size"
  (structures at: #Player ifAbsent: [#()]) = #(0 'dependents' 'costume') ifTrue:
  [trans := 1]. "now (0 costume costumes).  Do the conversion of Player class
  inst vars in Update 509."
  classInstVars do: [:list | | aName newCls rList newName start |
  aName := (list at: 1) asSymbol.
  rList := list.
  newName := renamed at: aName ifAbsent: [aName].
  newCls := Smalltalk at: newName
  ifAbsent: [self error: 'UniClass definition missing'].
+ ("old conversion" trans == 1 and: [newCls inheritsFrom: classPlayer]) ifTrue: [
- ("old conversion" trans == 1 and: [newCls inheritsFrom: Player]) ifTrue: [
  "remove costumeDictionary from Player class inst vars"
  rList := rList asOrderedCollection.
  rList removeAt: 4]. "costumeDictionary's value"
  start := list second = 'Update to read classPool' ifTrue: [4] ifFalse: [2].
  newCls class instSize = (normal + (rList size) - start + 1) ifFalse:
  [self error: 'UniClass superclass class has changed size'].
  "Need to install a conversion method mechanism"
  start = 4 ifTrue: [newCls instVarAt: normal - 1 "classPool" put: (list at: 3)].
  start to: rList size do: [:ii |
  newCls instVarAt: normal + ii - start + 1 put: (rList at: ii)]].
  !

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 newKey |
 
  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 := (Smalltalk at: #Player) class superclass instSize.
- 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 | | oldPlayer |
  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 | | newSelList oldSelList |
  oldSelList := OrderedCollection new.   newSelList := OrderedCollection new.
  newClass selectorsDo: [:sel |
  (newClass compiledMethodAt: sel) literals do: [:assoc | | newAssoc |
  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>>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 |
 
  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 | | existing |
  ((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]].
- 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 |
  aFake indexIfCompact > 0 ifTrue: [aFake
  becomeUncompact].
  aFake removeFromSystemUnlogged].
  SystemOrganization removeEmptyCategories].
  "^ self"
  !

Item was removed:
- ----- Method: Project>>displayFontProgress (in category 'menu messages') -----
- displayFontProgress
- "Display progress for fonts"
- | done b |
- done := false.
- b := ScriptableButton new.
- b color: Color yellow.
- b borderWidth: 1; borderColor: Color black.
- [ | dots str idx |
- dots := #(' - ' ' \ ' ' | ' ' / '). idx := 0.
- [done] whileFalse:[
- str := '$ Fixing fonts $ ' translated.
- str := str copyReplaceTokens: '$' with: (dots atWrap: (idx := idx + 1)) asString.
- b label: str font: (TextStyle defaultFont emphasized: 1).
- b extent: 200@50.
- b center: Display center.
- b fullDrawOn: Display getCanvas.
- (Delay forMilliseconds: 250) wait.
- ].
- ] forkAt: Processor userInterruptPriority.
- ^[done := true]!