Packages September 2016

packages@lists.squeakfoundation.org

1 participants
72 discussions

The Trunk: EToys-jl.238.mcz
by commits＠source.squeak.org 20 Sep '16

20 Sep '16

Jens Lincke uploaded a new version of EToys to project The Trunk: http://source.squeak.org/trunk/EToys-jl.238.mcz ==================== Summary ==================== Name: EToys-jl.238 Author: jl Time: 20 September 2016, 3:50:57.399902 pm UUID: 4130651d-c6a9-1c43-a5aa-734f9e8d8202 Ancestors: EToys-jl.237 allow closing projects in the project history view morph. necessary because of changes to how project deletion works for trees of projects. =============== Diff against EToys-jl.237 =============== Item was added: + ----- Method: EToyProjectHistoryMorph>>confirmedDelete:evt:from: (in category 'as yet unclassified') ----- + confirmedDelete: aProject evt: evt from: origin + + self delete. + aProject = Project current ifTrue: [ + ^ self inform: 'Cannot delete current project' translated]. + (self confirm: ('Do you really want to delete {1} + and all its content?' translated format: {aProject name})) + ifTrue: [aProject delete].! Item was changed: ----- Method: EToyProjectHistoryMorph>>jumpToProject (in category 'as yet unclassified') ----- jumpToProject - | selection | - selection := (Project current buildJumpToMenu: MenuMorph new) invokeModal. self closeMyFlapIfAny. + Project current jumpToProject. + - Project current jumpToSelection: selection ! Item was changed: ----- Method: EToyProjectHistoryMorph>>rebuild (in category 'as yet unclassified') ----- rebuild | history r1 | history := ProjectHistory currentHistory mostRecentCopy. changeCounter := ProjectHistory changeCounter. self removeAllMorphs. self rubberBandCells: false. "enable growing" r1 := self addARow: { self inAColumn: { StringMorph new contents: 'Jump...' translated; lock. }. }. r1 on: #mouseUp send: #jumpToProject to: self. history do: [ :each | ( self addARow: { (self inAColumn: { StretchyImageMorph new form: each second; minWidth: 35; minHeight: 35; lock }) vResizing: #spaceFill. self inAColumn: { StringMorph new contents: each first; lock. + "StringMorph new contents: each fourth first; lock." - "StringMorph new contents: each third; lock." }. + (self inAColumn: { + StringMorph new + color: Color red; + contents: 'X'; + on: #mouseDown send: #confirmedDelete:evt:from: to: self withValue: each fourth first + }) hResizing: #rigid. } ) color: Color paleYellow; borderWidth: 1; borderColor: #raised; vResizing: #spaceFill; on: #mouseUp send: #mouseUp:in: to: self; on: #mouseDown send: #mouseDown:in: to: self; on: #mouseMove send: #mouseMove:in: to: self; on: #mouseLeave send: #mouseLeave:in: to: self; setProperty: #projectParametersTuple toValue: each; setBalloonText: (each third isEmptyOrNil ifTrue: ['not saved'] ifFalse: [each third]) ]. "--- newTuple := { aProject name. aProject thumbnail. aProject url. WeakArray with: aProject. }. ---"! Item was changed: ----- Method: SugarNavigatorBar>>newProject (in category 'the actions') ----- newProject + "Not creating a view. mt's refactoring of projects breaks the assumption that we can always delete a project and all it's children through a view anyway" MorphicProject new enter!

1 0

The Trunk: EToys-jl.237.mcz
by commits＠source.squeak.org 20 Sep '16

20 Sep '16

Jens Lincke uploaded a new version of EToys to project The Trunk: http://source.squeak.org/trunk/EToys-jl.237.mcz ==================== Summary ==================== Name: EToys-jl.237 Author: jl Time: 20 September 2016, 1:48:28.446902 pm UUID: 255d2987-bffc-ef4b-bb13-a862a8adbc86 Ancestors: EToys-jl.235, EToys-tfel.236 - distanceTo calculations in Kedama between groups of turtles - conditions in Kedama per turtle, not globally - fix for dynamically changing the size of a Kedama world =============== Diff against EToys-tfel.236 =============== Item was added: + ----- Method: KedamaExamplerPlayer>>getXAndY (in category 'slot getters/setters') ----- + getXAndY + + ^ self turtles getXAndY! Item was changed: ----- Method: KedamaMorph>>dimensions: (in category 'accessing') ----- dimensions: anExtent dimensions := anExtent. wrapX := dimensions x asFloat. wrapY := dimensions y asFloat. patchVarDisplayForm := Form extent: dimensions depth: 32. + patchesToDisplay ifNotNil: [ + patchesToDisplay do: [ :ea | + ea newExtent: anExtent. + ]. - patchesToDisplay do: [ :ea | - ea newExtent: anExtent. ]. self pixelsPerPatch: self pixelsPerPatch.! Item was added: + ----- Method: KedamaTurtlePlayer>>getXAndY (in category 'commands and slots') ----- + getXAndY + + ^ x@y. + ! Item was changed: ----- Method: KedamaTurtleVectorPlayer2 class>>primGetDistanceToX:toY:xArray:yArray:resultInto: (in category 'as yet unclassified') ----- primGetDistanceToX: pX toY: pY xArray: xArray yArray: yArray resultInto: result + | ppx ppy tempMin | - | ppx ppy | <primitive: 'vectorGetDistanceTo' module:'KedamaPlugin2'> "^ KedamaPlugin doPrimitive: #vectorGetDistanceTo." ppx := pX. ppy := pY. 1 to: result size do: [:index | pX isCollection ifTrue: [ + tempMin := SmallInteger maxVal. + 1 to: pX size do: [:index2 | + ppx := pX at: index2. + ppy := pY at: index2. + tempMin := tempMin min: ((ppx - (xArray at: index)) squared + (ppy - (yArray at: index)) squared) sqrt. + ]. + self flag: #todo. "should really also remember the other side index to re-use inside the script" + result at: index put: tempMin. + ] ifFalse: [ + result at: index put: ((ppx - (xArray at: index)) squared + (ppy - (yArray at: index)) squared) sqrt. + ] - ppx := pX at: index. - ppy := pY at: index. - ]. - result at: index put: ((ppx - (xArray at: index)) squared + (ppy - (yArray at: index)) squared) sqrt. - ]. ^ result. ! Item was changed: ----- Method: KedamaTurtleVectorPlayer2>>getDistanceTo: (in category 'player commands') ----- getDistanceTo: players | p xArray yArray result pX pY xy | players isCollection ifFalse: [ p := players ]. xArray := arrays at: 2. yArray := arrays at: 3. result := KedamaFloatArray new: self size. players isCollection ifTrue: [ pX := KedamaFloatArray new: players size. pY := KedamaFloatArray new: players size. 1 to: players size do: [:i | xy := (players at: i) getXAndY. pX at: i put: xy x. pY at: i put: xy y. ]. ] ifFalse: [ + pX := p turtles getX. + pY := p turtles getY. - xy := p getXAndY. - pX := xy x. - pY := xy y. ]. ^ KedamaTurtleVectorPlayer2 primGetDistanceToX: pX toY: pY xArray: xArray yArray: yArray resultInto: result. ! Item was added: + ----- Method: KedamaTurtleVectorPlayer2>>getXAndY (in category 'player commands') ----- + getXAndY + | ys | + ys := self getY. + ^ self getX asArray withIndexCollect: [:ea :idx | ea @ (ys at: idx)] + ! Item was changed: ----- Method: KedamaTurtleVectorPlayer2>>test:ifTrue:ifFalse: (in category 'command execution') ----- test: cond ifTrue: trueBlock ifFalse: falseBlock + | origPredicate c actualCond condValue | + - | origPredicate c actualCond | (cond == true or: [cond == false]) ifTrue: [ ^ cond ifTrue: [trueBlock value: self] ifFalse: [falseBlock value: self]. ]. actualCond := cond. cond isBlock ifTrue: [ actualCond := ByteArray new: predicate size. + condValue := cond value. + condValue isCollection + ifTrue: [ + actualCond := condValue. + ] ifFalse: [ + 1 to: predicate size do: [:i | actualCond at: i put: (cond value ifTrue: [1] ifFalse: [0])] + ] - 1 to: predicate size do: [:i | actualCond at: i put: (cond value ifTrue: [1] ifFalse: [0])] ]. origPredicate := predicate clone. predicate bytesAnd: actualCond. trueBlock value: self. c := actualCond clone. c not. predicate replaceFrom: 1 to: (predicate size min: origPredicate size) with: origPredicate startingAt: 1. predicate bytesAnd: c. falseBlock value: self. predicate replaceFrom: 1 to: (predicate size min: origPredicate size) with: origPredicate startingAt: 1.! Item was changed: ----- Method: Object>>test:ifTrue:ifFalse: (in category '*Etoys-Squeakland-Tweak-Kedama') ----- test: cond ifTrue: trueBlock ifFalse: falseBlock + cond value ifTrue: [trueBlock value: self] ifFalse: [falseBlock value: self]. - cond ifTrue: [trueBlock value: self] ifFalse: [falseBlock value: self]. ! Item was added: + ----- Method: Player>>getXAndY (in category 'slot getters/setters') ----- + getXAndY + + ^ self getX @ self getY + ! Item was changed: ----- Method: WordArray>>eToysEQ: (in category '*Etoys-Squeakland-array arithmetic') ----- eToysEQ: other | result | + result := ByteArray new: self size. other isNumber ifTrue: [ ^ self primEQScalar: self and: other into: result. ]. other isCollection ifTrue: [ ^ self primEQArray: self and: other into: result. ]. + other isColor ifTrue: [ + ^ self primEQScalar: self and: (other pixelValueForDepth: 32) into: result. + ]. + ^ super = other. !

1 0

The Trunk: Tools-jl.727.mcz
by commits＠source.squeak.org 20 Sep '16

20 Sep '16

Jens Lincke uploaded a new version of Tools to project The Trunk: http://source.squeak.org/trunk/Tools-jl.727.mcz ==================== Summary ==================== Name: Tools-jl.727 Author: jl Time: 20 September 2016, 1:42:21.385902 pm UUID: 5ef2f6d9-b959-1d4c-81dc-db164dd7ee6e Ancestors: Tools-jl.725, Tools-bf.726 fix etoys project load dialog =============== Diff against Tools-bf.726 =============== Item was changed: ----- Method: FileList2 class>>morphicViewProjectLoader2InWorld:reallyLoad:dirFilterType: (in category 'blue ui') ----- morphicViewProjectLoader2InWorld: aWorld reallyLoad: aBoolean dirFilterType: aSymbol | window aFileList buttons treePane textColor1 fileListPane pane2a pane2b treeExtent filesExtent | window := AlignmentMorphBob1 newColumn. window hResizing: #shrinkWrap; vResizing: #shrinkWrap. textColor1 := Color r: 0.742 g: 0.839 b: 1.0. + aFileList := self new. - aFileList := self new directory: FileDirectory default. aFileList optionalButtonSpecs: aFileList servicesForProjectLoader; fileSelectionBlock: ( aSymbol == #limitedSuperSwikiDirectoryList ifTrue: [ MessageSend receiver: self selector: #projectOnlySelectionMethod: ] ifFalse: [ self projectOnlySelectionBlock ] ); "dirSelectionBlock: self hideSqueakletDirectoryBlock;" modalView: window. + aFileList directory: FileDirectory default. window setProperty: #FileList toValue: aFileList; wrapCentering: #center; cellPositioning: #topCenter; borderWidth: 1; borderColor: (Color r: 0.9 g: 0.801 b: 0.2); useRoundedCorners. buttons := {{'OK'. Color lightGreen}. {'Cancel'. Color lightRed}} collect: [ :each | self blueButtonText: each first textColor: textColor1 color: each second inWindow: window ]. aWorld width < 800 ifTrue: [ treeExtent := 150@300. filesExtent := 350@300. ] ifFalse: [ + treeExtent := 350@500. + filesExtent := 550@500. - treeExtent := 250@300. - filesExtent := 350@300. ]. (treePane := aFileList morphicDirectoryTreePaneFiltered: aSymbol) extent: treeExtent; retractable: false; borderWidth: 0. fileListPane := aFileList morphicFileListPane extent: filesExtent; retractable: false; borderWidth: 0. window addARow: { window fancyText: 'Load A Project' translated font: Preferences standardEToysTitleFont color: textColor1 }; addARowCentered: { buttons first. (Morph new extent: 30@5) color: Color transparent. buttons second }; addARow: { window fancyText: 'Please select a project' translated font: Preferences standardEToysFont color: textColor1 }; addARow: { (window inAColumn: {(pane2a := window inARow: {window inAColumn: {treePane}}) useRoundedCorners; layoutInset: 0; borderWidth: 1; borderColor: (Color r: 0.6 g: 0.7 b: 1) }) layoutInset: 10. (window inAColumn: {(pane2b := window inARow: {window inAColumn: {fileListPane}}) useRoundedCorners; layoutInset: 0; borderWidth: 1; borderColor: (Color r: 0.6 g: 0.7 b: 1) }) layoutInset: 10. }. window fullBounds. window fillWithRamp: (Color r: 1 g: 0.85 b: 0.975) oriented: 0.65. pane2a fillWithRamp: (Color r: 0.85 g: 0.9 b: 1) oriented: (0.7 @ 0.35). pane2b fillWithRamp: (Color r: 0.85 g: 0.9 b: 1) oriented: (0.7 @ 0.35). " buttons do: [ :each | each fillWithRamp: ColorTheme current dialogButtonsRampOrColor oriented: (0.75 @ 0). ]. " buttons first on: #mouseUp send: (aBoolean ifTrue: [#okHitForProjectLoader] ifFalse: [#okHit]) to: aFileList. buttons second on: #mouseUp send: #cancelHit to: aFileList. aFileList postOpen. window position: aWorld topLeft + (aWorld extent - window extent // 2). window adoptPaneColor: (Color r: 0.548 g: 0.677 b: 1.0). window becomeModal. ^ window openInWorld: aWorld.!

1 0

The Trunk: EToys-tfel.236.mcz
by commits＠source.squeak.org 20 Sep '16

20 Sep '16

Tim Felgentreff uploaded a new version of EToys to project The Trunk: http://source.squeak.org/trunk/EToys-tfel.236.mcz ==================== Summary ==================== Name: EToys-tfel.236 Author: tfel Time: 20 September 2016, 12:53:18.013404 pm UUID: 4e58e94c-ad35-324e-8af8-0f0426cb9d10 Ancestors: EToys-tfel.235 - move forgotten method from OLPC-Display package into Etoys - until we have a final solution for project saving, install SISS into releases for squeakland =============== Diff against EToys-tfel.235 =============== Item was added: + ----- Method: Form>>isVirtualScreen (in category '*Etoys-OLPC-Display') ----- + isVirtualScreen + "Am I a virtual display screen?" + ^false! Item was added: + ----- Method: ReleaseBuilderSqueakland class>>installExtraPackages (in category 'preparing') ----- + installExtraPackages + + #('Meta-Implementation' 'Meta-Examples' 'SISS') do: [:pkg | + Installer swasource project: 'etoys-spur'; install: pkg].! Item was changed: ----- Method: ReleaseBuilderSqueakland class>>prepareEnvironment (in category 'preparing') ----- prepareEnvironment | directory entries projectNames | super prepareEnvironment. projectNames := #('Gallery' 'Tutorials' 'Home'). directory := FileDirectory on: Smalltalk imagePath. entries := FileList2 projectOnlySelectionMethod: directory entries. projectNames do: [:projectName | (entries anySatisfy: [:each | (Project parseProjectFileName: each first) first = projectName]) ifFalse: [self inform: projectName , ' is not found']]. + self installExtraPackages. DeferredTask := [ProjectLoading openFromImagePath: 'Home'].!

1 0

The Trunk: EToys-tfel.235.mcz
by commits＠source.squeak.org 20 Sep '16

20 Sep '16

Tim Felgentreff uploaded a new version of EToys to project The Trunk: http://source.squeak.org/trunk/EToys-tfel.235.mcz ==================== Summary ==================== Name: EToys-tfel.235 Author: tfel Time: 20 September 2016, 10:40:06.499404 am UUID: 4c293f06-9bcb-5348-844b-76cc91922065 Ancestors: EToys-bf.234 - begin removal of old Kedama classes, to eventually replace everything with Kedama2 - move SugarLauncher code that needs Dbus into SugarDBus package - remove unused BooleanPreferenceView and HaloThemePrefernceView classes - remove unused MorphicGamesInfo class - remove old Utilities methods that got moved into McmUpdater and re-added by the merge heuristic =============== Diff against EToys-bf.234 =============== Item was removed: - PreferenceView subclass: #BooleanPreferenceView - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Etoys-Squeakland-System-Support'! - - !BooleanPreferenceView commentStamp: '<historical>' prior: 0! - I am responsible for building the visual representation of a preference that accepts true and false values! Item was removed: - ----- Method: BooleanPreferenceView class>>handlesPanel: (in category 'view registry') ----- - handlesPanel: aPreferencePanel - ^aPreferencePanel isKindOf: PreferencesPanel! Item was removed: - ----- Method: BooleanPreferenceView class>>initialize (in category 'class initialization') ----- - initialize - PreferenceViewRegistry ofBooleanPreferences register: self.! Item was removed: - ----- Method: BooleanPreferenceView class>>unload (in category 'class initialization') ----- - unload - PreferenceViewRegistry ofBooleanPreferences unregister: self.! Item was removed: - ----- Method: BooleanPreferenceView>>offerPersistenceMenu (in category 'user interface') ----- - offerPersistenceMenu - | aMenu | - Preferences ensurePersistedPreferencesAccessible - ifFalse: [^self]. - aMenu := MenuMorph new defaultTarget: self preference. - aMenu addTitle: self preference name. - aMenu addUpdating: #isEnabledOnStartupString target: self preference selector: #persistValue: argumentList: {true}. - aMenu addUpdating: #isDisabledOnStartupString target: self preference selector: #persistValue: argumentList: {false}. - aMenu addUpdating: #isNotSetOnStartupString target: self preference selector: #persistValue: argumentList: {nil}. - aMenu popUpInWorld! Item was removed: - ----- Method: BooleanPreferenceView>>offerPreferenceNameMenu:with:in: (in category 'user interface') ----- - offerPreferenceNameMenu: aPanel with: ignored1 in: ignored2 - "the user clicked on a preference name -- put up a menu" - - | aMenu | - ActiveHand showTemporaryCursor: nil. - aMenu := MenuMorph new defaultTarget: self preference. - aMenu addTitle: self preference name. - - (Preferences okayToChangeProjectLocalnessOf: self preference name) ifTrue: - [aMenu addUpdating: #isProjectLocalString target: self preference action: #toggleProjectLocalness. - aMenu balloonTextForLastItem: 'Some preferences are best applied uniformly to all projects, and others are best set by each individual project. If this item is checked, then this preference will be printed in bold and will have a separate value for each project' translated]. - - aMenu add: 'browse senders' translated target: self systemNavigation selector: #browseAllCallsOn: argument: self preference name. - aMenu balloonTextForLastItem: 'This will open a method-list browser on all methods that the send the preference "' translated, self preference name, '".'. - aMenu add: 'show category...' translated target: aPanel selector: #findCategoryFromPreference: argument: self preference name. - aMenu balloonTextForLastItem: 'Allows you to find out which category, or categories, this preference belongs to.' translated. - - Smalltalk isMorphic ifTrue: - [aMenu add: 'hand me a button for this preference' translated target: self selector: #tearOffButton. - aMenu balloonTextForLastItem: 'Will give you a button that governs this preference, which you may deposit wherever you wish' translated]. - - aMenu add: 'copy this name to clipboard' translated target: self preference selector: #copyName. - aMenu balloonTextForLastItem: 'Copy the name of the preference to the text clipboard, so that you can paste into code somewhere' translated. - aMenu add: 'set automatically on startup...' translated target: self selector: #offerPersistenceMenu. - aMenu balloonTextForLastItem: 'Store a value for this preference on file. On startup, it will be automatically restored.' translated. - - aMenu popUpInWorld! Item was removed: - ----- Method: BooleanPreferenceView>>representativeButtonWithColor:inPanel: (in category 'user interface') ----- - representativeButtonWithColor: aColor inPanel: aPreferencesPanel - "Return a button that controls the setting of prefSymbol. It will keep up to date even if the preference value is changed in a different place" - - | outerButton aButton str miniWrapper | - - outerButton := AlignmentMorph newRow height: 24. - outerButton color: (aColor ifNil: [Color r: 0.645 g: 1.0 b: 1.0]). - outerButton hResizing: (aPreferencesPanel ifNil: [#shrinkWrap] ifNotNil: [#spaceFill]). - outerButton vResizing: #shrinkWrap. - outerButton addMorph: (aButton := UpdatingThreePhaseButtonMorph checkBox). - aButton - target: self preference; - actionSelector: #togglePreferenceValue; - getSelector: #preferenceValue. - - outerButton addTransparentSpacerOfSize: (2 @ 0). - str := StringMorph contents: self preference name font: Preferences standardButtonFont. - - self preference localToProject ifTrue: - [str emphasis: 1]. - - miniWrapper := AlignmentMorph newRow hResizing: #shrinkWrap; vResizing: #shrinkWrap. - miniWrapper layoutInset: 0. - miniWrapper beTransparent addMorphBack: str lock. - aPreferencesPanel - ifNotNil: "We're in a Preferences panel" - [miniWrapper on: #mouseDown send: #offerPreferenceNameMenu:with:in: to: self withValue: aPreferencesPanel. - miniWrapper on: #mouseEnter send: #menuButtonMouseEnter: to: miniWrapper. - miniWrapper on: #mouseLeave send: #menuButtonMouseLeave: to: miniWrapper. - miniWrapper setBalloonText: 'Click here for a menu of options regarding this preference. Click on the checkbox to the left to toggle the setting of this preference' translated] - - ifNil: "We're a naked button, not in a panel" - [miniWrapper setBalloonText: self preference helpString translated; setProperty: #balloonTarget toValue: aButton]. - - outerButton addMorphBack: miniWrapper. - outerButton setNameTo: self preference name. - - aButton setBalloonText: self preference helpString. - - ^ outerButton - ! Item was removed: - PreferenceView subclass: #HaloThemePreferenceView - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Etoys-Squeakland-System-Support'! - - !HaloThemePreferenceView commentStamp: '<historical>' prior: 0! - I am responsible for building the view for the preference that choose the halo theme! Item was removed: - ----- Method: HaloThemePreferenceView class>>handlesPanel: (in category 'view registry') ----- - handlesPanel: aPreferencePanel - ^aPreferencePanel isKindOf: PreferencesPanel! Item was removed: - ----- Method: HaloThemePreferenceView class>>initialize (in category 'class initialization') ----- - initialize - "adding the halo theme preference to Preferences and registering myself as its view" - PreferenceViewRegistry ofHaloThemePreferences register: self. - Preferences - addPreference: #haloTheme - categories: {#halos} - default: #iconicHaloSpecifications - balloonHelp: '' - projectLocal: false - changeInformee: nil - changeSelector: nil - viewRegistry: PreferenceViewRegistry ofHaloThemePreferences.! Item was removed: - ----- Method: HaloThemePreferenceView class>>unload (in category 'class initialization') ----- - unload - PreferenceViewRegistry ofHaloThemePreferences unregister: self.! Item was removed: - ----- Method: HaloThemePreferenceView>>haloThemeRadioButtons (in category 'user interface') ----- - haloThemeRadioButtons - "Answer a column of butons representing the choices of halo theme" - - | buttonColumn aRow aRadioButton aStringMorph | - buttonColumn := AlignmentMorph newColumn beTransparent. - #('iconic' 'classic' 'simple' 'custom') translatedNoop. - #( (iconicHaloSpecifications iconic iconicHalosInForce 'circular halos with icons inside') - (classicHaloSpecs classic classicHalosInForce 'plain circular halos') - (simpleFullHaloSpecifications simple simpleHalosInForce 'fewer, larger halos') - (customHaloSpecs custom customHalosInForce 'customizable halos')) translatedNoop do: - - [:quad | - aRow := AlignmentMorph newRow beTransparent. - aRow addMorph: (aRadioButton := UpdatingThreePhaseButtonMorph radioButton). - aRadioButton target: Preferences. - aRadioButton setBalloonText: quad fourth translated. - aRadioButton actionSelector: #installHaloTheme:. - aRadioButton getSelector: quad third. - aRadioButton arguments: (Array with: quad first). - aRow addTransparentSpacerOfSize: (4 @ 0). - aRow addMorphBack: (aStringMorph := StringMorph contents: quad second asString translated). - aStringMorph setBalloonText: quad fourth translated. - buttonColumn addMorphBack: aRow]. - ^ buttonColumn - - "(Preferences preferenceAt: #haloTheme) view tearOffButton"! Item was removed: - ----- Method: HaloThemePreferenceView>>representativeButtonWithColor:inPanel: (in category 'user interface') ----- - representativeButtonWithColor: aColor inPanel: aPreferencesPanel - | outerButton editButton | - editButton := SimpleButtonMorph new - target: Preferences; - color: Color transparent; - actionSelector: #editCustomHalos; - label: 'Edit custom halos' translated; - setBalloonText: 'Click here to edit the method that defines the custom halos' translated. - - outerButton := AlignmentMorph newColumn. - outerButton - color: (aColor ifNil: [Color r: 0.645 g: 1.0 b: 1.0]); - hResizing: (aPreferencesPanel ifNil: [#shrinkWrap] ifNotNil: [#spaceFill]); - vResizing: #shrinkWrap; - addTransparentSpacerOfSize: (0@4); - addMorphBack: self haloThemeRadioButtons; - addTransparentSpacerOfSize: (0@4); - addMorphBack: editButton. - - ^outerButton. - - "(Preferences preferenceAt: #haloTheme) view tearOffButton" ! Item was removed: - ----- Method: KedamaExamplerPlayer>>copyAllMethodsAgain (in category 'debug support') ----- - copyAllMethodsAgain - - | c result | - c := turtles class. - result := (ClassBuilder new) - name: c name - inEnvironment: c environment - subclassOf: c superclass - type: c typeOfClass - instanceVariableNames: KedamaTurtleVectorPlayer instanceVariablesString - classVariableNames: KedamaTurtleVectorPlayer classVariablesString - poolDictionaries: KedamaTurtleVectorPlayer sharedPoolsString - category: c category. - turtles class copyAllCategoriesUnobtrusivelyFrom: KedamaTurtleVectorPlayer. - sequentialStub ifNotNil: [sequentialStub class copyAllCategoriesUnobtrusivelyFrom: KedamaSequenceExecutionStub]. - ! Item was removed: - ----- Method: KedamaExamplerPlayer>>createTurtles (in category 'subclass players management') ----- - createTurtles - - turtles := self class createTurtleSubclass new. - turtles kedamaWorld: kedamaWorld. - turtles exampler: self. - ^ turtles. - ! Item was added: + ----- Method: KedamaSequenceExecutionStub class>>isSystemDefined (in category 'as yet unclassified') ----- + isSystemDefined + ^ name endsWithDigit not! Item was added: + ----- Method: KedamaSequenceExecutionStub class>>isUniClass (in category 'as yet unclassified') ----- + isUniClass + + ^ self ~~ self officialClass! Item was removed: - ----- Method: KedamaTurtleMorph class>>copyAllMethodsAgain (in category 'scripting') ----- - copyAllMethodsAgain - " - KedamaTurtleMorph copyAllMethodsAgain. - " - KedamaTurtleMorph allInstancesDo: [:e | e player ifNotNil: [e player copyAllMethodsAgain]]. - ! Item was removed: - KedamaExamplerPlayer subclass: #KedamaTurtleVectorPlayer - instanceVariableNames: 'exampler info types arrays deletingIndex whoTable whoTableBase whoTableValid turtlesMap turtleMapValid lastWho lastWhoStub' - classVariableNames: '' - poolDictionaries: '' - category: 'Etoys-StarSqueak'! Item was removed: - ----- Method: KedamaTurtleVectorPlayer class>>officialClass (in category 'all') ----- - officialClass - - ^ KedamaTurtleVectorPlayer - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>aTurtleAtX:y: (in category 'turtle map') ----- - aTurtleAtX: xPos y: yPos - - | w x y index who stub | - turtleMapValid ifFalse: [ - self makeTurtlesMap. - ]. - - w := kedamaWorld dimensions x. - x := xPos truncated. - y := yPos truncated. - x < 0 ifTrue: [^ nil]. - x >= w ifTrue: [^ nil]. - y < 0 ifTrue: [^ nil]. - y >= kedamaWorld dimensions y ifTrue: [^ nil]. - index := (w * y) + x + 1. - who := turtlesMap at: index. - who = 0 ifTrue: [^ nil]. - who = lastWho ifTrue: [^ lastWhoStub]. - stub := exampler clonedSequentialStub. - stub who: who. - lastWho := who. - ^ lastWhoStub := stub. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>addInstanceVarNamed:withValue: (in category 'player protocol') ----- - addInstanceVarNamed: aName withValue: aValue - - | newArray | - (aValue isKindOf: Number) ifTrue: [ - newArray := KedamaFloatArray new: self size. - ]. - (aValue isKindOf: Color) ifTrue: [ - newArray := WordArray new: self size. - ]. - (aValue isKindOf: Player) ifTrue: [ - newArray := Array new: self size. - ]. - - arrays := arrays, newArray. - info at: aName asSymbol put: arrays size. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>addInstanceVarVectorNamed:withValue: (in category 'player protocol') ----- - addInstanceVarVectorNamed: aName withValue: aValue - - | newArray | - newArray := KedamaFloatArray new: self size. - arrays := arrays, (Array with: newArray). - newArray atAllPut: aValue. - info at: aName asSymbol put: arrays size. - types at: arrays size put: #Number. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>addTurtlesCount:ofPrototype:for:positionAndColorArray: (in category 'add turtles') ----- - addTurtlesCount: count ofPrototype: prototype for: aKedamaWorld positionAndColorArray: positionAndColorArray - - | oldCount | - oldCount := self size. - info associationsDo: [:assoc | | defaultValue index newArray array | - index := info at: assoc key. - array := arrays at: (info at: assoc key). - defaultValue := prototype at: index. - newArray := array class new: count. - (#(who x y heading color normal) includes: assoc key) ifFalse: [ - newArray atAllPut: defaultValue. - ]. - assoc key = #x ifTrue: [newArray replaceFrom: 1 to: newArray size with: positionAndColorArray first startingAt: 1]. - assoc key = #y ifTrue: [newArray replaceFrom: 1 to: newArray size with: positionAndColorArray second startingAt: 1]. - assoc key = #color ifTrue: [newArray replaceFrom: 1 to: newArray size with: positionAndColorArray third startingAt: 1]. - assoc key = #heading ifTrue: [newArray atAllPut: 1.57079631 "Float pi / 2.0"]. - assoc key = #normal ifTrue: [newArray atAllPut: 1.57079631 "Float pi / 2.0"]. - - arrays at: (assoc value) put: array, newArray. - ]. - - #(who) do: [:name | - self setInitialValueOf: name from: oldCount + 1 to: self size for: aKedamaWorld. - ]. - whoTableValid := false. - turtleMapValid := false. - - - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>addTurtlesCount:ofPrototype:for:randomize: (in category 'add turtles') ----- - addTurtlesCount: count ofPrototype: prototype for: aKedamaWorld randomize: randomizeFlag - - | oldCount | - oldCount := self size. - info associationsDo: [:assoc | | array defaultValue newArray index | - index := info at: assoc key. - array := arrays at: index. - defaultValue := prototype at: index. - newArray := array class new: count. - newArray atAllPut: defaultValue. - arrays at: index put: (array, newArray). - ]. - - self setInitialValueOf: #who from: oldCount + 1 to: self size for: aKedamaWorld. - - randomizeFlag ifTrue: [ - #(x y heading) do: [:name | - self setInitialValueOf: name from: oldCount + 1 to: self size for: aKedamaWorld. - ]. - ]. - whoTableValid := false. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>arrayForType: (in category 'private') ----- - arrayForType: typeName - - | newArray | - (typeName = #Number) ifTrue: [ - newArray := KedamaFloatArray new: self size. - ]. - (typeName = #Color) ifTrue: [ - newArray := WordArray new: self size. - ]. - (typeName = #Boolean) ifTrue: [ - newArray := ByteArray new: self size. - ]. - - newArray ifNil: [ - newArray := Array new: self size. - ]. - - ^ newArray. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>arrays (in category 'accessing') ----- - arrays - - ^ arrays. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>basicGetAngleTo: (in category 'player commands') ----- - basicGetAngleTo: players - - | ret p xArray yArray result | - players isCollection ifFalse: [ - p := players - ]. - xArray := arrays at: 2. - yArray := arrays at: 3. - result := KedamaFloatArray new: self size. - 1 to: self size do: [:index | - players isCollection ifTrue: [ - p := players at: index. - ]. - ret := ((p getX - (xArray at: index))@(p getY - (yArray at: index))) theta radiansToDegrees + 90.0. - ret > 360.0 ifTrue: [ret := ret - 360.0]. - result at: index put: ret. - ]. - ^ result. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>basicGetDistanceTo: (in category 'player commands') ----- - basicGetDistanceTo: players - - | p xArray yArray result | - players isCollection ifFalse: [ - p := players - ]. - xArray := arrays at: 2. - yArray := arrays at: 3. - result := KedamaFloatArray new: self size. - 1 to: self size do: [:index | - players isCollection ifTrue: [ - p := players at: index. - ]. - result at: index put: ((p getX - (xArray at: index)) squared + (p getY - (yArray at: index)) squared) sqrt. - - ]. - ^ result. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>basicMakeTurtlesMap (in category 'turtle map') ----- - basicMakeTurtlesMap - - | x y xArray yArray width height mapIndex whoArray | - xArray := arrays at: 2. - yArray := arrays at: 3. - whoArray := arrays at: 1. - width := kedamaWorld dimensions x. - height := kedamaWorld dimensions y. - turtlesMap atAllPut: 0. - - 1 to: self size do: [:index | - x := (xArray at: index) truncated. - y := (yArray at: index) truncated. - mapIndex := (width * y) + x + 1. - (0 < mapIndex and: [mapIndex <= turtlesMap size]) ifTrue: [ - turtlesMap at: mapIndex put: (whoArray at: index). - ]. - ]. - - turtleMapValid := true. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>color: (in category 'player commands') ----- - color: c - - c isColor ifTrue: [ - self setColorVarAt: 5 put: ((c pixelValueForDepth: 32) bitAnd: 16rFFFFFF). - ] ifFalse: [ - self setColorVarAt: 5 put: c. - ]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>colorFromPatch: (in category 'player commands') ----- - colorFromPatch: aPatch - - | xArray yArray cArray patch | - xArray := arrays at: 2. - yArray := arrays at: 3. - cArray := arrays at: 5. - patch := aPatch costume renderedMorph. - 1 to: self size do: [:i | - cArray at: i put: ((patch pixelAtX: (xArray at: i) y: (yArray at: i)) bitAnd: 16rFFFFFF). - ]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>colorToPatch: (in category 'player commands') ----- - colorToPatch: aPatch - - | xArray yArray cArray patch | - xArray := arrays at: 2. - yArray := arrays at: 3. - cArray := arrays at: 5. - patch := aPatch costume renderedMorph. - 1 to: self size do: [:i | - patch pixelAtX: (xArray at: i) y: (yArray at: i) put: (cArray at: i). - ]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>compileAllAccessors (in category 'player protocol') ----- - compileAllAccessors - - info keys do: [:k | - (#(who x y heading color visible) includes: k) ifFalse: [ - self compileVectorInstVarAccessorsFor: k. - ]. - ]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>compileVectorInstVarAccessorsFor: (in category 'player protocol') ----- - compileVectorInstVarAccessorsFor: varName - - | nameString index type setPhrase | - nameString := varName asString capitalized. - index := info at: varName asSymbol. - self class compileSilently: ('get', nameString, ' - ^ ', '(arrays at: ', index printString, ')') - classified: 'access'. - - type := types at: index. - type = #Number ifTrue: [ - setPhrase := 'setNumberVarAt:'. - ]. - type = #Boolean ifTrue: [ - setPhrase := 'setBooleanVarAt:'. - ]. - type = #Color ifTrue: [ - setPhrase := 'setColorVarAt:'. - ]. - setPhrase ifNil: [setPhrase := 'setObjectVarAt:']. - - self class compileSilently: ('set', nameString, ': xxxArg - self ', setPhrase, index printString, ' put: xxxArg') - classified: 'access'! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>delete (in category 'deleting') ----- - delete - - exampler := nil. - arrays := nil. - whoTable := nil. - turtlesMap := nil. - self class removeFromSystem: false. - self becomeForward: UnscriptedPlayer new - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>deleteTurtleID: (in category 'player commands') ----- - deleteTurtleID: who - - | whoArray whoIndex | - whoArray := arrays at: 1. - whoIndex := whoArray indexOf: who ifAbsent: [^ self]. - deletingIndex := whoIndex - 1. - arrays withIndexDo: [:array :index | | newArray | - newArray := (array copyFrom: 1 to: whoIndex - 1), (array copyFrom: whoIndex + 1 to: array size). - arrays at: index put: newArray. - ]. - whoTableValid := false. - turtleMapValid := false. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>doCommand: (in category 'command execution') ----- - doCommand: aBlock - - ^ aBlock value: self. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>doDieCommand: (in category 'command execution') ----- - doDieCommand: aBlock - - ^ exampler doDieCommand: aBlock. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>doExamplerCommand: (in category 'command execution') ----- - doExamplerCommand: aBlock - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>doSequentialCommand: (in category 'command execution') ----- - doSequentialCommand: aBlock - - ^ exampler doSequentialCommand: aBlock. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>drawOn: (in category 'displaying') ----- - drawOn: aForm - - | xArray yArray colorArray visibleArray bits x y visible bitsIndex dimX dimY ret | - xArray := arrays at: 2. - yArray := arrays at: 3. - colorArray := arrays at: 5. - visibleArray := arrays at: 6. - bits := aForm bits. - dimX := aForm width. - dimY := aForm height. - - ret := self primDrawOn: bits destWidth: dimX destHeight: dimY xArray: xArray yArray: yArray colorArray: colorArray visibleArray: visibleArray. - ret ifNotNil: [^ self]. - - 1 to: self size do: [:index | - x := (xArray at: index) truncated. - y := (yArray at: index) truncated. - visible := (visibleArray at: index) ~= 0. - (visible and: [((x >= 0) and: [y >= 0]) and: [(x < dimX) and: [y < dimY]]]) ifTrue: [ - bitsIndex := ((y * dimX) + x) + 1. - bits at: bitsIndex put: (colorArray at: index). - ]. - ]. - - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>exampler: (in category 'accessing') ----- - exampler: e - - exampler := e. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>forward: (in category 'player commands') ----- - forward: val - - exampler getGrouped ifFalse: [ - self primForwardXArray: (arrays at: 2) yArray: (arrays at: 3) headingArray: (arrays at: 4) value: (val isNumber ifTrue: [val asFloat] ifFalse: [val]) destWidth: kedamaWorld wrapX asFloat destHeight: kedamaWorld wrapY asFloat leftEdgeMode: kedamaWorld leftEdgeModeMnemonic rightEdgeMode: kedamaWorld rightEdgeModeMnemonic topEdgeMode: kedamaWorld topEdgeModeMnemonic bottomEdgeMode: kedamaWorld bottomEdgeModeMnemonic. - ] ifTrue: [ - self groupForward: val - ]. - turtleMapValid := false. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>getAngleTo: (in category 'player commands') ----- - getAngleTo: players - - | p xArray yArray result pX pY xy | - players isCollection ifFalse: [ - p := players - ]. - xArray := arrays at: 2. - yArray := arrays at: 3. - result := KedamaFloatArray new: self size. - players isCollection ifTrue: [ - pX := KedamaFloatArray new: players size. - pY := KedamaFloatArray new: players size. - 1 to: players size do: [:i | - xy := (players at: i) getXAndY. - pX at: i put: xy x. - pY at: i put: xy y. - ]. - ] ifFalse: [ - xy := p getXAndY. - pX := xy x. - pY := xy y. - ]. - ^ self primGetAngleToX: pX toY: pY xArray: xArray yArray: yArray resultInto: result. - - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>getBlueComponentIn: (in category 'player commands') ----- - getBlueComponentIn: aPatch - - | pix xArray yArray patch w | - xArray := arrays at: 2. - yArray := arrays at: 3. - patch := aPatch costume renderedMorph. - w := WordArray new: self size. - 1 to: self size do: [:i | - pix := patch pixelAtX: (xArray at: i) y: (yArray at: i). - w at: i put: (pix bitAnd: 16rFF). - ]. - ^ w. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>getBooleanVarAt: (in category 'accessing - private') ----- - getBooleanVarAt: index - - ^ arrays at: index. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>getColor (in category 'player commands') ----- - getColor - - ^ self getVarAt: 5. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>getColorVarAt: (in category 'accessing - private') ----- - getColorVarAt: index - - ^ (arrays at: index) collect: [:c | Color colorFromPixelValue: c depth: 32]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>getDistanceTo: (in category 'player commands') ----- - getDistanceTo: players - - | p xArray yArray result pX pY xy | - players isCollection ifFalse: [ - p := players - ]. - xArray := arrays at: 2. - yArray := arrays at: 3. - result := KedamaFloatArray new: self size. - players isCollection ifTrue: [ - pX := KedamaFloatArray new: players size. - pY := KedamaFloatArray new: players size. - 1 to: players size do: [:i | - xy := (players at: i) getXAndY. - pX at: i put: xy x. - pY at: i put: xy y. - ]. - ] ifFalse: [ - xy := p getXAndY. - pX := xy x. - pY := xy y. - ]. - ^ self primGetDistanceToX: pX toY: pY xArray: xArray yArray: yArray resultInto: result. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>getGreenComponentIn: (in category 'player commands') ----- - getGreenComponentIn: aPatch - - | pix xArray yArray patch w | - xArray := arrays at: 2. - yArray := arrays at: 3. - patch := aPatch costume renderedMorph. - w := WordArray new: self size. - 1 to: self size do: [:i | - pix := patch pixelAtX: (xArray at: i) y: (yArray at: i). - w at: i put: ((pix bitShift: -8) bitAnd: 16rFF). - ]. - ^ w. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>getGrouped (in category 'player commands') ----- - getGrouped - - ^ exampler getGrouped. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>getHeading (in category 'player commands') ----- - getHeading - - | heading result ret | - heading := (arrays at: 4). - result := KedamaFloatArray new: heading size. - ret := self primGetHeading: heading into: result. - ret ifNotNil: [^ result]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>getNormal (in category 'player commands') ----- - getNormal - - | result ret normal | - normal := (arrays at: 7). - result := KedamaFloatArray new: normal size. - ret := self primGetHeading: normal into: result. - ret ifNotNil: [^ result]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>getPatchValueIn: (in category 'player commands') ----- - getPatchValueIn: aPatch - - | w patch xArray yArray | - w := WordArray new: self size. - patch := aPatch costume renderedMorph. - xArray := arrays at: 2. - yArray := arrays at: 3. - patch pixelsAtXArray: xArray yArray: yArray into: w. - ^ w. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>getRedComponentIn: (in category 'player commands') ----- - getRedComponentIn: aPatch - - | pix xArray yArray patch w | - xArray := arrays at: 2. - yArray := arrays at: 3. - patch := aPatch costume renderedMorph. - w := WordArray new: self size. - 1 to: self size do: [:i | - pix := patch pixelAtX: (xArray at: i) y: (yArray at: i). - w at: i put: ((pix bitShift: -16) bitAnd: 16rFF). - ]. - ^ w. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>getTurtleAt: (in category 'player commands') ----- - getTurtleAt: aPlayer - - | xy | - aPlayer isCollection ifTrue: [ - self error: 'should not happen'. - ]. - xy := aPlayer getXAndY. - ^ (self aTurtleAtX: xy x y: xy y) ifNil: [^ aPlayer]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>getTurtleOf: (in category 'player commands') ----- - getTurtleOf: aBreedPlayer - - | xy | - aBreedPlayer isCollection ifTrue: [ - "self error: 'should not happen'." - ^ aBreedPlayer. - ]. - xy := aBreedPlayer getXAndY. - ^ (self aTurtleAtX: xy x y: xy y) ifNil: [^ aBreedPlayer]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>getTurtleVisible (in category 'player commands') ----- - getTurtleVisible - - ^ (turtles arrays at: 6) collect: [:t | t = 1]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>getUphillIn: (in category 'player commands') ----- - getUphillIn: aPatch - - | xArray yArray headingArray result patch | - xArray := arrays at: 2. - yArray := arrays at: 3. - headingArray := arrays at: 4. - result := KedamaFloatArray new: self size. - patch := aPatch costume renderedMorph. - 1 to: self size do: [:index | - result at: index put: (patch - uphillForTurtleX: (xArray at: index) - turtleY: (yArray at: index) - turtleHeading: (headingArray at: index)). - ]. - ^ result. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>getVarAt: (in category 'accessing - private') ----- - getVarAt: index - - ^ arrays at: index. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>getX (in category 'player commands') ----- - getX - - | xArray | - exampler getGrouped ifFalse: [ - ^ arrays at: 2. - ] ifTrue: [ - xArray := arrays at: 2. - xArray size = 0 ifTrue: [^ exampler getX]. - ^ xArray first. - ]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>getY (in category 'player commands') ----- - getY - - | yArray | - exampler getGrouped ifFalse: [ - ^ arrays at: 3. - ] ifTrue: [ - yArray := arrays at: 3. - yArray size = 0 ifTrue: [^ exampler getY]. - ^ yArray first. - ]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>groupForward: (in category 'private') ----- - groupForward: dist - - | x y headingRadians | - self size = 0 ifTrue: [^ self]. - - x := (arrays at: 2) first. - y := (arrays at: 3) first. - headingRadians := (arrays at: 4) first. - self groupSetX: (x + (dist asFloat * headingRadians cos)). - self groupSetY: (y - (dist asFloat * headingRadians sin)). - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>groupSetX: (in category 'private') ----- - groupSetX: val - - | xArray headingArray origX origHeading leftEdgeMode rightEdgeMode newArray wrapX minX maxX | - self size = 0 ifTrue: [^ self]. - xArray := arrays at: 2. - headingArray := arrays at: 4. - - origX := xArray first. - origHeading := headingArray first. - - leftEdgeMode := kedamaWorld leftEdgeModeMnemonic. - rightEdgeMode := kedamaWorld rightEdgeModeMnemonic. - - newArray := xArray collect: [:e | e + val - origX]. - wrapX := kedamaWorld wrapX. - minX := newArray min. - maxX := newArray max. - ((minX < 0.0) not and: [(maxX >= wrapX) not]) ifTrue: [ - arrays at: 2 put: newArray. - ^ self. - ]. - - minX < 0.0 ifTrue: [ - leftEdgeMode = 1 ifTrue: [ - newArray withIndexDo: [:e :i | - e < 0.0 ifTrue: [newArray at: i put: e + wrapX]. - ]. - ]. - leftEdgeMode = 2 ifTrue: [ - newArray withIndexDo: [:e :i | - newArray at: i put: e - minX. - ]. - ]. - leftEdgeMode = 3 ifTrue: [ - newArray withIndexDo: [:e :i | - newArray at: i put: e + (minX * -2.0). - ]. - ]. - ]. - - maxX >= wrapX ifTrue: [ - rightEdgeMode = 1 ifTrue: [ - newArray withIndexDo: [:e :i | - e >= wrapX ifTrue: [newArray at: i put: e - wrapX]. - ]. - ]. - rightEdgeMode = 2 ifTrue: [ - newArray withIndexDo: [:e :i | - newArray at: i put: e - (maxX - wrapX) - 2.35099e-038. - ]. - ]. - rightEdgeMode = 3 ifTrue: [ - newArray withIndexDo: [:e :i | - newArray at: i put: e - ((maxX - wrapX) * 2.0) - 2.35099e-038. - ]. - ]. - ]. - - arrays at: 2 put: newArray. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>groupSetY: (in category 'private') ----- - groupSetY: val - - | yArray headingArray origY origHeading topEdgeMode bottomEdgeMode newArray wrapY minY maxY | - self size = 0 ifTrue: [^ self]. - yArray := arrays at: 3. - headingArray := arrays at: 4. - - origY := yArray first. - origHeading := headingArray first. - - topEdgeMode := kedamaWorld topEdgeModeMnemonic. - bottomEdgeMode := kedamaWorld bottomEdgeModeMnemonic. - - newArray := yArray collect: [:e | e + val - origY]. - wrapY := kedamaWorld wrapY. - minY := newArray min. - maxY := newArray max. - ((minY < 0.0) not and: [(maxY >= wrapY) not]) ifTrue: [ - arrays at: 3 put: newArray. - ^ self. - ]. - - minY < 0.0 ifTrue: [ - topEdgeMode = 1 ifTrue: [ - newArray withIndexDo: [:e :i | - e < 0.0 ifTrue: [newArray at: i put: e + wrapY]. - ]. - ]. - topEdgeMode = 2 ifTrue: [ - newArray withIndexDo: [:e :i | - newArray at: i put: e - minY. - ]. - ]. - topEdgeMode = 3 ifTrue: [ - newArray withIndexDo: [:e :i | - newArray at: i put: e + (minY * -2.0). - ]. - ]. - ]. - - maxY >= wrapY ifTrue: [ - bottomEdgeMode = 1 ifTrue: [ - newArray withIndexDo: [:e :i | - e >= wrapY ifTrue: [newArray at: i put: e - wrapY]. - ]. - ]. - bottomEdgeMode = 2 ifTrue: [ - newArray withIndexDo: [:e :i | - newArray at: i put: e - (maxY - wrapY) - 2.35099e-038. - ]. - ]. - bottomEdgeMode = 3 ifTrue: [ - newArray withIndexDo: [:e :i | - newArray at: i put: e - ((maxY - wrapY) * 2.0) - 2.35099e-038. - ]. - ]. - ]. - - arrays at: 3 put: newArray. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>heading (in category 'player commands') ----- - heading - - ^ self getHeading. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>heading: (in category 'player commands') ----- - heading: degrees - - | deg | - deg := degrees isNumber ifTrue: [degrees asFloat] ifFalse: [degrees]. - self primSetHeading: (arrays at: 4) from: deg. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>hide (in category 'player commands') ----- - hide - - (arrays at: 6) atAllPut: 0. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>indexOf: (in category 'enumeration') ----- - indexOf: who - - | whoArray | - whoTableValid ifTrue: [^ whoTable at: (who - whoTableBase)]. - - whoArray := arrays at: 1. - - whoArray size = 0 ifTrue: [^ 0]. - - whoTableBase := whoArray first - 1. - whoTable := WordArray new: whoArray last - whoTableBase. - 1 to: whoArray size do: [:w | - whoTable at: (whoArray at: w) - whoTableBase put: w. - ]. - whoTableValid := true. - - ^ whoTable at: (who - whoTableBase). - - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>info (in category 'accessing') ----- - info - - ^ info. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>initialize (in category 'initialization') ----- - initialize - - super initialize. - info := IdentityDictionary new. - info at: #who put: 1. - info at: #x put: 2. - info at: #y put: 3. - info at: #heading put: 4. - info at: #color put: 5. - info at: #visible put: 6. - info at: #normal put: 7. - - arrays := Array new: 7. - arrays at: (info at: #who) put: (WordArray new: 0). - arrays at: (info at: #x) put: (KedamaFloatArray new: 0). - arrays at: (info at: #y) put: (KedamaFloatArray new: 0). - arrays at: (info at: #heading) put: (KedamaFloatArray new: 0). - arrays at: (info at: #color) put: (WordArray new: 0). - arrays at: (info at: #visible) put: (ByteArray new: 0). - arrays at: (info at: #normal) put: (KedamaFloatArray new: 0). - - types := Array new: 64. - - types at: 1 put: #Integer. - types at: 2 put: #Number. - types at: 3 put: #Number. - types at: 4 put: #Number. - types at: 5 put: #Color. - types at: 6 put: #Boolean. - types at: 7 put: #Number. - - whoTableValid := false. - turtleMapValid := false. - - - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>initializeDeletingIndex (in category 'enumeration') ----- - initializeDeletingIndex - - deletingIndex := 0. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>instSize (in category 'accessing') ----- - instSize - - ^ arrays size. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>invalidateTurtleMap (in category 'turtle map') ----- - invalidateTurtleMap - - turtleMapValid := false. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>makePrototypeFromFirstInstance (in category 'add turtles') ----- - makePrototypeFromFirstInstance - - ^ (1 to: arrays size) collect: [:index | - (arrays at: index) first - ]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>makeTurtlesMap (in category 'turtle map') ----- - makeTurtlesMap - - | xArray yArray width height whoArray ret | - xArray := arrays at: 2. - yArray := arrays at: 3. - whoArray := arrays at: 1. - width := kedamaWorld dimensions x. - height := kedamaWorld dimensions y. - turtlesMap ifNil: [turtlesMap := WordArray new: width * height]. - - ret := self primMakeTurtlesMap: turtlesMap whoArray: whoArray xArray: xArray yArray: yArray width: width height: height. - - ret ifNil: [self basicMakeTurtlesMap]. - - turtleMapValid := true. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>nextDeletingIndex (in category 'enumeration') ----- - nextDeletingIndex - - ^ deletingIndex := deletingIndex + 1. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>normal: (in category 'player commands') ----- - normal: degrees - - | deg | - deg := degrees isNumber ifTrue: [degrees asFloat] ifFalse: [degrees]. - self primSetHeading: (arrays at: 7) from: deg. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>noteRenameOf:to:inPlayer: (in category 'player protocol') ----- - noteRenameOf: oldSlotName to: newSlotName inPlayer: aPlayer - - self compileAllAccessors - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>primDrawOn:destWidth:destHeight:xArray:yArray:colorArray:visibleArray: (in category 'primitives') ----- - primDrawOn: destBits destWidth: destWidth destHeight: destHeight xArray: xArray yArray: yArray colorArray: colorArray visibleArray: visibleArray - - | x y visible bitsIndex | - <primitive: 'drawTurtlesInArray' module: 'KedamaPlugin'> - "^ KedamaPlugin doPrimitive: #drawTurtlesInArray." - - 1 to: xArray size do: [:i | - x := (xArray at: i) asInteger. - y := (yArray at: i) asInteger. - visible := (visibleArray at: i). - (visible ~= 0 and: [((x >= 0) and: [y >= 0]) and: [(x < destWidth) and: [y < destHeight]]]) ifTrue: [ - bitsIndex := ((y * destWidth) + x) + 1. - destBits at: bitsIndex put: (colorArray at: i). - ] - ]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>primForwardXArray:yArray:headingArray:value:destWidth:destHeight:leftEdgeMode:rightEdgeMode:topEdgeMode:bottomEdgeMode: (in category 'primitives') ----- - primForwardXArray: xArray yArray: yArray headingArray: headingArray value: v destWidth: destWidth destHeight: destHeight leftEdgeMode: leftEdgeMode rightEdgeMode: rightEdgeMode topEdgeMode: topEdgeMode bottomEdgeMode: bottomEdgeMode - - | dist newX newY | - <primitive: 'primTurtlesForward' module: 'KedamaPlugin'> - "^ KedamaPlugin doPrimitive: #primTurtlesForward." - - 1 to: xArray size do: [:i | - v isCollection ifTrue: [ - dist := (v at: i) asFloat. - ] ifFalse: [ - dist := v asFloat. - ]. - newX := (xArray at: i) + (dist * (headingArray at: i) cos). - newY := (yArray at: i) - (dist * (headingArray at: i) sin). - KedamaMorph scalarXAt: i xArray: xArray headingArray: headingArray value: newX destWidth: destWidth leftEdgeMode: leftEdgeMode rightEdgeMode: rightEdgeMode. - KedamaMorph scalarYAt: i yArray: yArray headingArray: headingArray value: newY destHeight: destHeight topEdgeMode: topEdgeMode bottomEdgeMode: bottomEdgeMode. - ]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>primGetAngleToX:toY:xArray:yArray:resultInto: (in category 'primitives') ----- - primGetAngleToX: pX toY: pY xArray: xArray yArray: yArray resultInto: result - - | ppx ppy x y ret | - <primitive: 'vectorGetAngleTo' module:'KedamaPlugin'> - "^ KedamaPlugin doPrimitive: #vectorGetAngleTo." - - ppx := pX. - ppy := pY. - 1 to: result size do: [:index | - pX isCollection ifTrue: [ - ppx := pX at: index. - ppy := pY at: index. - ]. - x := ppx - (xArray at: index). - y := ppy - (yArray at: index). - ret := (x@y) theta radiansToDegrees + 90.0. - ret > 360.0 ifTrue: [ret := ret - 360.0]. - result at: index put: ret. - ]. - ^ result. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>primGetDistanceToX:toY:xArray:yArray:resultInto: (in category 'primitives') ----- - primGetDistanceToX: pX toY: pY xArray: xArray yArray: yArray resultInto: result - - | ppx ppy | - <primitive: 'vectorGetDistanceTo' module:'KedamaPlugin'> - "^ KedamaPlugin doPrimitive: #vectorGetDistanceTo." - - ppx := pX. - ppy := pY. - 1 to: result size do: [:index | - pX isCollection ifTrue: [ - ppx := pX at: index. - ppy := pY at: index. - ]. - result at: index put: ((ppx - (xArray at: index)) squared + (ppy - (yArray at: index)) squared) sqrt. - - ]. - ^ result. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>primGetHeading:into: (in category 'primitives') ----- - primGetHeading: headingArray into: resultArray - - | heading | - <primitive: 'getHeadingArrayInto' module:'KedamaPlugin'> - "^ KedamaPlugin doPrimitive: #getHeadingArrayInto." - - 1 to: headingArray size do: [:i | - heading := headingArray at: i. - heading := heading / 0.0174532925199433. - heading := 90.0 - heading. - heading > 0.0 ifFalse: [heading := heading + 360.0]. - resultArray at: i put: heading. - ]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>primMakeTurtlesMap:whoArray:xArray:yArray:width:height: (in category 'primitives') ----- - primMakeTurtlesMap: map whoArray: whoArray xArray: xArray yArray: yArray width: w height: h - - <primitive: 'makeTurtlesMap' module: 'KedamaPlugin'> - ^ nil. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>primRandomRange:from:to:intoFloatArray:factor: (in category 'primitives') ----- - primRandomRange: range from: from to: to intoFloatArray: aFloatArray factor: factor - - <primitive: 'randomIntoFloatArray' module: 'KedamaPlugin'> - - from to: to do: [:index | - aFloatArray at: index put: (kedamaWorld random: range) asFloat * factor. - ]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>primRandomRange:from:to:intoIntegerArray:factor: (in category 'primitives') ----- - primRandomRange: range from: from to: to intoIntegerArray: anIntegerArray factor: factor - - <primitive: 'randomIntoIntegerArray' module: 'KedamaPlugin'> - - from to: to do: [:index | - anIntegerArray at: index put: ((kedamaWorld random: range) asFloat * factor) asInteger. - ]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>primSetHeading:from: (in category 'primitives') ----- - primSetHeading: headingArray from: val - - | heading | - <primitive: 'setHeadingArrayFrom' module:'KedamaPlugin'> - "^ KedamaPlugin doPrimitive: #setHeadingArrayFrom." - - val isCollection ifFalse: [ - heading := val asFloat. - heading := KedamaMorph degreesToRadians: heading. - ]. - - 1 to: headingArray size do: [:i | - val isCollection ifTrue: [ - heading := val at: i. - heading := KedamaMorph degreesToRadians: heading. - ]. - headingArray at: i put: heading. - ]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>primSetX:headingArray:value:destWidth:leftEdgeMode:rightEdgeMode: (in category 'primitives') ----- - primSetX: xArray headingArray: headingArray value: v destWidth: destWidth leftEdgeMode: leftEdgeMode rightEdgeMode: rightEdgeMode - - | val newX | - <primitive: 'turtlesSetX' module: 'KedamaPlugin'> - "^ KedamaPlugin doPrimitive: #turtlesSetX." - - v isCollection ifFalse: [ - val := v asFloat. - ]. - - 1 to: xArray size do: [:i | - v isCollection ifTrue: [ - newX := v at: i. - ] ifFalse: [ - newX := val. - ]. - KedamaMorph scalarXAt: i xArray: xArray headingArray: headingArray value: newX destWidth: destWidth leftEdgeMode: leftEdgeMode rightEdgeMode: rightEdgeMode. - ]. - - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>primSetY:headingArray:value:destHeight:topEdgeMode:bottomEdgeMode: (in category 'primitives') ----- - primSetY: yArray headingArray: headingArray value: v destHeight: destHeight topEdgeMode: topEdgeMode bottomEdgeMode: bottomEdgeMode - - | val newY | - <primitive: 'turtlesSetY' module: 'KedamaPlugin'> - "^ KedamaPlugin doPrimitive: #turtlesSetY." - - v isCollection ifFalse: [ - val := v asFloat. - ]. - - 1 to: yArray size do: [:i | - v isCollection ifTrue: [ - newY := v at: i. - ] ifFalse: [ - newY := val. - ]. - KedamaMorph scalarYAt: i yArray: yArray headingArray: headingArray value: newY destHeight: destHeight topEdgeMode: topEdgeMode bottomEdgeMode: bottomEdgeMode. - ]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>removeSlotNamed: (in category 'player protocol') ----- - removeSlotNamed: aSlotName - - | index newArrays | - self basicRemoveSlotNamed: aSlotName. - index := info at: aSlotName asSymbol ifAbsent: [^ self]. - newArrays := (arrays copyFrom: 1 to: index - 1), (arrays copyFrom: index + 1 to: arrays size). - types replaceFrom: index to: types size with: types startingAt: index + 1. - - info removeKey: aSlotName asSymbol. - arrays := newArrays. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>removeVectorSlotNamed: (in category 'player protocol') ----- - removeVectorSlotNamed: aSlotName - - | index newArrays | - index := info at: aSlotName asSymbol ifAbsent: [^ self]. - newArrays := (arrays copyFrom: 1 to: index - 1), (arrays copyFrom: index + 1 to: arrays size). - types replaceFrom: index to: types size - 1 with: types startingAt: index + 1. - - info removeKey: aSlotName asSymbol. - arrays := newArrays. - self compileAllAccessors. - - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>renameVectorSlot:newSlotName: (in category 'player protocol') ----- - renameVectorSlot: oldSlotName newSlotName: newSlotName - - | index | - index := info at: oldSlotName asSymbol ifAbsent: [^ self]. - info removeKey: oldSlotName asSymbol. - info at: newSlotName put: index. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>setBlueComponentIn:to: (in category 'player commands') ----- - setBlueComponentIn: aPatch to: value - - | xArray yArray patch component | - xArray := arrays at: 2. - yArray := arrays at: 3. - patch := aPatch costume renderedMorph. - value isCollection ifFalse: [ - component := value asInteger bitAnd: 16rFF. - ]. - (1 to: self size) do: [:i | | pix | - value isCollection ifTrue: [ - component := (value at: i) asInteger bitAnd: 16rFF. - ]. - pix := patch pixelAtX: (xArray at: i) y: (yArray at: i). - pix := (pix bitAnd: 16rFFFF00) bitOr: component. - patch pixelAtX: (xArray at: i) y: (yArray at: i) put: pix. - ]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>setBooleanVarAt:put: (in category 'accessing - private') ----- - setBooleanVarAt: index put: v - - (v == true or: [v == false]) ifTrue: [ - (arrays at: index) atAllPut: (v == true ifTrue: [1] ifFalse: [0]). - ^ self. - ]. - (arrays at: index) replaceFrom: 1 to: v size with: v startingAt: 1. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>setColor: (in category 'player commands') ----- - setColor: color - - ^ self color: color. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>setColorVarAt:put: (in category 'accessing - private') ----- - setColorVarAt: index put: cPixel - - cPixel isNumber ifTrue: [ - (arrays at: index) atAllPut: cPixel. - ^ self. - ]. - - (arrays at: index) replaceFrom: 1 to: cPixel size with: cPixel startingAt: 1. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>setGreenComponentIn:to: (in category 'player commands') ----- - setGreenComponentIn: aPatch to: value - - | xArray yArray patch component | - xArray := arrays at: 2. - yArray := arrays at: 3. - patch := aPatch costume renderedMorph. - value isCollection ifFalse: [ - component := (value asInteger bitAnd: 16rFF) bitShift: 8. - ]. - (1 to: self size) do: [:i | | pix | - value isCollection ifTrue: [ - component := ((value at: i) asInteger bitAnd: 16rFF) bitShift: 8. - ]. - pix := patch pixelAtX: (xArray at: i) y: (yArray at: i). - pix := (pix bitAnd: 16rFF00FF) bitOr: component. - patch pixelAtX: (xArray at: i) y: (yArray at: i) put: pix. - ]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>setHeading: (in category 'player commands') ----- - setHeading: degrees - - ^ self heading: degrees. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>setInitialValueOf:from:to:for: (in category 'player commands') ----- - setInitialValueOf: name from: from to: to for: aKedamaWorld - - | array max | - array := arrays at: (info at: name). - name = #who ifTrue: [ - from to: to do: [:index | - array at: index put: (aKedamaWorld nextTurtleID). - ]. - ^ self. - ]. - name = #x ifTrue: [ - max := aKedamaWorld dimensions x * 100. - self primRandomRange: max from: from to: to intoFloatArray: array factor: 0.01. - ^ self. - ]. - name = #y ifTrue: [ - max := aKedamaWorld dimensions y * 100. - self primRandomRange: max from: from to: to intoFloatArray: array factor: 0.01. - ^ self. - ]. - name = #heading ifTrue: [ - self primRandomRange: 36000 from: from to: to intoFloatArray: array factor: (0.01 * 0.0174532925199433). - ^ self. - ]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>setNormal: (in category 'player commands') ----- - setNormal: degrees - - ^ self normal: degrees. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>setNumberVarAt:put: (in category 'accessing - private') ----- - setNumberVarAt: index put: v - - v isNumber ifTrue: [ - (arrays at: index) atAllPut: v. - ^ self. - ]. - (v isMemberOf: KedamaFloatArray) ifTrue: [ - (arrays at: index) replaceFrom: 1 to: v size with: v startingAt: 1. - ^ self. - ]. - (v isMemberOf: WordArray) ifTrue: [ - v primAddScalar: v and: 0.0 into: (arrays at: index). - ^ self. - ]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>setObjectVarAt:put: (in category 'accessing - private') ----- - setObjectVarAt: index put: v - - (v isKindOf: Array) ifFalse: [ - (arrays at: index) atAllPut: v. - ^ self. - ]. - (arrays at: index) replaceFrom: 1 to: v size with: v startingAt: 1. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>setPatchValueIn:to: (in category 'player commands') ----- - setPatchValueIn: aPatch to: value - - | xArray yArray patchMorph | - xArray := arrays at: 2. - yArray := arrays at: 3. - patchMorph := aPatch costume renderedMorph. - patchMorph setPixelsAtXArray: xArray yArray: yArray value: value. - - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>setRedComponentIn:to: (in category 'player commands') ----- - setRedComponentIn: aPatch to: value - - | xArray yArray patch component | - xArray := arrays at: 2. - yArray := arrays at: 3. - patch := aPatch costume renderedMorph. - value isCollection ifFalse: [ - component := (value asInteger bitAnd: 16rFF) bitShift: 16. - ]. - (1 to: self size) do: [:i | | pix | - value isCollection ifTrue: [ - component := ((value at: i) asInteger bitAnd: 16rFF) bitShift: 16. - ]. - pix := patch pixelAtX: (xArray at: i) y: (yArray at: i). - pix := (pix bitAnd: 16r00FFFF) bitOr: component. - patch pixelAtX: (xArray at: i) y: (yArray at: i) put: pix. - ]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>setTurtleVisible: (in category 'player commands') ----- - setTurtleVisible: aBooleanArray - - 1 to: self size do: [:i | - (turtles arrays at: 6) at: i put: ((aBooleanArray at: i) ifTrue: [1] ifFalse: [0]). - ]. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>setTurtlesCount:prototype:for:randomize: (in category 'add turtles') ----- - setTurtlesCount: count prototype: prototype for: aKedamaWorld randomize: rondomizeFlag - - | anInteger | - anInteger := count. - count < 0 ifTrue: [anInteger := 0]. - - self size > anInteger ifTrue: [ - info associationsDo: [:assoc | | array | - array := (arrays at: assoc value). - array := array copyFrom: 1 to: anInteger. - arrays at: assoc value put: array. - ]. - turtleMapValid := false. - whoTableValid := false. - ]. - - self size < anInteger ifTrue: [ - self addTurtlesCount: (anInteger - self size) ofPrototype: prototype for: aKedamaWorld randomize: rondomizeFlag. - turtleMapValid := false. - whoTableValid := false. - - ]. - - - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>setVectorSlotTypeFor:typeChosen: (in category 'player protocol') ----- - setVectorSlotTypeFor: slotName typeChosen: typeChosen - - | index initVar | - index := info at: slotName asSymbol. - index = 0 ifTrue: [^ self]. - - initVar := self initialValueForSlotOfType: typeChosen. - - types at: index put: typeChosen. - - self compileAllAccessors. - arrays at: index put: (self arrayForType: typeChosen). - self perform: ('set', slotName capitalized, ':') asSymbol with: initVar. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>setX: (in category 'player commands') ----- - setX: v - - exampler getGrouped ifFalse: [ - self - primSetX: (arrays at: 2) - headingArray: (arrays at: 4) - value: (v isNumber ifTrue: [v asFloat] ifFalse: [v]) - destWidth: kedamaWorld wrapX - leftEdgeMode: kedamaWorld leftEdgeModeMnemonic - rightEdgeMode: kedamaWorld rightEdgeModeMnemonic. - ] ifTrue: [ - self groupSetX: v - ]. - turtleMapValid := false. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>setY: (in category 'player commands') ----- - setY: v - - exampler getGrouped ifFalse: [ - self - primSetY: (arrays at: 3) - headingArray: (arrays at: 4) - value: (v isNumber ifTrue: [v asFloat] ifFalse: [v]) - destHeight: kedamaWorld wrapY - topEdgeMode: kedamaWorld topEdgeModeMnemonic - bottomEdgeMode: kedamaWorld bottomEdgeModeMnemonic. - ] ifTrue: [ - self groupSetY: v. - ]. - turtleMapValid := false. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>show (in category 'player commands') ----- - show - - (arrays at: 6) atAllPut: 1. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>size (in category 'accessing') ----- - size - - ^ arrays first size. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>turn: (in category 'player commands') ----- - turn: degrees - "Turn by the given number of degrees." - - self heading: (self heading + degrees). - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>types (in category 'accessing') ----- - types - - ^ types. - ! Item was removed: - ----- Method: KedamaTurtleVectorPlayer>>useKedamaFloatArray (in category 'private') ----- - useKedamaFloatArray - - - arrays withIndexDo: [:array :index | | newArray | - (array isMemberOf: FloatArray) ifTrue: [ - newArray := KedamaFloatArray new: array size. - newArray replaceFrom: 1 to: array size with: array startingAt: 1. - arrays at: index put: newArray. - ]. - ]. - ! Item was removed: - PackageInfo subclass: #MorphicGamesInfo - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Etoys-Squeakland-Morphic-Games'! - - !MorphicGamesInfo commentStamp: 'asm 7/5/2003 15:59' prior: 0! - to create the package: - - in a 5325 image - -file in SARBuilder - - SARPackageDumper fileOutPackageNamed: 'Morphic-Games' - as: (FileDirectory default nextNameFor: 'Morphic-Games' extension: 'sar')! Item was removed: - ----- Method: MorphicGamesInfo>>changesText (in category 'introspection') ----- - changesText - ^' - version 6: included Rick McGeer''s Chess Castling Fix - version 5: included Atomic (some changes were needed to make it work in 3.7) and some Babel stuff - version 4: includes Andreas Raab''s rewrite of ChessConstants as declarative pool (update 5325) - version 3: -added one change by the KCP team - -Chess its playing again - version 2: applied changes by the MCP team'! Item was removed: - ----- Method: MorphicGamesInfo>>postscriptText (in category 'introspection') ----- - postscriptText - "Executed after load" - ^ 'Utilities informUser: ''Generating Games thumbnails in PartsBin, please wait...'' during: [ - PartsBin clearThumbnailCache. - PartsBin cacheAllThumbnails. - ]. - "End ', self packageName, '"'! Item was removed: - ----- Method: MorphicGamesInfo>>readmeText (in category 'introspection') ----- - readmeText - ^'Morphic-Games has the games that were in the image before 3.6: - Chess, Chinese Checkers, Cipher, Crostic, FreeCell, Mines, Same and Tetris. - plus Atomic'! Item was removed: - ----- Method: Player class>>createTurtleSubclass (in category 'turtles') ----- - createTurtleSubclass - - | instVarString classInstVarString aName aClass | - instVarString := KedamaTurtleVectorPlayer instVarNames. - classInstVarString := ''. - aName := self chooseUniqueTurtleClassName. - aClass := self subclass: aName instanceVariableNames: instVarString - classVariableNames: '' poolDictionaries: '' category: self categoryForUniclasses. - classInstVarString size > 0 ifTrue: - [aClass class instanceVariableNames: classInstVarString]. - aClass copyAllCategoriesUnobtrusivelyFrom: KedamaTurtleVectorPlayer. - ^ aClass - ! Item was removed: - ----- Method: SugarLauncher>>badgeFlap (in category 'presence') ----- - badgeFlap - "This finds or creates a flap to hold badges" - - | translatedFlapName flapTab flap spacer holder | - translatedFlapName := 'Buddies' translated. - flapTab := Flaps globalFlapTab: translatedFlapName. - flapTab ifNotNil: [^flapTab]. - - flap := AlignmentMorph newRow. - flap clipSubmorphs: true. - flap beTransparent. - flap layoutInset: 0; cellInset: 0; borderWidth: 0. - flap setProperty: #wantsHaloFromClick toValue: false. - flap beFlap: true. - - spacer := Morph new beTransparent. "This provides space for tabs to be seen." - spacer width: 20. - spacer hResizing: #rigid; vResizing: #spaceFill. - flap addMorphBack: spacer. - - holder := Morph new. - holder name: 'Badges'. - holder position: 0@100. - holder layoutPolicy: TableLayout new. - holder color: Color red muchLighter; - wrapDirection: #topToBottom; - hResizing: #spaceFill; - vResizing: #spaceFill; - cellInset: 10; - layoutInset: 10. - flap addMorphBack: holder. - - flap beSticky. - spacer beSticky; lock: true. - holder beSticky. - - flapTab := FlapTab new. - flapTab referent: flap. - flapTab setName: translatedFlapName edge: #left color: Color red muchLighter. - flapTab referentMargin: 0@75. - flapTab setToPopOutOnDragOver: true. - Flaps addGlobalFlap: flapTab. - ActiveWorld addGlobalFlaps. - ScriptingSystem cleanUpFlapTabsOnLeft. - - ^flapTab! Item was removed: - ----- Method: SugarLauncher>>badgeFor: (in category 'presence') ----- - badgeFor: aBuddy - ^self badgeHolder submorphs - detect: [:m | - (m isKindOf: NebraskaSenderMorph) and: [ - (m valueOfProperty: #buddy) = aBuddy]] - ifNone: [nil] - ! Item was removed: - ----- Method: SugarLauncher>>badgeHolder (in category 'presence') ----- - badgeHolder - "This finds or creates a flap to hold badges" - - ^self badgeFlap referent submorphNamed: 'Badges' - ! Item was removed: - ----- Method: SugarLauncher>>buddies (in category 'presence') ----- - buddies - sharedActivity ifNil: [^Dictionary new]. - buddies ifNil: [self setupBuddies]. - ^buddies! Item was removed: - ----- Method: SugarLauncher>>buddiesLock (in category 'presence') ----- - buddiesLock - ^buddiesLock ifNil: [buddiesLock := Semaphore forMutualExclusion]! Item was removed: - ----- Method: SugarLauncher>>createJournalEntryFor:filename:mimetype: (in category 'datastore') ----- - createJournalEntryFor: aProject filename: aFilename mimetype: mimetypeString - | properties id | - properties := self propertiesFrom: aProject. - properties at: 'ctime' put: (properties at: 'mtime'). - properties at: 'mime_type' put: mimetypeString. - properties removeKey: 'uid' ifAbsent: []. "would confuse Sugar 0.82" - aFilename ifEmpty: [properties at: 'title:text' put: 'Etoys' translated]. - id := self dataStore create: properties with: aFilename squeakToUtf8 with: true. - ^id asString! Item was removed: - ----- Method: SugarLauncher>>deleteBadges (in category 'presence') ----- - deleteBadges - | flapTab | - flapTab := (Flaps globalFlapTab: 'Buddies' translated) ifNil: [^self]. - Flaps removeFlapTab: flapTab keepInList: false. - ! Item was removed: - ----- Method: SugarLauncher>>deleteUnused: (in category 'datastore') ----- - deleteUnused: filePath - "Delete file if filePath is indeed unused" - - World submorphs do: [:m | - (m isSystemWindow and: [ - (m model isKindOf: FileList) and: [ - m model fullName = filePath]]) ifTrue: [ - ^self deleteUnused: filePath whenDoneWith: m]]. - - [FileDirectory deleteFilePath: filePath] on: Error do: ["ignore"] - ! Item was removed: - ----- Method: SugarLauncher>>deleteUnused:whenDoneWith: (in category 'datastore') ----- - deleteUnused: fileName whenDoneWith: anObject - "Delete fileName when anObject is not in use anymore" - - ^anObject - toFinalizeSend: #deleteUnused: - to: self - with: fileName! Item was removed: - ----- Method: SugarLauncher>>enableSharedActivitySignals (in category 'presence') ----- - enableSharedActivitySignals - sharedActivity onBuddyJoinedSend: #buddyJoined: to: self. - sharedActivity onBuddyLeftSend: #buddyLeft: to: self. - ! Item was removed: - ----- Method: SugarLauncher>>findJournalEntries:properties: (in category 'datastore') ----- - findJournalEntries: query properties: propNames - "query is either a String or a dictionary, e.g. {'mime_type'->'application/x-squeak-project'}. Answers an array of properties. If propNames is not nil, only the named properties will be returned (which will be more efficient)" - ^(self dataStore find: query with: (propNames ifNil: [#()])) first! Item was removed: - ----- Method: SugarLauncher>>getFile: (in category 'datastore') ----- - getFile: id - "answer a temporary file, will be deleted if not used anymore" - | utf8Name file | - utf8Name := self dataStore getFilename: id. - utf8Name isEmptyOrNil ifTrue: [^nil]. - file := FileStream readOnlyFileNamed: utf8Name utf8ToSqueak. - self deleteUnused: file name whenDoneWith: file. - ^file! Item was removed: - ----- Method: SugarLauncher>>getProperties: (in category 'datastore') ----- - getProperties: objectId - | props | - props := self dataStore getProperties: objectId. - "Make sure the props we care about are strings" - props at: 'title' ifPresent: [:value | props at: 'title' put: value asString utf8ToSqueak composeAccents]. - props at: 'mime_type' ifPresent: [:value | props at: 'mime_type' put: value asString]. - props at: 'uid' put: objectId asString. - ^props! Item was removed: - ----- Method: SugarLauncher>>handleStream:mimetype:titled: (in category 'datastore') ----- - handleStream: tmpStream mimetype: mimetypeOrNil titled: title - "tmpStream was opened from journal or other media. - For simplicity, we re-use the file drop logic." - - ActiveHand lastEvent position: World center. - [ - [(ExternalDropHandler lookupExternalDropHandler: tmpStream) - handle: tmpStream in: World dropEvent: ActiveHand lastEvent] - ifError: [self inform: ('Cannot open {1}' translated format: {title})] - ] ensure: [tmpStream ifNotNil: [tmpStream close]].! Item was removed: - ----- Method: SugarLauncher>>joinSharedActivity (in category 'presence') ----- - joinSharedActivity - "join a shared activity on startup" - Utilities informUser: 'Looking for shared activity ...' translated - during: [ - [sharedActivity := self presence getActivityById: self activityId] - ifError: [^sharedActivity := nil]]. - - Utilities informUser: 'Joining activity ...' translated - during: [ - [sharedActivity join] ifError: [^sharedActivity := nil] . - self setupBuddies. - self setupTubes. - self enableSharedActivitySignals. - SugarNavigatorBar current ifNotNilDo: [:bar | bar joinSharedActivity]. - ]. - - ! Item was removed: - ----- Method: SugarLauncher>>leaveSharedActivity (in category 'presence') ----- - leaveSharedActivity - sharedActivity ifNotNil: [ - sharedActivity leaveAsync. - sharedActivity := nil. - self buddiesLock critical: [buddies := nil]. - self deleteBadges]. - ! Item was removed: - ----- Method: SugarLauncher>>makeJournalEntryFor:filename:mimetype: (in category 'datastore') ----- - makeJournalEntryFor: aProject filename: aFilename mimetype: mimetypeString - "If this is a new project (no journal id yet), create a new Journal object, and remember the new id. - Otherwise, if this is an auto-save, update the existing Journal entry. - But if it is an explicit save, always create a new entry. Which entry we continue to work on depends on the sugarAutoSave preference. If enabled (before 4.1), the new entry is just a checkpoint, the project continues to use the old id/entry, and will be saved again on quit. If disabled (default since 4.1), we switch to the newly created id/entry." - | id | - (id := aProject sugarObjectId) - ifNil: [ - id := self createJournalEntryFor: aProject filename: aFilename mimetype: mimetypeString. - aProject sugarObjectId: id. - self monitorJournalEntry: id] - ifNotNil: [ - (Preferences sugarAutoSave and: [aProject projectParameterAt: #sugarAutoSave ifAbsent: [true]]) - ifTrue: [self updateJournalEntry: id for: aProject filename: aFilename mimetype: mimetypeString] - ifFalse: [ - id := self createJournalEntryFor: aProject filename: aFilename mimetype: mimetypeString. - Preferences sugarAutoSave ifFalse: [ - self unmonitorJournalEntry: aProject sugarObjectId. - aProject sugarObjectId: id. - self monitorJournalEntry: id]]]! Item was removed: - ----- Method: SugarLauncher>>monitorJournalEntry: (in category 'datastore') ----- - monitorJournalEntry: objectId - self dataStore - onUpdated: objectId - send: #updatedJournalEntry: - to: self.! Item was removed: - ----- Method: SugarLauncher>>propertiesFrom: (in category 'datastore') ----- - propertiesFrom: aProject - | preview autoSave props markFavorite setActivity | - preview := [ByteArray streamContents: [:s | PNGReadWriter - putForm: (aProject thumbnail asFormOfDepth: 16) - onStream: s]] ifError: ['']. - autoSave := aProject projectParameterAt: #sugarAutoSave ifAbsent: [true]. - setActivity := Preferences sugarAutoSave not | autoSave. - markFavorite := Preferences sugarAutoSave & autoSave not. - props := (aProject sugarProperties ifNil: [Dictionary new]) copy. - { - 'activity' -> self bundleId. - 'activity_id' -> (setActivity ifTrue: [self activityId] ifFalse: ['']). - 'title:text' -> (self titleFromProject: aProject) squeakToUtf8. - 'title_set_by_user' -> (aProject currentVersionNumber>0 ifTrue: ['1'] ifFalse: ['0']). - 'keep' -> (markFavorite ifTrue: ['1'] ifFalse: ['0']). - 'mtime' -> (DateAndTime now asString first: 19). - 'timestamp' -> (DateAndTime now asUnixTime). - 'preview' -> preview. - 'icon-color' -> self ownerBuddy colors. - } do: [:each | props add: each]. - ^props - ! Item was removed: - ----- Method: SugarLauncher>>resumeJournalEntry: (in category 'datastore') ----- - resumeJournalEntry: id - | props file title project mimetype | - props := self getProperties: id. - title := props at: 'title' ifAbsent: ['untitled' translated]. - mimetype := props at: 'mime_type' ifAbsent: ['']. - - mimetype isEmpty ifTrue: [^self welcome: '']. - - mimetype = 'application/x-squeak-project' ifFalse: [ - "reuse drop code" - WorldState addDeferredUIMessage: [ - self open: id title: title mimetype: mimetype]. - ^Project enterNew]. - - 'Loading a Project...' displaySequentialProgress: [ - Display fillWhite;forceToScreen. - file := self getFile: id. - "load project and close temp file (which will thus be deleted)" - project := ProjectLoading - loadName: ((title copyReplaceAll: '/' with: '\') contractTo: 64) - stream: file - fromDirectory: nil - withProjectView: nil. - file close. - project keepSugarProperties: props monitor: true. - project projectParameterAt: #sugarAutoSave put: true. - project enter]. - ! Item was removed: - ----- Method: SugarLauncher>>setupBuddies (in category 'presence') ----- - setupBuddies - self badgeFlap. - self buddiesLock critical: [buddies := Dictionary new]. - sharedActivity getJoinedBuddies do: [:each | - self buddyJoined: each]. - ! Item was removed: - ----- Method: SugarLauncher>>sharePublicly: (in category 'presence') ----- - sharePublicly: aBoolean - sharedActivity ifNotNil: [^self]. - - sharedActivity := self presence - shareActivity: self activityId - with: self bundleId - with: (self titleFromProject: Project current) squeakToUtf8 - with: Dictionary new. "due to bug 4660 we can't pass properties directly" - sharedActivity setProperties: ({'private' -> aBoolean not} as: Dictionary). - self setupBuddies. - self enableSharedActivitySignals. - self setupTubes. - ! Item was removed: - ----- Method: SugarLauncher>>showBadges (in category 'presence') ----- - showBadges - self badgeFlap openFully! Item was removed: - ----- Method: SugarLauncher>>titleFromProject: (in category 'datastore') ----- - titleFromProject: aProject - ^(aProject name beginsWith: 'Unnamed' translated) - ifTrue: ['Etoys Project' translated] - ifFalse: [aProject name]! Item was removed: - ----- Method: SugarLauncher>>unmonitorJournalEntry: (in category 'datastore') ----- - unmonitorJournalEntry: objectId - self dataStore - onUpdated: objectId - send: nil - to: self.! Item was removed: - ----- Method: SugarLauncher>>updateJournalEntry: (in category 'datastore') ----- - updateJournalEntry: id - ^self updateJournalEntry: id - for: Project current - filename: '' - mimetype: ''! Item was removed: - ----- Method: SugarLauncher>>updateJournalEntry:for:filename:mimetype: (in category 'datastore') ----- - updateJournalEntry: id for: aProject filename: aFilename mimetype: mimetypeString - "Move aProject saved to aFilename into the datastore, delete aFilename" - | properties | - properties := self propertiesFrom: aProject. - properties at: 'mime_type' put: mimetypeString. - self dataStore update: id with: properties with: aFilename squeakToUtf8 with: true.! Item was removed: - ----- Method: Utilities class>>defaultRepositoryChangeLogOn: (in category '*Etoys-Squeakland-fetching updates') ----- - defaultRepositoryChangeLogOn: aStream - "Transcript clear. Utilities defaultRepositoryChangeLogOn: Transcript" - | repo updates latest previous latestVersion previousVersion added removed latestPackages previousPackages prevDep prevInfo latestInfo | - repo := MCRepositoryGroup default repositories detect: [:r | - r description = MCMcmUpdater defaultUpdateURL]. - updates := repo allFileNames select: [:each | 'update-*.mcm' match: each]. - updates := updates asSortedCollection: - [:a :b | a splitInteger second > b splitInteger second]. - latest := repo versionFromFileNamed: updates first. - previous := repo versionFromFileNamed: updates second. - latestVersion := self versionNumberAndDateFromConfig: latest. - previousVersion := self versionNumberAndDateFromConfig: previous. - aStream nextPutAll: 'Changes from v'; print: previousVersion first; - nextPutAll: ' of '; print: previousVersion second; - nextPutAll: ' to v'; print: latestVersion first; - nextPutAll: ' of '; print: latestVersion second; - nextPutAll: ':'; cr. - aStream flush. - latestPackages := latest dependencies collect: [:dep | dep package]. - previousPackages := previous dependencies collect: [:dep | dep package]. - added := latestPackages difference: previousPackages. - removed := previousPackages difference: latestPackages. - added ifNotEmpty: [ - aStream nextPutAll: 'Added packages:'. - added do: [:each | aStream space; nextPutAll: each name]. - aStream cr]. - removed ifNotEmpty: [ - aStream nextPutAll: 'Removed packages:'. - removed do: [:each | aStream space; nextPutAll: each name]. - aStream cr]. - latest dependencies do: [:latestDep | - prevDep := previous dependencies detect: [:p | latestDep package = p package] ifNone: []. - (prevDep notNil and: [prevDep versionInfo ~= latestDep versionInfo]) - ifTrue: [ - aStream nextPutAll: '--------------------'; cr. - prevInfo := prevDep package workingCopy ancestry findAncestor: prevDep versionInfo. - latestInfo := latestDep package workingCopy ancestry findAncestor: latestDep versionInfo. - (latestInfo allAncestorsOnPathTo: prevInfo) reverse, {latestInfo} - do: [:ver | aStream nextPutAll: ver name; cr; nextPutAll: ver message; cr] - separatedBy: [aStream cr]]]. - aStream flush - ! Item was removed: - ----- Method: Utilities class>>updateFromDefaultRepository (in category '*Etoys-Squeakland-fetching updates') ----- - updateFromDefaultRepository - | config | - "Flush all caches. If a previous download failed this is often helpful" - MCFileBasedRepository flushAllCaches. - config := MCMcmUpdater updateFromDefaultRepository. - config ifNil: [^self inform: 'Repository unavailable' translated]. - self setSystemVersionFromConfig: config. - self inform: ('Update completed. - System version is now: - {1}' translated format: {SystemVersion current asString}). - !

1 0

The Trunk: WebClient-HTTP-cmm.6.mcz
by commits＠source.squeak.org 16 Sep '16

16 Sep '16

Chris Muller uploaded a new version of WebClient-HTTP to project The Trunk: http://source.squeak.org/trunk/WebClient-HTTP-cmm.6.mcz ==================== Summary ==================== Name: WebClient-HTTP-cmm.6 Author: cmm Time: 14 September 2016, 3:27:23.768768 pm UUID: 900bff82-5c5e-478b-a08a-1ba7736a074d Ancestors: WebClient-HTTP-cmm.4 Accept text/html by default only when the user has not specified their own mimeType. =============== Diff against WebClient-HTTP-cmm.4 =============== Item was changed: ----- Method: HTTPSocket class>>httpGetDocument:args:accept:request: (in category '*webclient-http') ----- httpGetDocument: url args: args accept: mimeType request: requestString "Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. An extra requestString may be submitted and must end with crlf. The parsed header is saved. Use a proxy server if one has been registered. tk 7/23/97 17:12" "Note: To fetch raw data, you can use the MIME type 'application/octet-stream'." | client xhdrs resp urlString progress | "Normalize the url" urlString := (Url absoluteFromText: url) asString. args ifNotNil: [ urlString := urlString, (self argString: args) ]. "Some raw extra headers which historically have been added" xhdrs := HTTPProxyCredentials, HTTPBlabEmail, "may be empty" requestString. "extra user request. Authorization" client := WebClient new. ^[resp := client httpGet: urlString do:[:req| + "Add ACCEPT header, accept plain text by default." + req headerAt: 'Accept' put: (mimeType ifNil: ['text/html']). - "Add ACCEPT header" - mimeType ifNotNil:[req headerAt: 'Accept' put: mimeType]. - "Always accept plain text" - req addHeader: 'Accept' value: 'text/html'. - "Add the additional headers" (WebUtils readHeadersFrom: xhdrs readStream) do:[:assoc| req addHeader: assoc key value: assoc value]]. progress := [:total :amount| (HTTPProgress new) total: total; amount: amount; signal: 'Downloading...' ]. "Simulate old HTTPSocket return behavior" (resp code between: 200 and: 299) ifTrue:[MIMEDocument contentType: resp contentType content: (resp contentWithProgress: progress) url: url] ifFalse:[resp asString, resp content]. ] ensure:[client destroy]. !

1 0

The Trunk: Kernel-bf.1038.mcz
by commits＠source.squeak.org 15 Sep '16

15 Sep '16

Bert Freudenberg uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-bf.1038.mcz ==================== Summary ==================== Name: Kernel-bf.1038 Author: bf Time: 15 September 2016, 6:33:16.643947 pm UUID: 8c354082-7d64-4039-8dc2-e2d78c537570 Ancestors: Kernel-bf.1037 Fix typos =============== Diff against Kernel-bf.1037 =============== Item was changed: ----- Method: Monitor>>primitiveTestAndSetOwnershipOfCriticalSection (in category 'private-primitives') ----- primitiveTestAndSetOwnershipOfCriticalSection "Primitive. Attempt to set the ownership of the receiver. If the receiver is unowned set its owningProcess to the activeProcess and answer false. If the receiver is owned by the activeProcess answer true. If the receiver is owned by some other process answer nil. Copyright (c) 2016 - 3D Immersive Collaboration Consulting, LLC." <primitive: 187> + self primitiveFailed - self primitiveFail "In the spirit of the following" "[owner ifNil: [owningProcess := Processor activeProcess. ^false]. owner = Processor activeProcess ifTrue: [^true]. ^nil] valueUnpreemptively"! Item was changed: ----- Method: Mutex>>primitiveTestAndSetOwnershipOfCriticalSection (in category 'private-primitives') ----- primitiveTestAndSetOwnershipOfCriticalSection "Primitive. Attempt to set the ownership of the receiver. If the receiver is unowned set its owningProcess to the activeProcess and answer false. If the receiver is owned by the activeProcess answer true. If the receiver is owned by some other process answer nil. Copyright (c) 2016 - 3D Immersive Collaboration Consulting, LLC." <primitive: 187> + self primitiveFailed - self primitiveFail "In the spirit of the following" "[owner ifNil: [owningProcess := Processor activeProcess. ^false]. owner = Processor activeProcess ifTrue: [^true]. ^nil] valueUnpreemptively"!

1 0

The Trunk: EToys-bf.234.mcz
by commits＠source.squeak.org 15 Sep '16

15 Sep '16

Bert Freudenberg uploaded a new version of EToys to project The Trunk: http://source.squeak.org/trunk/EToys-bf.234.mcz ==================== Summary ==================== Name: EToys-bf.234 Author: bf Time: 15 September 2016, 1:46:41.663164 pm UUID: e2796761-35e4-418b-b7d2-65e8e3b6eb07 Ancestors: EToys-bf.233 Remove ImageSegment extension methods =============== Diff against EToys-bf.233 =============== Item was removed: - ----- Method: ImageSegment>>classOrganizersBeRoots: (in category '*Etoys-Squeakland-read/write segment') ----- - classOrganizersBeRoots: dummy - "The ClassOrganizers of some UniClasses may slip into OutPointers. They point directly at the class of the UniClass (in subject). They need to be in arrayOfRoots. Find them and insert them into dummy's references." - - dummy references keys do: [:anObject | - anObject isBehavior & (anObject isKindOf: ClassDescription) ifTrue: [ - anObject theNonMetaClass isSystemDefined ifFalse: ["uniClass will be in image seg" - (dummy references includesKey: anObject organization) ifFalse: [ - dummy references at: anObject organization put: 47]]]]. "will get into roots"! Item was removed: - ----- Method: ImageSegment>>rehashDictionaries: (in category '*Etoys-Squeakland-fileIn/Out') ----- - rehashDictionaries: aCollection - ProgressInitiationException - display: 'Rehash objects...' - during: [:bar | 1 - to: aCollection size - do: [:i | - (aCollection at: i) rehash. - i \\ 10 = 0 - ifTrue: [bar value: i / aCollection size]]]! Item was removed: - ----- Method: ImageSegment>>rehashMethodDictionaries: (in category '*Etoys-Squeakland-fileIn/Out') ----- - rehashMethodDictionaries: oldDictionaries - | newDictionaries | - newDictionaries := oldDictionaries collect: [:d | d rehashWithoutBecome]. - oldDictionaries asArray elementsForwardIdentityTo: newDictionaries asArray. - !

1 0

The Trunk: System-bf.916.mcz
by commits＠source.squeak.org 15 Sep '16

15 Sep '16

Bert Freudenberg uploaded a new version of System to project The Trunk: http://source.squeak.org/trunk/System-bf.916.mcz ==================== Summary ==================== Name: System-bf.916 Author: bf Time: 14 September 2016, 3:44:50.062121 pm UUID: aeafedd5-da52-4801-a48b-d5bb2fd288cc Ancestors: System-bf.915 Replace VM-level ImageSegment loading with a Smalltalk implementation for old (interpreter-era) projects. Also removes support for writing segments. This overrides the Spur support introduced in System-eem.758. =============== Diff against System-bf.915 =============== Item was changed: Object subclass: #ImageSegment instanceVariableNames: 'arrayOfRoots segment outPointers state segmentName fileName userRootCnt renamedClasses' + classVariableNames: 'RecentlyRenamedClasses' - classVariableNames: 'BiggestFileNumber RecentlyRenamedClasses' poolDictionaries: '' category: 'System-Object Storage'! + !ImageSegment commentStamp: 'bf 9/14/2016 13:42' prior: 0! + ImageSegment is used to import old (interpreter VM era) projects + into new images. Instead of a VM primitive it uses ImageSegmentLoader + to load objects from the segment. All methods for writing have been removed. + + The original ImageSegment used an "endMarker" object to enumerate + all objects in the segment, relying on the fact that all objects were layed + out continuously in object memory and could be traversed via #nextObject. + Since Spur makes no such guarantees the endMarker instance var has been + removed, instead the segment is converted into an Array of all objects, + so they can be enumerated. + + --- Original class comment --- - !ImageSegment commentStamp: 'eem 8/21/2015 18:55' prior: 0! I represent a segment of Squeak address space. I am created from an array of root objects. After storing, my segment contains a binary encoding of every object accessible from my roots but not otherwise accessible from anywhere else in the system. My segment contains outward pointers that are indices into my table of outPointers. On load my segment is converted back into objects and becommed into an Array of the loaded objects, so they can be enumerated. - The main use of ImageSegments is to store Projects. A dummy version of SmartRefStream traverses the Project. Everything it finds is classified as either an object that is owned by the project (only pointed to inside the project), or an object outside the project that is pointed to from inside the project. The objects that are completely owned by the project are compressed into pure binary form in an ImageSegment. The outside objects are put in the 'outPointers' array. The entire ImageSegment (binary part plus outPointers) is encoded in a SmartRefStream, and saved on the disk. (aProject exportSegmentWithChangeSet:fileName:directory:) calls (anImageSegment writeForExportWithSources:inDirectory:changeSet:). - Note that every object inside the project is put into the segment's arrayOfRoots. This is because a dummy SmartRefStream to scan the project, in order to make intelligent decisions about what belongs in the project. See Project's class comment for what messages are sent to objects as they are unpacked in a new image. ---- Older Details ------ The primary kind of image segment is an Export Segment. It can be saved on a server and read into a completely different Squeak image. Old way to create one: (ImageSegment new copyFromRootsForExport: (Array with: Baz with: Baz class)) writeForExport: 'myFile.extSeg'. Old way to create one for a project: (Project named: 'Play With Me - 3') exportSegment. To read it into another image: Select 'myFile.extSeg' in a FileList, Menu 'load as project'. It will install its classes automatically. If you need to see the roots array, it is temporarily stored in (SmartRefStream scannedObject). Most of 'states' of an ImageSegment are not used to export a project, and have been abandoned. When a segment is written out onto a file, it goes in a folder called <image name>_segs. If your image is called "Squeak2.6.image", the folder "Squeak2.6_segs" must accompany the image whenever your move, copy, or rename it. Whenever a Class is in arrayOfRoots, its class (aClass class) must also be in the arrayOfRoots. There are two kinds of image segments. Normal image segments are a piece of a specific Squeak image, and can only be read back into that image. The image holds the array of outPointers that are necessary to turn the bits in the file into objects. To put out a normal segment that holds a Project (not the current project), execute (Project named: 'xxx') storeSegment. arrayOfRoots The objects that head the tree we will trace. segment The WordArray of raw bits of all objects in the tree. outPointers Oops of all objects outside the segment pointed to from inside. state (see below) segmentName Its basic name. Often the name of a Project. fileName The local name of the file. 'Foo-23.seg' userRootCnt number of roots submitted by caller. Extras are added in preparation for saving. state that an ImageSegment may exist in... #activeCopy (has been copied, with the intent to become active) arrayOfRoots, segment, and outPointers have been created by copyFromRoots:. The tree of objects has been encoded in the segment, but those objects are still present in the Squeak system. #active (segment is actively holding objects) The segment is now the only holder of tree of objects. Each of the original roots has been transmuted into an ImageSegmentRootStub that refers back to this image segment. The original objects in the segment will all be garbageCollected. #onFile The segment has been written out to a file and replaced by a file pointer. Only ImageSegmentRootStubs and the array of outPointers remains in the image. To get this far: (ImageSegment new copyFromRoots: (Array with: Baz with: Baz class)) writeToFile: 'myFile.seg'. #inactive The segment has been brought back into memory and turned back into objects. rootsArray is set, but the segment is invalid. #onFileWithSymbols The segment has been written out to a file, along with the text of all the symbols in the outPointers array, and replaced by a file pointer. This reduces the size of the outPointers array, and also allows the system to reclaim any symbols that are not referred to from elsewhere in the image. The specific format used is that of a literal array as follows: #(symbol1 symbol2 # symbol3 symbol4 'symbolWithSpaces' # symbol5). In this case, the original outPointers array was 8 long, but the compacted table of outPointers retains only two entries. These get inserted in place of the #'s in the array of symbols after it is read back in. Symbols with embedded spaces or other strange characters are written as strings, and converted back to symbols when read back in. The symbol # is never written out. NOTE: All IdentitySets or dictionaries must be rehashed when being read back from this format. The symbols are effectively internal. (No, not if read back into same image. If a different image, then use #imported. -tk) #imported The segment is on an external file or just read in from one. The segment and outPointers are meant to be read into a foreign image. In this form, the image segment can be read from a URL, and installed. A copy of the original array of root objects is constructed, with former outPointers bound to existing objects in the host system. (Any Class inside the segment MUST be in the arrayOfRoots. This is so its association can be inserted into Smalltalk. The class's metaclass must be in roots also. Methods that are in outPointers because blocks point at them, were found and added to the roots. All IdentitySets and dictionaries are rehashed when being read back from exported segments.) To discover why only some of the objects in a project are being written out, try this (***Destructive Test***). This breaks lots of backpointers in the target project, and puts up an array of suspicious objects, a list of the classes of the outPointers, and a debugger. "Close any transcripts in the target project" World currentHand objectToPaste ifNotNil: [ self inform: 'Hand is holding a Morph in its paste buffer:\' withCRs, World currentHand objectToPaste printString]. PV := Project named: 'xxxx'. (IS := ImageSegment new) findRogueRootsImSeg: (Array with: PV world presenter with: PV world). IS findOwnersOutPtrs. "Optionally: write a file with owner chains" "Quit and DO NOT save" When an export image segment is brought into an image, it is like an image starting up. Certain startUp messages need to be run. These are byte and word reversals for nonPointer data that comes from a machine of the opposite endianness. #startUpProc passes over all objects in the segment, and: + The first time an instance of class X is encountered, (msg := - The first time an instance of class X is encountered, (msg _ X startUpFrom: anImageSegment) is sent. If msg is nil, the usual case, it means that instances of X do not need special work. X is included in the IdentitySet, noStartUpNeeded. If msg is not nil, store it in the dictionary, startUps (aClass -> aMessage). When a later instance of X is encountered, if X is in noStartUpNeeded, do nothing. If X is in startUps, send the message to the instance. Typically this is a message like #swapShortObjects. Every class that implements #startUp, should see if it needs a parallel implementation of #startUpFrom:. ! Item was removed: - ----- Method: ImageSegment class>>activeClasses (in category 'testing') ----- - activeClasses "ImageSegment activeClasses" - "Restore all remaining MD faults and return the active classes" - - | unused active | - unused := OrderedCollection new. - active := OrderedCollection new. - Smalltalk allClasses do: - [:c | (c instVarNamed: 'methodDict') - ifNil: [unused addLast: c] - ifNotNil: [active addLast: c]]. - unused do: [:c | c recoverFromMDFault]. - ^ active - ! Item was removed: - ----- Method: ImageSegment class>>activeClassesByCategory (in category 'testing') ----- - activeClassesByCategory "ImageSegment activeClassesByCategory" - "Return a dictionary of active classes by system category. - Useful for finding kernel categories to minimize swapping." - - | active dict | - active := self activeClasses. - dict := Dictionary new. - active do: - [:c | | cat list | cat := c category. - list := dict at: cat ifAbsent: [Array new]. - dict at: cat put: (list copyWith: c)]. - ^ dict - " - ImageSegment discoverActiveClasses <-- do it - -- do something typical -- - ImageSegment activeClassesByCategory <-- inspect it - "! Item was removed: - ----- Method: ImageSegment class>>compressedFileExtension (in category 'accessing') ----- - compressedFileExtension - ^'sqz'! Item was removed: - ----- Method: ImageSegment class>>discoverActiveClasses (in category 'testing') ----- - discoverActiveClasses "ImageSegment discoverActiveClasses" - "Run this method, do a few things, maybe save and resume the image. - This will leave unused classes with MDFaults. - You MUST follow this soon by activeClasses, or by swapOutInactiveClasses." - - "NOTE: discoverActiveClasses uses Squeak's ability to detect and recover from faults due to a nil method dictionary. It staches the method dict in with the organization during the time when discovery is in progress (Gag me with a spoon). This is why the faults need to be cleared promptly before resuming normal work with the system. It is also important that classes *do not* refer directly to their method dictionary, but only via the accessor message." - - Smalltalk allClasses do: - [:c | | ok | ok := true. - #(Array Object Class Message MethodDictionary) do: - [:n | ((Smalltalk at: n) == c or: - [(Smalltalk at: n) inheritsFrom: c]) ifTrue: [ok := false]]. - ok ifTrue: [c induceMDFault]]. - " - ImageSegment discoverActiveClasses. - -- do something typical -- - PopUpMenu notify: ImageSegment activeClasses size printString , ' classes were active out of ' , - Smalltalk allClasses size printString. - "! Item was removed: - ----- Method: ImageSegment class>>fileExtension (in category 'accessing') ----- - fileExtension - ^'extSeg'! Item was removed: - ----- Method: ImageSegment class>>folder (in category 'fileIn/Out') ----- - folder - | im | - "Full path name of segments folder. Be sure to duplicate and rename the folder when you duplicate and rename an image. Is $_ legal in all file systems?" - - im := Smalltalk imageName. - ^ (im copyFrom: 1 to: im size - 6 "'.image' size"), '_segs'! Item was removed: - ----- Method: ImageSegment class>>reclaimObsoleteSegmentFiles (in category 'fileIn/Out') ----- - reclaimObsoleteSegmentFiles "ImageSegment reclaimObsoleteSegmentFiles" - "Delete segment files that can't be used after this image is saved. - Note that this is never necessary -- it just saves file space." - - | segDir segFiles folderName byName exists | - folderName := FileDirectory default class localNameFor: self folder. - (FileDirectory default includesKey: folderName) ifFalse: [ - ^ self "don't create if absent"]. - segDir := self segmentDirectory. - segFiles := (segDir fileNames select: [:fn | fn endsWith: '.seg']) asSet. - exists := segFiles copy. - segFiles isEmpty ifTrue: [^ self]. - byName := Set new. - "Remove (save) every file owned by a segment in memory" - ImageSegment allInstancesDo: [:is | | aFileName | - (aFileName := is localName) ifNotNil: [ - segFiles remove: aFileName ifAbsent: []. - (exists includes: aFileName) ifFalse: [ - Transcript cr; show: 'Segment file not found: ', aFileName]. - byName add: is segmentName]]. - "Of the segments we have seen, delete unclaimed the files." - segFiles do: [:fName | - "Delete other file versions with same project name as one known to us" - (byName includes: (fName sansPeriodSuffix stemAndNumericSuffix first)) - ifTrue: [segDir deleteFileNamed: fName]].! Item was removed: - ----- Method: ImageSegment class>>segmentDirectory (in category 'fileIn/Out') ----- - segmentDirectory - "Return a directory object for the folder of segments. - Create such a folder if none exists." - | dir folderName | - dir := FileDirectory default. - folderName := dir class localNameFor: self folder. "imageName:=segs" - (dir includesKey: folderName) ifFalse: - [dir createDirectory: folderName]. "create the folder if necess" - ^ dir directoryNamed: folderName! Item was removed: - ----- Method: ImageSegment class>>shutDown (in category 'fileIn/Out') ----- - shutDown - "Delete segment files that can't be used after this image is saved." - - "This is Optional. - (1) How tell if saving image now? Only do if is. - (2) ImageSegmentRootStub allInstancesDo: - If more than one file, delete all but one we are using now. - Leave files with not stubs (could be out in a segment) - Must forbid two projects from having the same name!! - (3) all Projects do: - If project is in, delete all files with its name. - " - ! Item was removed: - ----- Method: ImageSegment class>>startUp (in category 'fileIn/Out') ----- - startUp - | choice | - "Minimal thing to assure that a .segs folder is present" - - (Preferences valueOfFlag: #projectsSentToDisk) ifTrue: [ - (FileDirectory default includesKey: (FileDirectory localNameFor: self folder)) - ifFalse: [ - choice := UIManager default - chooseFrom: #('Create folder' 'Quit without saving') - title: - 'The folder with segments for this image is missing.\' withCRs, - self folder, '\If you have moved or renamed the image file,\' withCRs, - 'please Quit and rename the segments folder in the same way'. - choice = 1 ifTrue: [FileDirectory default createDirectory: self folder]. - choice = 2 ifTrue: [Smalltalk snapshot: false andQuit: true]]] - - ! Item was removed: - ----- 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 | - 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 | - 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: - [:cat | | roots | 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 removed: - ----- Method: ImageSegment class>>swapOutProjects (in category 'testing') ----- - swapOutProjects "ImageSegment swapOutProjects" - "Swap out segments for all projects other than the current one." - - | spaceLeft | - spaceLeft := Smalltalk garbageCollect. - Project allProjects doWithIndex: - [:p :i | | newSpaceLeft | p couldBeSwappedOut ifTrue: - [Transcript cr; cr; nextPutAll: p name. - (ImageSegment new copyFromRoots: (Array with: p) sizeHint: 0) - extract; writeToFile: 'project' , i printString. - newSpaceLeft := Smalltalk garbageCollect. - Transcript cr; print: newSpaceLeft - spaceLeft; endEntry. - spaceLeft := newSpaceLeft]].! Item was removed: - ----- Method: ImageSegment class>>testClassFaultOn: (in category 'testing') ----- - testClassFaultOn: someClass "ImageSegment testClassFaultOn: FileList" - "Swap out a class with an existing instance. Then send a message to the inst. - This will cause the VM to choke down deep and resend #cannotInterpret:. - This in turn will send a message to the stubbed class which will choke - and resend: #doesNotUnderstand:. Then, if we're lucky, things will start working." - - (ImageSegment new copyFromRoots: (Array with: someClass with: someClass class) - sizeHint: 0) extract; writeToFile: 'test'. - ! Item was removed: - ----- Method: ImageSegment class>>uniqueFileNameFor: (in category 'fileIn/Out') ----- - uniqueFileNameFor: segName - "Choose a unique file name for the segment with this name." - | segDir fileName listOfFiles | - segDir := self segmentDirectory. - listOfFiles := segDir fileNames. - BiggestFileNumber ifNil: [BiggestFileNumber := 1]. - BiggestFileNumber > 99 ifTrue: [BiggestFileNumber := 1]. "wrap" - [fileName := segName, BiggestFileNumber printString, '.seg'. - (listOfFiles includes: fileName)] whileTrue: [ - BiggestFileNumber := BiggestFileNumber + 1]. "force a unique file name" - ^ fileName! Item was removed: - ----- Method: ImageSegment>>aComment (in category 'compact classes') ----- - aComment - "Compact classes are a potential problem because a pointer to the class would not ordinarily show up in the outPointers. We add the classes of all compact classes to outPointers, both for local and export segments. - Compact classes are never allowed as roots. No compact class may be in an Environment that is written out to disk. (In local segments, the compact classes array should never have an ImageSegmentRootStub in it. For export, fileIn the class first, then load a segment with instances of it. The fileIn code can be pasted onto the front of the .extSeg file) - For local segments, a class may become compact while its instances are out on the disk. Or it may become un-compact. A compact class may change shape while some of its instances are on disk. All three cases go through (ClassDescription updateInstancesFrom:). If it can't rule out an instance being in the segment, it reads it in to fix the instances. - See Behavior.becomeCompact for the rules on Compact classes. Indexes may not be reused. This is so that an incoming export segment has its index available. (Changes may be needed in the way indexes are assigned.) - For export segments, a compact class may have a different shape. The normal class reshape mechanism will catch this. During the installation of the segment, objects will have the wrong version of their class momentarily. We will change them back before we get caught. - For export segments, the last two items in outPointers are the number 1717 and an array of the compact classes used in this segment. (The classes in the array are converted from DiskProxies by SmartRefStream.) If that class is not compact in the new image, the instances are recopied. - "! Item was removed: - ----- Method: ImageSegment>>acceptSingleMethodSource: (in category 'fileIn/Out') ----- - acceptSingleMethodSource: aDictionary - - | oldClassInfo oldClassName ismeta newName actualClass selector | - oldClassInfo := (aDictionary at: #oldClassName) findTokens: ' '. "'Class' or 'Class class'" - oldClassName := oldClassInfo first asSymbol. - ismeta := oldClassInfo size > 1. - - "must use class var since we may not be the same guy who did the initial work" - - newName := RecentlyRenamedClasses ifNil: [ - oldClassName - ] ifNotNil: [ - RecentlyRenamedClasses at: oldClassName ifAbsent: [oldClassName] - ]. - actualClass := Smalltalk at: newName. - ismeta ifTrue: [actualClass := actualClass class]. - selector := actualClass newParser parseSelector: (aDictionary at: #methodText). - (actualClass compiledMethodAt: selector ifAbsent: [^self "hosed input"]) - putSource: (aDictionary at: #methodText) - fromParseNode: nil - class: actualClass - category: (aDictionary at: #category) - withStamp: (aDictionary at: #changeStamp) - inFile: 2 - priorMethod: nil. - - ! Item was removed: - ----- Method: ImageSegment>>allInstancesOf:do: (in category 'instance change shape') ----- - allInstancesOf: aClass do: aBlock - | withSymbols oldInstances segSize | - "Bring me in, locate instances of aClass and submit them to the block. Write me out again." - - (state = #onFile or: [state = #onFileWithSymbols]) ifFalse: [^ self]. - withSymbols := state = #onFileWithSymbols. - (outPointers includes: aClass) ifFalse: [^ self]. - "If has instances, they point out at the class" - state = #onFile ifTrue: [Cursor read showWhile: [self readFromFile]]. - segSize := segment size. - self install. - oldInstances := OrderedCollection new. - self allObjectsDo: [:obj | obj class == aClass ifTrue: [ - oldInstances add: obj]]. - oldInstances do: aBlock. "do the work" - self copyFromRoots: arrayOfRoots sizeHint: segSize. - self extract. - withSymbols - ifTrue: [self writeToFileWithSymbols] - ifFalse: [self writeToFile]. - - ! Item was changed: ----- Method: ImageSegment>>checkAndReportLoadError (in category 'error checking') ----- checkAndReportLoadError "Check that the load has occurred. A side-efect of the load primitive is to become the segment into an Array of the loaded objects, so they can be enumerated. If this hasn't happened also check if the segment is a zero-length word array which indicates we're running on an older Spur VM that doesn't do the become." + segment class isPointers ifTrue: [^self]. "ok" - segment isArray ifTrue: [^self]. "ok" (segment class == WordArrayForSegment and: [segment size = 0]) ifTrue: [^self error: 'The load primitive has not becomed segment into an Array of the loaded objects. \Please upgrade your virtual machine to one that does this.' withCRs]. ^self error: 'Segment has not been becommed into the loaded objects'! Item was removed: - ----- Method: ImageSegment>>classNameAt: (in category 'statistics') ----- - classNameAt: index - | ccIndex | - ccIndex := self compactIndexAt: index. - ccIndex = 0 ifFalse:[^(Smalltalk compactClassesArray at: ccIndex) name]. - ccIndex := segment at: index-1. - (ccIndex bitAnd: 16r80000000) = 0 ifTrue:[ - "within segment; likely a user object" - ^#UserObject]. - ccIndex := (ccIndex bitAnd: 16r7FFFFFFF) bitShift: -2. - ^(outPointers at: ccIndex) name! Item was changed: + ----- Method: ImageSegment>>comeFullyUpOnReload: (in category 'fileIn') ----- - ----- 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 receiverClasses rootsToUnhiberhate myProject existing forgetDoItsClass endianness | - | mapFakeClassesToReal receiverClasses rootsToUnhiberhate myProject forgetDoItsClasses endianness | + forgetDoItsClass := Set new. - forgetDoItsClasses := Set new. RecentlyRenamedClasses := nil. "in case old data hanging around" mapFakeClassesToReal := smartRefStream reshapedClassesIn: outPointers. + "Dictionary of just the ones that change shape. Substitute them in outPointers." - "Dictionary of just the ones that change shape. Substitute them in outPointers." self fixCapitalizationOfSymbols. + endianness := (segment first bitShift: -24) asCharacter == $d ifTrue: [#big] ifFalse: [#little]. + segment := ImageSegmentLoader new loadSegmentFrom: segment outPointers: outPointers. + arrayOfRoots := segment first. - endianness := self endianness. - arrayOfRoots := self loadSegmentFrom: segment outPointers: outPointers. - self checkAndReportLoadError. - "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 | - 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 isMemberOf: TTCFontSet) ifTrue: [ + existing := TTCFontSet familyName: importedObject familyName + pointSize: importedObject pointSize. "supplies default" - (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: endianness ~~ Smalltalk endianness. "rehash sets" - receiverClasses := self restoreEndianness: (endianness ~~ Smalltalk endianness). "rehash sets" smartRefStream checkFatalReshape: receiverClasses. "Classes in this segment." arrayOfRoots do: [:importedObject | + importedObject class class == Metaclass ifTrue: [forgetDoItsClass add: importedObject. self declare: importedObject]]. + rootsToUnhiberhate := OrderedCollection new. - importedObject class class == Metaclass ifTrue: [ - forgetDoItsClasses add: importedObject. - self declare: importedObject]]. arrayOfRoots do: [:importedObject | + ((importedObject isMemberOf: ScriptEditorMorph) + or: [(importedObject isKindOf: TileMorph) + or: [(importedObject isMemberOf: ScriptingTileHolder) + or: [importedObject isKindOf: CompoundTileMorph]]]) ifTrue: [ + rootsToUnhiberhate add: importedObject + ]. + (importedObject isMemberOf: Project) ifTrue: [ - importedObject isCompiledMethod 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])]]. - self dependentsRestore: importedObject]]. - rootsToUnhiberhate := arrayOfRoots select: [:importedObject | - importedObject respondsTo: #unhibernate - "ScriptEditors and ViewerFlapTabs" - ]. myProject ifNotNil: [ myProject world setProperty: #thingsToUnhibernate toValue: rootsToUnhiberhate asArray. ]. mapFakeClassesToReal isEmpty ifFalse: [ mapFakeClassesToReal keysAndValuesDo: [:aFake :aReal | aFake removeFromSystemUnlogged. + aFake becomeForward: aReal]. - "do not assign the fake's hash to the real class" - aFake becomeForward: aReal copyHash: false]. SystemOrganization removeEmptyCategories]. + forgetDoItsClass do: [:c | c forgetDoIts]. - forgetDoItsClasses do: [:c | c forgetDoIts]. "^ self" ! Item was removed: - ----- Method: ImageSegment>>compactClassesArray (in category 'compact classes') ----- - compactClassesArray - | ccIndexes ind ccArray hdrBits | - "A copy of the real compactClassesArray, but with only the classes actually used in the segment. Slow, but OK for export." - - ccIndexes := Set new. - ind := 2. "skip version word, first object" - "go past extra header words" - (hdrBits := (segment atPin: ind) bitAnd: 3) = 1 ifTrue: [ind := ind+1]. - hdrBits = 0 ifTrue: [ind := ind+2]. - - [ccIndexes add: (self compactIndexAt: ind). "0 if has class field" - ind := self objectAfter: ind. - ind > segment size] whileFalse. - ccArray := Smalltalk compactClassesArray clone. - 1 to: ccArray size do: [:ii | "only the ones we use" - (ccIndexes includes: ii) ifFalse: [ccArray at: ii put: nil]]. - ^ ccArray! Item was removed: - ----- Method: ImageSegment>>compactIndexAt: (in category 'compact classes') ----- - compactIndexAt: ind - | word | - "Look in this header word in the segment and find it's compact class index. *** Warning: When class ObjectMemory change, be sure to change it here. *** " - - ((word := segment at: ind) bitAnd: 3) = 2 ifTrue: [^ 0]. "free block" - ^ (word >> 12) bitAnd: 16r1F "Compact Class field of header word" - - ! Item was removed: - ----- Method: ImageSegment>>copyFromRoots:sizeHint: (in category 'read/write segment') ----- - copyFromRoots: aRootArray sizeHint: segSizeHint - "Copy a tree of objects into a WordArray segment. The copied objects in the segment are not in the normal Squeak space. If this method yields a very small segment, it is because objects just below the roots are pointed at from the outside. (See findRogueRootsImSeg: for a *destructive* diagnostic of who is pointing in.) - Caller must hold onto Symbols. - To go faster, make sure objects are not repeated in aRootArray and other method directly, with true." - - self copyFromRoots: aRootArray sizeHint: segSizeHint areUnique: false - ! Item was removed: - ----- Method: ImageSegment>>copyFromRoots:sizeHint:areUnique: (in category 'read/write segment') ----- - copyFromRoots: aRootArray sizeHint: segSizeHint areUnique: areUnique - "Copy a tree of objects into a WordArray segment. The copied objects in the segment are not in the normal Squeak space. - [1] For exporting a project. Objects were enumerated by ReferenceStream and aRootArray has them all. - [2] For exporting some classes. See copyFromRootsForExport:. (Caller must hold Symbols, or they will not get registered in the target system.) - [3] For 'local segments'. outPointers are kept in the image. - If this method yields a very small segment, it is because objects just below the roots are pointed at from the outside. (See findRogueRootsImSeg: for a *destructive* diagnostic of who is pointing in.)" - | segmentWordArray outPointerArray segSize rootSet uniqueRoots | - aRootArray ifNil: [self errorWrongState]. - uniqueRoots := areUnique - ifTrue: [aRootArray] - ifFalse: [rootSet := IdentitySet new: aRootArray size * 3. - uniqueRoots := OrderedCollection new. - 1 to: aRootArray size do: [:ii | "Don't include any roots twice" - (rootSet includes: (aRootArray at: ii)) - ifFalse: [ - uniqueRoots addLast: (aRootArray at: ii). - rootSet add: (aRootArray at: ii)] - ifTrue: [userRootCnt ifNotNil: ["adjust the count" - ii <= userRootCnt ifTrue: [userRootCnt := userRootCnt - 1]]]]. - uniqueRoots]. - arrayOfRoots := uniqueRoots asArray. - rootSet := uniqueRoots := nil. "be clean" - userRootCnt ifNil: [userRootCnt := arrayOfRoots size]. - outPointers := nil. "may have used this instance before" - segSize := segSizeHint > 0 ifTrue: [segSizeHint *3 //2] ifFalse: [50000]. - - ["Guess a reasonable segment size" - segmentWordArray := WordArrayForSegment new: segSize. - outPointerArray := [Array new: segSize // 20] ifError: [ - state := #tooBig. ^ self]. - "Smalltalk garbageCollect." - (self storeSegmentFor: arrayOfRoots - into: segmentWordArray - outPointers: outPointerArray) == nil] - whileTrue: - ["Double the segment size and try again" - segmentWordArray := outPointerArray := nil. - segSize := segSize * 2]. - segment := segmentWordArray. - outPointers := outPointerArray. - state := #activeCopy - ! Item was removed: - ----- Method: ImageSegment>>copyFromRootsForExport: (in category 'read/write segment') ----- - copyFromRootsForExport: rootArray - "When possible, use copySmartRootsExport:. This way may not copy a complete tree of objects. Add to roots: all of the methods pointed to from the outside by blocks." - | newRoots list segSize symbolHolder | - arrayOfRoots := rootArray. - "self halt." - symbolHolder := Symbol allSymbols. "Hold onto Symbols with strong pointers, - so they will be in outPointers" - (newRoots := self rootsIncludingPlayers) ifNotNil: [ - arrayOfRoots := newRoots]. "world, presenter, and all Player classes" - "Creation of the segment happens here" - self copyFromRoots: arrayOfRoots sizeHint: 0. - segSize := segment size. - [(newRoots := self rootsIncludingBlockMethods) == nil] whileFalse: [ - arrayOfRoots := newRoots. - self copyFromRoots: arrayOfRoots sizeHint: segSize]. - "with methods pointed at from outside" - [(newRoots := self rootsIncludingBlocks) == nil] whileFalse: [ - arrayOfRoots := newRoots. - self copyFromRoots: arrayOfRoots sizeHint: segSize]. - "with methods, blocks from outPointers" - "classes of receivers of blocks" - list := self compactClassesArray. - outPointers := outPointers, ((list select: [:cls | cls ~~ nil]), (Array with: 1717 with: list)). - "Zap sender of a homeContext. Can't send live stacks out." - 1 to: outPointers size do: [:ii | - (outPointers at: ii) isBlock ifTrue: [outPointers at: ii put: nil]. - (outPointers at: ii) class == MethodContext ifTrue: [outPointers at: ii put: nil]]. - symbolHolder.! Item was removed: - ----- Method: ImageSegment>>copyFromRootsLocalFileFor:sizeHint: (in category 'read/write segment') ----- - copyFromRootsLocalFileFor: rootArray sizeHint: segSize - "If the roots include a World, add its Player classes to the roots." - | newRoots | - - arrayOfRoots := rootArray. - [(newRoots := self rootsIncludingPlayers) == nil] whileFalse: [ - arrayOfRoots := newRoots]. "world, presenter, and all Player classes" - self copyFromRoots: arrayOfRoots sizeHint: segSize. - ! Item was removed: - ----- Method: ImageSegment>>copySmartRootsExport: (in category 'read/write segment') ----- - copySmartRootsExport: rootArray - "Use SmartRefStream to find the object. Make them all roots. Create the segment in memory. Project should be in first five objects in rootArray." - | newRoots list segSize symbolHolder replacements naughtyBlocks allClasses sizeHint proj dummy | - - "self halt." - symbolHolder := Symbol allSymbols. "Hold onto Symbols with strong pointers, - so they will be in outPointers" - - dummy := ReferenceStream on: (DummyStream on: nil). - "Write to a fake Stream, not a file" - "Collect all objects" - dummy insideASegment: true. "So Uniclasses will be traced" - dummy rootObject: rootArray. "inform him about the root" - dummy nextPut: rootArray. - (proj :=dummy project) ifNotNil: [self dependentsSave: dummy]. - allClasses := SmartRefStream new uniClassInstVarsRefs: dummy. - "catalog the extra objects in UniClass inst vars. Put into dummy" - allClasses do: [:cls | - dummy references at: cls class put: false. "put Player5 class in roots" - dummy blockers removeKey: cls class ifAbsent: []]. - "refs := dummy references." - arrayOfRoots := self smartFillRoots: dummy. "guaranteed none repeat" - self savePlayerReferences: dummy references. "for shared References table" - replacements := dummy blockers. - dummy project "recompute it" ifNil: [self error: 'lost the project!!']. - dummy project class == DiskProxy ifTrue: [self error: 'saving the wrong project']. - dummy := nil. "force GC?" - naughtyBlocks := arrayOfRoots select: [ :each | - (each isKindOf: ContextPart) and: [each hasInstVarRef] - ]. - - "since the caller switched ActiveWorld, put the real one back temporarily" - naughtyBlocks isEmpty ifFalse: [ - World becomeActiveDuring: [World firstHand becomeActiveDuring: [ | goodToGo | - goodToGo := (UIManager default - chooseFrom: #('keep going' 'stop and take a look') - title: - 'Some block(s) which reference instance variables - are included in this segment. These may fail when - the segment is loaded if the class has been reshaped. - What would you like to do?') = 1. - goodToGo ifFalse: [ - naughtyBlocks inspect. - self error: 'Here are the bad blocks']. - ]]. - ]. - "Creation of the segment happens here" - - "try using one-quarter of memory min: four megs to publish (will get bumped later)" - sizeHint := (Smalltalk garbageCollect // 4 // 4) min: 1024*1024. - self copyFromRoots: arrayOfRoots sizeHint: sizeHint areUnique: true. - segSize := segment size. - [(newRoots := self rootsIncludingBlockMethods) == nil] whileFalse: [ - arrayOfRoots := newRoots. - self copyFromRoots: arrayOfRoots sizeHint: segSize areUnique: true]. - "with methods pointed at from outside" - [(newRoots := self rootsIncludingBlocks) == nil] whileFalse: [ - arrayOfRoots := newRoots. - self copyFromRoots: arrayOfRoots sizeHint: segSize areUnique: true]. - "with methods, blocks from outPointers" - list := self compactClassesArray. - outPointers := outPointers, ((list select: [:cls | cls ~~ nil]), (Array with: 1717 with: list)). - 1 to: outPointers size do: [:ii | - (outPointers at: ii) isBlock ifTrue: [outPointers at: ii put: nil]. - (outPointers at: ii) class == MethodContext ifTrue: [outPointers at: ii put: nil]. - "substitute new object in outPointers" - (replacements includesKey: (outPointers at: ii)) ifTrue: [ - outPointers at: ii put: (replacements at: (outPointers at: ii))]]. - proj ifNotNil: [self dependentsCancel: proj]. - symbolHolder.! Item was changed: + ----- Method: ImageSegment>>declare: (in category 'fileIn') ----- - ----- Method: ImageSegment>>declare: (in category 'fileIn/Out') ----- declare: classThatIsARoot | nameOnArrival | "The class just arrived in this segment. How fit it into the Smalltalk dictionary? If it had an association, that was installed with associationDeclareAt:." nameOnArrival := classThatIsARoot name. + [self declareAndPossiblyRename: classThatIsARoot] + on: AttemptToWriteReadOnlyGlobal do: [:ex | ex resume: true]. - self declareAndPossiblyRename: classThatIsARoot. nameOnArrival == classThatIsARoot name ifTrue: [^self]. renamedClasses ifNil: [RecentlyRenamedClasses := renamedClasses := Dictionary new]. renamedClasses at: nameOnArrival put: classThatIsARoot name. ! Item was changed: + ----- Method: ImageSegment>>declareAndPossiblyRename: (in category 'fileIn') ----- - ----- Method: ImageSegment>>declareAndPossiblyRename: (in category 'fileIn/Out') ----- 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: Object categoryForUniclasses]]. ]. 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. ! Item was removed: - ----- Method: ImageSegment>>deepCopyTest: (in category 'testing') ----- - deepCopyTest: aRootArray - "ImageSegment new deepCopyTest: Morph withAllSubclasses asArray" - "Project allInstances do: - [:p | p == Project current ifFalse: - [Transcript cr; cr; nextPutAll: p name. - ImageSegment new deepCopyTest: (Array with: p)]]." - | t1 t2 copy | - t1 := Time millisecondsToRun: [self copyFromRoots: aRootArray sizeHint: 0]. - t2 := Time millisecondsToRun: [copy := self segmentCopy]. - Transcript cr; print: segment size * 4; nextPutAll: ' bytes stored with '; - print: outPointers size; show: ' outpointers in '; print: t1; show: 'ms.'. - Transcript cr; nextPutAll: 'Reconstructed in '; print: t2; show: 'ms.'. - ^ copy - " - Smalltalk allClasses do: - [:m | ImageSegment new deepCopyTest: (Array with: m with: m class)] - "! Item was changed: + ----- Method: ImageSegment>>dependentsCancel: (in category 'fileIn') ----- - ----- Method: ImageSegment>>dependentsCancel: (in category 'read/write segment') ----- dependentsCancel: aProject "Erase the place we temporarily held the dependents of things in this project. So we don't carry them around forever." aProject projectParameters removeKey: #GlobalDependentsInProject ifAbsent: []! Item was changed: + ----- Method: ImageSegment>>dependentsRestore: (in category 'fileIn') ----- - ----- Method: ImageSegment>>dependentsRestore: (in category 'read/write segment') ----- dependentsRestore: aProject "Retrieve the list of dependents from the exporting system, hook them up, and erase the place we stored them." | dict | dict := aProject projectParameterAt: #GlobalDependentsInProject. dict ifNil: [^ self]. dict associationsDo: [:assoc | assoc value do: [:dd | assoc key addDependent: dd]]. self dependentsCancel: aProject.! Item was removed: - ----- Method: ImageSegment>>dependentsSave: (in category 'read/write segment') ----- - dependentsSave: dummy - "Object that have dependents are supposed to be instances of subclasses of Model. But, class Objects still provides 'Global Dependents', and some people still use them. When both the model and the dependent are in a project that is being saved, remember them, so we can hook them up when this project is loaded in." - - | dict proj | - proj := dummy project. - dict := Dictionary new. - DependentsFields associationsDo: [:assoc | | list | - (dummy references includesKey: assoc key) ifTrue: [ - list := assoc value select: [:dd | dummy references includesKey: dd]. - list size > 0 ifTrue: [dict at: assoc key put: list]]]. - - dict size > 0 ifTrue: [ - proj projectParameterAt: #GlobalDependentsInProject put: dict]. - ! Item was removed: - ----- Method: ImageSegment>>doSpaceAnalysis (in category 'statistics') ----- - doSpaceAnalysis - "Capture statistics about the IS and print the number of instances per class and space usage" - | index sz word hdrBits cc instCount instSpace | - state == #activeCopy ifFalse:[self errorWrongState]. - instCount := IdentityDictionary new. - instSpace := IdentityDictionary new. - index := 2. "skip version word, first object" - "go past extra header words" - hdrBits := (segment at: index) bitAnd: 3. - hdrBits = 1 ifTrue: [index := index+1]. - hdrBits = 0 ifTrue: [index := index+2]. - [index > segment size] whileFalse:[ - hdrBits := (word := segment at: index) bitAnd: 3. - hdrBits = 2 ifTrue:[sz := word bitAnd: 16rFFFFFFFC]. - hdrBits = 0 ifTrue:[sz := ((segment at: index-2) bitAnd: 16rFFFFFFFC) + 8]. - hdrBits = 1 ifTrue:[sz := (word bitAnd: "SizeMask" 252) + 4]. - hdrBits = 3 ifTrue:[sz := word bitAnd: "SizeMask" 252]. - hdrBits = 2 - ifTrue:[cc := #freeChunk] - ifFalse:[cc := self classNameAt: index]. - instCount at: cc put: (instCount at: cc ifAbsent:[0]) + 1. - instSpace at: cc put: (instSpace at: cc ifAbsent:[0]) + sz. - index := self objectAfter: index]. - ^{instCount. instSpace}! Item was removed: - ----- Method: ImageSegment>>endianness (in category 'fileIn/Out') ----- - endianness - "Return which endian kind the incoming segment came from" - - segment class isBits ifFalse: - ["Hope that primitive 98 did the right thing - anyway, we lost information about endianness, so pretend we share the image's endianness." - ^Smalltalk endianness]. - ^(segment first bitShift: -24) asCharacter == $d ifTrue: [#big] ifFalse: [#little]! Item was removed: - ----- Method: ImageSegment>>errorWrongState (in category 'testing') ----- - errorWrongState - - ^ self error: 'wrong state'! Item was removed: - ----- Method: ImageSegment>>extract (in category 'read/write segment') ----- - extract - "This operation replaces (using become:) all the original roots of a segment with segmentRootStubs. Thus the original objects will be reclaimed, and the root stubs will remain to bring the segment back in if it is needed." - - Cursor write showWhile: [ - state = #inactive ifTrue: [self copyFromRoots: arrayOfRoots sizeHint: 0]. - state = #activeCopy ifFalse: [self errorWrongState]. - arrayOfRoots elementsForwardIdentityTo: - (arrayOfRoots collect: [:r | r rootStubInImageSegment: self]). - state := #active]. - ! Item was removed: - ----- Method: ImageSegment>>extractThenInstall (in category 'read/write segment') ----- - extractThenInstall - "For testing only" - - | newRoots | - state = #activeCopy ifFalse: [self errorWrongState]. - arrayOfRoots elementsForwardIdentityTo: - (arrayOfRoots collect: [:r | r rootStubInImageSegment: self]). - state := #active. - newRoots := self loadSegmentFrom: segment outPointers: outPointers. - state := #inactive. - arrayOfRoots elementsForwardIdentityTo: newRoots. - ! Item was removed: - ----- Method: ImageSegment>>findInOut: (in category 'testing') ----- - findInOut: anArray - "Take an array of references to a morph, and try to classify them: in the segment, in outPointers, or other." - - String streamContents: [:strm | - anArray withIndexDo: [:obj :ind | - strm cr; nextPutAll: obj printString; space. - - ]].! Item was removed: - ----- Method: ImageSegment>>findOwnerMap: (in category 'testing') ----- - findOwnerMap: morphs - | st | - "Construct a string that has a printout of the owner chain for every morph in the list. Need it as a string so not hold onto them." - - st := ''. - morphs do: [:mm | - (st includesSubstring: mm printString) ifFalse: [ - st := st, ' - ', mm allOwners printString]]. - Smalltalk at: #Owners put: st. - ! Item was removed: - ----- Method: ImageSegment>>findOwnersOutPtrs (in category 'testing') ----- - findOwnersOutPtrs - - | ow ff | - ow := Smalltalk at: #Owners ifAbsent: [^ self]. - ow ifNil: [^ self]. - outPointers do: [:oo | - oo isMorph ifTrue: [ - ow := ow copyReplaceAll: oo printString with: oo printString, '[<<<- Pointed at]']]. - ff := FileStream fileNamed: 'Owners log'. - ff nextPutAll: ow; close. - Smalltalk at: #Owners put: ow. - ff edit.! Item was removed: - ----- Method: ImageSegment>>findRogueRootsAllMorphs: (in category 'testing') ----- - findRogueRootsAllMorphs: 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 should be in seg: morph tree, presenter, scripts, player classes, metaclasses. 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." - - | inSeg testRoots scriptEditors pointIn wld xRoots | - Smalltalk garbageCollect. - inSeg := IdentitySet new: 200. - arrayOfRoots := rootArray. - (testRoots := self rootsIncludingPlayers) ifNil: [testRoots := rootArray]. - testRoots do: - [:obj | - (obj isKindOf: Project) - ifTrue: - [inSeg add: obj. - wld := obj world. - inSeg add: wld presenter]. - (obj isKindOf: Presenter) ifTrue: [inSeg add: obj]]. - xRoots := wld ifNil: [testRoots] ifNotNil: [testRoots , (Array with: wld)]. - xRoots do: - [:obj | - "root is a project" - - obj isMorph - ifTrue: - [obj allMorphs do: - [:mm | - inSeg add: mm. - mm player ifNotNil: [inSeg add: mm player]]. - obj isWorldMorph ifTrue: [inSeg add: obj presenter]]]. - scriptEditors := IdentitySet new. - inSeg do: - [:obj | - obj isPlayerLike - ifTrue: - [scriptEditors addAll: (obj class tileScriptNames - collect: [:nn | obj scriptEditorFor: nn])]]. - scriptEditors do: [:se | inSeg addAll: se allMorphs]. - testRoots do: [:each | inSeg remove: each ifAbsent: []]. - "want them to be pointed at from outside" - pointIn := IdentitySet new: 400. - inSeg do: [:ob | pointIn addAll: (Utilities pointersTo: ob except: inSeg)]. - testRoots do: [:each | pointIn remove: each ifAbsent: []]. - pointIn remove: inSeg array ifAbsent: []. - pointIn remove: pointIn array ifAbsent: []. - inSeg do: - [:obj | - obj isMorph - ifTrue: - [pointIn remove: (obj instVarAt: 3) - ifAbsent: - ["submorphs" - - ]. - "associations in extension" - pointIn remove: obj extension ifAbsent: []. - obj extension ifNotNil: - [obj extension otherProperties ifNotNil: - [obj extension otherProperties associationsDo: - [:ass | - pointIn remove: ass ifAbsent: [] - "*** and extension actorState" - "*** and ActorState instantiatedUserScriptsDictionary ScriptInstantiations"]]]]. - obj isPlayerLike - ifTrue: [obj class scripts values do: [:us | pointIn remove: us ifAbsent: []]]]. - "*** presenter playerlist" - self halt: 'Examine local variables pointIn and inSeg'. - ^pointIn! Item was removed: - ----- Method: ImageSegment>>findRogueRootsImSeg: (in category 'testing') ----- - findRogueRootsImSeg: 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) Break all owner pointers in submorphs and all scripts. - 2) Create the segment and look at outPointers. - 3) Remove those we expect. - 4) Remember to quit without saving -- the owner pointers are smashed." - - | newRoots suspects bag1 bag2 | - arrayOfRoots := rootArray. - [(newRoots := self rootsIncludingPlayers) == nil] whileFalse: [ - arrayOfRoots := newRoots]. "world, presenter, and all Player classes" - self findRogueRootsPrep. "and free that context!!" - Smalltalk garbageCollect. - self copyFromRoots: arrayOfRoots sizeHint: 0. - - suspects := outPointers select: [:oo | oo isMorph]. - suspects size > 0 ifTrue: [suspects inspect]. - bag1 := Bag new. bag2 := Bag new. - outPointers do: [:key | - (key isKindOf: Class) - ifTrue: [bag2 add: key class name] - ifFalse: [(#(Symbol Point Rectangle True False String Float Color Form ColorForm StrikeFont Metaclass UndefinedObject TranslucentColor) includes: key class name) - ifTrue: [bag2 add: key class name] - ifFalse: [bag1 add: key class name]]]. - "(bag sortedCounts) is the SortedCollection" - (StringHolder new contents: bag1 sortedCounts printString, ' - - ', bag2 sortedCounts printString) - openLabel: 'Objects pointed at by the outside'. - self halt: 'Examine local variables pointIn and inSeg'. - - "Use this in inspectors: - outPointers select: [:oo | oo class == <a Class>]. " - - ! Item was removed: - ----- Method: ImageSegment>>findRogueRootsPrep (in category 'testing') ----- - findRogueRootsPrep - "Part of the tool to track down unwanted pointers into the segment. Break all owner pointers in submorphs, scripts, and viewers in flaps." - - | wld players morphs | - wld := arrayOfRoots detect: [:obj | - obj isMorph ifTrue: [obj isWorldMorph] ifFalse: [false]] ifNone: [nil]. - wld ifNil: [wld := arrayOfRoots detect: [:obj | obj isMorph] - ifNone: [^ self error: 'can''t find a root morph']]. - morphs := IdentitySet new: 400. - wld allMorphsAndBookPagesInto: morphs. - players := wld presenter allExtantPlayers. "just the cached list" - players do: [:pp | | scriptEditors | - scriptEditors := pp class tileScriptNames collect: [:nn | - pp scriptEditorFor: nn]. - scriptEditors do: [:se | morphs addAll: se allMorphs]]. - wld submorphs do: [:mm | "non showing flaps" - (mm isKindOf: FlapTab) ifTrue: [ - mm referent allMorphsAndBookPagesInto: morphs]]. - morphs do: [:mm | "break the back pointers" - mm isInMemory ifTrue: [ - (mm respondsTo: #target) ifTrue: [ - mm nearestOwnerThat: [:ow | ow == mm target - ifTrue: [mm target: nil. true] - ifFalse: [false]]]. - (mm respondsTo: #arguments) ifTrue: [ - mm arguments do: [:arg | arg ifNotNil: [ - mm nearestOwnerThat: [:ow | ow == arg - ifTrue: [mm arguments at: (mm arguments indexOf: arg) put: nil. true] - ifFalse: [false]]]]]. - mm eventHandler ifNotNil: ["recipients point back up" - (morphs includesAllOf: (mm eventHandler allRecipients)) ifTrue: [ - mm eventHandler: nil]]. - "temporary, until using Model for PartsBin" - (mm isMorphicModel) ifTrue: [ - (mm model isMorphicModel) ifTrue: [ - mm model breakDependents]]. - (mm isTextMorph) ifTrue: [mm setContainer: nil]]]. - (Smalltalk includesKey: #Owners) ifTrue: [Smalltalk at: #Owners put: nil]. - "in case findOwnerMap: is commented out" - "self findOwnerMap: morphs." - morphs do: [:mm | "break the back pointers" - mm isInMemory ifTrue: [mm privateOwner: nil]]. - "more in extensions?" - - ! Item was removed: - ----- 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." - - | goodInSeg inSeg pointIn dummy | - 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. - 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 | - 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 removed: - ----- 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! Item was changed: + ----- Method: ImageSegment>>fixCapitalizationOfSymbols (in category 'fileIn') ----- - ----- Method: ImageSegment>>fixCapitalizationOfSymbols (in category 'fileIn/Out') ----- fixCapitalizationOfSymbols "MultiString>>capitalized was not implemented correctly. Fix eventual accessors and mutators here." | sym ms | 1 to: outPointers size do:[:i| sym := outPointers at: i. (sym class == WideSymbol and:[sym size > 3]) ifTrue:[ ((sym beginsWith: 'get') and:[(sym at: 4) asInteger < 256 and:[(sym at: 4) isLowercase]]) ifTrue:[ ms := sym asString. ms at: 4 put: (ms at: 4) asUppercase. ms := ms asSymbol. sym becomeForward: ms. ]. ((sym beginsWith: 'set') and:[(sym at: 4) asInteger < 256 and:[(sym at: 4) isLowercase and:[sym last = $: and:[(sym occurrencesOf: $:) = 1]]]]) ifTrue:[ ms := sym asString. ms at: 4 put: (ms at: 4) asUppercase. ms := ms asSymbol. sym becomeForward: ms. ]. outPointers at: i put: sym. ]. ].! Item was removed: - ----- Method: ImageSegment>>ifOutPointer:thenAllObjectsDo: (in category 'instance change shape') ----- - ifOutPointer: anObject thenAllObjectsDo: aBlock - | withSymbols segSize | - "If I point out to anObject, bring me in, Submit all my objects to the block. Write me out again." - - (state = #onFile or: [state = #onFileWithSymbols]) ifFalse: [^ self]. - withSymbols := state = #onFileWithSymbols. - (outPointers includes: anObject) ifFalse: [^ self]. - state = #onFile ifTrue: [Cursor read showWhile: [self readFromFile]]. - segSize := segment size. - self install. - self allObjectsDo: aBlock. "do the work" - self copyFromRoots: arrayOfRoots sizeHint: segSize. - self extract. - withSymbols - ifTrue: [self writeToFileWithSymbols] - ifFalse: [self writeToFile]. - - ! Item was removed: - ----- Method: ImageSegment>>install (in category 'read/write segment') ----- - install - "This operation retrieves the segment if necessary from file storage, installs it in memory, and replaces (using become:) all the root stubs with the reconstructed roots of the segment." - - | newRoots | - state = #onFile ifTrue: [self readFromFile]. - state = #onFileWithSymbols ifTrue: - [self readFromFileWithSymbols]. - (state = #active) | (state = #imported) ifFalse: [self errorWrongState]. - newRoots := self loadSegmentFrom: segment outPointers: outPointers. - self checkAndReportLoadError. - state = #imported - ifTrue: ["just came in from exported file" - arrayOfRoots := newRoots] - ifFalse: [ - arrayOfRoots elementsForwardIdentityTo: newRoots]. - state := #inactive. - Beeper beepPrimitive! Item was removed: - ----- Method: ImageSegment>>isOnFile (in category 'testing') ----- - isOnFile - ^ state == #onFile! Item was removed: - ----- Method: ImageSegment>>loadSegmentFrom:outPointers: (in category 'primitives') ----- - loadSegmentFrom: segmentWordArray outPointers: outPointerArray - "This primitive will install a binary image segment and return as its value the array - of roots of the tree of objects represented. Upon successful completion, the - wordArray will have been becomed into anArray of the loaded objects. If this - primitive should fail, it will have destroyed the contents of the segment wordArray." - - <primitive: 99 error: ec> "successful completion returns the array of roots" - ^nil "failure returns nil"! Item was removed: - ----- Method: ImageSegment>>localName (in category 'read/write segment') ----- - localName - | segs ind sep | - "Return the current file name for this segment, a local name in the segments directory." - - fileName ifNil: [^ nil]. - "^ fileName" - - "The following is for backward compatibility. Remove this part after June 2000. - Check if the fileName is a full path, and make it local. Regardless of current or previous file system delimiter." - - segs := self class folder copyLast: 4. ":=segs" - ind := 1. - [ind := fileName findString: segs startingAt: ind+1 caseSensitive: false. - ind = 0 ifTrue: [^ fileName]. - sep := fileName at: ind + (segs size). - sep isAlphaNumeric ] whileTrue. "sep is letter or digit, not a separator" - - ^ fileName := fileName copyFrom: ind+(segs size)+1 "delimiter" to: fileName size! Item was removed: - ----- Method: ImageSegment>>objectAfter: (in category 'compact classes') ----- - objectAfter: ind - "Return the object or free chunk immediately following the given object or free chunk in the segment. *** Warning: When class ObjectMemory change, be sure to change it here. ***" - - | sz word newInd hdrBits | - sz := ((word := segment at: ind "header") bitAnd: 3) = 2 "free block?" - ifTrue: [word bitAnd: 16rFFFFFFFC] - ifFalse: [(word bitAnd: 3) = 0 "HeaderTypeSizeAndClass" - ifTrue: [(segment at: ind-2) bitAnd: 16rFFFFFFFC] - ifFalse: [word bitAnd: "SizeMask" 252]]. - - newInd := ind + (sz>>2). - "adjust past extra header words" - (hdrBits := (segment atPin: newInd) bitAnd: 3) = 3 ifTrue: [^ newInd]. - "If at end, header word will be garbage. This is OK" - hdrBits = 1 ifTrue: [^ newInd+1]. - hdrBits = 0 ifTrue: [^ newInd+2]. - ^ newInd "free"! Item was removed: - ----- Method: ImageSegment>>originalRoots (in category 'access') ----- - originalRoots - "Return only the roots that the user submitted, not the ones we had to add." - - userRootCnt ifNil: [^ arrayOfRoots]. - ^ arrayOfRoots copyFrom: 1 to: userRootCnt! Item was removed: - ----- Method: ImageSegment>>outPointers (in category 'access') ----- - outPointers - ^ outPointers! Item was removed: - ----- Method: ImageSegment>>prepareToBeSaved (in category 'fileIn/Out') ----- - prepareToBeSaved - "Prepare objects in outPointers to be written on the disk. They must be able to match up with existing objects in their new system. outPointers is already a copy. - Classes are already converted to a DiskProxy. - Associations in outPointers: - 1) in Smalltalk. - 2) in a classPool. - 3) in a shared pool. - 4) A pool dict pointed at directly" - - | left myClasses outIndexes | - self flag: #environments. - myClasses := Set new. - arrayOfRoots do: [:aRoot | aRoot class class == Metaclass ifTrue: [myClasses add: aRoot]]. - outIndexes := IdentityDictionary new. - outPointers withIndexDo: [:anOut :ind | | key | - anOut isVariableBinding ifTrue: [ - (myClasses includes: anOut value) - ifFalse: [outIndexes at: anOut put: ind] - ifTrue: [(Smalltalk globals associationAt: anOut key ifAbsent: [3]) == anOut - ifTrue: [outPointers at: ind put: - (DiskProxy global: #Smalltalk selector: #associationDeclareAt: - args: (Array with: anOut key))] - ifFalse: [outIndexes at: anOut put: ind] - ]]. - (anOut isKindOf: Dictionary) ifTrue: ["Pools pointed at directly" - (key := Smalltalk globals keyAtIdentityValue: anOut ifAbsent: [nil]) ifNotNil: [ - outPointers at: ind put: - (DiskProxy global: key selector: #yourself args: #())]]. - anOut isMorph ifTrue: [outPointers at: ind put: - (StringMorph contents: anOut printString, ' that was not counted')] - ]. - left := outIndexes keys asSet. - left size > 0 ifTrue: ["Globals" - (left copy) do: [:assoc | "stay stable while delete items" - (Smalltalk globals associationAt: assoc key ifAbsent: [3]) == assoc ifTrue: [ - outPointers at: (outIndexes at: assoc) put: - (DiskProxy global: #Smalltalk selector: #associationAt: - args: (Array with: assoc key)). - left remove: assoc]]]. - left size > 0 ifTrue: ["Class variables" - Smalltalk allClassesDo: [:cls | cls classPool size > 0 ifTrue: [ - (left copy) do: [:assoc | "stay stable while delete items" - (cls classPool associationAt: assoc key ifAbsent: [3]) == assoc ifTrue: [ - outPointers at: (outIndexes at: assoc) put: - (DiskProxy new global: cls name - preSelector: #classPool - selector: #associationAt: - args: (Array with: assoc key)). - left remove: assoc]]]]]. - left size > 0 ifTrue: ["Pool variables" - Smalltalk globals associationsDo: [:poolAssoc | | pool | - poolAssoc value class == Dictionary ifTrue: ["a pool" - pool := poolAssoc value. - (left copy) do: [:assoc | "stay stable while delete items" - (pool associationAt: assoc key ifAbsent: [3]) == assoc ifTrue: [ - outPointers at: (outIndexes at: assoc) put: - (DiskProxy global: poolAssoc key selector: #associationAt: - args: (Array with: assoc key)). - left remove: assoc]]]]]. - left size > 0 ifTrue: [ - "If points to class in arrayOfRoots, must deal with it separately" - "OK to have obsolete associations that just get moved to the new system" - self inform: 'extra associations'. - left inspect]. - ! Item was removed: - ----- Method: ImageSegment>>printSpaceAnalysisOn: (in category 'statistics') ----- - printSpaceAnalysisOn: aStream - "Capture statistics about the IS and print the number of instances per class and space usage" - | instCount instSpace sorted sum1 sum2 | - instCount := self doSpaceAnalysis. - instSpace := instCount last. - instCount := instCount first. - sorted := SortedCollection sortBlock:[:a1 :a2| a1 value >= a2 value]. - instSpace associationsDo:[:a| sorted add: a]. - sorted do:[:assoc| - aStream cr; nextPutAll: assoc key; tab. - aStream print: (instCount at: assoc key); nextPutAll:' instances '. - aStream print: assoc value; nextPutAll: ' bytes '. - ]. - sum1 := instCount inject: 0 into:[:sum :n| sum + n]. - sum2 := instSpace inject: 0 into:[:sum :n| sum + n]. - aStream cr; cr. - aStream print: sum1; nextPutAll:' instances '. - aStream print: sum2; nextPutAll: ' bytes '. - ! Item was removed: - ----- Method: ImageSegment>>readFromFile (in category 'read/write segment') ----- - readFromFile - "Read in a simple segment. Use folder of this image, even if remembered as previous location of this image" - - | ff realName | - realName := self class folder, FileDirectory slash, self localName. - ff := FileStream readOnlyFileNamed: realName. - segment := ff nextWordsInto: (WordArrayForSegment new: ff size//4). - ff close. - state := #active! Item was added: + ----- Method: ImageSegment>>rehashDictionaries: (in category 'fileIn') ----- + rehashDictionaries: aCollection + ProgressInitiationException + display: 'Rehash objects...' + during: [:bar | 1 + to: aCollection size + do: [:i | + (aCollection at: i) rehash. + i \\ 10 = 0 + ifTrue: [bar value: i / aCollection size]]]! Item was removed: - ----- Method: ImageSegment>>rehashSets (in category 'fileIn/Out') ----- - rehashSets - "I have just been brought in and converted to live objects. Find all Sets and Dictionaries in the newly created objects and rehash them. Segment is near then end of memory, since is was newly brought in (and a new object created for it). - Also, collect all classes of receivers of blocks. Return them. Caller will check if they have been reshaped." - - | hashedCollections receiverClasses | - hashedCollections := OrderedCollection new. - "have to collect them, because Dictionary makes a copy, and that winds up at the end of memory and gets rehashed and makes another one." - receiverClasses := IdentitySet new. - self allObjectsDo: - [:object| - object isInMemory ifTrue: - [(object isCollection and: [object isKindOf: HashedCollection]) ifTrue: - [hashedCollections add: object]. - (object isBlock or: [object isContext]) ifTrue: - [receiverClasses add: object receiver class]]]. - hashedCollections do: [ :each | each compact ]. "our purpose" - ^receiverClasses "our secondary job"! Item was changed: + ----- Method: ImageSegment>>reshapeClasses:refStream: (in category 'fileIn') ----- - ----- Method: ImageSegment>>reshapeClasses:refStream: (in category 'fileIn/Out') ----- reshapeClasses: mapFakeClassesToReal refStream: smartRefStream | bads allVarMaps partials in out perfect | self flag: #bobconv. partials := OrderedCollection new. bads := OrderedCollection new. allVarMaps := IdentityDictionary new. mapFakeClassesToReal keysAndValuesDo: [ :aFakeClass :theRealClass | aFakeClass allInstances do: [ :misShapen | perfect := smartRefStream convert1: misShapen to: theRealClass allVarMaps: allVarMaps. bads detect: [ :x | x == misShapen] ifNone: [ bads add: misShapen. partials add: perfect ]. ]. ]. bads isEmpty ifFalse: [ bads asArray elementsForwardIdentityTo: partials asArray ]. in := OrderedCollection new. out := OrderedCollection new. partials do: [ :each | perfect := smartRefStream convert2: each allVarMaps: allVarMaps. in detect: [ :x | x == each] ifNone: [ in add: each. out add: perfect ] ]. in isEmpty ifFalse: [ in asArray elementsForwardIdentityTo: out asArray ]. ! Item was removed: - ----- Method: ImageSegment>>restoreEndianness (in category 'fileIn/Out') ----- - restoreEndianness - ^self restoreEndianness: self endianness ~~ Smalltalk endianness! Item was changed: + ----- Method: ImageSegment>>restoreEndianness: (in category 'fileIn') ----- - ----- Method: ImageSegment>>restoreEndianness: (in category 'fileIn/Out') ----- restoreEndianness: endiannessHasToBeFixed + "If endiannessHasToBeFixed, then fix endianness (byte order) of any objects not already fixed. Do this by discovering classes that need a startUp message sent to each instance, and sending it. - "If endiannessHasToBeFixed, then fix endianness (byte order) of any objects not already fixed. Do this by discovering classes that need a startUp message sent to each instance, and sending it.. I have just been brought in and converted to live objects. Find all Sets and Dictionaries in the newly created objects and rehash them. Segment is near then end of memory, since is was newly brought in (and a new object created for it). Also, collect all classes of receivers of blocks which refer to instance variables. Return them. Caller will check if they have been reshaped." + | sets receiverClasses noStartUpNeeded startUps cls msg | + sets := OrderedCollection new. + "have to collect them, because Dictionary makes a copy, and that winds up at the end of memory and gets rehashed and makes another one." - | hashedCollections receiverClasses noStartUpNeeded startUps | - - hashedCollections := OrderedCollection new. receiverClasses := IdentitySet new. noStartUpNeeded := IdentitySet new. "classes that don't have a per-instance startUp message" startUps := IdentityDictionary new. "class -> MessageSend of a startUp message" + self allObjectsDo: [:object | + object isInMemory ifTrue: [ + (object isKindOf: HashedCollection) ifTrue: [sets add: object]. + ((object isKindOf: ContextPart) and: [object hasInstVarRef]) ifTrue: [ + receiverClasses add: object receiver class]. + (noStartUpNeeded includes: object class) ifFalse: [ + cls := object class. + (msg := startUps at: cls ifAbsent: [nil]) ifNil: [ + msg := cls startUpFrom: endiannessHasToBeFixed. "a Message, if we need to swap bytes this time" + msg ifNil: [noStartUpNeeded add: cls] - self allObjectsDo: - [:object| | cls msg | - object isInMemory ifTrue: - [(object isCollection and: [object isKindOf: HashedCollection]) ifTrue: - [hashedCollections add: object]. - (object isContext and: [object hasInstVarRef]) ifTrue: - [receiverClasses add: object receiver class]]. - (noStartUpNeeded includes: object class) ifFalse: - [cls := object class. - (msg := startUps at: cls ifAbsent: nil) ifNil: - [msg := cls startUpFrom: endiannessHasToBeFixed. "a Message, if we need to swap bytes this time" - msg ifNil: [noStartUpNeeded add: cls] ifNotNil: [startUps at: cls put: msg]]. + msg ifNotNil: [msg sentTo: object]]]]. + self rehashDictionaries: sets. "our purpose" + ^ receiverClasses "our secondary job" + ! - msg ifNotNil: [msg sentTo: object]]]. - hashedCollections do: [ :each | each compact ]. "our purpose" - ^ receiverClasses "our secondary job"! Item was removed: - ----- Method: ImageSegment>>revert (in category 'read/write segment') ----- - revert - "Pretend this segment was never brought in. Check that it has a fileName. Replace (using become:) all the original roots of a segment with segmentRootStubs. Thus the original objects will be reclaimed, and the root stubs will remain to bring the segment back in if it is needed. - How to use revert: In the project, choose 'save for reverting'. - - ReEnter the project. Make changes. - Either exit normally, and change will be kept, or - Choose 'Revert to saved version'." - - fileName ifNil: [^ self]. - (state = #inactive) | (state = #onFile) ifFalse: [^ self]. - Cursor write showWhile: [ - arrayOfRoots elementsForwardIdentityTo: - (arrayOfRoots collect: [:r | r rootStubInImageSegment: self]). - state := #onFile. - segment := nil] - - "Old version: - How to use revert: In the project, execute - (Project current projectParameters at: #frozen put: true) - Leave the project. Check that the project went out to disk (it is gray in the Jump to Project list). - ReEnter the project. Hear a plink as it comes in from disk. Make a change. - Exit the project. Choose 'Revert to previous version' in the dialog box. - Check that the project went out to disk (it is gray in the Jump to Project list). - ReEnter the project and see that it is in the original state."! Item was removed: - ----- Method: ImageSegment>>rootsIncludingBlockMethods (in category 'read/write segment') ----- - rootsIncludingBlockMethods - "Return a new roots array with more objects. (Caller should store into rootArray.) Any CompiledMethods that create blocks will be in outPointers if the block is held outside of this segment. Put such methods into the roots list. Then ask for the segment again." - - | myClasses extras | - userRootCnt ifNil: [userRootCnt := arrayOfRoots size]. - extras := OrderedCollection new. - myClasses := OrderedCollection new. - arrayOfRoots do: [:aRoot | aRoot class class == Metaclass ifTrue: [ - myClasses add: aRoot]]. - myClasses isEmpty ifTrue: [^ nil]. "no change" - outPointers do: [:anOut | | gotIt | - anOut class == CompiledMethod ifTrue: [ - "specialized version of who" - gotIt := false. - myClasses detect: [:class | - class methodsDo: [:m | - m == anOut - ifTrue: [extras add: anOut. gotIt := true]]. - gotIt] - ifNone: [] - ]. - ]. - extras := extras select: [:ea | (arrayOfRoots includes: ea) not]. - extras isEmpty ifTrue: [^ nil]. "no change" - ^ arrayOfRoots, extras! Item was removed: - ----- Method: ImageSegment>>rootsIncludingBlocks (in category 'read/write segment') ----- - rootsIncludingBlocks - "For export segments only. Return a new roots array with more objects. (Caller should store into rootArray.) Collect Blocks and external methods pointed to by them. Put them into the roots list. Then ask for the segment again." - - | extras have | - userRootCnt ifNil: [userRootCnt := arrayOfRoots size]. - extras := OrderedCollection new. - outPointers do: [:anOut | - anOut class == CompiledMethod ifTrue: [extras add: anOut]. - (anOut isBlock) ifTrue: [extras add: anOut]. - (anOut class == MethodContext) ifTrue: [extras add: anOut]]. - - [have := extras size. - extras copy do: [:anOut | - anOut isBlock ifTrue: [ - anOut home ifNotNil: [ - (extras includes: anOut home) ifFalse: [extras add: anOut home]]]. - (anOut class == MethodContext) ifTrue: [ - anOut method ifNotNil: [ - (extras includes: anOut method) ifFalse: [extras add: anOut method]]]]. - have = extras size] whileFalse. - extras := extras select: [:ea | (arrayOfRoots includes: ea) not]. - extras isEmpty ifTrue: [^ nil]. "no change" - - ^ arrayOfRoots, extras! Item was removed: - ----- Method: ImageSegment>>rootsIncludingPlayers (in category 'read/write segment') ----- - rootsIncludingPlayers - "Return a new roots array with more objects. (Caller should store into rootArray.) Player (non-systemDefined) gets its class and metaclass put into the Roots array. Then ask for the segment again." - - | extras havePresenter players morphs existing | - userRootCnt ifNil: [userRootCnt := arrayOfRoots size]. - extras := OrderedCollection new. - arrayOfRoots do: [:root | - (root isKindOf: Presenter) ifTrue: [havePresenter := root]. - (root isKindOf: PasteUpMorph) ifTrue: [ - root isWorldMorph ifTrue: [havePresenter := root presenter]]. - (root isKindOf: Project) ifTrue: [havePresenter := root world presenter]]. - havePresenter ifNotNil: [ - havePresenter flushPlayerListCache. "old and outside guys" - morphs := IdentitySet new: 400. - havePresenter associatedMorph allMorphsAndBookPagesInto: morphs. - players := (morphs select: [:m | m player ~~ nil] - thenCollect: [:m | m player]) asArray. - players := players select: [:ap | (arrayOfRoots includes: ap class) not - & (ap class isSystemDefined not)]. - extras addAll: (players collect: [:each | each class]). - extras addAll: (players collect: [:each | each class class]). - extras addAll: morphs. "Make then ALL roots!!" - ]. - existing := arrayOfRoots asIdentitySet. - extras := extras reject: [ :each | existing includes: each]. - extras isEmpty ifTrue: [^ nil]. "no change" - - havePresenter := players := morphs := nil. - ^ arrayOfRoots, extras "will contain multiples of some, but reduced later" - ! Item was removed: - ----- Method: ImageSegment>>savePlayerReferences: (in category 'read/write segment') ----- - savePlayerReferences: dictOfAllObjects - | save world | - "Save our associations we own in the shared References table. They will be installed when the segment is imported." - - save := OrderedCollection new. - References associationsDo: [:assoc | - (dictOfAllObjects includesKey: assoc) ifTrue: [save add: assoc]]. - 1 to: 5 do: [:ii | ((arrayOfRoots at: ii) respondsTo: #isCurrentProject) ifTrue: [ - world := (arrayOfRoots at: ii) world]]. - world setProperty: #References toValue: save. - "assume it is not refed from outside and will be traced"! Item was removed: - ----- Method: ImageSegment>>scanFrom: (in category 'fileIn/Out') ----- - scanFrom: aStream - "Move source code from a fileIn to the changes file for classes in an ImageSegment. Do not compile the methods. They already came in via the image segment. After the ImageSegment in the file, !!ImageSegment new!! captures control, and scanFrom: is called." - | val chunk | - - [aStream atEnd] whileFalse: - [aStream skipSeparators. - val := (aStream peekFor: $!!) - ifTrue: ["Move (aStream nextChunk), find the method or class - comment, and install the file location bytes" - (Compiler evaluate: aStream nextChunk logged: false) - scanFromNoCompile: aStream forSegment: self] - ifFalse: [chunk := aStream nextChunk. - aStream checkForPreamble: chunk. - Compiler evaluate: chunk logged: true]. - aStream skipStyleChunk]. - "regular fileIn will close the file" - ^ val! Item was removed: - ----- Method: ImageSegment>>scanFrom:environment: (in category 'fileIn/Out') ----- - scanFrom: aStream environment: anEnvironment - ^ self scanFrom: aStream! Item was removed: - ----- Method: ImageSegment>>segUpdateInstancesOf:toBe:isMeta: (in category 'instance change shape') ----- - segUpdateInstancesOf: oldClass toBe: newClass isMeta: isMeta - | withSymbols oldInstances segSize | - "Bring me in, locate instances of oldClass and get them converted. Write me out again." - - (state = #onFile or: [state = #onFileWithSymbols]) ifFalse: [^ self]. - withSymbols := state = #onFileWithSymbols. - "If has instances, they point out at the class" - (outPointers includes: oldClass) ifFalse: [ - oldClass == SmallInteger ifTrue: [^ self]. "instance not changable" - oldClass == Symbol ifTrue: [^ self]. "instance is never in a segment" - oldClass == ByteSymbol ifTrue: [^ self]. "instance is never in a segment" - (Smalltalk compactClassesArray includes: oldClass) ifFalse: [^ self]]. - "For a compact class, must search the segment. Instance does not - point outward to class" - state = #onFile ifTrue: [Cursor read showWhile: [self readFromFile]]. - segSize := segment size. - self install. - oldInstances := OrderedCollection new. - self allObjectsDo: [:obj | obj class == oldClass ifTrue: [ - oldInstances add: obj]]. - newClass updateInstances: oldInstances asArray from: oldClass isMeta: isMeta. - self copyFromRoots: arrayOfRoots sizeHint: segSize. - self extract. - withSymbols - ifTrue: [self writeToFileWithSymbols] - ifFalse: [self writeToFile]. - ! Item was removed: - ----- Method: ImageSegment>>segment (in category 'access') ----- - segment - ^ segment! Item was removed: - ----- Method: ImageSegment>>segmentCopy (in category 'read/write segment') ----- - segmentCopy - "This operation will install a copy of the segment in memory, and return a copy of the array of roots. The effect is to perform a deep copy of the original structure. Note that installation destroys the segment, so it must be copied before doing the operation." - - state = #activeCopy ifFalse: [self errorWrongState]. - ^ self loadSegmentFrom: segment copy outPointers: outPointers! Item was removed: - ----- Method: ImageSegment>>segmentName (in category 'read/write segment') ----- - segmentName - "Return the local file name for this segment." - - ^ segmentName! Item was removed: - ----- Method: ImageSegment>>segmentName: (in category 'read/write segment') ----- - segmentName: aString - "Local file name for this segment." - - segmentName := aString! Item was removed: - ----- 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" - (obj isSymbol) ifTrue: [refs removeKey: obj. known := known-1]. - (obj class == PasteUpMorph) ifTrue: [ - obj isWorldMorph & (obj owner == nil) ifTrue: [ - (dummy project ~~ nil and: [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 ifNotNil: [dummy project world] ifNil: [ActiveWorld]. - 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: []]. - self classOrganizersBeRoots: dummy. - ^ dummy rootObject, refs fasterKeys asArray.! Item was removed: - ----- Method: ImageSegment>>state (in category 'access') ----- - state - ^ state! Item was removed: - ----- Method: ImageSegment>>storeDataOn: (in category 'fileIn/Out') ----- - storeDataOn: aDataStream - "Don't wrote the array of Roots. Also remember the structures of the classes of objects inside the segment." - - | tempRoots tempOutP list | - state = #activeCopy ifFalse: [self error: 'wrong state']. - "real state is activeCopy, but we changed it will be right when coming in" - tempRoots := arrayOfRoots. - tempOutP := outPointers. - outPointers := outPointers clone. - self prepareToBeSaved. - arrayOfRoots := nil. - state := #imported. - super storeDataOn: aDataStream. "record my inst vars" - arrayOfRoots := tempRoots. - outPointers := tempOutP. - state := #activeCopy. - aDataStream references at: #AnImageSegment put: false. "the false is meaningless" - "This key in refs is the flag that there is an ImageSegment in this file." - - "Find the receivers of blocks in the segment. Need to get the structure of their classes into structures. Put the receivers into references." - (aDataStream byteStream isKindOf: DummyStream) ifTrue: [ - list := Set new. - arrayOfRoots do: [:ea | - ea isBlock | (ea class == MethodContext) ifTrue: [ - list add: ea receiver class ]]. - aDataStream references at: #BlockReceiverClasses put: list]. - ! Item was removed: - ----- Method: ImageSegment>>storeSegmentFor:into:outPointers: (in category 'primitives') ----- - storeSegmentFor: rootsArray into: segmentWordArray outPointers: outPointerArray - "This primitive will store a binary image segment (in the same format as the Squeak image file) of the receiver and every object in its proper tree of subParts (ie, that is not refered to from anywhere else outside the tree). Note: all elements of the reciever are treated as roots indetermining the extent of the tree. All pointers from within the tree to objects outside the tree will be copied into the array of outpointers. In their place in the image segment will be an oop equal to the offset in the outpointer array (the first would be 4). but with the high bit set." - - "The primitive expects the array and wordArray to be more than adequately long. In this case it returns normally, and truncates the two arrays to exactly the right size. If either array is too small, the primitive will fail, but in no other case." - - <primitive: 98> "successful completion returns self" - ^ nil "failure returns nil"! Item was removed: - ----- Method: ImageSegment>>verify:matches:knowing: (in category 'testing') ----- - verify: ob1 matches: ob2 knowing: matchDict - - | priorMatch first | - ob1 == ob2 ifTrue: - ["If two pointers are same, they must be immediates or in outPointers" - (ob1 class isImmediateClass and: [ob1 = ob2]) ifTrue: [^self]. - (outPointers includes: ob1) ifTrue: [^ self]. - self halt]. - priorMatch := matchDict at: ob1 ifAbsent: [nil]. - priorMatch == nil - ifTrue: [matchDict at: ob1 put: ob2] - ifFalse: [priorMatch == ob2 - ifTrue: [^ self] - ifFalse: [self halt]]. - self verify: ob1 class matches: ob2 class knowing: matchDict. - ob1 class isVariable ifTrue: - [ob1 basicSize = ob2 basicSize ifFalse: [self halt]. - first := 1. - ob1 isCompiledMethod ifTrue: [first := ob1 initialPC]. - first to: ob1 basicSize do: - [:i | self verify: (ob1 basicAt: i) matches: (ob2 basicAt: i) knowing: matchDict]]. - ob1 class instSize = ob2 class instSize ifFalse: [self halt]. - 1 to: ob1 class instSize do: - [:i | self verify: (ob1 instVarAt: i) matches: (ob2 instVarAt: i) knowing: matchDict]. - ob1 isCompiledMethod ifTrue: - [ob1 header = ob2 header ifFalse: [self halt]. - ob1 numLiterals = ob2 numLiterals ifFalse: [self halt]. - 1 to: ob1 numLiterals do: - [:i | self verify: (ob1 literalAt: i) matches: (ob2 literalAt: i) knowing: matchDict]]! Item was removed: - ----- Method: ImageSegment>>verifyCopy (in category 'testing') ----- - verifyCopy - - | copyOfRoots matchDict | - copyOfRoots := self segmentCopy. - matchDict := IdentityDictionary new. - arrayOfRoots with: copyOfRoots do: - [:r :c | self verify: r matches: c knowing: matchDict]! Item was removed: - ----- Method: ImageSegment>>writeForExport: (in category 'read/write segment') ----- - writeForExport: shortName - "Write the segment on the disk with all info needed to reconstruct it in a new image. For export. Out pointers are encoded as normal objects on the disk." - - | fileStream | - state = #activeCopy ifFalse: [self error: 'wrong state']. - fileStream := FileStream newFileNamed: (FileDirectory fileName: shortName extension: self class fileExtension). - fileStream fileOutClass: nil andObject: self. - "remember extra structures. Note class names."! Item was removed: - ----- Method: ImageSegment>>writeForExportWithSources:inDirectory: (in category 'read/write segment') ----- - writeForExportWithSources: fName inDirectory: aDirectory - "Write the segment on the disk with all info needed to reconstruct it in a new image. For export. Out pointers are encoded as normal objects on the disk. Append the source code of any classes in roots. Target system will quickly transfer the sources to its changes file." - - "this is the old version which I restored until I solve the gzip problem" - - | fileStream tempFileName zipper allClassesInRoots classesToWriteEntirely methodsWithSource | - state = #activeCopy ifFalse: [self error: 'wrong state']. - (fName includes: $.) ifFalse: [ - ^ self inform: 'Please use ''.pr'' or ''.extSeg'' at the end of the file name'.]. - tempFileName := aDirectory nextNameFor: 'SqProject' extension: 'temp'. - zipper := [ - ProgressNotification signal: '3:uncompressedSaveComplete'. - (aDirectory oldFileNamed: tempFileName) compressFile. "makes xxx.gz" - aDirectory - rename: (tempFileName, FileDirectory dot, 'gz') - toBe: fName. - aDirectory - deleteFileNamed: tempFileName - ifAbsent: [] - ]. - fileStream := aDirectory newFileNamed: tempFileName. - fileStream fileOutClass: nil andObject: self. - "remember extra structures. Note class names." - - "append sources" - allClassesInRoots := arrayOfRoots select: [:cls | cls isBehavior]. - classesToWriteEntirely := allClassesInRoots select: [ :cls | cls theNonMetaClass isSystemDefined]. - methodsWithSource := OrderedCollection new. - allClassesInRoots do: [ :cls | - (classesToWriteEntirely includes: cls) ifFalse: [ - cls selectorsAndMethodsDo: [ :sel :meth | - meth sourcePointer = 0 ifFalse: [methodsWithSource add: {cls. sel. meth}]. - ]. - ]. - ]. - (classesToWriteEntirely isEmpty and: [methodsWithSource isEmpty]) ifTrue: [zipper value. ^ self]. - - fileStream reopen; setToEnd. - fileStream nextPutAll: '\\!!ImageSegment new!!\\' withCRs. - methodsWithSource do: [ :each | - fileStream nextPut: $!!. "try to pacify ImageSegment>>scanFrom:" - fileStream nextChunkPut: 'RenamedClassSourceReader formerClassName: ', - each first name printString,' methodsFor: ', - (each first organization categoryOfElement: each second) asString printString, - ' stamp: ',(each third timeStamp) printString; cr. - fileStream nextChunkPut: (each third getSourceFor: each second in: each first) asString. - fileStream nextChunkPut: ' '; cr. - ]. - classesToWriteEntirely do: [:cls | - cls isMeta ifFalse: [fileStream nextPutAll: - (cls name, ' category: ''', cls category, '''.!!'); cr; cr]. - cls organization - putCommentOnFile: fileStream - numbered: 0 - moveSource: false - forClass: cls. "does nothing if metaclass" - cls organization categories do: - [:heading | - cls fileOutCategory: heading - on: fileStream - moveSource: false - toFile: 0]]. - "no class initialization -- it came in as a real object" - fileStream close. - zipper value! Item was removed: - ----- Method: ImageSegment>>writeForExportWithSources:inDirectory:changeSet: (in category 'read/write segment') ----- - writeForExportWithSources: fName inDirectory: aDirectory changeSet: - aChangeSetOrNil - "Write the segment on the disk with all info needed to - reconstruct it in a new image. For export. Out pointers are encoded - as normal objects on the disk. Append the source code of any classes - in roots. Target system will quickly transfer the sources to its - changes file." - "Files out a changeSet first, so that a project can contain - classes that are unique to the project." - - | fileStream tempFileName zipper allClassesInRoots classesToWriteEntirely methodsWithSource | - state = #activeCopy ifFalse: [self error: 'wrong state']. - (fName includes: $.) ifFalse: [ - ^ self inform: 'Please use ''.pr'' or ''.extSeg'' at - the end of the file name']. - tempFileName := aDirectory nextNameFor: 'SqProject' extension: 'temp'. - zipper := [ - Preferences debugPrintSpaceLog ifTrue:[ - fileStream := aDirectory newFileNamed: - (fName copyFrom: 1 to: (fName - lastIndexOf: $.)), 'space'. - self printSpaceAnalysisOn: fileStream. - fileStream close]. - ProgressNotification signal: '3:uncompressedSaveComplete'. - (aDirectory oldFileNamed: tempFileName) compressFile. - "makes xxx.gz" - aDirectory - rename: (tempFileName, FileDirectory dot, 'gz') - toBe: fName. - aDirectory - deleteFileNamed: tempFileName - ifAbsent: [] - ]. - fileStream := aDirectory newFileNamed: tempFileName. - fileStream fileOutChangeSet: aChangeSetOrNil andObject: self. - "remember extra structures. Note class names." - - "append sources" - allClassesInRoots := arrayOfRoots select: [:cls | cls isBehavior]. - classesToWriteEntirely := allClassesInRoots select: [ :cls | - cls theNonMetaClass isSystemDefined]. - methodsWithSource := OrderedCollection new. - allClassesInRoots do: [ :cls | - (classesToWriteEntirely includes: cls) ifFalse: [ - cls selectorsAndMethodsDo: [ :sel :meth | - meth sourcePointer = 0 ifFalse: - [methodsWithSource add: {cls. sel. meth}]. - ]. - ]. - ]. - (classesToWriteEntirely isEmpty and: [methodsWithSource isEmpty]) ifTrue: - [zipper value. ^ self]. - - fileStream reopen; setToEnd. - fileStream nextPutAll: '\\!!ImageSegment new!!\\' withCRs. - methodsWithSource do: [ :each | - fileStream nextPut: $!!. "try to pacify - ImageSegment>>scanFrom:" - fileStream nextChunkPut: 'RenamedClassSourceReader - formerClassName: ', - each first name printString,' methodsFor: ', - (each first organization - categoryOfElement: each second) asString printString, - ' stamp: ',(each third timeStamp) printString; cr. - fileStream nextChunkPut: (each third getSourceFor: - each second in: each first) asString. - fileStream nextChunkPut: ' '; cr. - ]. - classesToWriteEntirely do: [:cls | - cls isMeta ifFalse: [fileStream nextPutAll: - (cls name, ' - category: ''', cls category, '''.!!'); cr; cr]. - cls organization - putCommentOnFile: fileStream - numbered: 0 - moveSource: false - forClass: cls. "does nothing if metaclass" - cls organization categories do: - [:heading | - cls fileOutCategory: heading - on: fileStream - moveSource: false - toFile: 0]]. - "no class initialization -- it came in as a real object" - fileStream close. - zipper value - ! Item was removed: - ----- Method: ImageSegment>>writeForExportWithSourcesGZ:inDirectory: (in category 'read/write segment') ----- - writeForExportWithSourcesGZ: fName inDirectory: aDirectory - "Write the segment on the disk with all info needed to reconstruct it in a new image. For export. Out pointers are encoded as normal objects on the disk. Append the source code of any classes in roots. Target system will quickly transfer the sources to its changes file." - - "this is the gzipped version which I have temporarily suspended until I can get resolve the problem with forward references tring to reposition the stream - RAA 11 june 2000" - - - - - | fileStream allClassesInRoots classesToWriteEntirely methodsWithSource | - state = #activeCopy ifFalse: [self error: 'wrong state']. - (fName includes: $.) ifFalse: [ - ^ self inform: 'Please use ''.pr'' or ''.extSeg'' at the end of the file name'.]. - fileStream := GZipSurrogateStream newFileNamed: fName inDirectory: aDirectory. - fileStream fileOutClass: nil andObject: self. - "remember extra structures. Note class names." - - "append sources" - allClassesInRoots := arrayOfRoots select: [:cls | cls isBehavior]. - classesToWriteEntirely := allClassesInRoots select: [ :cls | cls theNonMetaClass isSystemDefined]. - methodsWithSource := OrderedCollection new. - allClassesInRoots do: [ :cls | - (classesToWriteEntirely includes: cls) ifFalse: [ - cls selectorsAndMethodsDo: [ :sel :meth | - meth sourcePointer = 0 ifFalse: [methodsWithSource add: {cls. sel. meth}]. - ]. - ]. - ]. - (classesToWriteEntirely isEmpty and: [methodsWithSource isEmpty]) ifTrue: [ - fileStream reallyClose. "since #close is ignored" - ^ self - ]. - "fileStream reopen; setToEnd." "<--not required with gzipped surrogate stream" - fileStream nextPutAll: '\\!!ImageSegment new!!\\' withCRs. - methodsWithSource do: [ :each | - fileStream nextPut: $!!. "try to pacify ImageSegment>>scanFrom:" - fileStream nextChunkPut: 'RenamedClassSourceReader formerClassName: ', - each first name printString,' methodsFor: ', - (each first organization categoryOfElement: each second) asString printString, - ' stamp: ',(each third timeStamp) printString; cr. - fileStream nextChunkPut: (each third getSourceFor: each second in: each first) asString. - fileStream nextChunkPut: ' '; cr. - ]. - classesToWriteEntirely do: [:cls | - cls isMeta ifFalse: [fileStream nextPutAll: - (cls name, ' category: ''', cls category, '''.!!'); cr; cr]. - cls organization - putCommentOnFile: fileStream - numbered: 0 - moveSource: false - forClass: cls. "does nothing if metaclass" - cls organization categories do: - [:heading | - cls fileOutCategory: heading - on: fileStream - moveSource: false - toFile: 0]]. - "no class initialization -- it came in as a real object" - fileStream reallyClose "since #close is ignored" - ! Item was removed: - ----- Method: ImageSegment>>writeToFile (in category 'read/write segment') ----- - writeToFile - - state = #active ifFalse: [self error: 'wrong state'. ^ self]. - Cursor write showWhile: [ - segmentName ifNil: [ - segmentName := (FileDirectory localNameFor: fileName) sansPeriodSuffix]. - "OK that still has number on end. This is an unusual case" - fileName := self class uniqueFileNameFor: segmentName. "local name" - (self class segmentDirectory newFileNamed: fileName) nextPutAll: segment; close. - segment := nil. - state := #onFile].! Item was removed: - ----- Method: ImageSegment>>writeToFile: (in category 'read/write segment') ----- - writeToFile: shortName - "The short name can't have any fileDelimiter characters in it. It is remembered in case the segment must be brought in and then sent out again (see ClassDescription updateInstancesFrom:)." - - segmentName := (shortName endsWith: '.seg') - ifTrue: [shortName copyFrom: 1 to: shortName size - 4] - ifFalse: [shortName]. - segmentName last isDigit ifTrue: [segmentName := segmentName, '-']. - self writeToFile.! Item was removed: - ----- Method: ImageSegment>>writeToFileWithSymbols (in category 'read/write segment') ----- - writeToFileWithSymbols - | symbols nonSymbols pound | - - state = #extracted ifFalse: [self error: 'wrong state']. - segmentName ifNil: [ - segmentName := (FileDirectory localNameFor: fileName) sansPeriodSuffix]. - "OK that still has number on end. This is an unusual case" - fileName := self class uniqueFileNameFor: segmentName. - symbols := OrderedCollection new. - nonSymbols := OrderedCollection new. - pound := '#' asSymbol. - outPointers do: - [:s | - ((s isSymbol) and: [s isLiteral and: [s ~~ pound]]) - ifTrue: [symbols addLast: s] - ifFalse: [symbols addLast: pound. nonSymbols addLast: s]]. - (self class segmentDirectory newFileNamed: fileName) - store: symbols asArray; cr; - nextPutAll: segment; close. - outPointers := nonSymbols asArray. - state := #onFileWithSymbols! Item was removed: - ----- Method: ImageSegment>>writeToFileWithSymbols: (in category 'read/write segment') ----- - writeToFileWithSymbols: shortName - - segmentName := (shortName endsWith: '.seg') - ifTrue: [shortName copyFrom: 1 to: shortName size - 4] - ifFalse: [shortName]. - segmentName last isDigit ifTrue: [segmentName := segmentName, '-']. - self writeToFileWithSymbols.! Item was added: + Object subclass: #ImageSegmentLoader + instanceVariableNames: 'segment outPointers oopMap position' + classVariableNames: 'BytesInHeader CompactClasses HeaderTypeClass HeaderTypeFree HeaderTypeMask HeaderTypeShort HeaderTypeSizeAndClass' + poolDictionaries: '' + category: 'System-Object Storage'! + + !ImageSegmentLoader commentStamp: 'bf 8/16/2016 18:16' prior: 0! + This class is used to load objects from an ImageSegment that is incompatible with the current VM (see ImageSegment>>loadSegmentFrom:outPointers:).! Item was added: + ----- Method: ImageSegmentLoader class>>initialize (in category 'class initialization') ----- + initialize + HeaderTypeMask := 3. + HeaderTypeSizeAndClass := 0. "3-word header" + HeaderTypeClass := 1. "2-word header" + HeaderTypeFree := 2. "free block" + HeaderTypeShort := 3. "1-word header" + BytesInHeader := { + HeaderTypeSizeAndClass -> 12. + HeaderTypeClass -> 8. + HeaderTypeShort -> 4. + } as: Dictionary. + "explicit list in case image has no/different compact classes" + CompactClasses := {CompiledMethod. nil. Array. nil. + LargePositiveInteger. Float. MethodDictionary. Association. + Point. Rectangle. ByteString. nil. + BlockContext. MethodContext. nil. Bitmap. + nil. nil. nil. nil. nil. nil. nil. nil. nil. nil. nil. nil. nil. nil. nil}. + ! Item was added: + ----- Method: ImageSegmentLoader>>allocateBlockContext: (in category 'allocating') ----- + allocateBlockContext: nWords + | homeOop methodOop method | + homeOop := self uint32At: position + 24. + methodOop := self uint32At: homeOop + 16. + method := self readObjectAt: methodOop. + ^BlockContext newForMethod: method.! Item was added: + ----- Method: ImageSegmentLoader>>allocateBytesObject:size: (in category 'allocating') ----- + allocateBytesObject: classOop size: nBytes + | class | + class := self fetchClass: classOop. + class isBytes ifFalse: + [self error: 'bytes class expected']. + ^class basicNew: nBytes! Item was added: + ----- Method: ImageSegmentLoader>>allocateCompiledMethod: (in category 'allocating') ----- + allocateCompiledMethod: nBytes + "CompiledMethods need special handling: + - the method header bits changed + - the primitive is now the first 3 bytecodes + - the trailer encoding changed, too + Here we calculate the new size needed after adding + the primitive byte codes, stripping the old trailer and + adding one byte for the NoTrailer code." + | header numLits bytecodes lastByte trailerBytes | + header := self mapOop: (self uint32At: position + 4). + header := self mapToSpurHeader: header. + numLits := header bitAnd: 16rFF. + bytecodes := nBytes - (1 + numLits * 4). "subtract header and literals" + lastByte := self uint8At: position + nBytes. + trailerBytes := lastByte = 0 ifTrue: "up to four 0 bytes" + [(self uint8At: position + nBytes - 1) = 0 ifFalse: [1] ifTrue: + [(self uint8At: position + nBytes - 2) = 0 ifFalse: [2] ifTrue: + [(self uint8At: position + nBytes - 3) = 0 ifFalse: [3] ifTrue: [4]]]] ifFalse: + [lastByte < 252 ifTrue: + [lastByte + 1 "Magic sources (tempnames encoded in last bytes)"] ifFalse: + [4 "Normal 4-byte source pointer"]]. + "subtract old trailer, add 1 byte for new trailer" + bytecodes := (bytecodes - trailerBytes max: 0) + 1. + "add 3 bytes for prim call" + (header bitAnd: 16r10000) > 0 ifTrue: [bytecodes := bytecodes + 3]. + ^CompiledMethod newMethod: bytecodes header: header! Item was added: + ----- Method: ImageSegmentLoader>>allocateFixedAndVariableObject:size: (in category 'allocating') ----- + allocateFixedAndVariableObject: classOop size: nWords + | class | + classOop = 13 ifTrue: + [^self allocateBlockContext: nWords]. + classOop = 14 ifTrue: + [^self allocateMethodContext: nWords]. + class := self fetchClass: classOop. + (class isPointers and: [class isVariable]) ifFalse: + [self error: 'variable pointers class expected']. + ^class basicNew: nWords - class instSize! Item was added: + ----- Method: ImageSegmentLoader>>allocateFixedSizeObject:size: (in category 'allocating') ----- + allocateFixedSizeObject: classOop size: nWords + | class | + class := self fetchClass: classOop. + (class isPointers and: [class isFixed]) ifFalse: + [self error: 'fixed pointers class expected']. + class instSize = nWords ifFalse: [self halt]. + ^class basicNew! Item was added: + ----- Method: ImageSegmentLoader>>allocateMethodContext: (in category 'allocating') ----- + allocateMethodContext: nWords + | methodOop method | + methodOop := self uint32At: position + 16. + method := self readObjectAt: methodOop. + ^MethodContext newForMethod: method.! Item was added: + ----- Method: ImageSegmentLoader>>allocateObject:class:size: (in category 'allocating') ----- + allocateObject: format class: class size: nWords + | nBytes | + format <= 1 ifTrue: + [^self allocateFixedSizeObject: class size: nWords]. + format = 2 ifTrue: + [^self allocateVariableSizeObject: class size: nWords]. + (format between: 3 and: 4) ifTrue: + [^self allocateFixedAndVariableObject: class size: nWords]. + format = 6 ifTrue: + [^self allocateWordsObject: class size: nWords]. + nBytes := (nWords * 4) - (format bitAnd: 3). + format >= 12 ifTrue: + [^self allocateCompiledMethod: nBytes]. + format >= 8 ifTrue: + [^self allocateBytesObject: class size: nBytes]. + self error: 'Unknown object format'. + ! Item was added: + ----- Method: ImageSegmentLoader>>allocateVariableSizeObject:size: (in category 'allocating') ----- + allocateVariableSizeObject: classOop size: nWords + | class | + class := self fetchClass: classOop. + (class isPointers and: [class isVariable]) ifFalse: + [self error: 'variable pointers class expected']. + ^class basicNew: nWords! Item was added: + ----- Method: ImageSegmentLoader>>allocateWordsObject:size: (in category 'allocating') ----- + allocateWordsObject: classOop size: nWords + | class | + class := self fetchClass: classOop. + class == Float ifTrue: [class := BoxedFloat64]. + (class isBits and: [class isWords]) ifFalse: + [self error: 'words class expected']. + ^class basicNew: nWords! Item was added: + ----- Method: ImageSegmentLoader>>fetchClass: (in category 'reading') ----- + fetchClass: classOop + | index class superclass format | + classOop < 32 ifTrue: + [^CompactClasses at: classOop]. + (index := classOop >> 2) >= 16r20000000 ifTrue: + [^outPointers at: index - 16r20000000]. + "class is in segment ... load it out-of-order" + superclass := self fetchClass: (self uint32At: classOop + 4). + format := self mapOop: (self uint32At: classOop + 12). + format := self mapToSpurFormat: format. + class := self readObjectAt: classOop. + class superclass: superclass + methodDictionary: MethodDictionary new + format: format. + class flushCache. + ^class! Item was added: + ----- Method: ImageSegmentLoader>>fillBehavior:oop: (in category 'filling') ----- + fillBehavior: class oop: oop + position := oop. + class superclass: (self mapOop: self readUint32). + class methodDict: (self mapOop: self readUint32). + class setFormat: (self mapToSpurFormat: (self mapOop: self readUint32)). + 4 to: class class instSize do: + [:i | class instVarAt: i put: (self mapOop: self readUint32)]. + class flushCache. + ^class! Item was added: + ----- Method: ImageSegmentLoader>>fillBytes:oop: (in category 'filling') ----- + fillBytes: object oop: oop + | word | + position := oop. + word := self readUint32. + 1 to: object basicSize do: + [:i | object basicAt: i put: (word bitAnd: 16rFF). + word := (i bitAnd: 3) = 0 + ifTrue: [self readUint32] + ifFalse: [word >> 8]]. + ! Item was added: + ----- Method: ImageSegmentLoader>>fillCompiledMethod:oop: (in category 'filling') ----- + fillCompiledMethod: method oop: oop + "The method header was already mapped to Spur format. + Here we just insert the bytecode for calling a primitive. + The last byte is left at 0 to indicate no trailer." + | header start size prim word | + position := oop. + header := self mapOop: self readUint32. + 1 to: method numLiterals do: + [:i | method literalAt: i put: (self mapOop: self readUint32)]. + start := method initialPC - 1. + size := method basicSize - start - 1. "subtract 1 byte for empty trailer" + (method header anyMask: 65536) ifTrue: "add primitive call" + [prim := self mapToSpurPrim: header. + method basicAt: start + 1 put: 16r8B. + method basicAt: start + 2 put: prim \\ 256. + method basicAt: start + 3 put: prim // 256. + start := start + 3. + size := size - 3]. + word := self readUint32. + 1 to: size do: + [:i | method basicAt: start + i put: (word bitAnd: 16rFF). + word := (i bitAnd: 3) = 0 + ifTrue: [self readUint32] + ifFalse: [word >> 8]]. + ! Item was added: + ----- Method: ImageSegmentLoader>>fillContext:oop: (in category 'filling') ----- + fillContext: ctx oop: oop + position := oop. + 1 to: ctx class instSize do: + [:i | ctx instVarAt: i put: (self mapOop: self readUint32)]. + 1 to: ctx stackPtr do: + [:i | ctx basicAt: i put: (self mapOop: self readUint32)]. + ^ctx! Item was added: + ----- Method: ImageSegmentLoader>>fillObject:oop: (in category 'filling') ----- + fillObject: object oop: oop + object isBehavior ifTrue: + [^self fillBehavior: object oop: oop]. + object isContext ifTrue: + [^self fillContext: object oop: oop]. + object class isPointers ifTrue: + [^self fillPointers: object oop: oop]. + object isCompiledMethod ifTrue: + [^self fillCompiledMethod: object oop: oop]. + object class isBytes ifTrue: + [^self fillBytes: object oop: oop]. + ^self fillWords: object oop: oop + + ! Item was added: + ----- Method: ImageSegmentLoader>>fillPointers:oop: (in category 'filling') ----- + fillPointers: object oop: oop + position := oop. + 1 to: object class instSize do: + [:i | object instVarAt: i put: (self mapOop: self readUint32)]. + 1 to: object basicSize do: + [:i | object basicAt: i put: (self mapOop: self readUint32)]. + ^object! Item was added: + ----- Method: ImageSegmentLoader>>fillWords:oop: (in category 'filling') ----- + fillWords: object oop: oop + position := oop. + 1 to: object basicSize do: + [:i | object basicAt: i put: self readUint32]. + ! Item was added: + ----- Method: ImageSegmentLoader>>loadSegmentFrom:outPointers: (in category 'loading') ----- + loadSegmentFrom: segmentWordArray outPointers: outPointerArray + | version end memory | + segment := segmentWordArray. + outPointers := outPointerArray. + position := 0. + version := self readUint32. + (version bitAnd: 16rFFFF) = 6502 ifFalse: + [^self error: 'Cannot read this segment (endianness?)']. + "First allocate all objects, then fill in their fields via oopMap" + memory := OrderedCollection new: 1000. + oopMap := Dictionary new. + end := segment size * 4. + [position < end] whileTrue: + [memory add: self readObject]. + oopMap keysAndValuesDo: + [:oop :obj | self fillObject: obj oop: oop]. + "Return list of all objects (unlike primitive, which returned the first object and relied on other objects being consecutive in memory)" + ^memory! Item was added: + ----- Method: ImageSegmentLoader>>mapOop: (in category 'reading') ----- + mapOop: oop + | i | + (oop bitAnd: 1) = 0 ifTrue: "pointer" + [(i := oop >> 2) >= 16r20000000 ifTrue: + [^outPointers at: i - 16r20000000]. + ^oopMap at: oop]. + i := oop >> 1. "signed small int" + i <= 16r3FFFFFFF ifTrue: [^i]. + ^i - 16r80000000! Item was added: + ----- Method: ImageSegmentLoader>>mapToSpurFormat: (in category 'reading') ----- + mapToSpurFormat: format + | instSpec instSize | + instSpec := format >> 7 bitAnd: 16r0F. + instSize := (format >> 10 bitAnd: 16rC0) + (format >> 1 bitAnd: 16r3F) - 1. + instSpec := instSpec <= 4 + ifTrue: [instSpec] "no change" + ifFalse: [instSpec = 6 + ifTrue: [10] "WordArray was 6 now 10-11" + ifFalse: [instSpec >= 12 + ifTrue: [instSpec + 12] "CompiledMethods 12-15 now 24-31" + ifFalse: [instSpec >= 8 + ifTrue: [instSpec + 8] "CompiledMethods 8-11 now 16-23" + ifFalse: [self error: 'unexpected format']]]]. + ^instSpec << 16 + instSize! Item was added: + ----- Method: ImageSegmentLoader>>mapToSpurHeader: (in category 'reading') ----- + mapToSpurHeader: header + "Keep numLits, numArgs, and largeFrame bits, move numLits, set primitive flag" + | primFlag numLits | + primFlag := (header bitAnd: 16r100001FF) > 0 ifTrue: [16r10000] ifFalse: [0]. + numLits := header >> 9 bitAnd: 16rFF. + ^(header bitAnd: 16r0FFE0000) + primFlag + numLits + ! Item was added: + ----- Method: ImageSegmentLoader>>mapToSpurPrim: (in category 'reading') ----- + mapToSpurPrim: header + | primBits | + primBits := header bitAnd: 16r100001FF. + ^(primBits bitAnd: 16r1FF) + (primBits bitShift: -19)! Item was added: + ----- Method: ImageSegmentLoader>>readObject (in category 'reading') ----- + readObject + | header oop nWords class format | + header := self readUint32. + (header bitAnd: HeaderTypeMask) caseOf: { + [HeaderTypeSizeAndClass] -> + [nWords := header >> 2. class := self readUint32. header := self readUint32]. + [HeaderTypeClass] -> + [class := header - 1. header := self readUint32. nWords := header >> 2 bitAnd: 63]. + [HeaderTypeShort] -> + [nWords := header >> 2 bitAnd: 63. class := header >> 12 bitAnd: 31]. + } otherwise: [self error: 'unexpected free chunk']. + nWords := nWords - 1. "nWords includes 1 header word" + oop := position. + ^[oopMap at: oop ifAbsentPut: + [format := header >> 8 bitAnd: 15. + "hash := header >> 17 bitAnd: 4095." + self allocateObject: format class: class size: nWords]] + ensure: [position := oop + (nWords * 4)] + + + ! Item was added: + ----- Method: ImageSegmentLoader>>readObjectAt: (in category 'reading') ----- + readObjectAt: oop + | headerType oldPos | + oopMap at: oop ifPresent: [:obj | ^obj]. + headerType := (self uint32At: oop) bitAnd: HeaderTypeMask. + oldPos := position. + position := oop - (BytesInHeader at: headerType). + ^[self readObject] ensure: [position := oldPos]! Item was added: + ----- Method: ImageSegmentLoader>>readUint32 (in category 'reading') ----- + readUint32 + ^self uint32At: (position := position + 4)! Item was added: + ----- Method: ImageSegmentLoader>>uint32At: (in category 'reading') ----- + uint32At: addr + "TODO: do endian conversion here" + ^segment at: addr // 4! Item was added: + ----- Method: ImageSegmentLoader>>uint8At: (in category 'reading') ----- + uint8At: addr + "TODO: do endian conversion here" + | word | + word := segment at: addr + 3 // 4. + ^word >> (8 * (addr + 3 \\ 4)) bitAnd: 16rFF.! Item was changed: ----- Method: Project>>setParent: (in category 'sub-projects & hierarchy') ----- setParent: newParent "Notify the current parent to discard views and other references. Avoids deleting that project later if the former parent is deleted. You can only have one parent anyway.." + (self parent isKindOf: Project) ifTrue: [ + self parent ~= newParent ifTrue: [self parent deletingProject: self]. + ]. - self parent ~= newParent ifTrue: [self parent deletingProject: self]. parentProject := newParent. nextProject := previousProject := nil.! Item was changed: ----- Method: SmalltalkImage>>snapshot:andQuit:withExitCode:embedded: (in category 'snapshot and quit') ----- snapshot: save andQuit: quit withExitCode: exitCode embedded: embeddedFlag "Mark the changes file and close all files as part of #processShutdownList. If save is true, save the current state of this Smalltalk in the image file. If quit is true, then exit to the outer OS shell. If exitCode is not nil, then use it as exit code. The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." | resuming msg | Object flushDependents. Object flushEvents. (SourceFiles at: 2) ifNotNil:[ msg := String streamContents: [ :s | s nextPutAll: '----'; nextPutAll: (save ifTrue: [ quit ifTrue: [ 'QUIT' ] ifFalse: [ 'SNAPSHOT' ] ] ifFalse: [quit ifTrue: [ 'QUIT/NOSAVE' ] ifFalse: [ 'NOP' ]]); nextPutAll: '----'; print: Date dateAndTimeNow; space; nextPutAll: (FileDirectory default localNameFor: self imageName); nextPutAll: ' priorSource: '; print: LastQuitLogPosition ]. self assureStartupStampLogged. save ifTrue: [ LastQuitLogPosition := (SourceFiles at: 2) setToEnd; position ]. self logChange: msg. Transcript cr; show: msg ]. Smalltalk processShutDownList: quit. Cursor write show. save ifTrue: [resuming := embeddedFlag ifTrue: [self snapshotEmbeddedPrimitive] + ifFalse: [self snapshotPrimitive]] "<-- PC frozen here on image file" - ifFalse: [self snapshotPrimitive]. "<-- PC frozen here on image file" - resuming == false "guard against failure" ifTrue: - ["Time to reclaim segment files is immediately after a save" - Smalltalk at: #ImageSegment - ifPresent: [:theClass | theClass reclaimObsoleteSegmentFiles]]] ifFalse: [resuming := false]. quit & (resuming == false) ifTrue: [ exitCode ifNil: [ self quitPrimitive ] ifNotNil: [ self quitPrimitive: exitCode ] ]. Cursor normal show. Smalltalk setGCParameters. resuming == true ifTrue: [Smalltalk clearExternalObjects]. Smalltalk processStartUpList: resuming == true. resuming == true ifTrue:[ self setPlatformPreferences. self recordStartupStamp]. Project current wakeUpTopWindow. "Now it's time to raise an error" resuming == nil ifTrue: [self error:'Failed to write image file (disk full?)']. ^ resuming! Item was changed: ----- Method: SmartRefStream>>reshapedClassesIn: (in category 'import image segment') ----- reshapedClassesIn: outPointers "Look for classes in the outPointer array that have changed shape. Make a fake class for the old shape. Return a dictionary mapping Fake classes to Real classes. Substitute fake classes for real ones in outPointers." | mapFakeClassesToReal | self flag: #bobconv. mapFakeClassesToReal := IdentityDictionary new. outPointers withIndexDo: [:outp :ind | | originalName fakeCls | outp isBehavior ifTrue: [ + originalName := renamed keyAtValue: outp name + ifAbsent: [renamedConv at: ind ifAbsent: [outp name]]. - originalName := renamedConv at: ind ifAbsent: [outp name]. "in DiskProxy>>comeFullyUpOnReload: we saved the name at the index" fakeCls := self mapClass: outp origName: originalName. fakeCls == outp ifFalse: [ mapFakeClassesToReal at: fakeCls put: outp. outPointers at: ind put: fakeCls]]]. ^ mapFakeClassesToReal!

1 0

The Trunk: Morphic-cmm.1306.mcz
by commits＠source.squeak.org 14 Sep '16

14 Sep '16

Chris Muller uploaded a new version of Morphic to project The Trunk: http://source.squeak.org/trunk/Morphic-cmm.1306.mcz ==================== Summary ==================== Name: Morphic-cmm.1306 Author: cmm Time: 14 September 2016, 4:53:42.843871 pm UUID: 53b3f640-bc3a-42e9-bb01-66c8a4afc483 Ancestors: Morphic-bf.1306 Fix docking bars occluding windows when pinch-resizing them. =============== Diff against Morphic-bf.1306 =============== Item was changed: ----- Method: HaloMorph>>doResizeTarget: (in category 'dragging or resizing') ----- + doResizeTarget: evt + | newExtent | - doResizeTarget: evt - - | oldExtent newExtent newPosition | newExtent := originalExtent + (evt position - positionOffset * 2). + (newExtent x > 1 and: [ newExtent y > 1 ]) ifTrue: + [ | oldExtent dockingBarBottom newPosition | + oldExtent := target extent. + dockingBarBottom := owner mainDockingBars + inject: 0 + into: [ : bottomMostBottom : each | bottomMostBottom max: each bottom ]. + target setExtentFromHalo: (newExtent min: owner extent x @ (owner extent y - dockingBarBottom)). + newPosition := target position - (target extent - oldExtent // 2). + newPosition := (newPosition x + min: owner extent x - newExtent x + max: 0) @ + (newPosition y + min: owner extent y - newExtent y + max: dockingBarBottom). + target + setConstrainedPosition: newPosition + hangOut: true ]. + self bounds: self target worldBoundsForHalo! - - (newExtent x > 1 and: [newExtent y > 1]) - ifTrue: [ - oldExtent := target extent. - target setExtentFromHalo: (newExtent min: owner extent). - newPosition := target position - (target extent - oldExtent // 2). - newPosition := (newPosition x min: owner extent x - newExtent x max: 0) @ (newPosition y min: owner extent y - newExtent y max: 0). - target setConstrainedPosition: newPosition hangOut: true]. - - self bounds: self target worldBoundsForHalo.!

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Packages September 2016