'From Squeak3.1alpha of 4 February 2001 [latest update: #3656] on 21 March 2001 at 12:37:12 pm'! "Change Set: Discards-ar Date: 21 March 2001 Author: Andreas Raab Various modifications for a clean removal of wide parts of the system."! !Object methodsFor: 'error handling' stamp: 'ar 2/13/2001 20:49'! externalCallFailed "A call to an external function has failed." ^(Smalltalk at: #ExternalFunction ifAbsent:[^self error: 'FFI not installed']) externalCallFailed! ! !BalloonCanvas methodsFor: 'accessing' stamp: 'ar 2/13/2001 21:07'! ensuredEngine engine ifNil:[ engine _ BalloonEngine new. "engine _ BalloonDebugEngine new" engine aaLevel: aaLevel. engine bitBlt: port. engine destOffset: origin. engine clipRect: clipRect. engine deferred: deferred. engine]. engine colorTransform: colorTransform. engine edgeTransform: transform. ^engine! ! !BitBlt methodsFor: 'copying' stamp: 'ar 2/13/2001 21:12'! copyBitsSimulated ^Smalltalk at: #BitBltSimulation ifPresent:[:bb| bb copyBitsFrom: self].! ! !FFT methodsFor: 'plugin-testing' stamp: 'ar 2/13/2001 21:10'! pluginTransformData: forward "Plugin testing -- if the primitive is not implemented or cannot be found run the simulation. See also: FFTPlugin" ^(Smalltalk at: #FFTPlugin ifAbsent:[^self primitiveFailed]) doPrimitive: 'primitiveFFTTransformData'.! ! !FXBlt methodsFor: 'copying' stamp: 'ar 3/21/2001 12:20'! copyBitsSimulated ^Smalltalk at: #FXBltSimulation ifPresent:[:bb| bb copyBitsFrom: self].! ! !Form methodsFor: 'displaying' stamp: 'ar 2/13/2001 22:13'! displayInterpolatedIn: aRectangle on: aForm "Display the receiver on aForm, using interpolation if necessary. Form fromUser displayInterpolatedOn: Display. Note: When scaling we attempt to use bilinear interpolation based on the 3D engine. If the engine is not there then we use WarpBlt. " | engine adjustedR | self extent = aRectangle extent ifTrue:[^self displayOn: aForm at: aRectangle origin]. Smalltalk at: #B3DRenderEngine ifPresent:[:engineClass| engine _ (engineClass defaultForPlatformOn: aForm)]. engine ifNil:[ "We've got no bilinear interpolation. Use WarpBlt instead" (WarpBlt current toForm: aForm) sourceForm: self destRect: aRectangle; combinationRule: 3; cellSize: 2; warpBits. ^self ]. "Otherwise use the 3D engine for our purposes" "there seems to be a slight bug in B3D which the following adjusts for" adjustedR _ (aRectangle withRight: aRectangle right + 1) translateBy: 0@1. engine viewport: adjustedR. engine material: ((Smalltalk at: #B3DMaterial) new emission: Color white). engine texture: self. engine render: ((Smalltalk at: #B3DIndexedQuadMesh) new plainTextureRect). engine finish.! ! !Form methodsFor: 'displaying' stamp: 'ar 2/13/2001 22:12'! displayInterpolatedOn: aForm "Display the receiver on aForm, using interpolation if necessary. Form fromUser displayInterpolatedOn: Display. Note: When scaling we attempt to use bilinear interpolation based on the 3D engine. If the engine is not there then we use WarpBlt. " | engine | self extent = aForm extent ifTrue:[^self displayOn: aForm]. Smalltalk at: #B3DRenderEngine ifPresent:[:engineClass| engine _ (engineClass defaultForPlatformOn: aForm)]. engine ifNil:[ "We've got no bilinear interpolation. Use WarpBlt instead" (WarpBlt current toForm: aForm) sourceForm: self destRect: aForm boundingBox; combinationRule: 3; cellSize: 2; warpBits. ^self ]. "Otherwise use the 3D engine for our purposes" engine viewport: aForm boundingBox. engine material: ((Smalltalk at: #B3DMaterial) new emission: Color white). engine texture: self. engine render: ((Smalltalk at: #B3DIndexedQuadMesh) new plainTextureRect). engine finish.! ! !KlattSynthesizer methodsFor: 'processing' stamp: 'ar 3/21/2001 12:21'! synthesizeFrame: aKlattFrame into: aSoundBuffer startingAt: index ^(Smalltalk at: #KlattSynthesizerPlugin ifAbsent:[^self primitiveFail]) doPrimitive: 'primitiveSynthesizeFrameIntoStartingAt'! ! !MethodNode methodsFor: 'printing' stamp: 'ar 2/13/2001 21:15'! printPrimitiveOn: aStream "Print the primitive on aStream" | primIndex primDecl | primIndex _ primitive. primIndex = 0 ifTrue: [^ self]. primIndex = 120 ifTrue: ["External call spec" ^ aStream print: encoder literals first]. aStream nextPutAll: '. Smalltalk at: #Interpreter ifPresent:[:cls| aStream nextPutAll: ' "' , ((cls classPool at: #PrimitiveTable) at: primIndex + 1) , '" '].! ! !Project methodsFor: 'initialization' stamp: 'ar 3/21/2001 12:09'! installNewDisplay: extent depth: depth "When entering a new project, install a new Display if necessary." | params newDisplay | params _ self rawParameters. (params notNil and:[(self parameterAt: #enable3DAcceleration) == true]) ifTrue:[ Display isB3DDisplayScreen ifTrue:[^Display setExtent: extent depth: depth]. "Install a B3DDisplayScreen for future hardware acceleration" newDisplay _ (Smalltalk at: #B3DDisplayScreen ifAbsent:[^self]) extent: extent depth: depth. ] ifFalse:[ "Otherwise check if the current Display is a DisplayScreen" Display isB3DDisplayScreen ifFalse:[^Display setExtent: extent depth: depth]. "Install a DisplayScreen for future hardware acceleration" newDisplay _ (Smalltalk at: #DisplayScreen ifAbsent:[^self]) extent: extent depth: depth. ]. "Copy old contents of display to the (yet to be installed) newDisplay" newDisplay class == Display class ifTrue:[ "A workaround for DisplayScreen <-> DisplayScreen" Display displayOn: newDisplay. ] ifFalse:["*MUST* use FXBlt when switching between Displays" Smalltalk at: #FXBlt ifPresent:[:fxBlt| (fxBlt toForm: newDisplay) sourceForm: Display; combinationRule: 3; copyBits]. ]. "And make it Display" Display release. "Release it while it's still Display" Display _ newDisplay. Display beDisplay.! ! !Project methodsFor: 'release' stamp: 'ar 3/21/2001 12:10'! okToChange "Answer whether the window in which the project is housed can be dismissed -- which is destructive. We never clobber a project without confirmation" | ok is list | self subProjects size >0 ifTrue: [PopUpMenu notify: 'The project ', self name printString, ' contains sub-projects. You must remove these explicitly before removing their parent.'. ^ false]. ok _ world isMorph not and: [world scheduledControllers size <= 1]. ok ifFalse: [self isMorphic ifTrue: [ self parent == CurrentProject ifFalse: [^true]]]. "view from elsewhere. just delete it." ok _ (self confirm: 'Really delete the project ', self name printString, ' and all its windows?'). ok ifFalse: [^ false]. world isMorph ifTrue: [ Smalltalk at: #WonderlandCameraMorph ifPresent:[:aClass| world submorphs do: "special release for wonderlands" [:m | (m isKindOf: aClass) and: [m getWonderland release]]]. "Remove Player classes and metaclasses owned by project" is _ ImageSegment new arrayOfRoots: (Array with: self). (list _ is rootsIncludingPlayers) ifNotNil: [ list do: [:playerCls | (playerCls respondsTo: #isMeta) ifTrue: [ playerCls isMeta ifFalse: [ playerCls removeFromSystemUnlogged]]]]]. self removeChangeSetIfPossible. "do this last since it will render project inaccessible to #allProjects and their ilk" Project deletingProject: self. ^ true ! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'ar 2/13/2001 22:19'! discard3D "Smalltalk discard3D" "Discard 3D Support." self discardWonderland. Smalltalk removeKey: #B3DEngineConstants ifAbsent: []. Smalltalk at: #InterpolatingImageMorph ifPresent:[:cls| cls removeFromSystem]. SystemOrganization removeCategoriesMatching: 'Graphics-FXBlt'. SystemOrganization removeCategoriesMatching: 'Graphics-External'. SystemOrganization removeCategoriesMatching: 'Balloon3D-*'. Color removeSelector: #asB3DColor. Form removeSelector: #asTexture. Morph removeSelector: #asTexture. FileList removeSelector: #open3DSFile. Point removeSelector: #@. Smalltalk at: #BalloonCanvas ifPresent:[:cc| cc removeSelector: #render:]. Stream removeSelector: #asVRMLStream.! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'ar 2/13/2001 21:17'! discardFFI "Discard the complete foreign function interface. NOTE: Recreates specialObjectsArray to prevent obsolete references. Has to specially remove external structure hierarchy before ExternalType" Smalltalk at: #ExternalStructure ifPresent:[:cls| (ChangeSet superclassOrder: cls withAllSubclasses asArray) reverseDo: [:c | c removeFromSystem]]. Smalltalk removeKey: #FFIConstants ifAbsent: []. SystemOrganization removeCategoriesMatching: 'FFI-*'. Smalltalk recreateSpecialObjectsArray. "Remove obsolete refs" ByteArray removeSelector: #asExternalPointer. ByteArray removeSelector: #pointerAt:.! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'ar 3/21/2001 12:34'! discardVMConstruction "Discard the virtual machine construction classes and the Smalltalk-to-C translator. These are only needed by those wishing to build or study the Squeak virtual machine, or by those wishing to construct new primitives via Smalltalk-to-C translation. Updated to suit 2.8 TPR" "remove the code for virtual machines" Smalltalk removeKey: #InterpreterLog ifAbsent: []. "remove the Smalltalk-to-C translator" Smalltalk at: #CCodeGenerator ifPresent: [:codeGen | codeGen removeCompilerMethods]. "remove any plugins" Smalltalk at: #InterpreterPlugin ifPresent:[:cls| (ChangeSet superclassOrder: cls withAllSubclasses asArray) reverseDo: [:c | c removeFromSystem]]. #(B3DSimulRasterizer BalloonDebugEngine) do:[:clsName| Smalltalk at: clsName ifPresent:[:cls| cls removeFromSystem]]. SystemOrganization removeCategoriesMatching: 'VMConstruction-*'. SystemOrganization removeCategoriesMatching: 'Squeak-Plugins'. "Various references" #( (Object removeSelector: primitive:parameters:receiver:) (SystemDictionary macroBenchmarks) (SystemDictionary macroBenchmark2) (String primGetInteger32:) (String primPutInteger32:at:) ) do:[:spec| Smalltalk at: spec first ifPresent:[:cls| cls removeSelector: spec last]. ].! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'ar 3/21/2001 12:35'! discardWonderland "Smalltalk discardWonderland" "Discard 3D Support." Smalltalk at: #Wonderland ifPresent:[:cls| cls removeActorPrototypesFromSystem]. Smalltalk removeKey: #WonderlandConstants ifAbsent: []. Smalltalk removeKey: #AliceConstants ifAbsent: []. SystemOrganization removeCategoriesMatching: 'Balloon3D-Wonderland*'. SystemOrganization removeCategoriesMatching: 'Balloon3D-Alice*'. SystemOrganization removeCategoriesMatching: 'Balloon3D-Pooh*'. SystemOrganization removeCategoriesMatching: 'Balloon3D-UserObjects'. Smalltalk at: #VRMLWonderlandBuilder ifPresent:[:cls| cls removeFromSystem]. FileList removeSelector: #openVRMLFile. HaloMorph compile: 'addPoohHandle: ignored ^self'.! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'ar 2/13/2001 22:03'! majorShrink | oldDicts newDicts | "Smalltalk majorShrink; abandonSources; lastRemoval" "This method throws out lots of the system that is not needed for, eg, operation in a hand-held PC. majorShrink produces a 999k image in Squeak 2.8" Smalltalk isMorphic ifTrue: [^ self error: 'You can only run majorShrink in MVC']. Project current isTopProject ifFalse: [^ self error: 'You can only run majorShrink in the top project']. (Smalltalk confirm: 'All sub-projects will be deleted from this image. You should already have made a backup copy, or you must save with a different name after shrinking. Shall we proceed to discard most of the content in this image?') ifFalse: [^ PopUpMenu notify: 'No changes have been made.']. "Remove all projects but the current one. - saves 522k" ProjectView allInstancesDo: [:pv | pv controller closeAndUnscheduleNoTerminate]. Project current setParent: Project current. MorphWorldView allInstancesDo: [:pv | pv topView controller closeAndUnscheduleNoTerminate]. Smalltalk at: #Wonderland ifPresent:[:cls| cls removeActorPrototypesFromSystem]. Player freeUnreferencedSubclasses. MorphicModel removeUninstantiatedModels. Utilities classPool at: #ScrapsBook put: nil. Utilities zapUpdateDownloader. ProjectHistory currentHistory initialize. Project rebuildAllProjects. Smalltalk discardVMConstruction. "755k" Smalltalk discardSoundSynthesis. "544k" Smalltalk discardOddsAndEnds. "227k" Smalltalk discardNetworking. "234k" Smalltalk discard3D. "407k" Smalltalk discardFFI. "33k" Smalltalk discardMorphic. "1372k" Symbol rehash. "40k" "Above by itself saves about 4,238k" "Remove references to a few classes to be deleted, so that they won't leave obsolete versions around." FileList removeSelector: #fileIntoNewChangeSet. ChangeSet class compile: 'defaultName ^ ''Changes'' ' classified: 'initialization'. ScreenController removeSelector: #openChangeManager. ScreenController removeSelector: #exitProject. ScreenController removeSelector: #openProject. ScreenController removeSelector: #viewImageImports. "Now delete various other classes.." SystemOrganization removeSystemCategory: 'Graphics-Files'. SystemOrganization removeSystemCategory: 'System-Object Storage'. Smalltalk removeClassNamed: #ProjectController. Smalltalk removeClassNamed: #ProjectView. "Smalltalk removeClassNamed: #Project." Smalltalk removeClassNamed: #Environment. Smalltalk removeClassNamed: #Component1. Smalltalk removeClassNamed: #FormSetFont. Smalltalk removeClassNamed: #FontSet. Smalltalk removeClassNamed: #InstructionPrinter. Smalltalk removeClassNamed: #ChangeSorter. Smalltalk removeClassNamed: #DualChangeSorter. Smalltalk removeClassNamed: #EmphasizedMenu. Smalltalk removeClassNamed: #MessageTally. StringHolder class removeSelector: #originalWorkspaceContents. CompiledMethod removeSelector: #symbolic. RemoteString removeSelector: #makeNewTextAttVersion. Utilities class removeSelector: #absorbUpdatesFromServer. Smalltalk removeClassNamed: #PenPointRecorder. Smalltalk removeClassNamed: #Path. Smalltalk removeClassNamed: #Base64MimeConverter. "Smalltalk removeClassNamed: #EToySystem. Dont bother - its very small and used for timestamps etc" Smalltalk removeClassNamed: #RWBinaryOrTextStream. Smalltalk removeClassNamed: #AttributedTextStream. Smalltalk removeClassNamed: #WordNet. Smalltalk removeClassNamed: #SelectorBrowser. TextStyle allSubInstancesDo: [:ts | ts newFontArray: (ts fontArray copyFrom: 1 to: (2 min: ts fontArray size))]. ListParagraph initialize. PopUpMenu initialize. StandardSystemView initialize. Smalltalk noChanges. ChangeSorter classPool at: #AllChangeSets put: (OrderedCollection with: Smalltalk changes). SystemDictionary removeSelector: #majorShrink. [Smalltalk removeAllUnSentMessages > 0] whileTrue: [Smalltalk unusedClasses do: [:c | (Smalltalk at: c) removeFromSystem]]. SystemOrganization removeEmptyCategories. Smalltalk allClassesDo: [:c | c zapOrganization]. Smalltalk garbageCollect. 'Rehashing method dictionaries . . .' displayProgressAt: Sensor cursorPoint from: 0 to: MethodDictionary instanceCount during: [:bar | oldDicts _ MethodDictionary allInstances. newDicts _ Array new: oldDicts size. oldDicts withIndexDo: [:d :index | bar value: index. newDicts at: index put: d rehashWithoutBecome. ]. oldDicts elementsExchangeIdentityWith: newDicts. ]. oldDicts _ newDicts _ nil. Project rebuildAllProjects. Smalltalk changes initialize. "seems to take more than one try to gc all the weak refs in SymbolTable" 3 timesRepeat: [ Smalltalk garbageCollect. Symbol compactSymbolTable. ]. ! ! !WarpBlt methodsFor: 'system simulation' stamp: 'ar 2/13/2001 21:12'! warpBitsSimulated: n sourceMap: sourceMap "Simulate WarpBlt" Smalltalk at: #BitBltSimulation ifPresent:[:bb| bb warpBitsFrom: self].! !