'From Squeak3.2alpha of 4 October 2001 [latest update: #4583] on 6 December 2001 at 3:52:08 pm'! "Change Set: WondLandFix-tk Date: 6 December 2001 Author: Ted Kaehler Attempting to get the Flag Demo to load in a Project. Don't zap source pointer at end of a CompiledMethod if it does not have one!! Those are the valuable bytecodes of a DoIt!! Make the name of a WonderlandActor start with 'WonderlandActor' instead of 'Player'. Put WonderlandActors in the proper system category. When a project has special code that runs is, such as flagDemo.cs, that must be in the changeSet of the project, and you must say Yes to including the changeSet."! !ImageSegment methodsFor: 'fileIn/Out' stamp: 'tk 12/6/2001 15:36'! 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 | self flag: #bobconv. 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]. arrayOfRoots _ self loadSegmentFrom: segment outPointers: outPointers. "Can't use install. Not ready for rehashSets" mapFakeClassesToReal isEmpty ifFalse: [ self reshapeClasses: mapFakeClassesToReal refStream: smartRefStream ]. 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. 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"! ! !ImageSegment methodsFor: 'fileIn/Out' stamp: 'tk 12/5/2001 14:47'! declareAndPossiblyRename: classThatIsARoot | existing catInstaller | "The class just arrived in this segment. How fit it into the Smalltalk dictionary? If it had an association, that was installed with associationDeclareAt:." catInstaller _ [ classThatIsARoot superclass name == #Player ifTrue: [classThatIsARoot category: Object categoryForUniclasses] ifFalse: [(classThatIsARoot superclass name beginsWith: 'WonderLandActor') ifTrue: [classThatIsARoot category: 'Balloon3D-UserObjects'] ifFalse: [classThatIsARoot category: 'Morphic-Imported']]. ]. classThatIsARoot superclass addSubclass: classThatIsARoot. (Smalltalk includesKey: classThatIsARoot name) ifFalse: [ "Class entry in Smalltalk not referred to in Segment, install anyway." catInstaller value. ^ Smalltalk at: classThatIsARoot name put: classThatIsARoot]. existing _ Smalltalk at: classThatIsARoot name. existing xxxClass == ImageSegmentRootStub ifTrue: [ "We are that segment!! Must ask it carefully!!" catInstaller value. ^ Smalltalk at: classThatIsARoot name put: classThatIsARoot]. existing == false | (existing == nil) ifTrue: [ "association is in outPointers, just installed" catInstaller value. ^ Smalltalk at: classThatIsARoot name put: classThatIsARoot]. "Conflict with existing global or copy of the class" (existing isKindOf: Class) ifTrue: [ classThatIsARoot isSystemDefined not ifTrue: [ "UniClass. give it a new name" classThatIsARoot setName: classThatIsARoot baseUniclass chooseUniqueClassName. catInstaller value. "must be after new name" ^ Smalltalk at: classThatIsARoot name put: classThatIsARoot]. "Take the incoming one" self inform: 'Using newly arrived version of ', classThatIsARoot name. classThatIsARoot superclass removeSubclass: classThatIsARoot. "just in case" (Smalltalk at: classThatIsARoot name) becomeForward: classThatIsARoot. catInstaller value. ^ classThatIsARoot superclass addSubclass: classThatIsARoot]. self error: 'Name already in use by a non-class: ', classThatIsARoot name. ! ! !WonderlandActor class methodsFor: 'unique name creation' stamp: 'tk 12/5/2001 14:51'! baseUniclass "Answer the uniclass that new instances should be instances of; this protocol allows for individual cards of a background to have their own class" | curr | curr _ self. [curr theNonMetaClass superclass name endsWithDigit] whileTrue: [curr _ curr superclass]. ^ curr "CardPlayer100 baseUniclass CardPlayer100X baseUniclass "! !