[Pkg] The Trunk: System-ar.281.mcz
commits at source.squeak.org
commits at source.squeak.org
Sat Mar 6 05:48:53 UTC 2010
Andreas Raab uploaded a new version of System to project The Trunk:
http://source.squeak.org/trunk/System-ar.281.mcz
==================== Summary ====================
Name: System-ar.281
Author: ar
Time: 5 March 2010, 9:47:59.277 pm
UUID: 8c85469e-c5f2-f44d-96c3-363675d6ac44
Ancestors: System-ar.280
Clean up after Smalltalk/SystemDictionary transition.
=============== Diff against System-ar.280 ===============
Item was changed:
----- Method: SystemDictionary>>objectForDataStream: (in category 'objects from disk') -----
objectForDataStream: refStrm
| dp |
"I am about to be written on an object file. Write a reference to Smalltalk instead."
+ dp := DiskProxy global: #Smalltalk selector: #globals
- dp := DiskProxy global: #Smalltalk selector: #yourself
args: #().
refStrm replace: self with: dp.
^ dp!
Item was changed:
+ ----- Method: SmalltalkImage>>associationOrUndeclaredAt: (in category 'dictionary access') -----
- ----- Method: SmalltalkImage>>associationOrUndeclaredAt: (in category 'accessing') -----
associationOrUndeclaredAt: aKey
"DO NOT DEPRECATE - used by binary storage"
+
^globals associationOrUndeclaredAt: aKey!
Item was changed:
+ ----- Method: SystemDictionary>>allTraitsDo: (in category 'classes and traits') -----
- ----- Method: SystemDictionary>>allTraitsDo: (in category 'retrieving') -----
allTraitsDo: aBlock
"Evaluate the argument, aBlock, for each trait in the system."
(self traitNames collect: [:name | self at: name]) do: aBlock!
Item was changed:
----- Method: SmalltalkImage>>removeKey:ifAbsent: (in category 'dictionary access') -----
removeKey: key ifAbsent: aBlock
+ "Obsoleted."
+
+ self deprecated: 'Use Smalltalk globals'.
- "delegate to globals"
^globals removeKey: key ifAbsent: aBlock!
Item was changed:
----- Method: SmalltalkImage>>do: (in category 'dictionary access') -----
do: aBlock
+ "Obsoleted."
+
+ self deprecated: 'Use Smalltalk globals'.
- "delegate to globals"
^globals do: aBlock!
Item was changed:
----- Method: SystemDictionary>>printOn: (in category 'printing') -----
printOn: aStream
+ self == Smalltalk globals
+ ifTrue: [aStream nextPutAll: 'Smalltalk globals'.
- self == Smalltalk
- ifTrue: [aStream nextPutAll: #Smalltalk.
aStream nextPutAll:' "a SystemDictionary with lots of globals"']
ifFalse: [super printOn: aStream]!
Item was changed:
+ ----- Method: SystemDictionary>>renameClass:from:to: (in category 'classes and traits') -----
- ----- Method: SystemDictionary>>renameClass:from:to: (in category 'class and trait names') -----
renameClass: aClass from: oldName to: newName
"Rename the class, aClass, to have the title newName."
| oldref category |
category := SystemOrganization categoryOfElement: oldName.
self organization classify: newName under: category.
self organization removeElement: oldName.
oldref := self associationAt: oldName.
self removeKey: oldName.
oldref key: newName.
self add: oldref. "Old association preserves old refs"
Smalltalk renamedClass: aClass from: oldName to: newName.
self flushClassNameCache.
SystemChangeNotifier uniqueInstance classRenamed: aClass from: oldName to: newName inCategory: category!
Item was changed:
----- Method: SmalltalkImage>>includes: (in category 'dictionary access') -----
includes: element
+ "Obsoleted."
+
+ self deprecated: 'Use Smalltalk globals'.
- "delegate to globals"
^globals includes: element!
Item was changed:
+ ----- Method: SystemDictionary>>renameClass:from: (in category 'classes and traits') -----
- ----- Method: SystemDictionary>>renameClass:from: (in category 'class and trait names') -----
renameClass: aClass from: oldName
"Rename the class, aClass, to have the title newName."
^self renameClass: aClass from: oldName to: aClass name!
Item was changed:
+ ----- Method: SystemDictionary>>poolUsers (in category 'accessing') -----
- ----- Method: SystemDictionary>>poolUsers (in category 'retrieving') -----
poolUsers
"Answer a dictionary of pool name -> classes that refer to it.
Also includes any globally know dictionaries (such as
Smalltalk, Undeclared etc) which although not strictly
accurate is potentially useful information"
"Smalltalk poolUsers"
| poolUsers |
poolUsers := Dictionary new.
self keys
do: [:k | "yes, using isKindOf: is tacky but for reflective code like
this it is very useful. If you really object you can:-
a) go boil your head.
b) provide a better answer.
your choice."
| pool refs |
(((pool := self at: k) isKindOf: Dictionary)
or: [pool isKindOf: SharedPool class])
ifTrue: [refs := self systemNavigation allClasses
select: [:c | c sharedPools identityIncludes: pool]
thenCollect: [:c | c name].
refs
add: (self systemNavigation
allCallsOn: (self associationAt: k)).
poolUsers at: k put: refs]].
^ poolUsers!
Item was changed:
+ ----- Method: SystemDictionary>>classOrTraitNamed: (in category 'classes and traits') -----
- ----- Method: SystemDictionary>>classOrTraitNamed: (in category 'class and trait names') -----
classOrTraitNamed: aString
"aString is either a class or trait name or a class or trait name followed by ' class' or 'classTrait' respectively.
Answer the class or metaclass it names."
| meta baseName baseClass |
(aString endsWith: ' class')
ifTrue: [meta := true.
baseName := aString copyFrom: 1 to: aString size - 6]
ifFalse: [
(aString endsWith: ' classTrait')
ifTrue: [
meta := true.
baseName := aString copyFrom: 1 to: aString size - 11]
ifFalse: [
meta := false.
baseName := aString]].
baseClass := Smalltalk at: baseName asSymbol ifAbsent: [^ nil].
meta
ifTrue: [^ baseClass classSide]
ifFalse: [^ baseClass]!
Item was changed:
+ ----- Method: SmalltalkImage>>associationAt: (in category 'dictionary access') -----
- ----- Method: SmalltalkImage>>associationAt: (in category 'accessing') -----
associationAt: aKey
"DO NOT DEPRECATE - used by ImageSegments"
+
^globals associationAt: aKey!
Item was changed:
+ ----- Method: SystemDictionary>>hasClassNamed: (in category 'classes and traits') -----
- ----- Method: SystemDictionary>>hasClassNamed: (in category 'class and trait names') -----
hasClassNamed: aString
"Answer whether there is a class of the given name, but don't intern aString if it's not alrady interned. 4/29/96 sw"
Symbol hasInterned: aString ifTrue:
[:aSymbol | ^ (self at: aSymbol ifAbsent: [nil]) isKindOf: Class].
^ false!
Item was changed:
----- Method: SmalltalkImage>>at:put: (in category 'accessing') -----
at: aKey put: anObject
+ "Set the global at key to be anObject. If key is not found, create a
+ new entry for key and set is value to anObject. Answer anObject."
+
+ ^globals at: aKey put: anObject!
- "Override from Dictionary to check Undeclared and fix up
- references to undeclared variables."
- (globals includesKey: aKey) ifFalse:
- [globals declare: aKey from: Undeclared.
- self flushClassNameCache].
- globals at: aKey put: anObject.
- ^ anObject!
Item was changed:
+ ----- Method: SmalltalkImage>>associationDeclareAt: (in category 'dictionary access') -----
- ----- Method: SmalltalkImage>>associationDeclareAt: (in category 'accessing') -----
associationDeclareAt: aKey
"DO NOT DEPRECATE - used by ImageSegments"
+
^globals associationDeclareAt: aKey!
Item was changed:
----- Method: SmalltalkImage>>removeKey: (in category 'dictionary access') -----
removeKey: key
+ "Obsoleted."
+
+ self deprecated: 'Use Smalltalk globals'.
- "delegate to globals"
^globals removeKey: key!
Item was changed:
+ ----- Method: SystemDictionary>>removeClassNamed: (in category 'classes and traits') -----
- ----- Method: SystemDictionary>>removeClassNamed: (in category 'class and trait names') -----
removeClassNamed: aName
"Invoked from fileouts: if there is currently a class in the system named aName, then remove it. If anything untoward happens, report it in the Transcript. "
| oldClass |
(oldClass := self at: aName asSymbol ifAbsent: [nil]) == nil
ifTrue:
[Transcript cr; show: 'Removal of class named ', aName, ' ignored because ', aName, ' does not exist.'.
^ self].
oldClass removeFromSystem!
Item was changed:
+ ----- Method: SystemDictionary>>allClassesDo: (in category 'classes and traits') -----
- ----- Method: SystemDictionary>>allClassesDo: (in category 'retrieving') -----
allClassesDo: aBlock
"Evaluate the argument, aBlock, for each class in the system."
(self classNames collect: [:name | self at: name]) do: aBlock!
Item was changed:
----- Method: SmalltalkImage>>at:ifAbsent: (in category 'accessing') -----
at: key ifAbsent: aBlock
+ "Answer the global associated with the key or, if key isn't found,
+ answer the result of evaluating aBlock."
+
- "delegate to globals"
^globals at: key ifAbsent: aBlock!
Item was changed:
+ ----- Method: SystemDictionary>>traitNames (in category 'classes and traits') -----
- ----- Method: SystemDictionary>>traitNames (in category 'class and trait names') -----
traitNames
"Answer a SortedCollection of all traits (not including class-traits) names."
| names |
names := OrderedCollection new.
self do:
[:cl | (cl isInMemory
and: [(cl isTrait)
and: [(cl name beginsWith: 'AnObsolete') not]])
ifTrue: [names add: cl name]].
^ names!
Item was changed:
----- Method: SmalltalkImage>>globals (in category 'accessing') -----
globals
"Answer the global SystemDictionary"
+
^globals!
Item was changed:
+ ----- Method: SystemDictionary>>classNamed: (in category 'classes and traits') -----
- ----- Method: SystemDictionary>>classNamed: (in category 'class and trait names') -----
classNamed: className
^self classOrTraitNamed: className.!
Item was changed:
----- Method: SmalltalkImage>>size (in category 'dictionary access') -----
size
+ "Obsoleted."
+
+ self deprecated: 'Use Smalltalk globals'.
- "delegate to globals"
^globals size!
Item was changed:
----- Method: SmalltalkImage>>organization (in category 'accessing') -----
organization
"Return the organizer for the receiver"
+
^globals organization!
Item was changed:
+ ----- Method: SystemDictionary>>allClasses (in category 'classes and traits') -----
- ----- Method: SystemDictionary>>allClasses (in category 'retrieving') -----
allClasses
"Return all the class defines in the Smalltalk SystemDictionary"
"Smalltalk allClasses"
^ self classNames collect: [:name | self at: name]!
Item was changed:
----- Method: SmalltalkImage>>keyAtIdentityValue:ifAbsent: (in category 'dictionary access') -----
keyAtIdentityValue: anObject ifAbsent: aBlock
+ "Obsoleted."
+
+ self deprecated: 'Use Smalltalk globals'.
- "delegate to globals"
^globals keyAtIdentityValue: anObject ifAbsent: aBlock!
Item was changed:
+ ----- Method: SystemDictionary>>flushClassNameCache (in category 'classes and traits') -----
- ----- Method: SystemDictionary>>flushClassNameCache (in category 'class and trait names') -----
flushClassNameCache
"Smalltalk flushClassNameCache"
"Forse recomputation of the cached list of class names."
cachedClassNames := nil!
Item was changed:
+ ----- Method: SmalltalkImage>>scopeFor:from:envtAndPathIfFound: (in category 'dictionary access') -----
- ----- Method: SmalltalkImage>>scopeFor:from:envtAndPathIfFound: (in category 'accessing') -----
scopeFor: varName from: lower envtAndPathIfFound: envtAndPathBlock
+ "Obsoleted."
- "Null compatibility with partitioning into environments."
+ self deprecated: 'Use Smalltalk globals'.
(globals includesKey: varName)
ifTrue: [^ envtAndPathBlock value: self value: String new]
ifFalse: [^ nil]!
Item was changed:
+ ----- Method: SystemDictionary>>forgetClass:logged: (in category 'classes and traits') -----
- ----- Method: SystemDictionary>>forgetClass:logged: (in category 'class and trait names') -----
forgetClass: aClass logged: aBool
"Delete the class, aClass, from the system.
Note that this doesn't do everything required to dispose of a class - to do that use Class>>removeFromSystem."
aBool ifTrue: [SystemChangeNotifier uniqueInstance classRemoved: aClass fromCategory: aClass category].
self organization removeElement: aClass name.
Smalltalk removeFromStartUpList: aClass.
Smalltalk removeFromShutDownList: aClass.
self removeKey: aClass name ifAbsent: [].
self flushClassNameCache.!
Item was changed:
----- Method: SmalltalkImage>>keys (in category 'dictionary access') -----
keys
+ "Obsoleted."
+
+ self deprecated: 'Use Smalltalk globals'.
- "delegate to globals"
^globals keys!
Item was changed:
+ ----- Method: SmalltalkImage>>includesKey: (in category 'dictionary access') -----
- ----- Method: SmalltalkImage>>includesKey: (in category 'accessing') -----
includesKey: key
+ "Answer whether the receiver has a key equal to the argument, key."
+
- "delegate to globals"
^globals includesKey: key!
Item was changed:
----- Method: SmalltalkImage>>associationAt:ifAbsent: (in category 'dictionary access') -----
associationAt: key ifAbsent: aBlock
+ "Obsoleted."
+
+ self deprecated: 'Use Smalltalk globals'.
- "delegate to globals"
^globals associationAt: key ifAbsent: aBlock!
Item was changed:
+ ----- Method: SystemDictionary>>allClassesAndTraitsDo: (in category 'classes and traits') -----
- ----- Method: SystemDictionary>>allClassesAndTraitsDo: (in category 'class and trait names') -----
allClassesAndTraitsDo: aBlock
^self allClassesAndTraits do: aBlock!
Item was changed:
----- Method: SmalltalkImage>>globals: (in category 'accessing') -----
globals: aSystemDictionary
"Sets the system-wide globals"
+
globals ifNotNil:[self error: 'Cannot overwrite existing globals'].
globals := aSystemDictionary!
Item was changed:
+ ----- Method: SystemDictionary>>renameClassNamed:as: (in category 'classes and traits') -----
- ----- Method: SystemDictionary>>renameClassNamed:as: (in category 'class and trait names') -----
renameClassNamed: oldName as: newName
"Invoked from fileouts: if there is currently a class in the system named oldName, then rename it to newName. If anything untoward happens, report it in the Transcript. "
| oldClass |
(oldClass := self at: oldName asSymbol ifAbsent: [nil]) == nil
ifTrue:
[Transcript cr; show: 'Class-rename for ', oldName, ' ignored because ', oldName, ' does not exist.'.
^ self].
oldClass rename: newName!
Item was changed:
----- Method: SmalltalkImage>>environment (in category 'accessing') -----
environment
"For conversion from Smalltalk to SystemDictionary"
+
^globals!
Item was changed:
----- Method: SmalltalkImage>>at: (in category 'accessing') -----
at: aKey
+ "Answer the global associated with the key."
+
- "delegate to globals"
^globals at: aKey!
Item was changed:
----- Method: SmalltalkImage class>>initialize (in category 'class initialization') -----
initialize
"SmalltalkImage initialize"
+ "XXX: Just to clean up after the transition"
+ Smalltalk removeEmptyMessageCategories.
- SmalltalkImage current == Smalltalk
- ifFalse:[self convertFromSystemDictionary].
self initializeStartUpList.
self initializeShutDownList.
!
Item was changed:
+ ----- Method: SystemDictionary>>allClassesAndTraits (in category 'classes and traits') -----
- ----- Method: SystemDictionary>>allClassesAndTraits (in category 'class and trait names') -----
allClassesAndTraits
"Return all the classes and traits defined in the Smalltalk SystemDictionary"
^ self classNames , self traitNames collect: [:each | self at: each]!
Item was changed:
+ ----- Method: SystemDictionary>>renameClass:as: (in category 'classes and traits') -----
- ----- Method: SystemDictionary>>renameClass:as: (in category 'class and trait names') -----
renameClass: aClass as: newName
"Rename the class, aClass, to have the title newName."
^self renameClass: aClass from: aClass name to: newName!
Item was changed:
----- Method: SmalltalkImage>>at:ifPresent: (in category 'accessing') -----
at: key ifPresent: aBlock
+ "Lookup the given key in the globals. If it is present, answer the value of evaluating the given block with the value associated with the key. Otherwise, answer nil."
+
- "delegate to globals"
^globals at: key ifPresent: aBlock!
Item was changed:
+ ----- Method: SystemDictionary>>classNames (in category 'classes and traits') -----
- ----- Method: SystemDictionary>>classNames (in category 'class and trait names') -----
classNames
"Answer a SortedCollection of all class names."
| names |
cachedClassNames == nil ifTrue:
[names := OrderedCollection new: self size.
self do:
[:cl | (cl isInMemory
and: [(cl isKindOf: Class)
and: [(cl name beginsWith: 'AnObsolete') not]])
ifTrue: [names add: cl name]].
cachedClassNames := names asSortedCollection].
^ cachedClassNames!
Item was changed:
+ ----- Method: SystemDictionary>>allTraits (in category 'classes and traits') -----
- ----- Method: SystemDictionary>>allTraits (in category 'retrieving') -----
allTraits
"Return all traits defined in the Smalltalk SystemDictionary"
^ self traitNames collect: [:each | self at: each]!
Item was removed:
- ----- Method: SystemDictionary>>cleanUp: (in category 'housekeeping') -----
- cleanUp: aggressive
- "Clean up. When aggressive is true, this will destroy projects, change sets, etc."
- "Smalltalk cleanUp: false"
- "Smalltalk cleanUp: true"
-
- ^self cleanUp: aggressive except: #()!
Item was removed:
- ----- Method: SystemDictionary>>internalizeChangeLog (in category 'sources, change log') -----
- internalizeChangeLog
- "Smalltalk internalizeChangeLog"
- "Bring the changes file into a memory-resident filestream, for faster access and freedom from external file system. 1/31/96 sw"
-
- | reply aName aFile |
- reply := self confirm: 'CAUTION -- do not undertake this lightly!!
- If you have backed up your system and
- are prepared to face the consequences of
- the requested internalization of sources,
- hit Yes. If you have any doubts, hit No
- to back out with no harm done.'.
-
- (reply == true) ifFalse:
- [^ self inform: 'Okay - abandoned'].
-
- aName := SmalltalkImage current changesName.
- (aFile := SourceFiles last) == nil ifTrue:
- [(FileDirectory default fileExists: aName)
- ifFalse: [^ self halt: 'Cannot locate ', aName, ' so cannot proceed.'].
- aFile := FileStream readOnlyFileNamed: aName].
- SourceFiles at: 2 put: (ReadWriteStream with: aFile contentsOfEntireFile).
-
- self inform: 'Okay, changes file internalized'!
Item was removed:
- ----- Method: SystemDictionary>>add:toList:after: (in category 'snapshot and quit') -----
- add: aClass toList: startUpOrShutDownList after: predecessor
- "Add the name of aClass to the startUp or shutDown list.
- Add it after the name of predecessor, or at the end if predecessor is nil."
-
- | name earlierName |
- name := aClass name.
- (self at: name ifAbsent: [nil]) == aClass ifFalse:
- [self error: name , ' cannot be found in Smalltalk dictionary.'].
- predecessor == nil
- ifTrue: ["No-op if alredy in the list."
- (startUpOrShutDownList includes: name) ifFalse:
- [startUpOrShutDownList == StartUpList
- ifTrue: ["Add to end of startUp list"
- startUpOrShutDownList addLast: name]
- ifFalse: ["Add to front of shutDown list"
- startUpOrShutDownList addFirst: name]]]
- ifFalse: ["Add after predecessor, moving it if already there."
- earlierName := predecessor name.
- (self at: earlierName) == predecessor ifFalse:
- [self error: earlierName , ' cannot be found in Smalltalk dictionary.'].
- (startUpOrShutDownList includes: earlierName) ifFalse:
- [self error: earlierName , ' cannot be found in the list.'].
- startUpOrShutDownList remove: name ifAbsent:[].
- startUpOrShutDownList add: name after: earlierName]!
Item was removed:
- ----- Method: SystemDictionary>>discardFFI (in category 'shrinking') -----
- discardFFI
- "Discard the complete foreign function interface.
- NOTE: Recreates specialObjectsArray to prevent obsolete
- references. Has to specially remove external structure
- hierarchy before ExternalType"
- self
- at: #ExternalStructure
- ifPresent: [:cls | (ChangeSet superclassOrder: cls withAllSubclasses asArray)
- reverseDo: [:c | c removeFromSystem]].
- SystemOrganization removeCategoriesMatching: 'FFI-*'.
- self recreateSpecialObjectsArray.
- "Remove obsolete refs"
- ByteArray removeSelector: #asExternalPointer.
- ByteArray removeSelector: #pointerAt:!
Item was removed:
- ----- Method: SystemDictionary>>primVmPath (in category 'image, changes name') -----
- primVmPath
- "Answer the path for the directory containing the Smalltalk virtual machine. Return the empty string if this primitive is not implemented."
- "Smalltalk vmPath"
-
- <primitive: 142>
- ^ ''!
Item was removed:
- ----- Method: SystemDictionary>>discardOddsAndEnds (in category 'shrinking') -----
- discardOddsAndEnds
- "This method throws out lots of classes that are not frequently
- used."
- "Smalltalk discardOddsAndEnds"
- self organization removeSystemCategory: 'System-Serial Port'.
- self organization removeSystemCategory: 'ST80-Symbols'.
- self organization removeSystemCategory: 'Tools-File Contents Browser'.
- self organization removeSystemCategory: 'System-Compression'.
- self organization removeSystemCategory: 'Tools-Explorer'.
- self organization removeSystemCategory: 'System-Digital Signatures'.
- Form removeSelector: #edit.
- self
- at: #FormView
- ifPresent: [:c | c compile: 'defaultControllerClass ^ NoController' classified: 'controller access'].
- self removeClassNamed: #FormEditorView.
- self removeClassNamed: #FormEditor.
- self organization removeSystemCategory: 'ST80-Paths'.
- "bit editor (remove Form editor first):"
- Form removeSelector: #bitEdit.
- Form removeSelector: #bitEditAt:scale:.
- StrikeFont removeSelector: #edit:.
- self removeClassNamed: #FormButtonCache.
- self removeClassNamed: #FormMenuController.
- self removeClassNamed: #FormMenuView.
- self removeClassNamed: #BitEditor.
- "inspector for Dictionaries of Forms"
- Dictionary removeSelector: #inspectFormsWithLabel:.
- SystemDictionary removeSelector: #viewImageImports.
- self
- at: #ScreenController
- ifPresent: [:c | c removeSelector: #viewImageImport].
- self removeClassNamed: #FormHolderView.
- self removeClassNamed: #FormInspectView.
- "experimental updating object viewer:"
- Object removeSelector: #evaluate:wheneverChangeIn:.
- self removeClassNamed: #ObjectViewer.
- self removeClassNamed: #ObjectTracer.
- "miscellaneous classes:"
- self removeClassNamed: #Array2D.
- self removeClassNamed: #DriveACar.
- self removeClassNamed: #EventRecorder.
- self removeClassNamed: #FindTheLight.
- self removeClassNamed: #PluggableTest.
- self removeClassNamed: #SystemMonitor.
- self removeClassNamed: #ProtocolBrowser.
- self removeClassNamed: #ObjectExplorerWrapper.
- self removeClassNamed: #HierarchyBrowser.
- self removeClassNamed: #LinkedMessageSet.
- self removeClassNamed: #ObjectExplorer.
- self removeClassNamed: #PackageBrowser.
- self removeClassNamed: #AbstractHierarchicalList.
- self removeClassNamed: #ChangeList.
- self removeClassNamed: #VersionsBrowser.
- self removeClassNamed: #ChangeRecord.
- self removeClassNamed: #SelectorBrowser.
- self removeClassNamed: #HtmlFileStream.
- self removeClassNamed: #CrLfFileStream.
- self removeClassNamed: #FXGrafPort.
- self removeClassNamed: #FXBlt.
- self
- at: #SampledSound
- ifPresent: [:c | c initialize].
- #(#Helvetica #Palatino #Courier #ComicBold #ComicPlain )
- do: [:k | TextConstants
- removeKey: k
- ifAbsent: []].
- Preferences
- setButtonFontTo: (StrikeFont familyName: #NewYork size: 12).
- Preferences
- setFlapsFontTo: (StrikeFont familyName: #NewYork size: 12).
- #(#GZipConstants #ZipConstants #KlattResonatorIndices )
- do: [:k | self
- removeKey: k
- ifAbsent: []]!
Item was removed:
- ----- Method: SystemDictionary>>currentChangeSetString (in category 'sources, change log') -----
- currentChangeSetString
- "Smalltalk currentChangeSetString"
- ^ 'Current Change Set: ' translated, ChangeSet current name!
Item was removed:
- ----- Method: SystemDictionary>>removeFromShutDownList: (in category 'snapshot and quit') -----
- removeFromShutDownList: aClass
-
- ShutDownList remove: aClass name ifAbsent: []!
Item was removed:
- ----- Method: SystemDictionary>>unregisterExternalObject: (in category 'special objects') -----
- unregisterExternalObject: anObject
- "Unregister the given object in the external objects array. Do nothing if it isn't registered."
-
- ExternalSemaphoreTable unregisterExternalObject: anObject!
Item was removed:
- ----- Method: SmalltalkImage>>discardMIDI (in category 'shrinking') -----
- discardMIDI
-
- "this seems to have gone away"!
Item was removed:
- ----- Method: SystemDictionary>>discardMorphic (in category 'shrinking') -----
- discardMorphic
- "Discard Morphic.
- Updated for 2.8 TPR"
- "Smalltalk discardMorphic"
- "Check that we are in an MVC Project and that there are no
- Morphic Projects
- or WorldMorphViews."
- | subs |
- Flaps clobberFlapTabList.
- self discardFlash.
- self discardTrueType.
- subs := OrderedCollection new.
- Morph
- allSubclassesWithLevelDo: [:c :i | subs addFirst: c]
- startingLevel: 0.
- subs
- do: [:c | c removeFromSystem].
- self removeClassNamed: #CornerRounder.
- self
- removeKey: #BalloonEngineConstants
- ifAbsent: [].
- SystemOrganization removeCategoriesMatching: 'Balloon-*'.
- SystemOrganization removeCategoriesMatching: 'Morphic-*'.
- SystemOrganization removeSystemCategory: 'Graphics-Transformations'.
- SystemOrganization removeSystemCategory: 'ST80-Morphic'.
- ScriptingSystem := nil!
Item was removed:
- ----- Method: SystemDictionary>>version (in category 'sources, change log') -----
- version
- "Answer the version of this release."
-
- ^SystemVersion current version!
Item was removed:
- ----- Method: SystemDictionary>>writeImageSegmentsFrom:withKernel: (in category 'shrinking') -----
- writeImageSegmentsFrom: segmentDictionary withKernel: kernel
- "segmentDictionary is associates segmentName -> {classNames. methodNames},
- and kernel is another set of classNames determined to be essential.
- Add a partition, 'Secondary' with everything not in partitions and not in the kernel.
- Then write segments based on this partitioning of classes."
-
- | secondary dups segDict overlaps symbolHolder classes |
- "First, put all classes that are in no other partition, and not in kernel into a new partition called 'Secondary'. Also remove any classes in kernel from putative partitions."
- secondary := Smalltalk classNames asIdentitySet.
- segmentDictionary keysDo:
- [:segName |
- secondary removeAllFoundIn: (segmentDictionary at: segName) first.
- (segmentDictionary at: segName) first removeAllFoundIn: kernel].
- secondary removeAllFoundIn: kernel.
- secondary removeAllFoundIn: #(PseudoContext TranslatedMethod Utilities Preferences OutOfScopeNotification FakeClassPool BlockCannotReturn FormSetFont ExternalSemaphoreTable NetNameResolver ScreenController InterpreterPlugin Command WeakSet).
- FileDirectory allSubclassesDo: [:c | secondary remove: c name ifAbsent: []].
- segmentDictionary at: 'Secondary' put: {secondary. {}}.
-
- "Now build segDict giving className -> segName, and report any duplicates."
- dups := Dictionary new.
- segDict := IdentityDictionary new: 3000.
- segmentDictionary keysDo:
- [:segName | (segmentDictionary at: segName) first do:
- [:className |
- (segDict includesKey: className) ifTrue:
- [(dups includesKey: className) ifFalse: [dups at: className put: Array new].
- dups at: className put: (dups at: className) , {segName}].
- segDict at: className put: segName]].
- dups size > 0 ifTrue: [dups inspect. ^ self error: 'Duplicate entries'].
-
- "Then for every class in every partition, make sure that neither it
- nor any of its superclasses are in any other partition. If they are,
- enter them in a dictionary of overlaps.
- If the dictionary is not empty, then stop and report it."
- overlaps := Dictionary new.
- segmentDictionary keysDo:
- [:segName |
- classes := (segmentDictionary at: segName) first asArray collect: [:k | Smalltalk at: k].
- classes do:
- [:c | (c isKindOf: Class) ifTrue:
- [c withAllSuperclasses do:
- [:sc | | n | n := segDict at: sc name ifAbsent: [segName].
- n ~= segName ifTrue:
- [n = 'Secondary'
- ifTrue: [(segmentDictionary at: 'Secondary') first
- remove: sc name ifAbsent: []]
- ifFalse: [overlaps at: c name put:
- (c withAllSuperclasses collect: [:cc | segDict associationAt: cc name ifAbsent: [cc name -> 'Kernel']])]]]]]].
- overlaps size > 0 ifTrue: [overlaps inspect. ^ self error: 'Superclasses in separate segments'].
-
- "If there are no overlaps, then proceed to write the partitioned classes."
- symbolHolder := Symbol allSymbols. "Hold onto Symbols with strong pointers,
- so they will be in outPointers"
- segmentDictionary keysDo:
- [:segName | Utilities informUser: segName during:
- [ | metas |classes := (segmentDictionary at: segName) first asArray collect: [:k | Smalltalk at: k].
- metas := classes select: [:c | c isKindOf: Class] thenCollect: [:c | c class].
- (ImageSegment new copyFromRoots: classes , metas sizeHint: 0) extract;
- writeToFile: segName]].
- symbolHolder. "Keep compiler for getting uppity."!
Item was removed:
- ----- Method: SystemDictionary>>registerExternalObject: (in category 'special objects') -----
- registerExternalObject: anObject
- "Register the given object in the external objects array and return its index. If it is already there, just return its index."
-
- ^ExternalSemaphoreTable registerExternalObject: anObject!
Item was removed:
- ----- Method: SystemDictionary>>useUpMemoryWithContexts (in category 'memory space') -----
- useUpMemoryWithContexts
- "For testing the low space handler..."
- "Smalltalk installLowSpaceWatcher; useUpMemoryWithContexts"
-
- self useUpMemoryWithContexts!
Item was removed:
- ----- Method: SystemDictionary>>garbageCollect (in category 'memory space') -----
- garbageCollect
- "Primitive. Reclaims all garbage and answers the number of bytes of available space."
- Object flushDependents.
- Object flushEvents.
- ^self primitiveGarbageCollect!
Item was removed:
- ----- Method: SystemDictionary>>verifyMorphicAvailability (in category 'miscellaneous') -----
- verifyMorphicAvailability
- "If Morphic is available, return true; if not, put up an informer and return false"
- self hasMorphic ifFalse:
- [Beeper beep.
- self inform: 'Sorry, Morphic must
- be present to use this feature'.
- ^ false].
- ^ true!
Item was removed:
- ----- Method: SystemDictionary>>removeAllLineFeedsQuietly (in category 'housekeeping') -----
- removeAllLineFeedsQuietly
- "Smalltalk removeAllLineFeedsQuietly"
- "Scan all methods for source code with lineFeeds.
- Replaces all occurrences of <CR><LF> or <LF> by <CR>.
- Answer a Dictionary keyed by author name containing sets of affected method names,
- as well as (at the key 'OK') a list of methods that still contain LF characters inside literal strings or characters."
- ^self removeAllLineFeedsQuietlyCalling: [ :cls :sel | ].!
Item was removed:
- ----- Method: SmalltalkImage>>removeAllLineFeedsQuietlyCalling: (in category 'housekeeping') -----
- removeAllLineFeedsQuietlyCalling: aBlock
- "Smalltalk removeAllLineFeedsQuietly"
- "Scan all methods for source code with lineFeeds.
- Replaces all occurrences of <CR><LF> or <LF> by <CR>.
- Answer a Dictionary keyed by author name containing sets of affected method names,
- as well as (at the key 'OK') a list of methods that still contain LF characters inside literal strings or characters.
- Evaluate aBlock for each method so that status can be updated."
- | authors |
- self forgetDoIts.
- authors := Dictionary new.
- authors at: 'OK' put: Set new.
- self systemNavigation
- allBehaviorsDo: [:cls | cls selectors
- do: [:selector | | oldCodeString oldStamp oldCategory newCodeString nameString |
- aBlock value: cls value: selector.
- oldCodeString := cls sourceCodeAt: selector.
- (oldCodeString includes: Character lf)
- ifTrue: [
- newCodeString := oldCodeString withSqueakLineEndings.
- nameString := cls name , '>>' , selector.
- ((cls compiledMethodAt: selector) hasLiteralSuchThat: [ :lit | lit asString includes: Character lf ])
- ifTrue: [(authors at: 'OK')
- add: nameString]
- ifFalse: [oldStamp := (Utilities
- timeStampForMethod: (cls compiledMethodAt: selector))
- copy replaceAll: Character cr
- with: Character space.
- (authors
- at: (oldStamp copyFrom: 1 to: (oldStamp findFirst: [ :c | c isAlphaNumeric not ]))
- ifAbsentPut: [Set new])
- add: nameString.
- oldCategory := cls whichCategoryIncludesSelector: selector.
- cls
- compile: newCodeString
- classified: oldCategory
- withStamp: oldStamp
- notifying: nil ]]]].
- ^ authors!
Item was removed:
- ----- Method: SmalltalkImage>>testFormatter (in category 'housekeeping') -----
- testFormatter
- "Smalltalk testFormatter"
-
- "Reformats the source for every method in the system, and
- then compiles that source and verifies that it generates
- identical code. The formatting used will be either classic
- monochrome or fancy polychrome, depending on the setting
- of the preference #colorWhenPrettyPrinting."
-
- "Note: removed references to Preferences colorWhenPrettyPrinting and replaced them simply with false, as I've been removing this preference lately. --Ron Spengler 8/23/09"
-
- | badOnes |
- badOnes := OrderedCollection new.
- self forgetDoIts.
- 'Formatting all classes...'
- displayProgressAt: Sensor cursorPoint
- from: 0
- to: CompiledMethod instanceCount
- during:
- [:bar | | n |
- n := 0.
- self systemNavigation allBehaviorsDo:
- [:cls |
- "Transcript cr; show: cls name."
-
- cls selectorsAndMethodsDo:
- [:selector :oldMethod |
- | newMethod newCodeString methodNode |
- (n := n + 1) \\ 100 = 0 ifTrue: [bar value: n].
- newCodeString := cls prettyPrinterClass
- format: (cls sourceCodeAt: selector)
- in: cls
- notifying: nil
- decorated: false.
- methodNode := cls compilerClass new
- compile: newCodeString
- in: cls
- notifying: nil
- ifFail: [].
- newMethod := methodNode generate.
- oldMethod = newMethod
- ifFalse:
- [Transcript
- cr;
- show: '***' , cls name , ' ' , selector.
- badOnes add: cls name , ' ' , selector]]]].
- self systemNavigation browseMessageList: badOnes asSortedCollection
- name: 'Formatter Discrepancies'!
Item was removed:
- ----- Method: SystemDictionary>>specialSelectors (in category 'special objects') -----
- specialSelectors
- "Used by SystemTracer only."
-
- ^SpecialSelectors!
Item was removed:
- ----- Method: SystemDictionary>>discardSoundSynthesis (in category 'shrinking') -----
- discardSoundSynthesis
- "Discard the sound synthesis facilities, and the methods and
- classes that use it. This also discards MIDI."
- self discardMIDI.
- self discardSpeech.
- SystemOrganization removeCategoriesMatching: 'Sound-Interface'.
- self
- at: #GraphMorph
- ifPresent: [:graphMorph | #(#playOnce #readDataFromFile )
- do: [:sel | graphMorph removeSelector: sel]].
- self
- at: #TrashCanMorph
- ifPresent: [:trashMorph |
- trashMorph class removeSelector: #samplesForDelete.
- trashMorph class removeSelector: #samplesForMouseEnter.
- trashMorph class removeSelector: #samplesForMouseLeave].
- SystemOrganization removeCategoriesMatching: 'Sound-Synthesis'.
- SystemOrganization removeCategoriesMatching: 'Sound-Scores'!
Item was removed:
- ----- Method: SystemDictionary>>primitiveGarbageCollect (in category 'memory space') -----
- primitiveGarbageCollect
- "Primitive. Reclaims all garbage and answers the number of bytes of available space."
-
- <primitive: 130>
- ^ self primBytesLeft!
Item was removed:
- ----- Method: SystemDictionary>>abandonTempNames (in category 'shrinking') -----
- abandonTempNames
- "Replaces every method by a copy with no source pointer or
- encoded temp names."
- "Smalltalk abandonTempNames"
- | continue oldMethods newMethods n |
- continue := self confirm: '-- CAUTION --
- If you have backed up your system and
- are prepared to face the consequences of
- abandoning all source code, hit Yes.
- If you have any doubts, hit No,
- to back out with no harm done.'.
- continue
- ifFalse: [^ self inform: 'Okay - no harm done'].
- self forgetDoIts; garbageCollect.
- oldMethods := OrderedCollection new.
- newMethods := OrderedCollection new.
- n := 0.
- 'Removing temp names to save space...'
- displayProgressAt: Sensor cursorPoint
- from: 0
- to: CompiledMethod instanceCount
- during: [:bar | self systemNavigation
- allBehaviorsDo: [:cl | cl methodsDo: [:m |
- bar value: (n := n + 1).
- oldMethods addLast: m.
- newMethods
- addLast: (m copyWithTrailerBytes: #(0 ))]]].
- oldMethods asArray elementsExchangeIdentityWith: newMethods asArray.
- SmalltalkImage current closeSourceFiles.
- self flag: #shouldUseAEnsureBlockToBeSureThatTheFileIsClosed.
- "sd: 17 April 2003"
- Preferences disable: #warnIfNoChangesFile.
- Preferences disable: #warnIfNoSourcesFile!
Item was removed:
- ----- Method: SystemDictionary>>forceTenure (in category 'memory space') -----
- forceTenure
- "Primitive. Tell the GC logic to force a tenure on the next increment GC."
- <primitive: 'primitiveForceTenure'>
- ^self primitiveFailed!
Item was removed:
- ----- Method: SmalltalkImage>>reconstructChanges (in category 'housekeeping') -----
- reconstructChanges
- "Move all the changes and its histories onto another sources file."
- "Smalltalk reconstructChanges"
-
- | f oldChanges |
- f := FileStream fileNamed: 'ST80.temp'.
- f header; timeStamp.
- 'Condensing Changes File...'
- displayProgressAt: Sensor cursorPoint
- from: 0 to: self classNames size + self traitNames size
- during:
- [:bar | | classCount | classCount := 0.
- Smalltalk allClassesAndTraitsDo:
- [:classOrTrait | bar value: (classCount := classCount + 1).
- classOrTrait moveChangesWithVersionsTo: f.
- classOrTrait putClassCommentToCondensedChangesFile: f.
- classOrTrait classSide moveChangesWithVersionsTo: f]].
- SmalltalkImage current lastQuitLogPosition: f position.
- f trailer; close.
- oldChanges := SourceFiles at: 2.
- oldChanges close.
- FileDirectory default
- deleteFileNamed: oldChanges name , '.old';
- rename: oldChanges name toBe: oldChanges name , '.old';
- rename: f name toBe: oldChanges name.
- self setMacFileInfoOn: oldChanges name.
- SourceFiles at: 2
- put: (FileStream oldFileNamed: oldChanges name)!
Item was removed:
- ----- Method: SmalltalkImage>>discardNetworking (in category 'shrinking') -----
- discardNetworking
- "Discard the support for TCP/IP networking."
-
- SystemOrganization removeCategoriesMatching: 'Network-*'.
-
- !
Item was removed:
- ----- Method: SmalltalkImage class>>convertFromSystemDictionary (in category 'class initialization') -----
- convertFromSystemDictionary
- "Converts Smalltalk from an instance of SystemDictionary to an instance
- of the receiver."
-
- "1. Fix up the usage of class vars"
- SystemDictionary classPool keysAndValuesDo:[:k :oldVal|
- self classPool at: k ifPresent:[:newVal| newVal ifNil:[self classPool at: k put: oldVal]].
- ].
-
- "2. Install the new globals"
- SmalltalkImage current globals: Smalltalk.
-
- "3. Update the new Smalltalk global"
- [Smalltalk := SmalltalkImage current]
- on: AttemptToWriteReadOnlyGlobal
- do:[:ex| ex resume: true].
-
- !
Item was removed:
- ----- Method: SystemDictionary>>currentProjectDo: (in category 'sources, change log') -----
- currentProjectDo: aBlock
- "So that code can work after removal of Projects"
- self
- at: #Project
- ifPresent: [:projClass | aBlock value: projClass current]!
Item was removed:
- ----- Method: SystemDictionary>>logError:inContext:to: (in category 'miscellaneous') -----
- logError: errMsg inContext: aContext to: aFilename
- "Log the error message and a stack trace to the given file."
-
- | ff |
- FileDirectory default deleteFileNamed: aFilename ifAbsent: [].
- (ff := FileStream fileNamed: aFilename) ifNil: [^ self "avoid recursive errors"].
-
- ff nextPutAll: errMsg; cr.
- aContext errorReportOn: ff.
- ff close.!
Item was removed:
- ----- Method: SmalltalkImage>>unusedClassesAndMethodsWithout: (in category 'shrinking') -----
- unusedClassesAndMethodsWithout: classesAndMessagesPair
- "Accepts and returns a pair: {set of class names. set of selectors}.
- It is expected these results will be diff'd with the normally unused
- results. "
- | classRemovals messageRemovals nClasses nMessages |
- (classRemovals := IdentitySet new) addAll: classesAndMessagesPair first.
- (messageRemovals := IdentitySet new) addAll: classesAndMessagesPair second.
- nClasses := nMessages := -1.
- ["As long as we keep making progress..."
- classRemovals size > nClasses
- or: [messageRemovals size > nMessages]]
- whileTrue: ["...keep trying for bigger sets of unused classes and selectors."
- nClasses := classRemovals size.
- nMessages := messageRemovals size.
- Utilities
- informUser: 'Iterating removals '
- , (classesAndMessagesPair first isEmpty
- ifTrue: ['for baseline...']
- ifFalse: ['for ' , classesAndMessagesPair first first , ' etc...']) , Character cr asString , nClasses printString , ' classes, ' , nMessages printString , ' messages.
- |
- |'
- during: ["spacers move menu off cursor"
- classRemovals
- addAll: (self systemNavigation allUnusedClassesWithout: {classRemovals. messageRemovals}).
- messageRemovals
- addAll: (self systemNavigation allUnSentMessagesWithout: {classRemovals. messageRemovals})]].
- ^ {classRemovals. self systemNavigation allUnSentMessagesWithout: {classRemovals. messageRemovals}}!
Item was removed:
- ----- Method: SystemDictionary>>exitToDebugger (in category 'miscellaneous') -----
- exitToDebugger
- "Primitive. Enter the machine language debugger, if one exists. Essential.
- See Object documentation whatIsAPrimitive."
-
- <primitive: 114>
- self primitiveFailed!
Item was removed:
- ----- Method: SystemDictionary>>specialSelectorAt: (in category 'special objects') -----
- specialSelectorAt: anInteger
- "Answer the special message selector from the interleaved specialSelectors array."
-
- ^ (self specialObjectsArray at: 24) at: anInteger * 2 - 1!
Item was removed:
- ----- Method: SystemDictionary>>cleanUp (in category 'housekeeping') -----
- cleanUp "Smalltalk cleanUp"
- "Gently clean up"
- ^self cleanUp: false!
Item was removed:
- ----- Method: SystemDictionary>>bytesLeftString (in category 'memory space') -----
- bytesLeftString
- "Return a string describing the amount of memory available"
- | availInternal availPhysical availTotal |
- self garbageCollect.
- availInternal := self primBytesLeft.
- availPhysical := self bytesLeft: false.
- availTotal := self bytesLeft: true.
- (availTotal > (availInternal + 10000)) "compensate for mini allocations inbetween"
- ifFalse:[^availInternal asStringWithCommas, ' bytes available'].
- ^String streamContents:[:s|
- s nextPutAll: availInternal asStringWithCommas, ' bytes (internal) '; cr.
- s nextPutAll: availPhysical asStringWithCommas, ' bytes (physical) '; cr.
- s nextPutAll: availTotal asStringWithCommas, ' bytes (total) '].!
Item was removed:
- ----- Method: SystemDictionary>>removeFromStartUpList: (in category 'snapshot and quit') -----
- removeFromStartUpList: aClass
-
- StartUpList remove: aClass name ifAbsent: []!
Item was removed:
- ----- Method: SmalltalkImage>>removeNormalCruft (in category 'shrinking') -----
- removeNormalCruft
- "Remove various graphics, uniclasses, references. Caution: see
- comment at bottom of method"
- "Smalltalk removeNormalCruft"
- ScriptingSystem stripGraphicsForExternalRelease.
- ScriptingSystem spaceReclaimed.
- References keys
- do: [:k | References removeKey: k].
- self classNames
- do: [:cName | #('Player' 'CardPlayer' 'Component' 'WonderlandActor' 'MorphicModel' 'PlayWithMe' )
- do: [:superName | ((cName ~= superName
- and: [cName beginsWith: superName])
- and: [(cName allButFirst: superName size)
- allSatisfy: [:ch | ch isDigit]])
- ifTrue: [self removeClassNamed: cName]]].
- self
- at: #Wonderland
- ifPresent: [:cls | cls removeActorPrototypesFromSystem].
- ChangeSet current clear
- "Caution: if any worlds in the image happen to have uniclass
- players associated with them, running this method would
- likely compromise their functioning and could cause errors,
- especially if the uniclass player of the current world had any
- scripts set to ticking. If that happens to you somehow, you will
- probably want to find a way to reset the offending world's
- player to be an UnscriptedCardPlayer, or perhaps nil"!
Item was removed:
- ----- Method: SystemDictionary>>okayToProceedEvenIfSpaceIsLow (in category 'memory space') -----
- okayToProceedEvenIfSpaceIsLow
- "Return true if either there is enough memory to do so safely or if the user gives permission after being given fair warning."
-
- self garbageCollectMost > self lowSpaceThreshold ifTrue: [^ true]. "quick"
- self garbageCollect > self lowSpaceThreshold ifTrue: [^ true]. "work harder"
-
- ^ self confirm:
- 'WARNING: There is not enough space to start the low space watcher.
- If you proceed, you will not be warned again, and the system may
- run out of memory and crash. If you do proceed, you can start the
- low space notifier when more space becomes available simply by
- opening and then closing a debugger (e.g., by hitting Cmd-period.)
- Do you want to proceed?'
- !
Item was removed:
- ----- Method: SystemDictionary>>addToShutDownList:after: (in category 'snapshot and quit') -----
- addToShutDownList: aClass after: predecessor
-
- self add: aClass toList: ShutDownList after: predecessor!
Item was removed:
- ----- Method: SystemDictionary>>shutDown (in category 'snapshot and quit') -----
- shutDown
- ^ SmalltalkImage current closeSourceFiles!
Item was removed:
- ----- Method: SystemDictionary>>garbageCollectMost (in category 'memory space') -----
- garbageCollectMost
- "Primitive. Reclaims recently created garbage (which is usually most of it) fairly quickly and answers the number of bytes of available space."
-
- <primitive: 131>
- ^ self primBytesLeft!
Item was removed:
- ----- Method: SystemDictionary>>hasMorphic (in category 'miscellaneous') -----
- hasMorphic
- "Answer whether the Morphic classes are available in the
- system (they may have been stripped, such as by a call to
- Smalltalk removeMorphic"
- ^ (self
- at: #Morph
- ifAbsent: [])
- isKindOf: Class!
Item was removed:
- ----- Method: SmalltalkImage>>internalizeSources (in category 'sources, changes log') -----
- internalizeSources
- "Smalltalk internalizeSources"
- "Bring the sources and changes files into memory-resident filestreams, for faster access and freedom from file-system interface. 1/29/96 sw"
-
- | reply aName aFile |
- reply := self confirm: 'CAUTION -- do not undertake this lightly!!
- If you have backed up your system and
- are prepared to face the consequences of
- the requested internalization of sources,
- hit Yes. If you have any doubts, hit No
- to back out with no harm done.'.
-
- (reply == true) ifFalse:
- [^ self inform: 'Okay - abandoned'].
-
- aName := SmalltalkImage current sourcesName.
- (aFile := SourceFiles first) == nil ifTrue:
- [(FileDirectory default fileExists: aName)
- ifFalse: [^ self halt: 'Cannot locate ', aName, ' so cannot proceed.'].
- aFile := FileStream readOnlyFileNamed: aName].
- SourceFiles at: 1 put: (ReadWriteStream with: aFile contentsOfEntireFile).
-
- aName := SmalltalkImage current changesName.
- (aFile := SourceFiles last) == nil ifTrue:
- [(FileDirectory default fileExists: aName)
- ifFalse: [^ self halt: 'Cannot locate ', aName, ' so cannot proceed.'].
- aFile := FileStream readOnlyFileNamed: aName].
- SourceFiles at: 2 put: (ReadWriteStream with: aFile contentsOfEntireFile).
-
- self inform: 'Okay, sources internalized'!
Item was removed:
- ----- Method: SmalltalkImage>>testFormatter2 (in category 'housekeeping') -----
- testFormatter2
- "Smalltalk testFormatter2"
-
- "Reformats the source for every method in the system, and
- then verifies that the order of source tokens is unchanged.
- The formatting used will be either classic monochrome or
- fancy polychrome, depending on the setting of the preference
- #colorWhenPrettyPrinting. "
-
- "Note: removed references to Preferences colorWhenPrettyPrinting and replaced them simply with false, as I've been removing this preference lately. --Ron Spengler 8/23/09"
-
- | badOnes |
- badOnes := OrderedCollection new.
- self forgetDoIts.
- 'Formatting all classes...'
- displayProgressAt: Sensor cursorPoint
- from: 0
- to: CompiledMethod instanceCount
- during:
- [:bar | | n |
- n := 0.
- self systemNavigation allBehaviorsDo:
- [:cls |
- "Transcript cr; show: cls name."
-
- cls selectorsDo:
- [:selector | | newCodeString oldCodeString oldTokens newTokens |
- (n := n + 1) \\ 100 = 0 ifTrue: [bar value: n].
- oldCodeString := (cls sourceCodeAt: selector) asString.
- newCodeString := cls prettyPrinterClass
- format: oldCodeString
- in: cls
- notifying: nil
- decorated: false.
- oldTokens := oldCodeString findTokens: Character separators.
- newTokens := newCodeString findTokens: Character separators.
- oldTokens = newTokens
- ifFalse:
- [Transcript
- cr;
- show: '***' , cls name , ' ' , selector.
- badOnes add: cls name , ' ' , selector]]]].
- self systemNavigation browseMessageList: badOnes asSortedCollection
- name: 'Formatter Discrepancies'!
Item was removed:
- ----- Method: SystemDictionary>>discardSUnit (in category 'shrinking') -----
- discardSUnit
- "Smalltalk discardSUnit"
- | oc |
- oc := OrderedCollection new.
- (self
- at: #TestCase
- ifAbsent: [^ self])
- allSubclassesWithLevelDo: [:c :i | oc addFirst: c]
- startingLevel: 0.
- oc
- do: [:c | c removeFromSystem].
- SystemOrganization removeCategoriesMatching: 'SUnit-*'!
Item was removed:
- ----- Method: SystemDictionary>>discardFlash (in category 'shrinking') -----
- discardFlash
- "Discard Flash support."
-
- SystemOrganization removeCategoriesMatching: 'Balloon-MMFlash*'
- !
Item was removed:
- ----- Method: SystemDictionary>>discardTrueType (in category 'shrinking') -----
- discardTrueType
- "Discard TrueType support."
-
- SystemOrganization removeCategoriesMatching: 'Balloon-TrueType*'.
-
- !
Item was removed:
- ----- Method: SystemDictionary>>lastRemoval (in category 'shrinking') -----
- lastRemoval
- "Smalltalk lastRemoval"
- "Some explicit removals - add unwanted methods keeping
- other methods."
- | oldDicts newDicts |
- #(#abandonSources )
- do: [:each | self class removeSelector: each].
- "Get rid of all unsent methods."
- [self removeAllUnSentMessages > 0] whileTrue.
- "Shrink method dictionaries."
- self garbageCollect.
- oldDicts := MethodDictionary allInstances.
- newDicts := Array new: oldDicts size.
- oldDicts
- withIndexDo: [:d :index | newDicts at: index put: d rehashWithoutBecome].
- oldDicts elementsExchangeIdentityWith: newDicts.
- oldDicts := newDicts := nil.
- self
- allClassesDo: [:c | c zapOrganization].
- SystemOrganization := nil.
- ChangeSet current initialize!
Item was removed:
- ----- Method: SystemDictionary>>bytesLeft: (in category 'memory space') -----
- bytesLeft: aBool
- "Return the amount of available space. If aBool is true, include possibly available swap space. If aBool is false, include possibly available physical memory. For a report on the largest free block currently availabe within Squeak memory but not counting extra memory use #primBytesLeft."
- <primitive: 112>
- ^self primBytesLeft!
Item was removed:
- ----- Method: SystemDictionary>>rootTable (in category 'memory space') -----
- rootTable
- "Primitive. Answer a snapshot of the VMs root table.
- Keep in mind that the primitive may itself cause GC."
- <primitive: 'primitiveRootTable'>
- ^self primitiveFailed!
Item was removed:
- ----- Method: SystemDictionary>>externalObjects (in category 'special objects') -----
- externalObjects
- "Return an array of objects that have been registered for use in non-Smalltalk code. Smalltalk objects should be referrenced by external code only via indirection through this array, thus allowing the objects to move during compaction. This array can be cleared when the VM re-starts, since variables in external code do not survive snapshots. Note that external code should not attempt to access a Smalltalk object, even via this mechanism, while garbage collection is in progress."
- "Smalltalk externalObjects"
-
- ^ ExternalSemaphoreTable externalObjects
- !
Item was removed:
- ----- Method: SystemDictionary>>majorShrink (in category 'shrinking') -----
- majorShrink
- "Undertake a major shrinkage of the image.
- This method throws out lots of the system that is not needed
- for, eg, operation in a hand-held PC. majorShrink produces a
- 999k image in Squeak 2.8
- Smalltalk majorShrink; abandonSources; lastRemoval"
- | oldDicts newDicts |
- self isMorphic
- ifTrue: [^ self error: 'You can only run majorShrink in MVC'].
- Project current isTopProject
- ifFalse: [^ self error: 'You can only run majorShrink in the top project'].
- (self confirm: 'All sub-projects will be deleted from this image.
- You should already have made a backup copy,
- or you must save with a different name after shrinking.
- Shall we proceed to discard most of the content in this image?')
- ifFalse: [^ self inform: 'No changes have been made.'].
- "Remove all projects but the current one. - saves 522k"
- Smalltalk at: #ProjectView ifPresent: [:pvClass |
- pvClass allInstancesDo: [:pv | pv controller closeAndUnscheduleNoTerminate]].
- Project current setParent: Project current.
- Smalltalk at: #Wonderland ifPresent: [:cls |
- cls removeActorPrototypesFromSystem].
- Smalltalk at: #Player ifPresent:[:aClass| aClass freeUnreferencedSubclasses].
- MorphicModel removeUninstantiatedModels.
- Utilities classPool at: #ScrapsBook put: nil.
- Utilities zapUpdateDownloader.
- ProjectHistory currentHistory initialize.
- Project rebuildAllProjects.
- "Smalltalk discardVMConstruction."
- "755k"
- self discardSoundSynthesis.
- "544k"
- self discardOddsAndEnds.
- "227k"
- self discardNetworking.
- "234k"
- "Smalltalk discard3D."
- "407k"
- self discardFFI.
- "33k"
- self discardMorphic.
- "1372k"
- Symbol rehash.
- "40k"
- "Above by itself saves about 4,238k"
- "Remove references to a few classes to be deleted, so that they
- won't leave obsolete versions around."
- ChangeSet class compile: 'defaultName
- ^ ''Changes'' ' classified: 'initialization'.
- Smalltalk at: #ScreenController ifPresent: [:sc |
- sc removeSelector: #openChangeManager.
- sc removeSelector: #exitProject.
- sc removeSelector: #openProject.
- sc removeSelector: #viewImageImports].
- "Now delete various other classes.."
- SystemOrganization removeSystemCategory: 'Graphics-Files'.
- SystemOrganization removeSystemCategory: 'System-Object Storage'.
- self removeClassNamed: #ProjectController.
- self removeClassNamed: #ProjectView.
- "Smalltalk removeClassNamed: #Project."
- self removeClassNamed: #Component1.
- self removeClassNamed: #FormSetFont.
- self removeClassNamed: #FontSet.
- self removeClassNamed: #InstructionPrinter.
- self removeClassNamed: #ChangeSorter.
- self removeClassNamed: #DualChangeSorter.
- self removeClassNamed: #EmphasizedMenu.
- self removeClassNamed: #MessageTally.
- StringHolder class removeSelector: #originalWorkspaceContents.
- CompiledMethod removeSelector: #symbolic.
- RemoteString removeSelector: #makeNewTextAttVersion.
- Utilities class removeSelector: #absorbUpdatesFromServer.
- self removeClassNamed: #PenPointRecorder.
- self removeClassNamed: #Path.
- self removeClassNamed: #Base64MimeConverter.
- "Smalltalk removeClassNamed: #EToySystem. Dont bother - its
- very small and used for timestamps etc"
- self removeClassNamed: #RWBinaryOrTextStream.
- self removeClassNamed: #AttributedTextStream.
- self removeClassNamed: #WordNet.
- self removeClassNamed: #SelectorBrowser.
- TextStyle
- allSubInstancesDo: [:ts | ts
- newFontArray: (ts fontArray
- copyFrom: 1
- to: (2 min: ts fontArray size))].
- #(ListParagraph PopUpMenu StandardSystemView) do:[:className|
- Smalltalk at: className ifPresent:[:aClass| aClass initialize].
- ].
- ChangeSet noChanges.
- ChangeSet classPool
- at: #AllChangeSets
- put: (OrderedCollection with: ChangeSet current).
- SystemDictionary removeSelector: #majorShrink.
- [self removeAllUnSentMessages > 0]
- whileTrue: [Smalltalk unusedClasses
- do: [:c | (Smalltalk at: c) removeFromSystem]].
- SystemOrganization removeEmptyCategories.
- self
- allClassesDo: [:c | c zapOrganization].
- self garbageCollect.
- 'Rehashing method dictionaries . . .'
- displayProgressAt: Sensor cursorPoint
- from: 0
- to: MethodDictionary instanceCount
- during: [:bar |
- oldDicts := MethodDictionary allInstances.
- newDicts := Array new: oldDicts size.
- oldDicts
- withIndexDo: [:d :index |
- bar value: index.
- newDicts at: index put: d rehashWithoutBecome].
- oldDicts elementsExchangeIdentityWith: newDicts].
- oldDicts := newDicts := nil.
- Project rebuildAllProjects.
- ChangeSet current initialize.
- "seems to take more than one try to gc all the weak refs in
- SymbolTable "
- 3
- timesRepeat: [self garbageCollect.
- Symbol compactSymbolTable]!
Item was removed:
- ----- Method: SystemDictionary>>setMacFileInfoOn: (in category 'miscellaneous') -----
- setMacFileInfoOn: aString
- "On Mac, set the file type and creator (noop on other platforms)"
- FileDirectory default
- setMacFileNamed: aString
- type: 'STch'
- creator: 'FAST'.!
Item was removed:
- ----- Method: SystemDictionary>>wordSize (in category 'sources, change log') -----
- wordSize
- "Answer the size in bytes of an object pointer or word in the object memory.
- The value does not change for a given image, but may be modified by a SystemTracer
- when converting the image to another format. The value is cached in WordSize to
- avoid the performance overhead of repeatedly consulting the VM."
-
- "Smalltalk wordSize"
-
- ^ WordSize ifNil: [WordSize := [SmalltalkImage current vmParameterAt: 40] on: Error do: [4]]!
Item was removed:
- ----- Method: SmalltalkImage>>doesNotUnderstand: (in category 'dictionary access') -----
- doesNotUnderstand: aMessage
- "Forward to globals if understood"
- (globals respondsTo: aMessage selector) ifTrue:[
- Transcript cr; show: aMessage selector.
- ^globals perform: aMessage selector withArguments: aMessage arguments
- ].
- ^super doesNotUnderstand: aMessage
- !
Item was removed:
- ----- Method: SmalltalkImage>>removeAllLineFeeds (in category 'housekeeping') -----
- removeAllLineFeeds
- "Smalltalk removeAllLineFeeds"
- "Scan all methods for source code with lineFeeds.
- Replaces all occurrences of <CR><LF> or <LF> by <CR>.
- When done, offers to display an Inspector containing the message
- names grouped by author initials.
- In this dictionary, the key 'OK' contains the methods that had literals that contained <LF> characters."
- | totalStripped totalOK authors |
- 'Scanning sources for LineFeeds.
- This will take a few minutes...'
- displayProgressAt: Sensor cursorPoint
- from: 0
- to: CompiledMethod instanceCount
- during: [:bar | | n |
- n := 0.
- authors := self
- removeAllLineFeedsQuietlyCalling: [:cls :sel | (n := n + 1) \\ 100 = 0
- ifTrue: [bar value: n]]].
- totalStripped := authors
- inject: 1
- into: [:sum :set | sum + set size].
- totalOK := (authors at: 'OK') size.
- totalStripped := totalStripped - totalOK.
- Transcript cr; show: totalStripped printString , ' methods stripped of LFs.'.
- Transcript cr; show: totalOK printString , ' methods still correctly contain LFs.'.
- (self confirm: 'Do you want to see the affected methods?')
- ifTrue: [authors inspect]!
Item was removed:
- ----- Method: SystemDictionary>>unusedClasses (in category 'shrinking') -----
- unusedClasses
- "Enumerates all classes in the system and returns a list of those that are
- apparently unused. A class is considered in use if it (a) has subclasses
- or (b) is referred to by some method or (c) has its name in use as a
- literal. "
- "Smalltalk unusedClasses asSortedCollection"
- ^ self systemNavigation allUnusedClassesWithout: {{}. {}}!
Item was removed:
- ----- Method: SystemDictionary>>m17nVersion (in category 'miscellaneous') -----
- m17nVersion
-
- ^ 'M17n 5.0' copy
- !
Item was removed:
- ----- Method: SystemDictionary>>makeExternalRelease (in category 'housekeeping') -----
- makeExternalRelease
- "Smalltalk makeExternalRelease"
- (self confirm: SystemVersion current version , '
- Is this the correct version designation?
- If not, choose no, and fix it.')
- ifFalse: [^ self].
- "Object classPool at: #DependentsFields"
- self reclaimDependents.
- Preferences enable: #mvcProjectsAllowed.
- Preferences enable: #fastDragWindowForMorphic.
- Smalltalk at: #Browser ifPresent:[:br| br initialize].
- Undeclared isEmpty
- ifFalse: [self halt].
- ScriptingSystem deletePrivateGraphics.
- #(#Helvetica #Palatino #Courier )
- do: [:n | TextConstants
- removeKey: n
- ifAbsent: []].
- (Utilities classPool at: #UpdateUrlLists) copy
- do: [:pair | (pair first includesSubstring: 'Disney' caseSensitive: false)
- ifTrue: [(Utilities classPool at: #UpdateUrlLists)
- remove: pair]].
- (ServerDirectory serverNames copyWithoutAll: #('UCSBCreateArchive' 'UIUCArchive' 'UpdatesExtUIUC' 'UpdatesExtWebPage' ))
- do: [:sn | ServerDirectory removeServerNamed: sn].
- self garbageCollect.
- self obsoleteClasses isEmpty
- ifFalse: [self halt].
- Symbol rehash.
- self halt: 'Ready to condense changes or sources'!
Item was removed:
- ----- Method: SystemDictionary>>send:toClassesNamedIn:with: (in category 'snapshot and quit') -----
- send: startUpOrShutDown toClassesNamedIn: startUpOrShutDownList with: argument
- "Send the message #startUp: or #shutDown: to each class named in the list.
- The argument indicates if the system is about to quit (for #shutDown:) or if
- the image is resuming (for #startUp:).
- If any name cannot be found, then remove it from the list."
-
- | removals |
- removals := OrderedCollection new.
- startUpOrShutDownList do:
- [:name | | class |
- class := self at: name ifAbsent: [nil].
- class == nil
- ifTrue: [removals add: name]
- ifFalse: [class isInMemory ifTrue:
- [class perform: startUpOrShutDown with: argument]]].
-
- "Remove any obsolete entries, but after the iteration"
- startUpOrShutDownList removeAll: removals!
Item was removed:
- ----- Method: SystemDictionary>>isMorphic (in category 'snapshot and quit') -----
- isMorphic
- "Answer true if the user interface is running in Morphic rathern than
- MVC. By convention the gloabl variable World is set to nil when MVC is
- running. ScheduledControllers could be set to nil when Morphic is
- running, but this symmetry is not yet in effect."
-
- ^ World ~~ nil "or: [RequestCurrentWorldNotification signal notNil]"!
Item was removed:
- ----- Method: SystemDictionary>>condenseSources (in category 'housekeeping') -----
- condenseSources
- "Move all the changes onto a compacted sources file."
- "Smalltalk condenseSources"
-
- | newSourcesFile defaultDirectory newVersion currentVersion |
- Utilities fixUpProblemsWithAllCategory.
- "The above removes any concrete, spurious '-- all --' categories, which mess up the process."
- defaultDirectory := FileDirectory default.
- currentVersion := SmalltalkImage current sourceFileVersionString.
- newVersion := UIManager default
- request: 'Please designate the version\for the new source code file...' withCRs
- initialAnswer: currentVersion.
- newVersion ifEmpty: [ ^ self ].
- newVersion = currentVersion ifTrue: [ ^ self error: 'The new source file must not be the same as the old.' ].
- SmalltalkImage current sourceFileVersionString: newVersion.
-
- "Write all sources with fileIndex 1"
- newSourcesFile := defaultDirectory newFileNamed: (defaultDirectory localNameFor: SmalltalkImage current sourcesName).
- newSourcesFile ifNil: [ ^ self error: 'Couldn''t create source code file in\' withCRs, defaultDirectory name].
- newSourcesFile
- header;
- timeStamp.
- 'Condensing Sources File...'
- displayProgressAt: Sensor cursorPoint
- from: 0
- to: self classNames size + self traitNames size
- during:
- [ :bar |
- | count |
- count := 0.
- Smalltalk allClassesAndTraitsDo:
- [ :classOrTrait |
- bar value: (count := count + 1).
- classOrTrait
- fileOutOn: newSourcesFile
- moveSource: true
- toFile: 1 ] ].
- newSourcesFile
- trailer;
- close.
-
- "Make a new empty changes file"
- SmalltalkImage current closeSourceFiles.
- defaultDirectory
- rename: SmalltalkImage current changesName
- toBe: SmalltalkImage current changesName , '.old'.
- (FileStream newFileNamed: SmalltalkImage current changesName)
- header;
- timeStamp;
- close.
- SmalltalkImage current lastQuitLogPosition: 0.
- self setMacFileInfoOn: SmalltalkImage current changesName.
- self setMacFileInfoOn: newSourcesFile name.
- SmalltalkImage current openSourceFiles.
- self inform: 'Source files have been rewritten to\' withCRs, newSourcesFile name, '\Check that all is well,\and then save/quit.' withCRs!
Item was removed:
- ----- Method: SystemDictionary>>processShutDownList: (in category 'snapshot and quit') -----
- processShutDownList: quitting
- "Send #shutDown to each class that needs to wrap up before a snapshot."
-
- self send: #shutDown: toClassesNamedIn: ShutDownList with: quitting.
- !
Item was removed:
- ----- Method: SmalltalkImage>>internalizeChangeLog (in category 'sources, changes log') -----
- internalizeChangeLog
- "Smalltalk internalizeChangeLog"
- "Bring the changes file into a memory-resident filestream, for faster access and freedom from external file system. 1/31/96 sw"
-
- | reply aName aFile |
- reply := self confirm: 'CAUTION -- do not undertake this lightly!!
- If you have backed up your system and
- are prepared to face the consequences of
- the requested internalization of sources,
- hit Yes. If you have any doubts, hit No
- to back out with no harm done.'.
-
- (reply == true) ifFalse:
- [^ self inform: 'Okay - abandoned'].
-
- aName := SmalltalkImage current changesName.
- (aFile := SourceFiles last) == nil ifTrue:
- [(FileDirectory default fileExists: aName)
- ifFalse: [^ self halt: 'Cannot locate ', aName, ' so cannot proceed.'].
- aFile := FileStream readOnlyFileNamed: aName].
- SourceFiles at: 2 put: (ReadWriteStream with: aFile contentsOfEntireFile).
-
- self inform: 'Okay, changes file internalized'!
Item was removed:
- ----- Method: SystemDictionary>>zapAllOtherProjects (in category 'shrinking') -----
- zapAllOtherProjects
- "Smalltalk zapAllOtherProjects"
- "Note: as of this writing, the only reliable way to get rid of all but the current project is te execute the following, one line at a time...
- Smalltalk zapAllOtherProjects.
- ProjectHistory currentHistory initialize.
- Smalltalk garbageCollect.
- Project rebuildAllProjects.
- "
-
-
- Project allInstancesDo: [:p | p setParent: nil].
- Project current setParent: Project current.
- Project current isMorphic ifTrue: [ScheduledControllers := nil].
- TheWorldMenu allInstancesDo: [:m | 1 to: m class instSize do: [:i | m instVarAt: i put: nil]].
- ChangeSet classPool at: #AllChangeSets put: nil.
- Project classPool at: #AllProjects put: nil.
- ProjectHistory currentHistory initialize.
- ChangeSet initialize.
- Project rebuildAllProjects. "Does a GC"
- Project allProjects size > 1 ifTrue: [Project allProjects inspect]!
Item was removed:
- ----- Method: SystemDictionary>>cleanUp:except: (in category 'housekeeping') -----
- cleanUp: aggressive except: exclusions
- "Clean up. When aggressive is true, this will destroy projects, change sets, etc.
- Leave out any classes specifically listed in exclusions."
-
- "Smalltalk cleanUp: true except: {Project. ChangeSet}"
-
- | classes |
- aggressive ifTrue:[
- "Give the user a chance to bail"
- (self confirm: 'Aggressive cleanup will destroy projects, change sets and more.
- Are you sure you want to proceed?') ifFalse:[^self].
- ].
-
- "Find all classes implementing #cleanUp or cleanUp:"
- classes := Smalltalk allClasses select:[:aClass|
- (aClass class includesSelector: #cleanUp)
- or:[aClass class includesSelector: #cleanUp:]
- ].
-
- "Leave out the classes in the exclusion set"
- classes := classes reject:[:aClass| exclusions includes: aClass].
-
- "Arrange classes in superclass order, superclasses before subclasses.
- This will ensure that specific cleanup (like MethodDictionary compaction)
- will run after generic superclass cleanup (HashedCollection rehashing).
- Otherwise generic superclass cleanup might undo specific one (in this
- case rehashing will undo a good bit of MD compaction)."
- classes := ChangeSet superclassOrder: classes.
-
- "Run the cleanup code"
- classes
- do:[:aClass| aClass cleanUp: aggressive]
- displayingProgress:[:aClass| 'Cleaning up in ', aClass name].!
Item was removed:
- ----- Method: SmalltalkImage>>discardFFI (in category 'shrinking') -----
- discardFFI
- "Discard the complete foreign function interface.
- NOTE: Recreates specialObjectsArray to prevent obsolete
- references. Has to specially remove external structure
- hierarchy before ExternalType"
- self
- at: #ExternalStructure
- ifPresent: [:cls | (ChangeSet superclassOrder: cls withAllSubclasses asArray)
- reverseDo: [:c | c removeFromSystem]].
- SystemOrganization removeCategoriesMatching: 'FFI-*'.
- self recreateSpecialObjectsArray.
- "Remove obsolete refs"
- ByteArray removeSelector: #asExternalPointer.
- ByteArray removeSelector: #pointerAt:!
Item was removed:
- ----- Method: SystemDictionary>>lowSpaceThreshold (in category 'memory space') -----
- lowSpaceThreshold
- "Return the low space threshold. When the amount of free memory (after garbage collection) falls below this limit, the system is in serious danger of completely exhausting memory and crashing. This limit should be made high enough to allow the user open a debugger to diagnose a problem or to save the image."
-
- thisContext isPseudoContext
- ifTrue: [^ 400000 "Enough for JIT compiler"]
- ifFalse: [^ 200000 "Enough for interpreter"]!
Item was removed:
- ----- Method: SystemDictionary>>condenseChanges (in category 'housekeeping') -----
- condenseChanges
- "Move all the changes onto a compacted sources file."
- "Smalltalk condenseChanges"
- | f oldChanges |
- f := FileStream fileNamed: 'ST80.temp'.
- f header; timeStamp.
- 'Condensing Changes File...'
- displayProgressAt: Sensor cursorPoint
- from: 0
- to: self classNames size + self traitNames size
- during: [:bar | | count |
- count := 0.
- self
- allClassesAndTraitsDo: [:classOrTrait |
- bar value: (count := count + 1).
- classOrTrait moveChangesTo: f.
- classOrTrait putClassCommentToCondensedChangesFile: f.
- classOrTrait classSide moveChangesTo: f]].
- SmalltalkImage current lastQuitLogPosition: f position.
- f trailer; close.
- oldChanges := SourceFiles at: 2.
- oldChanges close.
- FileDirectory default deleteFileNamed: oldChanges name , '.old';
- rename: oldChanges name toBe: oldChanges name , '.old';
- rename: f name toBe: oldChanges name.
- self setMacFileInfoOn: oldChanges name.
- SourceFiles
- at: 2
- put: (FileStream oldFileNamed: oldChanges name)!
Item was removed:
- ----- Method: SystemDictionary>>nihongoVersion (in category 'miscellaneous') -----
- nihongoVersion
-
- ^ 'Nihongo7.0' copy
- !
Item was removed:
- ----- Method: SmalltalkImage>>discardOddsAndEnds (in category 'shrinking') -----
- discardOddsAndEnds
- "This method throws out lots of classes that are not frequently
- used."
- "Smalltalk discardOddsAndEnds"
- self organization removeSystemCategory: 'System-Serial Port'.
- self organization removeSystemCategory: 'ST80-Symbols'.
- self organization removeSystemCategory: 'Tools-File Contents Browser'.
- self organization removeSystemCategory: 'System-Compression'.
- self organization removeSystemCategory: 'Tools-Explorer'.
- self organization removeSystemCategory: 'System-Digital Signatures'.
- Form removeSelector: #edit.
- self
- at: #FormView
- ifPresent: [:c | c compile: 'defaultControllerClass ^ NoController' classified: 'controller access'].
- self removeClassNamed: #FormEditorView.
- self removeClassNamed: #FormEditor.
- self organization removeSystemCategory: 'ST80-Paths'.
- "bit editor (remove Form editor first):"
- Form removeSelector: #bitEdit.
- Form removeSelector: #bitEditAt:scale:.
- StrikeFont removeSelector: #edit:.
- self removeClassNamed: #FormButtonCache.
- self removeClassNamed: #FormMenuController.
- self removeClassNamed: #FormMenuView.
- self removeClassNamed: #BitEditor.
- "inspector for Dictionaries of Forms"
- Dictionary removeSelector: #inspectFormsWithLabel:.
- SystemDictionary removeSelector: #viewImageImports.
- self
- at: #ScreenController
- ifPresent: [:c | c removeSelector: #viewImageImport].
- self removeClassNamed: #FormHolderView.
- self removeClassNamed: #FormInspectView.
- "experimental updating object viewer:"
- Object removeSelector: #evaluate:wheneverChangeIn:.
- self removeClassNamed: #ObjectViewer.
- self removeClassNamed: #ObjectTracer.
- "miscellaneous classes:"
- self removeClassNamed: #Array2D.
- self removeClassNamed: #DriveACar.
- self removeClassNamed: #EventRecorder.
- self removeClassNamed: #FindTheLight.
- self removeClassNamed: #PluggableTest.
- self removeClassNamed: #SystemMonitor.
- self removeClassNamed: #ProtocolBrowser.
- self removeClassNamed: #ObjectExplorerWrapper.
- self removeClassNamed: #HierarchyBrowser.
- self removeClassNamed: #LinkedMessageSet.
- self removeClassNamed: #ObjectExplorer.
- self removeClassNamed: #PackageBrowser.
- self removeClassNamed: #AbstractHierarchicalList.
- self removeClassNamed: #ChangeList.
- self removeClassNamed: #VersionsBrowser.
- self removeClassNamed: #ChangeRecord.
- self removeClassNamed: #SelectorBrowser.
- self removeClassNamed: #HtmlFileStream.
- self removeClassNamed: #CrLfFileStream.
- self removeClassNamed: #FXGrafPort.
- self removeClassNamed: #FXBlt.
- self
- at: #SampledSound
- ifPresent: [:c | c initialize].
- #(#Helvetica #Palatino #Courier #ComicBold #ComicPlain )
- do: [:k | TextConstants
- removeKey: k
- ifAbsent: []].
- Preferences
- setButtonFontTo: (StrikeFont familyName: #NewYork size: 12).
- Preferences
- setFlapsFontTo: (StrikeFont familyName: #NewYork size: 12).
- #(#GZipConstants #ZipConstants #KlattResonatorIndices )
- do: [:k | self
- removeKey: k
- ifAbsent: []]!
Item was removed:
- ----- Method: SystemDictionary>>reclaimDependents (in category 'housekeeping') -----
- reclaimDependents
- "No-opped due to weak dictionary in use"
- self garbageCollect!
Item was removed:
- ----- Method: SystemDictionary>>removeSelector: (in category 'shrinking') -----
- removeSelector: descriptor
- "Safely remove a selector from a class (or metaclass). If the
- class or the method doesn't exist anymore, never mind and
- answer nil.
- This method should be used instead of 'Class removeSelector:
- #method' to omit global class references."
- | class sel |
- class := self
- at: descriptor first
- ifAbsent: [^ nil].
- (descriptor size > 2
- and: [descriptor second == #class])
- ifTrue: [class := class class.
- sel := descriptor third]
- ifFalse: [sel := descriptor second].
- ^ class removeSelector: sel!
Item was removed:
- ----- Method: SystemDictionary>>setGCBiasToGrowGCLimit: (in category 'memory space') -----
- setGCBiasToGrowGCLimit: aNumber
- "Primitive. Indicate that the bias to grow logic should do a GC after aNumber Bytes"
- <primitive: 'primitiveSetGCBiasToGrowGCLimit'>
- ^self primitiveFailed
- "Example:
- Smalltalk setGCBiasToGrowGCLimit: 16*1024*1024.
- "!
Item was removed:
- ----- Method: SystemDictionary>>reportClassAndMethodRemovalsFor: (in category 'shrinking') -----
- reportClassAndMethodRemovalsFor: collectionOfClassNames
- | initialClassesAndMethods finalClassesAndMethods |
- "Smalltalk reportClassAndMethodRemovalsFor: #(Celeste Scamper MailMessage)"
-
- initialClassesAndMethods := self unusedClassesAndMethodsWithout: {{}. {}}.
- finalClassesAndMethods := self unusedClassesAndMethodsWithout: {collectionOfClassNames. {}}.
- ^ {finalClassesAndMethods first copyWithoutAll: initialClassesAndMethods first.
- finalClassesAndMethods second copyWithoutAll: initialClassesAndMethods second}!
Item was removed:
- ----- Method: SystemDictionary>>cleanOutUndeclared (in category 'housekeeping') -----
- cleanOutUndeclared
- Undeclared removeUnreferencedKeys!
Item was removed:
- ----- Method: SystemDictionary>>installLowSpaceWatcher (in category 'memory space') -----
- installLowSpaceWatcher
- "Start a process to watch for low-space conditions."
- "Smalltalk installLowSpaceWatcher"
-
- self primSignalAtBytesLeft: 0. "disable low-space interrupts"
- LowSpaceProcess == nil ifFalse: [LowSpaceProcess terminate].
- LowSpaceProcess := [self lowSpaceWatcher] newProcess.
- LowSpaceProcess priority: Processor lowIOPriority.
- LowSpaceProcess resume.
-
- !
Item was removed:
- ----- Method: SmalltalkImage>>discardMorphic (in category 'shrinking') -----
- discardMorphic
- "Discard Morphic.
- Updated for 2.8 TPR"
- "Smalltalk discardMorphic"
- "Check that we are in an MVC Project and that there are no
- Morphic Projects
- or WorldMorphViews."
- | subs |
- Flaps clobberFlapTabList.
- self discardFlash.
- self discardTrueType.
- subs := OrderedCollection new.
- Morph
- allSubclassesWithLevelDo: [:c :i | subs addFirst: c]
- startingLevel: 0.
- subs
- do: [:c | c removeFromSystem].
- self removeClassNamed: #CornerRounder.
- self
- removeKey: #BalloonEngineConstants
- ifAbsent: [].
- SystemOrganization removeCategoriesMatching: 'Balloon-*'.
- SystemOrganization removeCategoriesMatching: 'Morphic-*'.
- SystemOrganization removeSystemCategory: 'Graphics-Transformations'.
- SystemOrganization removeSystemCategory: 'ST80-Morphic'.
- ScriptingSystem := nil!
Item was removed:
- ----- Method: SystemDictionary>>snapshotPrimitive (in category 'snapshot and quit') -----
- snapshotPrimitive
- "Primitive. Write the current state of the object memory on a file in the
- same format as the Smalltalk-80 release. The file can later be resumed,
- returning you to this exact state. Return normally after writing the file.
- Essential. See Object documentation whatIsAPrimitive."
-
- <primitive: 97>
- ^nil "indicates error writing image file"!
Item was removed:
- ----- Method: SystemDictionary>>primLowSpaceSemaphore: (in category 'memory space') -----
- primLowSpaceSemaphore: aSemaphore
- "Primitive. Register the given Semaphore to be signalled when the
- number of free bytes drops below some threshold. Disable low-space
- interrupts if the argument is nil."
-
- <primitive: 124>
- self primitiveFailed!
Item was removed:
- ----- Method: SmalltalkImage>>writeImageSegmentsFrom:withKernel: (in category 'shrinking') -----
- writeImageSegmentsFrom: segmentDictionary withKernel: kernel
- "segmentDictionary is associates segmentName -> {classNames. methodNames},
- and kernel is another set of classNames determined to be essential.
- Add a partition, 'Secondary' with everything not in partitions and not in the kernel.
- Then write segments based on this partitioning of classes."
-
- | secondary dups segDict overlaps symbolHolder classes |
- "First, put all classes that are in no other partition, and not in kernel into a new partition called 'Secondary'. Also remove any classes in kernel from putative partitions."
- secondary := Smalltalk classNames asIdentitySet.
- segmentDictionary keysDo:
- [:segName |
- secondary removeAllFoundIn: (segmentDictionary at: segName) first.
- (segmentDictionary at: segName) first removeAllFoundIn: kernel].
- secondary removeAllFoundIn: kernel.
- secondary removeAllFoundIn: #(PseudoContext TranslatedMethod Utilities Preferences OutOfScopeNotification FakeClassPool BlockCannotReturn FormSetFont ExternalSemaphoreTable NetNameResolver ScreenController InterpreterPlugin Command WeakSet).
- FileDirectory allSubclassesDo: [:c | secondary remove: c name ifAbsent: []].
- segmentDictionary at: 'Secondary' put: {secondary. {}}.
-
- "Now build segDict giving className -> segName, and report any duplicates."
- dups := Dictionary new.
- segDict := IdentityDictionary new: 3000.
- segmentDictionary keysDo:
- [:segName | (segmentDictionary at: segName) first do:
- [:className |
- (segDict includesKey: className) ifTrue:
- [(dups includesKey: className) ifFalse: [dups at: className put: Array new].
- dups at: className put: (dups at: className) , {segName}].
- segDict at: className put: segName]].
- dups size > 0 ifTrue: [dups inspect. ^ self error: 'Duplicate entries'].
-
- "Then for every class in every partition, make sure that neither it
- nor any of its superclasses are in any other partition. If they are,
- enter them in a dictionary of overlaps.
- If the dictionary is not empty, then stop and report it."
- overlaps := Dictionary new.
- segmentDictionary keysDo:
- [:segName |
- classes := (segmentDictionary at: segName) first asArray collect: [:k | Smalltalk at: k].
- classes do:
- [:c | (c isKindOf: Class) ifTrue:
- [c withAllSuperclasses do:
- [:sc | | n | n := segDict at: sc name ifAbsent: [segName].
- n ~= segName ifTrue:
- [n = 'Secondary'
- ifTrue: [(segmentDictionary at: 'Secondary') first
- remove: sc name ifAbsent: []]
- ifFalse: [overlaps at: c name put:
- (c withAllSuperclasses collect: [:cc | segDict associationAt: cc name ifAbsent: [cc name -> 'Kernel']])]]]]]].
- overlaps size > 0 ifTrue: [overlaps inspect. ^ self error: 'Superclasses in separate segments'].
-
- "If there are no overlaps, then proceed to write the partitioned classes."
- symbolHolder := Symbol allSymbols. "Hold onto Symbols with strong pointers,
- so they will be in outPointers"
- segmentDictionary keysDo:
- [:segName | Utilities informUser: segName during:
- [ | metas |classes := (segmentDictionary at: segName) first asArray collect: [:k | Smalltalk at: k].
- metas := classes select: [:c | c isKindOf: Class] thenCollect: [:c | c class].
- (ImageSegment new copyFromRoots: classes , metas sizeHint: 0) extract;
- writeToFile: segName]].
- symbolHolder. "Keep compiler for getting uppity."!
Item was removed:
- ----- Method: SmalltalkImage>>removeAllLineFeedsQuietly (in category 'housekeeping') -----
- removeAllLineFeedsQuietly
- "Smalltalk removeAllLineFeedsQuietly"
- "Scan all methods for source code with lineFeeds.
- Replaces all occurrences of <CR><LF> or <LF> by <CR>.
- Answer a Dictionary keyed by author name containing sets of affected method names,
- as well as (at the key 'OK') a list of methods that still contain LF characters inside literal strings or characters."
- ^self removeAllLineFeedsQuietlyCalling: [ :cls :sel | ].!
Item was removed:
- ----- Method: SystemDictionary>>signalLowSpace (in category 'memory space') -----
- signalLowSpace
- "Signal the low-space semaphore to alert the user that space is running low."
-
- LowSpaceSemaphore signal.!
Item was removed:
- ----- Method: SystemDictionary>>compressSources (in category 'housekeeping') -----
- compressSources
- "Copy all the source file to a compressed file. Usually preceded by Smalltalk condenseSources."
- "The new file will be created in the default directory, and the code in openSources
- will try to open it if it is there, otherwise it will look for normal sources."
- "Smalltalk compressSources"
-
- | f cfName cf |
- f := SourceFiles first readOnlyCopy binary. "binary to preserve utf8 encoding"
- (f localName endsWith: 'sources')
- ifTrue: [cfName := (f localName allButLast: 7) , 'stc']
- ifFalse: [self error: 'Hey, I thought the sources name ended with ''.sources''.'].
- cf := (CompressedSourceStream on: (FileStream newFileNamed: cfName))
- segmentSize: 65536 maxSize: f size.
-
- "Copy the sources"
- 'Compressing Sources File...'
- displayProgressAt: Sensor cursorPoint
- from: 0 to: f size
- during:
- [:bar | f position: 0.
- [f atEnd] whileFalse:
- [cf nextPutAll: (f next: 65536).
- bar value: f position]].
- cf close.
- self setMacFileInfoOn: cfName.
- self inform: 'You now have a compressed sources file!!
- Squeak will use it the next time you start.'!
Item was removed:
- ----- Method: SmalltalkImage>>discardSoundSynthesis (in category 'shrinking') -----
- discardSoundSynthesis
- "Discard the sound synthesis facilities, and the methods and
- classes that use it. This also discards MIDI."
- self discardMIDI.
- self discardSpeech.
- SystemOrganization removeCategoriesMatching: 'Sound-Interface'.
- self
- at: #GraphMorph
- ifPresent: [:graphMorph | #(#playOnce #readDataFromFile )
- do: [:sel | graphMorph removeSelector: sel]].
- self
- at: #TrashCanMorph
- ifPresent: [:trashMorph |
- trashMorph class removeSelector: #samplesForDelete.
- trashMorph class removeSelector: #samplesForMouseEnter.
- trashMorph class removeSelector: #samplesForMouseLeave].
- SystemOrganization removeCategoriesMatching: 'Sound-Synthesis'.
- SystemOrganization removeCategoriesMatching: 'Sound-Scores'!
Item was removed:
- ----- Method: SystemDictionary>>computeImageSegmentation (in category 'shrinking') -----
- computeImageSegmentation
- "Smalltalk computeImageSegmentation"
- "Here's how the segmentation works:
- For each partition, we collect the classes involved, and also all
- messages no longer used in the absence of this partition. We
- start by computing a 'Miscellaneous' segment of all the
- unused classes in the system as is."
- | partitions unusedCandM newClasses expandedCandM |
- partitions := Dictionary new.
- unusedCandM := self unusedClassesAndMethodsWithout: {{}. {}}.
- partitions at: 'Miscellaneous' put: unusedCandM.
- newClasses := Array
- streamContents: [:s | (SystemOrganization categoriesMatching: 'VMConstruction-*')
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'VMConstruction' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | (SystemOrganization categoriesMatching: 'ST80-*')
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'ST80' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | (SystemOrganization categoriesMatching: 'Morphic-Games')
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'Games' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | (SystemOrganization categoriesMatching: 'Morphic-Remote')
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'Nebraska' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | ((SystemOrganization categoriesMatching: 'Network-*')
- copyWithoutAll: #('Network-Kernel' 'Network-Url' 'Network-Protocols' 'Network-ObjectSocket' ))
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- expandedCandM := Smalltalk unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'Network' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | (SystemOrganization categoriesMatching: 'Balloon3D-*')
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'Balloon3D' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | (SystemOrganization categoriesMatching: 'FFI-*')
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'FFI' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | (SystemOrganization categoriesMatching: 'Genie-*')
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'Genie' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | (SystemOrganization categoriesMatching: 'Speech-*')
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'Speech' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | #('Morphic-Components' )
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- newClasses := newClasses copyWithoutAll: #(#ComponentLikeModel ).
- expandedCandM := Smalltalk unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'Components' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | #('Sound-Scores' 'Sound-Interface' )
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- newClasses := newClasses , #(#WaveletCodec #Sonogram #FWT #AIFFFileReader ).
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'Sound' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | ((SystemOrganization categoriesMatching: 'Tools-*')
- copyWithout: 'Tools-Menus')
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- newClasses := newClasses copyWithoutAll: #(#Debugger #Inspector #ContextVariablesInspector #SyntaxError #ChangeSet #ChangeRecord #ClassChangeRecord #ChangeList #VersionsBrowser ).
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'Tools' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | (SystemOrganization categoriesMatching: 'Balloon-MMFlash*')
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- newClasses := newClasses , #(#ADPCMCodec ).
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'Flash' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | (SystemOrganization categoriesMatching: 'Balloon-TrueType*')
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'TrueType' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | (SystemOrganization categoriesMatching: 'Graphics-Files')
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'GraphicFiles' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- #(#AliceConstants 'Balloon3D' #B3DEngineConstants 'Balloon3D' #WonderlandConstants 'Balloon3D' #FFIConstants 'FFI' #KlattResonatorIndices 'Speech' )
- pairsDo: [:poolName :part | (partitions at: part) first add: poolName].
- partitions
- keysDo: [:k | k = 'Miscellaneous'
- ifFalse: [(partitions at: 'Miscellaneous') first removeAllFoundIn: (partitions at: k) first]].
- ^ partitions!
Item was removed:
- ----- Method: SystemDictionary>>recover: (in category 'sources, change log') -----
- recover: nCharacters
- "Schedule an editable text view on the last n characters of changes."
- self writeRecentCharacters: nCharacters toFileNamed: 'st80.recent'!
Item was removed:
- ----- Method: SystemDictionary class>>initialize (in category 'initialization') -----
- initialize
- "SystemDictionary initialize"
-
- | oldList |
- oldList := StartUpList.
- StartUpList := OrderedCollection new.
- "These get processed from the top down..."
- #(
- Delay
- DisplayScreen
- Cursor
- InputSensor
- ProcessorScheduler "Starts low space watcher and bkground."
- FileDirectory "Enables file stack dump and opens sources."
- ShortIntegerArray
- ShortRunArray
- CrLfFileStream
- ) do:[:clsName|
- Smalltalk at: clsName ifPresent:[:cls| Smalltalk addToStartUpList: cls].
- ].
- oldList ifNotNil: [oldList do: [:className | Smalltalk at: className
- ifPresent: [:theClass | Smalltalk addToStartUpList: theClass]]].
- #(
- ImageSegment
- PasteUpMorph
- ControlManager
- ) do:[:clsName|
- Smalltalk at: clsName ifPresent:[:cls| Smalltalk addToStartUpList: cls].
- ].
-
-
- oldList := ShutDownList.
- ShutDownList := OrderedCollection new.
- "These get processed from the bottom up..."
- #(
- Delay
- DisplayScreen
- InputSensor
- Form
- ControlManager
- PasteUpMorph
- StrikeFont
- Color
- FileDirectory
- SoundPlayer
- HttpUrl
- Password
- PWS
- MailDB
- ImageSegment
- ) do:[:clsName|
- Smalltalk at: clsName ifPresent:[:cls| Smalltalk addToShutDownList: cls].
- ].
-
- oldList ifNotNil: [oldList reverseDo: [:className | Smalltalk at: className
- ifPresent: [:theClass | Smalltalk addToShutDownList: theClass]]].
- !
Item was removed:
- ----- Method: SmalltalkImage>>reconstructChanges2 (in category 'housekeeping') -----
- reconstructChanges2
- "Move all the changes and its histories onto another sources file."
- "SmalltalkImage reconstructChanges2"
-
- | f oldChanges |
- f := FileStream fileNamed: 'ST80.temp'.
- f header; timeStamp.
- (SourceFiles at: 2) converter: MacRomanTextConverter new.
- 'Recoding Changes File...'
- displayProgressAt: Sensor cursorPoint
- from: 0 to: Smalltalk classNames size
- during:
- [:bar | | classCount | classCount := 0.
- Smalltalk allClassesDo:
- [:class | bar value: (classCount := classCount + 1).
- class moveChangesWithVersionsTo: f.
- class putClassCommentToCondensedChangesFile: f.
- class class moveChangesWithVersionsTo: f]].
- self lastQuitLogPosition: f position.
- f trailer; close.
- oldChanges := SourceFiles at: 2.
- oldChanges close.
- FileDirectory default
- deleteFileNamed: oldChanges name , '.old';
- rename: oldChanges name toBe: oldChanges name , '.old';
- rename: f name toBe: oldChanges name.
- Smalltalk setMacFileInfoOn: oldChanges name.
- SourceFiles at: 2
- put: (FileStream oldFileNamed: oldChanges name)!
Item was removed:
- ----- Method: SystemDictionary>>removeEmptyMessageCategories (in category 'housekeeping') -----
- removeEmptyMessageCategories
- "Smalltalk removeEmptyMessageCategories"
- self garbageCollect.
- (ClassOrganizer allInstances copyWith: SystemOrganization)
- do: [:org | org removeEmptyCategories]!
Item was removed:
- ----- Method: SystemDictionary>>recreateSpecialObjectsArray (in category 'special objects') -----
- recreateSpecialObjectsArray
- "Smalltalk recreateSpecialObjectsArray"
- "The Special Objects Array is an array of object pointers used
- by the
- Squeak virtual machine. Its contents are critical and
- unchecked, so don't even think of playing here unless you
- know what you are doing."
- | newArray |
- newArray := Array new: 50.
- "Nil false and true get used throughout the interpreter"
- newArray at: 1 put: nil.
- newArray at: 2 put: false.
- newArray at: 3 put: true.
- "This association holds the active process (a ProcessScheduler)"
- newArray at: 4 put: (self associationAt: #Processor).
- "Numerous classes below used for type checking and instantiation"
- newArray at: 5 put: Bitmap.
- newArray at: 6 put: SmallInteger.
- newArray at: 7 put: ByteString.
- newArray at: 8 put: Array.
- newArray at: 9 put: Smalltalk.
- newArray at: 10 put: Float.
- newArray at: 11 put: MethodContext.
- newArray at: 12 put: BlockContext.
- newArray at: 13 put: Point.
- newArray at: 14 put: LargePositiveInteger.
- newArray at: 15 put: Display.
- newArray at: 16 put: Message.
- newArray at: 17 put: CompiledMethod.
- newArray at: 18 put: (self specialObjectsArray at: 18).
- "(low space Semaphore)"
- newArray at: 19 put: Semaphore.
- newArray at: 20 put: Character.
- newArray at: 21 put: #doesNotUnderstand:.
- newArray at: 22 put: #cannotReturn:.
- newArray at: 23 put: nil.
- "An array of the 32 selectors that are compiled as special bytecodes,
- paired alternately with the number of arguments each takes."
- newArray at: 24 put: #( #+ 1 #- 1 #< 1 #> 1 #<= 1 #>= 1 #= 1 #~= 1
- #* 1 #/ 1 #\\ 1 #@ 1 #bitShift: 1 #// 1 #bitAnd: 1 #bitOr: 1
- #at: 1 #at:put: 2 #size 0 #next 0 #nextPut: 1 #atEnd 0 #== 1 #class 0
- #blockCopy: 1 #value 0 #value: 1 #do: 1 #new 0 #new: 1 #x 0 #y 0 ).
- "An array of the 255 Characters in ascii order."
- newArray at: 25 put: ((0 to: 255) collect: [:ascii | Character value: ascii]).
- newArray at: 26 put: #mustBeBoolean.
- newArray at: 27 put: ByteArray.
- newArray at: 28 put: Process.
- "An array of up to 31 classes whose instances will have compact headers"
- newArray at: 29 put: self compactClassesArray.
- newArray at: 30 put: (self specialObjectsArray at: 30).
- "(delay Semaphore)"
- newArray at: 31 put: (self specialObjectsArray at: 31).
- "(user interrupt Semaphore)"
- "Prototype instances that can be copied for fast initialization"
- newArray at: 32 put: (Float new: 2).
- newArray at: 33 put: (LargePositiveInteger new: 4).
- newArray at: 34 put: Point new.
- newArray at: 35 put: #cannotInterpret:.
- "Note: This must be fixed once we start using context prototypes (yeah, right)"
- "(MethodContext new: CompiledMethod fullFrameSize)."
- newArray at: 36 put: (self specialObjectsArray at: 36). "Is the prototype MethodContext (unused by the VM)"
- newArray at: 37 put: BlockClosure.
- "(BlockContext new: CompiledMethod fullFrameSize)."
- newArray at: 38 put: (self specialObjectsArray at: 38). "Is the prototype BlockContext (unused by the VM)"
- newArray at: 39 put: (self specialObjectsArray at: 39). "preserve external semaphores"
- "array of objects referred to by external code"
- newArray at: 40 put: PseudoContext.
- newArray at: 41 put: TranslatedMethod.
- "finalization Semaphore"
- newArray at: 42 put: ((self specialObjectsArray at: 42) ifNil: [Semaphore new]).
- newArray at: 43 put: LargeNegativeInteger.
- "External objects for callout.
- Note: Written so that one can actually completely remove the FFI."
- newArray at: 44 put: (self at: #ExternalAddress ifAbsent: []).
- newArray at: 45 put: (self at: #ExternalStructure ifAbsent: []).
- newArray at: 46 put: (self at: #ExternalData ifAbsent: []).
- newArray at: 47 put: (self at: #ExternalFunction ifAbsent: []).
- newArray at: 48 put: (self at: #ExternalLibrary ifAbsent: []).
- newArray at: 49 put: #aboutToReturn:through:.
- newArray at: 50 put: #run:with:in:.
- "Now replace the interpreter's reference in one atomic operation"
- self specialObjectsArray become: newArray!
Item was removed:
- ----- Method: SystemDictionary>>isRoot: (in category 'memory space') -----
- isRoot: oop
- "Primitive. Answer whether the object is currently a root for youngSpace."
- <primitive: 'primitiveIsRoot'>
- ^self primitiveFailed!
Item was removed:
- ----- Method: SystemDictionary>>forceChangesToDisk (in category 'sources, change log') -----
- forceChangesToDisk
- "Ensure that the changes file has been fully written to disk by closing and re-opening it. This makes the system more robust in the face of a power failure or hard-reboot."
-
- | changesFile |
- changesFile := SourceFiles at: 2.
- (changesFile isKindOf: FileStream) ifTrue: [
- changesFile flush.
- SecurityManager default hasFileAccess ifTrue:[
- changesFile close.
- changesFile open: changesFile name forWrite: true].
- changesFile setToEnd.
- ].
- !
Item was removed:
- ----- Method: SystemDictionary>>externalizeSources (in category 'sources, change log') -----
- externalizeSources
- "Write the sources and changes streams onto external files."
- "Smalltalk externalizeSources"
- "the logic of this method is complex because it uses changesName and self changesName
- may be this is normal - sd"
-
- | sourcesName changesName aFile |
- sourcesName := SmalltalkImage current sourcesName.
- (FileDirectory default fileExists: sourcesName)
- ifTrue: [^ self inform:
- 'Sorry, you must first move or remove the
- file named ', sourcesName].
- changesName := SmalltalkImage current changesName.
- (FileDirectory default fileExists: changesName)
- ifTrue: [^ self inform:
- 'Sorry, you must first move or remove the
- file named ', changesName].
-
- aFile := FileStream newFileNamed: sourcesName.
- aFile nextPutAll: SourceFiles first originalContents.
- aFile close.
- self setMacFileInfoOn: sourcesName.
- SourceFiles at: 1 put: (FileStream readOnlyFileNamed: sourcesName).
-
- aFile := FileStream newFileNamed: SmalltalkImage current changesName.
- aFile nextPutAll: SourceFiles last contents.
- aFile close.
- "On Mac, set the file type and creator (noop on other platforms)"
- FileDirectory default
- setMacFileNamed: SmalltalkImage current changesName
- type: 'STch'
- creator: 'FAST'.
- SourceFiles at: 2 put: (FileStream oldFileNamed: changesName).
-
- self inform: 'Sources successfully externalized'.
- !
Item was removed:
- ----- Method: SystemDictionary>>isYoung: (in category 'memory space') -----
- isYoung: oop
- "Primitive. Answer whether the object currently resides in youngSpace."
- <primitive: 'primitiveIsYoung'>
- ^self primitiveFailed!
Item was removed:
- ----- Method: SystemDictionary>>memoryHogs (in category 'memory space') -----
- memoryHogs
- "Answer the list of objects to notify with #freeSomeSpace if memory gets full."
-
- ^ MemoryHogs ifNil: [MemoryHogs := OrderedCollection new]!
Item was removed:
- ----- Method: SystemDictionary>>snapshotEmbeddedPrimitive (in category 'snapshot and quit') -----
- snapshotEmbeddedPrimitive
- <primitive: 247>
- ^nil "indicates error writing embedded image file"!
Item was removed:
- ----- Method: SystemDictionary>>addToStartUpList: (in category 'snapshot and quit') -----
- addToStartUpList: aClass
- "This will add a ref to this class at the END of the startUp list."
-
- self addToStartUpList: aClass after: nil!
Item was removed:
- ----- Method: SmalltalkImage>>scanFor: (in category 'dictionary access') -----
- scanFor: aKey
- "delegate to globals"
- ^globals scanFor: aKey!
Item was removed:
- ----- Method: SystemDictionary>>lowSpaceWatcherProcess (in category 'memory space') -----
- lowSpaceWatcherProcess
- ^LowSpaceProcess!
Item was removed:
- ----- Method: SystemDictionary>>specialObjectsArray (in category 'special objects') -----
- specialObjectsArray "Smalltalk specialObjectsArray at: 1"
- <primitive: 129>
- ^ self primitiveFailed!
Item was removed:
- ----- Method: SystemDictionary>>shutDownSound (in category 'snapshot and quit') -----
- shutDownSound
- "No longer used in the release, but retained for backward compatibility."
-
- SoundService default shutDown
- !
Item was removed:
- ----- Method: SystemDictionary>>writeRecentCharacters:toFileNamed: (in category 'sources, change log') -----
- writeRecentCharacters: nCharacters toFileNamed: aFilename
- "Schedule an editable text view on the last n characters of changes."
- | changes |
- changes := SourceFiles at: 2.
- changes setToEnd; skip: nCharacters negated.
- (FileStream newFileNamed: aFilename) nextPutAll: (changes next: nCharacters); close; open; edit!
Item was removed:
- ----- Method: SystemDictionary>>reformatChangesToUTF8 (in category 'housekeeping') -----
- reformatChangesToUTF8
- "Smalltalk reformatChangesToUTF8"
-
- | f oldChanges |
- f := FileStream fileNamed: 'ST80.temp'.
- f converter: (UTF8TextConverter new).
- f header; timeStamp.
- 'Condensing Changes File...'
- displayProgressAt: Sensor cursorPoint
- from: 0 to: Smalltalk classNames size
- during:
- [:bar | | classCount | classCount := 0.
- Smalltalk allClassesDo:
- [:class | bar value: (classCount := classCount + 1).
- class moveChangesTo: f.
- class putClassCommentToCondensedChangesFile: f.
- class class moveChangesTo: f]].
- SmalltalkImage current lastQuitLogPosition: f position.
- f trailer; close.
- oldChanges := SourceFiles at: 2.
- oldChanges close.
- FileDirectory default
- deleteFileNamed: oldChanges name , '.old';
- rename: oldChanges name toBe: oldChanges name , '.old';
- rename: f name toBe: oldChanges name.
- self setMacFileInfoOn: oldChanges name.
- SourceFiles at: 2
- put: (FileStream oldFileNamed: oldChanges name).
- MultiByteFileStream codeConverterClass: UTF8TextConverter.
- (SourceFiles at: 2) converter: (UTF8TextConverter new).
- !
Item was removed:
- ----- Method: SystemDictionary>>addToShutDownList: (in category 'snapshot and quit') -----
- addToShutDownList: aClass
- "This will add a ref to this class at the BEGINNING of the shutDown list."
-
- self addToShutDownList: aClass after: nil!
Item was removed:
- ----- Method: SmalltalkImage>>discardSUnit (in category 'shrinking') -----
- discardSUnit
- "Smalltalk discardSUnit"
- | oc |
- oc := OrderedCollection new.
- (self
- at: #TestCase
- ifAbsent: [^ self])
- allSubclassesWithLevelDo: [:c :i | oc addFirst: c]
- startingLevel: 0.
- oc
- do: [:c | c removeFromSystem].
- SystemOrganization removeCategoriesMatching: 'SUnit-*'!
Item was removed:
- ----- Method: SystemDictionary>>discardSpeech (in category 'shrinking') -----
- discardSpeech
- "Discard support for speech synthesis"
-
- SystemOrganization removeCategoriesMatching: 'Speech*'.
- !
Item was removed:
- ----- Method: SystemDictionary>>discardDiscards (in category 'shrinking') -----
- discardDiscards
- "Discard all discard* methods - including this one."
-
- (self class selectors select: [:each | each beginsWith: 'discard'])
- do: [:each | self class removeSelector: each].
- #(lastRemoval majorShrink zapMVCprojects)
- do: [:each | self class removeSelector: each]!
Item was removed:
- ----- Method: SystemDictionary>>quitPrimitive (in category 'snapshot and quit') -----
- quitPrimitive
- "Primitive. Exit to another operating system on the host machine, if one
- exists. All state changes in the object space since the last snapshot are lost.
- Essential. See Object documentation whatIsAPrimitive."
-
- <primitive: 113>
- self primitiveFailed!
Item was removed:
- ----- Method: SystemDictionary>>hasSpecialSelector:ifTrueSetByte: (in category 'special objects') -----
- hasSpecialSelector: aLiteral ifTrueSetByte: aBlock
-
- 1 to: self specialSelectorSize do:
- [:index |
- (self specialSelectorAt: index) == aLiteral
- ifTrue: [aBlock value: index + 16rAF. ^true]].
- ^false!
Item was removed:
- ----- Method: SystemDictionary>>processStartUpList: (in category 'snapshot and quit') -----
- processStartUpList: resuming
- "Send #startUp to each class that needs to run initialization after a snapshot."
-
- self send: #startUp: toClassesNamedIn: StartUpList with: resuming.
- !
Item was removed:
- ----- Method: SystemDictionary>>unloadAllKnownPackages (in category 'shrinking') -----
- unloadAllKnownPackages
- "Unload all packages we know how to unload and reload"
-
- "Prepare unloading"
- Smalltalk zapMVCprojects.
- Flaps disableGlobalFlaps: false.
- StandardScriptingSystem removeUnreferencedPlayers.
- Project removeAllButCurrent.
- #('Morphic-UserObjects' 'EToy-UserObjects' 'Morphic-Imported' )
- do: [:each | SystemOrganization removeSystemCategory: each].
- Smalltalk at: #ServiceRegistry ifPresent:[:aClass|
- SystemChangeNotifier uniqueInstance
- noMoreNotificationsFor: aClass.
- ].
- World removeAllMorphs.
-
- "Go unloading"
- #( 'ReleaseBuilder' 'ScriptLoader'
- '311Deprecated' '39Deprecated'
- 'Universes' 'SMLoader' 'SMBase' 'Installer-Core'
- 'VersionNumberTests' 'VersionNumber'
- 'Services-Base' 'PreferenceBrowser' 'Nebraska'
- 'ToolBuilder-MVC' 'ST80'
- 'CollectionsTests' 'GraphicsTests' 'KernelTests' 'MorphicTests'
- 'MultilingualTests' 'NetworkTests' 'ToolsTests' 'TraitsTests'
- 'SystemChangeNotification-Tests' 'FlexibleVocabularies'
- 'EToys' 'Protocols' 'XML-Parser' 'Tests' 'SUnitGUI'
- ) do:[:pkgName| (MCPackage named: pkgName) unload].
- "Traits use custom unload"
- Smalltalk at: #Trait ifPresent:[:aClass| aClass unloadTraits].
-
- "Post-unload cleanup"
- PackageOrganizer instVarNamed: 'default' put: nil.
- SystemOrganization removeSystemCategory: 'UserObjects'.
- Presenter defaultPresenterClass: nil.
- World dumpPresenter.
- ScheduledControllers := nil.
- Preferences removePreference: #allowEtoyUserCustomEvents.
- SystemOrganization removeEmptyCategories.
- ChangeSet removeChangeSetsNamedSuchThat:[:cs | (cs == ChangeSet current) not].
- Undeclared removeUnreferencedKeys.
- StandardScriptingSystem initialize.
- MCFileBasedRepository flushAllCaches.
- MCDefinition clearInstances.
- Behavior flushObsoleteSubclasses.
- ChangeSet current clear.
- ChangeSet current name: 'Unnamed1'.
- Smalltalk flushClassNameCache.
- Smalltalk at: #Browser ifPresent:[:br| br initialize].
- DebuggerMethodMap voidMapCache.
- DataStream initialize.
- Smalltalk forgetDoIts.
- AppRegistry removeObsolete.
- FileServices removeObsolete.
- Preferences removeObsolete.
- TheWorldMenu removeObsolete.
- Smalltalk garbageCollect.
- Symbol compactSymbolTable.
- TheWorldMainDockingBar updateInstances.
- !
Item was removed:
- ----- Method: SmalltalkImage>>discardFlash (in category 'shrinking') -----
- discardFlash
- "Discard Flash support."
-
- SystemOrganization removeCategoriesMatching: 'Balloon-MMFlash*'
- !
Item was removed:
- ----- Method: SystemDictionary>>makeInternalRelease (in category 'housekeeping') -----
- makeInternalRelease
- "Smalltalk makeInternalRelease"
- (self confirm: SystemVersion current version , '
- Is this the correct version designation?
- If not, choose no, and fix it.')
- ifFalse: [^ self].
- (Object classPool at: #DependentsFields) size > 1
- ifTrue: [self halt].
- Smalltalk at: #Browser ifPresent:[:br| br initialize].
- Undeclared isEmpty
- ifFalse: [self halt].
- self garbageCollect.
- self obsoleteClasses isEmpty
- ifFalse: [self halt].
- Symbol rehash.
- self halt: 'Ready to condense changes'.
- self condenseChanges!
Item was removed:
- ----- Method: SmalltalkImage>>discardTrueType (in category 'shrinking') -----
- discardTrueType
- "Discard TrueType support."
-
- SystemOrganization removeCategoriesMatching: 'Balloon-TrueType*'.
-
- !
Item was removed:
- ----- Method: SmalltalkImage>>lastRemoval (in category 'shrinking') -----
- lastRemoval
- "Smalltalk lastRemoval"
- "Some explicit removals - add unwanted methods keeping
- other methods."
- | oldDicts newDicts |
- #(#abandonSources )
- do: [:each | self class removeSelector: each].
- "Get rid of all unsent methods."
- [self removeAllUnSentMessages > 0] whileTrue.
- "Shrink method dictionaries."
- self garbageCollect.
- oldDicts := MethodDictionary allInstances.
- newDicts := Array new: oldDicts size.
- oldDicts
- withIndexDo: [:d :index | newDicts at: index put: d rehashWithoutBecome].
- oldDicts elementsExchangeIdentityWith: newDicts.
- oldDicts := newDicts := nil.
- self
- allClassesDo: [:c | c zapOrganization].
- SystemOrganization := nil.
- ChangeSet current initialize!
Item was removed:
- ----- Method: SystemDictionary>>useUpMemoryWithArrays (in category 'memory space') -----
- useUpMemoryWithArrays
- "For testing the low space handler..."
- "Smalltalk installLowSpaceWatcher; useUpMemoryWithArrays"
-
- | b | "First use up most of memory."
- b := String new: self bytesLeft - self lowSpaceThreshold - 100000.
- b := b. "Avoid unused value warning"
- (1 to: 10000) collect: [:i | Array new: 10000]!
Item was removed:
- ----- Method: SystemDictionary>>discardMVC (in category 'shrinking') -----
- discardMVC
- "After suitable checks, remove all of MVC from the system. Removal will destroy current
- MVC projects. MVC may be reinstalled by loading packages ST80 and ToolBuilder-MVC."
-
- "Smalltalk discardMVC"
-
- self isMorphic
- ifFalse: [^self inform: 'You must be in a Morphic project to discard MVC.'].
- "Check that there are no MVC Projects"
- (Project allProjects allSatisfy: [:proj | proj isMorphic])
- ifFalse: [(self confirm: 'Would you like a chance to remove your
- MVC projects in an orderly manner?')
- ifTrue: [^ self].
- (self confirm: 'If you wish, I can remove all MVC projects,
- make this project be the top project, and place
- all orphaned sub-projects of MVC parents here.
- Would you like be to do this
- and proceed to discard all MVC classes?')
- ifTrue: [self zapMVCprojects]
- ifFalse: [^ self]].
- (MCPackage named: 'ToolBuilder-MVC') unload.
- (MCPackage named: 'ST80') unload.
- ScheduledControllers := nil.
- Smalltalk garbageCollect.
- Undeclared removeUnreferencedKeys.
- SystemOrganization removeEmptyCategories.
- Symbol rehash!
Item was removed:
- ----- Method: SmalltalkImage>>majorShrink (in category 'shrinking') -----
- majorShrink
- "Undertake a major shrinkage of the image.
- This method throws out lots of the system that is not needed
- for, eg, operation in a hand-held PC. majorShrink produces a
- 999k image in Squeak 2.8
- Smalltalk majorShrink; abandonSources; lastRemoval"
- | oldDicts newDicts |
- self isMorphic
- ifTrue: [^ self error: 'You can only run majorShrink in MVC'].
- Project current isTopProject
- ifFalse: [^ self error: 'You can only run majorShrink in the top project'].
- (self confirm: 'All sub-projects will be deleted from this image.
- You should already have made a backup copy,
- or you must save with a different name after shrinking.
- Shall we proceed to discard most of the content in this image?')
- ifFalse: [^ self inform: 'No changes have been made.'].
- "Remove all projects but the current one. - saves 522k"
- Smalltalk at: #ProjectView ifPresent: [:pvClass |
- pvClass allInstancesDo: [:pv | pv controller closeAndUnscheduleNoTerminate]].
- Project current setParent: Project current.
- Smalltalk at: #Wonderland ifPresent: [:cls |
- cls removeActorPrototypesFromSystem].
- Smalltalk at: #Player ifPresent:[:aClass| aClass freeUnreferencedSubclasses].
- MorphicModel removeUninstantiatedModels.
- Utilities classPool at: #ScrapsBook put: nil.
- Utilities zapUpdateDownloader.
- ProjectHistory currentHistory initialize.
- Project rebuildAllProjects.
- "Smalltalk discardVMConstruction."
- "755k"
- self discardSoundSynthesis.
- "544k"
- self discardOddsAndEnds.
- "227k"
- self discardNetworking.
- "234k"
- "Smalltalk discard3D."
- "407k"
- self discardFFI.
- "33k"
- self discardMorphic.
- "1372k"
- Symbol rehash.
- "40k"
- "Above by itself saves about 4,238k"
- "Remove references to a few classes to be deleted, so that they
- won't leave obsolete versions around."
- ChangeSet class compile: 'defaultName
- ^ ''Changes'' ' classified: 'initialization'.
- Smalltalk at: #ScreenController ifPresent: [:sc |
- sc removeSelector: #openChangeManager.
- sc removeSelector: #exitProject.
- sc removeSelector: #openProject.
- sc removeSelector: #viewImageImports].
- "Now delete various other classes.."
- SystemOrganization removeSystemCategory: 'Graphics-Files'.
- SystemOrganization removeSystemCategory: 'System-Object Storage'.
- self removeClassNamed: #ProjectController.
- self removeClassNamed: #ProjectView.
- "Smalltalk removeClassNamed: #Project."
- self removeClassNamed: #Component1.
- self removeClassNamed: #FormSetFont.
- self removeClassNamed: #FontSet.
- self removeClassNamed: #InstructionPrinter.
- self removeClassNamed: #ChangeSorter.
- self removeClassNamed: #DualChangeSorter.
- self removeClassNamed: #EmphasizedMenu.
- self removeClassNamed: #MessageTally.
- StringHolder class removeSelector: #originalWorkspaceContents.
- CompiledMethod removeSelector: #symbolic.
- RemoteString removeSelector: #makeNewTextAttVersion.
- Utilities class removeSelector: #absorbUpdatesFromServer.
- self removeClassNamed: #PenPointRecorder.
- self removeClassNamed: #Path.
- self removeClassNamed: #Base64MimeConverter.
- "Smalltalk removeClassNamed: #EToySystem. Dont bother - its
- very small and used for timestamps etc"
- self removeClassNamed: #RWBinaryOrTextStream.
- self removeClassNamed: #AttributedTextStream.
- self removeClassNamed: #WordNet.
- self removeClassNamed: #SelectorBrowser.
- TextStyle
- allSubInstancesDo: [:ts | ts
- newFontArray: (ts fontArray
- copyFrom: 1
- to: (2 min: ts fontArray size))].
- #(ListParagraph PopUpMenu StandardSystemView) do:[:className|
- Smalltalk at: className ifPresent:[:aClass| aClass initialize].
- ].
- ChangeSet noChanges.
- ChangeSet classPool
- at: #AllChangeSets
- put: (OrderedCollection with: ChangeSet current).
- SystemDictionary removeSelector: #majorShrink.
- [self removeAllUnSentMessages > 0]
- whileTrue: [Smalltalk unusedClasses
- do: [:c | (Smalltalk at: c) removeFromSystem]].
- SystemOrganization removeEmptyCategories.
- self
- allClassesDo: [:c | c zapOrganization].
- self garbageCollect.
- 'Rehashing method dictionaries . . .'
- displayProgressAt: Sensor cursorPoint
- from: 0
- to: MethodDictionary instanceCount
- during: [:bar |
- oldDicts := MethodDictionary allInstances.
- newDicts := Array new: oldDicts size.
- oldDicts
- withIndexDo: [:d :index |
- bar value: index.
- newDicts at: index put: d rehashWithoutBecome].
- oldDicts elementsExchangeIdentityWith: newDicts].
- oldDicts := newDicts := nil.
- Project rebuildAllProjects.
- ChangeSet current initialize.
- "seems to take more than one try to gc all the weak refs in
- SymbolTable "
- 3
- timesRepeat: [self garbageCollect.
- Symbol compactSymbolTable]!
Item was removed:
- ----- Method: SystemDictionary>>abandonSources (in category 'shrinking') -----
- abandonSources
- "Smalltalk abandonSources"
- "Replaces every method by a copy with the 4-byte source pointer
- replaced by a string of all arg and temp names, followed by its
- length. These names can then be used to inform the decompiler."
- "wod 11/3/1998: zap the organization before rather than after
- condensing changes."
- "eem 7/1/2009 13:59 update for the closure schematic temp names regime"
- | oldMethods newMethods bTotal bCount |
- (self confirm: 'This method will preserve most temp names
- (up to about 15k characters of temporaries)
- while allowing the sources file to be discarded.
- -- CAUTION --
- If you have backed up your system and
- are prepared to face the consequences of
- abandoning source code files, choose Yes.
- If you have any doubts, you may choose No
- to back out with no harm done.')
- == true
- ifFalse: [^ self inform: 'Okay - no harm done'].
- self forgetDoIts.
- oldMethods := OrderedCollection new: CompiledMethod instanceCount.
- newMethods := OrderedCollection new: CompiledMethod instanceCount.
- bTotal := 0.
- bCount := 0.
- self systemNavigation allBehaviorsDo: [:b | bTotal := bTotal + 1].
- 'Saving temp names for better decompilation...'
- displayProgressAt: Sensor cursorPoint
- from: 0
- to: bTotal
- during:
- [:bar |
- self systemNavigation allBehaviorsDo:
- [:cl | "for test: (Array with: Arc with: Arc class) do:"
- bar value: (bCount := bCount + 1).
- cl selectorsAndMethodsDo:
- [:selector :m |
- | oldCodeString methodNode |
- m fileIndex > 0 ifTrue:
- [oldCodeString := cl sourceCodeAt: selector.
- methodNode := cl compilerClass new
- parse: oldCodeString
- in: cl
- notifying: nil.
- oldMethods addLast: m.
- newMethods addLast: (m copyWithTempsFromMethodNode: methodNode)]]]].
- oldMethods asArray elementsExchangeIdentityWith: newMethods asArray.
- self systemNavigation allBehaviorsDo: [:b | b zapOrganization].
- self condenseChanges.
- Preferences disable: #warnIfNoSourcesFile!
Item was removed:
- ----- Method: SystemDictionary>>inspectGlobals (in category 'ui') -----
- inspectGlobals
- "Smalltalk inspectGlobals"
-
- | associations aDict |
- associations := ((self keys reject: [:aKey | ((self at: aKey) isKindOf: Class)]) asArray sort collect:[:aKey | self associationAt: aKey]).
- aDict := IdentityDictionary new.
- associations do: [:as | aDict add: as].
- aDict inspectWithLabel: 'The Globals'!
Item was removed:
- ----- Method: SystemDictionary>>useUpMemory (in category 'memory space') -----
- useUpMemory
- "For testing the low space handler..."
- "Smalltalk installLowSpaceWatcher; useUpMemory"
-
- | lst |
- lst := nil.
- [true] whileTrue: [
- lst := Link nextLink: lst.
- ].!
Item was removed:
- ----- Method: SystemDictionary>>specialSelectorSize (in category 'special objects') -----
- specialSelectorSize
- "Answer the number of special selectors in the system."
-
- ^ (self specialObjectsArray at: 24) size // 2!
Item was removed:
- ----- Method: SystemDictionary>>setGCParameters (in category 'snapshot and quit') -----
- setGCParameters
- "Adjust the VM's default GC parameters to avoid premature tenuring."
-
- SmalltalkImage current vmParameterAt: 5 put: 4000. "do an incremental GC after this many allocations"
- SmalltalkImage current vmParameterAt: 6 put: 2000. "tenure when more than this many objects survive the GC"
- !
Item was removed:
- ----- Method: SystemDictionary>>createStackOverflow (in category 'memory space') -----
- createStackOverflow
- "For testing the low space handler..."
- "Smalltalk installLowSpaceWatcher; createStackOverflow"
-
- self createStackOverflow. "infinite recursion"!
Item was removed:
- ----- Method: SystemDictionary class>>cleanUp (in category 'initialization') -----
- cleanUp
- "Flush caches"
-
- Smalltalk flushClassNameCache.
- Smalltalk cleanUpUndoCommands.
- Undeclared removeUnreferencedKeys.
- Smalltalk forgetDoIts.!
Item was removed:
- ----- Method: SystemDictionary>>lowSpaceWatcher (in category 'memory space') -----
- lowSpaceWatcher
- "Wait until the low space semaphore is signalled, then take appropriate actions."
-
- | free preemptedProcess |
- self garbageCollectMost <= self lowSpaceThreshold
- ifTrue: [self garbageCollect <= self lowSpaceThreshold
- ifTrue: ["free space must be above threshold before
- starting low space watcher"
- ^ Beeper beep]].
-
- Smalltalk specialObjectsArray at: 23 put: nil. "process causing low space will be saved here"
- LowSpaceSemaphore := Semaphore new.
- self primLowSpaceSemaphore: LowSpaceSemaphore.
- self primSignalAtBytesLeft: self lowSpaceThreshold. "enable low space interrupts"
-
- LowSpaceSemaphore wait. "wait for a low space condition..."
-
- self primSignalAtBytesLeft: 0. "disable low space interrupts"
- self primLowSpaceSemaphore: nil.
- LowSpaceProcess := nil.
-
- "The process that was active at the time of the low space interrupt."
- preemptedProcess := Smalltalk specialObjectsArray at: 23.
- Smalltalk specialObjectsArray at: 23 put: nil.
-
- "Note: user now unprotected until the low space watcher is re-installed"
-
- self memoryHogs isEmpty
- ifFalse: [free := self bytesLeft.
- self memoryHogs
- do: [ :hog | hog freeSomeSpace ].
- self bytesLeft > free
- ifTrue: [ ^ self installLowSpaceWatcher ]].
- Project current
- interruptName: 'Space is low'
- preemptedProcess: preemptedProcess
- !
Item was removed:
- ----- Method: SystemDictionary>>specialNargsAt: (in category 'special objects') -----
- specialNargsAt: anInteger
- "Answer the number of arguments for the special selector at: anInteger."
-
- ^ (self specialObjectsArray at: 24) at: anInteger * 2!
Item was removed:
- ----- Method: SystemDictionary>>verifyChanges (in category 'housekeeping') -----
- verifyChanges "Smalltalk verifyChanges"
- "Recompile all methods in the changes file."
- self systemNavigation allBehaviorsDo: [:class | class recompileChanges].
- !
Item was removed:
- ----- Method: SystemDictionary>>discardMIDI (in category 'shrinking') -----
- discardMIDI
-
- "this seems to have gone away"!
Item was removed:
- ----- Method: SmalltalkImage>>makeExternalRelease (in category 'housekeeping') -----
- makeExternalRelease
- "Smalltalk makeExternalRelease"
- (self confirm: SystemVersion current version , '
- Is this the correct version designation?
- If not, choose no, and fix it.')
- ifFalse: [^ self].
- "Object classPool at: #DependentsFields"
- self reclaimDependents.
- Preferences enable: #mvcProjectsAllowed.
- Preferences enable: #fastDragWindowForMorphic.
- Smalltalk at: #Browser ifPresent:[:br| br initialize].
- Undeclared isEmpty
- ifFalse: [self halt].
- ScriptingSystem deletePrivateGraphics.
- #(#Helvetica #Palatino #Courier )
- do: [:n | TextConstants
- removeKey: n
- ifAbsent: []].
- (Utilities classPool at: #UpdateUrlLists) copy
- do: [:pair | (pair first includesSubstring: 'Disney' caseSensitive: false)
- ifTrue: [(Utilities classPool at: #UpdateUrlLists)
- remove: pair]].
- (ServerDirectory serverNames copyWithoutAll: #('UCSBCreateArchive' 'UIUCArchive' 'UpdatesExtUIUC' 'UpdatesExtWebPage' ))
- do: [:sn | ServerDirectory removeServerNamed: sn].
- self garbageCollect.
- self obsoleteClasses isEmpty
- ifFalse: [self halt].
- Symbol rehash.
- self halt: 'Ready to condense changes or sources'!
Item was removed:
- ----- Method: SystemDictionary>>removeAllLineFeedsQuietlyCalling: (in category 'housekeeping') -----
- removeAllLineFeedsQuietlyCalling: aBlock
- "Smalltalk removeAllLineFeedsQuietly"
- "Scan all methods for source code with lineFeeds.
- Replaces all occurrences of <CR><LF> or <LF> by <CR>.
- Answer a Dictionary keyed by author name containing sets of affected method names,
- as well as (at the key 'OK') a list of methods that still contain LF characters inside literal strings or characters.
- Evaluate aBlock for each method so that status can be updated."
- | authors |
- self forgetDoIts.
- authors := Dictionary new.
- authors at: 'OK' put: Set new.
- self systemNavigation
- allBehaviorsDo: [:cls | cls selectors
- do: [:selector | | oldCodeString oldStamp oldCategory newCodeString nameString |
- aBlock value: cls value: selector.
- oldCodeString := cls sourceCodeAt: selector.
- (oldCodeString includes: Character lf)
- ifTrue: [
- newCodeString := oldCodeString withSqueakLineEndings.
- nameString := cls name , '>>' , selector.
- ((cls compiledMethodAt: selector) hasLiteralSuchThat: [ :lit | lit asString includes: Character lf ])
- ifTrue: [(authors at: 'OK')
- add: nameString]
- ifFalse: [oldStamp := (Utilities
- timeStampForMethod: (cls compiledMethodAt: selector))
- copy replaceAll: Character cr
- with: Character space.
- (authors
- at: (oldStamp copyFrom: 1 to: (oldStamp findFirst: [ :c | c isAlphaNumeric not ]))
- ifAbsentPut: [Set new])
- add: nameString.
- oldCategory := cls whichCategoryIncludesSelector: selector.
- cls
- compile: newCodeString
- classified: oldCategory
- withStamp: oldStamp
- notifying: nil ]]]].
- ^ authors!
Item was removed:
- ----- Method: SystemDictionary>>testFormatter (in category 'housekeeping') -----
- testFormatter
- "Smalltalk testFormatter"
-
- "Reformats the source for every method in the system, and
- then compiles that source and verifies that it generates
- identical code. The formatting used will be either classic
- monochrome or fancy polychrome, depending on the setting
- of the preference #colorWhenPrettyPrinting."
-
- "Note: removed references to Preferences colorWhenPrettyPrinting and replaced them simply with false, as I've been removing this preference lately. --Ron Spengler 8/23/09"
-
- | badOnes |
- badOnes := OrderedCollection new.
- self forgetDoIts.
- 'Formatting all classes...'
- displayProgressAt: Sensor cursorPoint
- from: 0
- to: CompiledMethod instanceCount
- during:
- [:bar | | n |
- n := 0.
- self systemNavigation allBehaviorsDo:
- [:cls |
- "Transcript cr; show: cls name."
-
- cls selectorsAndMethodsDo:
- [:selector :oldMethod |
- | newMethod newCodeString methodNode |
- (n := n + 1) \\ 100 = 0 ifTrue: [bar value: n].
- newCodeString := cls prettyPrinterClass
- format: (cls sourceCodeAt: selector)
- in: cls
- notifying: nil
- decorated: false.
- methodNode := cls compilerClass new
- compile: newCodeString
- in: cls
- notifying: nil
- ifFail: [].
- newMethod := methodNode generate.
- oldMethod = newMethod
- ifFalse:
- [Transcript
- cr;
- show: '***' , cls name , ' ' , selector.
- badOnes add: cls name , ' ' , selector]]]].
- self systemNavigation browseMessageList: badOnes asSortedCollection
- name: 'Formatter Discrepancies'!
Item was removed:
- ----- Method: SystemDictionary>>reconstructChanges (in category 'housekeeping') -----
- reconstructChanges
- "Move all the changes and its histories onto another sources file."
- "Smalltalk reconstructChanges"
-
- | f oldChanges |
- f := FileStream fileNamed: 'ST80.temp'.
- f header; timeStamp.
- 'Condensing Changes File...'
- displayProgressAt: Sensor cursorPoint
- from: 0 to: self classNames size + self traitNames size
- during:
- [:bar | | classCount | classCount := 0.
- Smalltalk allClassesAndTraitsDo:
- [:classOrTrait | bar value: (classCount := classCount + 1).
- classOrTrait moveChangesWithVersionsTo: f.
- classOrTrait putClassCommentToCondensedChangesFile: f.
- classOrTrait classSide moveChangesWithVersionsTo: f]].
- SmalltalkImage current lastQuitLogPosition: f position.
- f trailer; close.
- oldChanges := SourceFiles at: 2.
- oldChanges close.
- FileDirectory default
- deleteFileNamed: oldChanges name , '.old';
- rename: oldChanges name toBe: oldChanges name , '.old';
- rename: f name toBe: oldChanges name.
- self setMacFileInfoOn: oldChanges name.
- SourceFiles at: 2
- put: (FileStream oldFileNamed: oldChanges name)!
Item was removed:
- ----- Method: SystemDictionary>>discardNetworking (in category 'shrinking') -----
- discardNetworking
- "Discard the support for TCP/IP networking."
-
- SystemOrganization removeCategoriesMatching: 'Network-*'.
-
- !
Item was removed:
- ----- Method: SystemDictionary>>copyright (in category 'sources, change log') -----
- copyright
- "The Smalltalk copyright."
-
- ^'Copyright (c) Xerox Corp. 1981, 1982 All rights reserved.
- Copyright (c) Apple Computer, Inc. 1985-1996 All rights reserved.'!
Item was removed:
- ----- Method: SystemDictionary>>cleanUpUndoCommands (in category 'shrinking') -----
- cleanUpUndoCommands
- "Smalltalk cleanUpUndoCommands" "<== print this to get classes involved"
-
- | classes |
- classes := Bag new.
- 'Ferreting out obsolete undo commands'
- displayProgressAt: Sensor cursorPoint
- from: 0 to: Morph withAllSubclasses size
- during:
- [:bar | | i | i := 0.
- Morph withAllSubclassesDo:
- [:c | bar value: (i := i+1).
- c allInstancesDo:
- [:m | | p | (p := m otherProperties) ifNotNil:
- [p keys do:
- [:k | (p at: k) class == Command ifTrue:
- [classes add: c name.
- m removeProperty: k]]]]]].
- ^ classes!
Item was removed:
- ----- Method: SystemDictionary>>primImageName (in category 'image, changes name') -----
- primImageName
- "Answer the full path name for the current image."
- "Smalltalk imageName"
-
- <primitive: 121>
- self primitiveFailed!
Item was removed:
- ----- Method: SystemDictionary>>setGCBiasToGrow: (in category 'memory space') -----
- setGCBiasToGrow: aNumber
- "Primitive. Indicate that the GC logic should be bias to grow"
- <primitive: 'primitiveSetGCBiasToGrow'>
- ^self primitiveFailed
- "Example:
- Smalltalk setGCBiasToGrowGCLimit: 16*1024*1024.
- Smalltalk setGCBiasToGrow: 1.
- "!
Item was removed:
- ----- Method: SystemDictionary>>unusedClassesAndMethodsWithout: (in category 'shrinking') -----
- unusedClassesAndMethodsWithout: classesAndMessagesPair
- "Accepts and returns a pair: {set of class names. set of selectors}.
- It is expected these results will be diff'd with the normally unused
- results. "
- | classRemovals messageRemovals nClasses nMessages |
- (classRemovals := IdentitySet new) addAll: classesAndMessagesPair first.
- (messageRemovals := IdentitySet new) addAll: classesAndMessagesPair second.
- nClasses := nMessages := -1.
- ["As long as we keep making progress..."
- classRemovals size > nClasses
- or: [messageRemovals size > nMessages]]
- whileTrue: ["...keep trying for bigger sets of unused classes and selectors."
- nClasses := classRemovals size.
- nMessages := messageRemovals size.
- Utilities
- informUser: 'Iterating removals '
- , (classesAndMessagesPair first isEmpty
- ifTrue: ['for baseline...']
- ifFalse: ['for ' , classesAndMessagesPair first first , ' etc...']) , Character cr asString , nClasses printString , ' classes, ' , nMessages printString , ' messages.
- |
- |'
- during: ["spacers move menu off cursor"
- classRemovals
- addAll: (self systemNavigation allUnusedClassesWithout: {classRemovals. messageRemovals}).
- messageRemovals
- addAll: (self systemNavigation allUnSentMessagesWithout: {classRemovals. messageRemovals})]].
- ^ {classRemovals. self systemNavigation allUnSentMessagesWithout: {classRemovals. messageRemovals}}!
Item was removed:
- ----- Method: SystemDictionary>>unbindExternalPrimitives (in category 'snapshot and quit') -----
- unbindExternalPrimitives
- "Primitive. Force all external primitives to be looked up again afterwards. Since external primitives that have not found are bound for fast failure this method will force the lookup of all primitives again so that after adding some plugin the primitives may be found."
- ^ self deprecated: 'Use SmalltalkImage unbindExternalPrimitives'
- block: [SmalltalkImage unbindExternalPrimitives].
- "Do nothing if the primitive fails for compatibility with older VMs"!
Item was removed:
- ----- Method: SystemDictionary>>addToStartUpList:after: (in category 'snapshot and quit') -----
- addToStartUpList: aClass after: predecessor
-
- self add: aClass toList: StartUpList after: predecessor!
Item was removed:
- ----- Method: SystemDictionary>>zapMVCprojects (in category 'shrinking') -----
- zapMVCprojects
- "Smalltalk zapMVCprojects"
-
-
- self flag: #bob. "zapping projects"
-
- Smalltalk garbageCollect.
- "So allInstances is precise"
- Project
- allSubInstancesDo: [:proj | | window | proj isTopProject
- ifTrue: [proj isMorphic
- ifFalse: ["Root project is MVC -- we must become the root"
- Project current setParent: Project current.]]
- ifFalse: [proj parent isMorphic
- ifFalse: [proj isMorphic
- ifTrue: ["Remove Morphic projects from MVC
- views "
- "... and add them back here."
- window := (SystemWindow labelled: proj name)
- model: proj.
- window
- addMorph: (ProjectViewMorph on: proj)
- frame: (0 @ 0 corner: 1.0 @ 1.0).
- window openInWorld.
- proj setParent: Project current]].
- proj isMorphic
- ifFalse: ["Remove MVC projects from Morphic views"
- Project deletingProject: proj]]]!
Item was removed:
- ----- Method: SmalltalkImage>>reportClassAndMethodRemovalsFor: (in category 'shrinking') -----
- reportClassAndMethodRemovalsFor: collectionOfClassNames
- | initialClassesAndMethods finalClassesAndMethods |
- "Smalltalk reportClassAndMethodRemovalsFor: #(Celeste Scamper MailMessage)"
-
- initialClassesAndMethods := self unusedClassesAndMethodsWithout: {{}. {}}.
- finalClassesAndMethods := self unusedClassesAndMethodsWithout: {collectionOfClassNames. {}}.
- ^ {finalClassesAndMethods first copyWithoutAll: initialClassesAndMethods first.
- finalClassesAndMethods second copyWithoutAll: initialClassesAndMethods second}!
Item was removed:
- ----- Method: SystemDictionary>>writeRecentToFile (in category 'sources, change log') -----
- writeRecentToFile
- "Smalltalk writeRecentToFile"
- | numChars aDirectory aFileName |
- aDirectory := FileDirectory default.
- aFileName := Utilities
- keyLike: 'squeak-recent.01'
- withTrailing: '.log'
- satisfying: [:aKey | (aDirectory includesKey: aKey) not].
- numChars := ChangeSet getRecentLocatorWithPrompt: 'copy logged source as far back as...'.
- numChars
- ifNotNil: [self writeRecentCharacters: numChars toFileNamed: aFileName]!
Item was removed:
- ----- Method: SystemDictionary>>removeNormalCruft (in category 'shrinking') -----
- removeNormalCruft
- "Remove various graphics, uniclasses, references. Caution: see
- comment at bottom of method"
- "Smalltalk removeNormalCruft"
- ScriptingSystem stripGraphicsForExternalRelease.
- ScriptingSystem spaceReclaimed.
- References keys
- do: [:k | References removeKey: k].
- self classNames
- do: [:cName | #('Player' 'CardPlayer' 'Component' 'WonderlandActor' 'MorphicModel' 'PlayWithMe' )
- do: [:superName | ((cName ~= superName
- and: [cName beginsWith: superName])
- and: [(cName allButFirst: superName size)
- allSatisfy: [:ch | ch isDigit]])
- ifTrue: [self removeClassNamed: cName]]].
- self
- at: #Wonderland
- ifPresent: [:cls | cls removeActorPrototypesFromSystem].
- ChangeSet current clear
- "Caution: if any worlds in the image happen to have uniclass
- players associated with them, running this method would
- likely compromise their functioning and could cause errors,
- especially if the uniclass player of the current world had any
- scripts set to ticking. If that happens to you somehow, you will
- probably want to find a way to reset the offending world's
- player to be an UnscriptedCardPlayer, or perhaps nil"!
Item was removed:
- ----- Method: SystemDictionary>>compactClassesArray (in category 'special objects') -----
- compactClassesArray
- "Smalltalk compactClassesArray"
- "Return the array of 31 classes whose instances may be
- represented compactly"
- ^ self specialObjectsArray at: 29!
Item was removed:
- ----- Method: SystemDictionary>>internalizeSources (in category 'sources, change log') -----
- internalizeSources
- "Smalltalk internalizeSources"
- "Bring the sources and changes files into memory-resident filestreams, for faster access and freedom from file-system interface. 1/29/96 sw"
-
- | reply aName aFile |
- reply := self confirm: 'CAUTION -- do not undertake this lightly!!
- If you have backed up your system and
- are prepared to face the consequences of
- the requested internalization of sources,
- hit Yes. If you have any doubts, hit No
- to back out with no harm done.'.
-
- (reply == true) ifFalse:
- [^ self inform: 'Okay - abandoned'].
-
- aName := SmalltalkImage current sourcesName.
- (aFile := SourceFiles first) == nil ifTrue:
- [(FileDirectory default fileExists: aName)
- ifFalse: [^ self halt: 'Cannot locate ', aName, ' so cannot proceed.'].
- aFile := FileStream readOnlyFileNamed: aName].
- SourceFiles at: 1 put: (ReadWriteStream with: aFile contentsOfEntireFile).
-
- aName := SmalltalkImage current changesName.
- (aFile := SourceFiles last) == nil ifTrue:
- [(FileDirectory default fileExists: aName)
- ifFalse: [^ self halt: 'Cannot locate ', aName, ' so cannot proceed.'].
- aFile := FileStream readOnlyFileNamed: aName].
- SourceFiles at: 2 put: (ReadWriteStream with: aFile contentsOfEntireFile).
-
- self inform: 'Okay, sources internalized'!
Item was removed:
- ----- Method: SystemDictionary>>testFormatter2 (in category 'housekeeping') -----
- testFormatter2
- "Smalltalk testFormatter2"
-
- "Reformats the source for every method in the system, and
- then verifies that the order of source tokens is unchanged.
- The formatting used will be either classic monochrome or
- fancy polychrome, depending on the setting of the preference
- #colorWhenPrettyPrinting. "
-
- "Note: removed references to Preferences colorWhenPrettyPrinting and replaced them simply with false, as I've been removing this preference lately. --Ron Spengler 8/23/09"
-
- | badOnes |
- badOnes := OrderedCollection new.
- self forgetDoIts.
- 'Formatting all classes...'
- displayProgressAt: Sensor cursorPoint
- from: 0
- to: CompiledMethod instanceCount
- during:
- [:bar | | n |
- n := 0.
- self systemNavigation allBehaviorsDo:
- [:cls |
- "Transcript cr; show: cls name."
-
- cls selectorsDo:
- [:selector | | newCodeString oldCodeString oldTokens newTokens |
- (n := n + 1) \\ 100 = 0 ifTrue: [bar value: n].
- oldCodeString := (cls sourceCodeAt: selector) asString.
- newCodeString := cls prettyPrinterClass
- format: oldCodeString
- in: cls
- notifying: nil
- decorated: false.
- oldTokens := oldCodeString findTokens: Character separators.
- newTokens := newCodeString findTokens: Character separators.
- oldTokens = newTokens
- ifFalse:
- [Transcript
- cr;
- show: '***' , cls name , ' ' , selector.
- badOnes add: cls name , ' ' , selector]]]].
- self systemNavigation browseMessageList: badOnes asSortedCollection
- name: 'Formatter Discrepancies'!
Item was removed:
- ----- Method: SystemDictionary>>forgetDoIts (in category 'housekeeping') -----
- forgetDoIts
- "Smalltalk forgetDoIts"
- "get rid of old DoIt methods"
-
- self systemNavigation allBehaviorsDo:
- [:cl | cl forgetDoIts]
-
- !
Item was removed:
- ----- Method: SystemDictionary>>removeAllUnSentMessages (in category 'shrinking') -----
- removeAllUnSentMessages
- "Smalltalk removeAllUnSentMessages"
- "[Smalltalk unusedClasses do: [:c | (Smalltalk at: c) removeFromSystem].
- Smalltalk removeAllUnSentMessages > 0] whileTrue."
- "Remove all implementations of unsent messages."
- | sels n |
- sels := self systemNavigation allUnSentMessages.
- "The following should be preserved for doIts, etc"
- "needed even after #majorShrink is pulled"
- #(#rehashWithoutBecome #compactSymbolTable #rebuildAllProjects #browseAllSelect: #lastRemoval #scrollBarValue: vScrollBarValue: #scrollBarMenuButtonPressed: #withSelectionFrom: #to: #removeClassNamed: #dragon: #hilberts: #mandala: #web #test3 #factorial #tinyBenchmarks #benchFib #newDepth: #restoreAfter: #forgetDoIts #zapAllMethods #obsoleteClasses #removeAllUnSentMessages #abandonSources #removeUnreferencedKeys #reclaimDependents #zapOrganization #condenseChanges #browseObsoleteReferences #subclass:instanceVariableNames:classVariableNames:poolDictionaries:category: #methodsFor:stamp: #methodsFor:stamp:prior: #instanceVariableNames: #startTimerInterruptWatcher #unusedClasses )
- do: [:sel | sels
- remove: sel
- ifAbsent: []].
- "The following may be sent by perform: in dispatchOnChar..."
- (Smalltalk at: #ParagraphEditor) ifNotNilDo: [:paragraphEditor |
- (paragraphEditor classPool at: #CmdActions) asSet
- do: [:sel | sels
- remove: sel
- ifAbsent: []].
- (paragraphEditor classPool at: #ShiftCmdActions) asSet
- do: [:sel | sels
- remove: sel
- ifAbsent: []]].
- sels size = 0
- ifTrue: [^ 0].
- n := 0.
- self systemNavigation
- allBehaviorsDo: [:x | n := n + 1].
- 'Removing ' , sels size printString , ' messages . . .'
- displayProgressAt: Sensor cursorPoint
- from: 0
- to: n
- during: [:bar |
- n := 0.
- self systemNavigation
- allBehaviorsDo: [:class |
- bar value: (n := n + 1).
- sels
- do: [:sel | class basicRemoveSelector: sel]]].
- ^ sels size!
Item was removed:
- ----- Method: SmalltalkImage>>computeImageSegmentation (in category 'shrinking') -----
- computeImageSegmentation
- "Smalltalk computeImageSegmentation"
- "Here's how the segmentation works:
- For each partition, we collect the classes involved, and also all
- messages no longer used in the absence of this partition. We
- start by computing a 'Miscellaneous' segment of all the
- unused classes in the system as is."
- | partitions unusedCandM newClasses expandedCandM |
- partitions := Dictionary new.
- unusedCandM := self unusedClassesAndMethodsWithout: {{}. {}}.
- partitions at: 'Miscellaneous' put: unusedCandM.
- newClasses := Array
- streamContents: [:s | (SystemOrganization categoriesMatching: 'VMConstruction-*')
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'VMConstruction' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | (SystemOrganization categoriesMatching: 'ST80-*')
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'ST80' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | (SystemOrganization categoriesMatching: 'Morphic-Games')
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'Games' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | (SystemOrganization categoriesMatching: 'Morphic-Remote')
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'Nebraska' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | ((SystemOrganization categoriesMatching: 'Network-*')
- copyWithoutAll: #('Network-Kernel' 'Network-Url' 'Network-Protocols' 'Network-ObjectSocket' ))
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- expandedCandM := Smalltalk unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'Network' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | (SystemOrganization categoriesMatching: 'Balloon3D-*')
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'Balloon3D' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | (SystemOrganization categoriesMatching: 'FFI-*')
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'FFI' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | (SystemOrganization categoriesMatching: 'Genie-*')
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'Genie' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | (SystemOrganization categoriesMatching: 'Speech-*')
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'Speech' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | #('Morphic-Components' )
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- newClasses := newClasses copyWithoutAll: #(#ComponentLikeModel ).
- expandedCandM := Smalltalk unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'Components' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | #('Sound-Scores' 'Sound-Interface' )
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- newClasses := newClasses , #(#WaveletCodec #Sonogram #FWT #AIFFFileReader ).
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'Sound' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | ((SystemOrganization categoriesMatching: 'Tools-*')
- copyWithout: 'Tools-Menus')
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- newClasses := newClasses copyWithoutAll: #(#Debugger #Inspector #ContextVariablesInspector #SyntaxError #ChangeSet #ChangeRecord #ClassChangeRecord #ChangeList #VersionsBrowser ).
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'Tools' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | (SystemOrganization categoriesMatching: 'Balloon-MMFlash*')
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- newClasses := newClasses , #(#ADPCMCodec ).
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'Flash' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | (SystemOrganization categoriesMatching: 'Balloon-TrueType*')
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'TrueType' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- newClasses := Array
- streamContents: [:s | (SystemOrganization categoriesMatching: 'Graphics-Files')
- do: [:cat | (SystemOrganization superclassOrder: cat)
- do: [:c | s nextPut: c name]]].
- expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
- partitions at: 'GraphicFiles' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
- yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
- unusedCandM := expandedCandM.
- #(#AliceConstants 'Balloon3D' #B3DEngineConstants 'Balloon3D' #WonderlandConstants 'Balloon3D' #FFIConstants 'FFI' #KlattResonatorIndices 'Speech' )
- pairsDo: [:poolName :part | (partitions at: part) first add: poolName].
- partitions
- keysDo: [:k | k = 'Miscellaneous'
- ifFalse: [(partitions at: 'Miscellaneous') first removeAllFoundIn: (partitions at: k) first]].
- ^ partitions!
Item was removed:
- ----- Method: SmalltalkImage>>recover: (in category 'sources, changes log') -----
- recover: nCharacters
- "Schedule an editable text view on the last n characters of changes."
- self writeRecentCharacters: nCharacters toFileNamed: 'st80.recent'!
Item was removed:
- ----- Method: SystemDictionary>>handleUserInterrupt (in category 'miscellaneous') -----
- handleUserInterrupt
- Preferences cmdDotEnabled ifTrue:
- [[Project current interruptName: 'User Interrupt'] fork]
- !
Item was removed:
- ----- Method: SystemDictionary>>clearExternalObjects (in category 'special objects') -----
- clearExternalObjects
- "Clear the array of objects that have been registered for use in non-Smalltalk code."
- "Smalltalk clearExternalObjects"
-
- ExternalSemaphoreTable clearExternalObjects
- !
Item was removed:
- ----- Method: SmalltalkImage>>externalizeSources (in category 'sources, changes log') -----
- externalizeSources
- "Write the sources and changes streams onto external files."
- "Smalltalk externalizeSources"
- "the logic of this method is complex because it uses changesName and self changesName
- may be this is normal - sd"
-
- | sourcesName changesName aFile |
- sourcesName := SmalltalkImage current sourcesName.
- (FileDirectory default fileExists: sourcesName)
- ifTrue: [^ self inform:
- 'Sorry, you must first move or remove the
- file named ', sourcesName].
- changesName := SmalltalkImage current changesName.
- (FileDirectory default fileExists: changesName)
- ifTrue: [^ self inform:
- 'Sorry, you must first move or remove the
- file named ', changesName].
-
- aFile := FileStream newFileNamed: sourcesName.
- aFile nextPutAll: SourceFiles first originalContents.
- aFile close.
- self setMacFileInfoOn: sourcesName.
- SourceFiles at: 1 put: (FileStream readOnlyFileNamed: sourcesName).
-
- aFile := FileStream newFileNamed: SmalltalkImage current changesName.
- aFile nextPutAll: SourceFiles last contents.
- aFile close.
- "On Mac, set the file type and creator (noop on other platforms)"
- FileDirectory default
- setMacFileNamed: SmalltalkImage current changesName
- type: 'STch'
- creator: 'FAST'.
- SourceFiles at: 2 put: (FileStream oldFileNamed: changesName).
-
- self inform: 'Sources successfully externalized'.
- !
Item was removed:
- ----- Method: SystemDictionary>>primBytesLeft (in category 'memory space') -----
- primBytesLeft
- "Primitive. Answer the number of bytes available for new object data.
- Not accurate unless preceded by
- Smalltalk garbageCollectMost (for reasonable accuracy), or
- Smalltalk garbageCollect (for real accuracy).
- See Object documentation whatIsAPrimitive."
-
- <primitive: 112>
- ^ 0!
Item was removed:
- ----- Method: SystemDictionary>>rootTableAt: (in category 'memory space') -----
- rootTableAt: index
- "Primitive. Answer the nth element of the VMs root table"
- <primitive: 'primitiveRootTableAt'>
- ^nil!
Item was removed:
- ----- Method: SystemDictionary>>primImageName: (in category 'image, changes name') -----
- primImageName: newName
- "Set the the full path name for the current image. All further snapshots will use this."
-
- <primitive: 121>
- ^ self primitiveFailed!
Item was removed:
- ----- Method: SystemDictionary>>primSignalAtBytesLeft: (in category 'memory space') -----
- primSignalAtBytesLeft: numBytes
- "Tell the interpreter the low-space threshold in bytes. When the free
- space falls below this threshold, the interpreter will signal the low-space
- semaphore, if one has been registered. Disable low-space interrupts if the
- argument is zero. Fail if numBytes is not an Integer."
-
- <primitive: 125>
- self primitiveFailed!
Item was removed:
- ----- Method: SystemDictionary>>removeAllLineFeeds (in category 'housekeeping') -----
- removeAllLineFeeds
- "Smalltalk removeAllLineFeeds"
- "Scan all methods for source code with lineFeeds.
- Replaces all occurrences of <CR><LF> or <LF> by <CR>.
- When done, offers to display an Inspector containing the message
- names grouped by author initials.
- In this dictionary, the key 'OK' contains the methods that had literals that contained <LF> characters."
- | totalStripped totalOK authors |
- 'Scanning sources for LineFeeds.
- This will take a few minutes...'
- displayProgressAt: Sensor cursorPoint
- from: 0
- to: CompiledMethod instanceCount
- during: [:bar | | n |
- n := 0.
- authors := self
- removeAllLineFeedsQuietlyCalling: [:cls :sel | (n := n + 1) \\ 100 = 0
- ifTrue: [bar value: n]]].
- totalStripped := authors
- inject: 1
- into: [:sum :set | sum + set size].
- totalOK := (authors at: 'OK') size.
- totalStripped := totalStripped - totalOK.
- Transcript cr; show: totalStripped printString , ' methods stripped of LFs.'.
- Transcript cr; show: totalOK printString , ' methods still correctly contain LFs.'.
- (self confirm: 'Do you want to see the affected methods?')
- ifTrue: [authors inspect]!
Item was removed:
- ----- Method: SmalltalkImage>>reformatChangesToUTF8 (in category 'housekeeping') -----
- reformatChangesToUTF8
- "Smalltalk reformatChangesToUTF8"
-
- | f oldChanges |
- f := FileStream fileNamed: 'ST80.temp'.
- f converter: (UTF8TextConverter new).
- f header; timeStamp.
- 'Condensing Changes File...'
- displayProgressAt: Sensor cursorPoint
- from: 0 to: Smalltalk classNames size
- during:
- [:bar | | classCount | classCount := 0.
- Smalltalk allClassesDo:
- [:class | bar value: (classCount := classCount + 1).
- class moveChangesTo: f.
- class putClassCommentToCondensedChangesFile: f.
- class class moveChangesTo: f]].
- SmalltalkImage current lastQuitLogPosition: f position.
- f trailer; close.
- oldChanges := SourceFiles at: 2.
- oldChanges close.
- FileDirectory default
- deleteFileNamed: oldChanges name , '.old';
- rename: oldChanges name toBe: oldChanges name , '.old';
- rename: f name toBe: oldChanges name.
- self setMacFileInfoOn: oldChanges name.
- SourceFiles at: 2
- put: (FileStream oldFileNamed: oldChanges name).
- MultiByteFileStream codeConverterClass: UTF8TextConverter.
- (SourceFiles at: 2) converter: (UTF8TextConverter new).
- !
Item was removed:
- ----- Method: SystemDictionary>>useUpMemoryWithTinyObjects (in category 'memory space') -----
- useUpMemoryWithTinyObjects
- "For testing the low space handler..."
- "Smalltalk installLowSpaceWatcher; useUpMemoryWithTinyObjects"
-
- | b | "First use up most of memory."
- b := String new: self bytesLeft - self lowSpaceThreshold - 100000.
- b := b. "Avoid unused value warning"
- (1 to: 10000) collect: [:i | BitBlt new]!
Item was removed:
- ----- Method: SystemDictionary>>presumedSentMessages (in category 'shrinking') -----
- presumedSentMessages | sent |
- "Smalltalk presumedSentMessages"
-
- "The following should be preserved for doIts, etc"
- sent := IdentitySet new.
- #( rehashWithoutBecome compactSymbolTable rebuildAllProjects
- browseAllSelect: lastRemoval
- scrollBarValue: vScrollBarValue: scrollBarMenuButtonPressed:
- withSelectionFrom: to: removeClassNamed:
- dragon: hilberts: mandala: web test3 factorial tinyBenchmarks benchFib
- newDepth: restoreAfter: forgetDoIts zapAllMethods obsoleteClasses
- removeAllUnSentMessages abandonSources removeUnreferencedKeys
- reclaimDependents zapOrganization condenseChanges browseObsoleteReferences
- subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:
- methodsFor:stamp: methodsFor:stamp:prior: instanceVariableNames:
- startTimerInterruptWatcher unusedClasses) do:
- [:sel | sent add: sel].
- "The following may be sent by perform: in dispatchOnChar..."
- (Smalltalk at: #ParagraphEditor) ifNotNilDo: [:paragraphEditor |
- (paragraphEditor classPool at: #CmdActions) asSet do:
- [:sel | sent add: sel].
- (paragraphEditor classPool at: #ShiftCmdActions) asSet do:
- [:sel | sent add: sel]].
- ^ sent!
Item was removed:
- ----- Method: SystemDictionary>>bytesLeft (in category 'memory space') -----
- bytesLeft
- "Answer the number of bytes of space available. Does a full garbage collection."
-
- ^ self garbageCollect
- !
Item was removed:
- ----- Method: SmalltalkImage>>discardSpeech (in category 'shrinking') -----
- discardSpeech
- "Discard support for speech synthesis"
-
- SystemOrganization removeCategoriesMatching: 'Speech*'.
- !
Item was removed:
- ----- Method: SmalltalkImage>>hasBindingThatBeginsWith: (in category 'dictionary access') -----
- hasBindingThatBeginsWith: aString
- "delegate to globals"
- ^globals hasBindingThatBeginsWith: aString!
Item was removed:
- ----- Method: SmalltalkImage>>discardDiscards (in category 'shrinking') -----
- discardDiscards
- "Discard all discard* methods - including this one."
-
- (self class selectors select: [:each | each beginsWith: 'discard'])
- do: [:each | self class removeSelector: each].
- #(lastRemoval majorShrink zapMVCprojects)
- do: [:each | self class removeSelector: each]!
Item was removed:
- ----- Method: SmalltalkImage>>makeInternalRelease (in category 'housekeeping') -----
- makeInternalRelease
- "Smalltalk makeInternalRelease"
- (self confirm: SystemVersion current version , '
- Is this the correct version designation?
- If not, choose no, and fix it.')
- ifFalse: [^ self].
- (Object classPool at: #DependentsFields) size > 1
- ifTrue: [self halt].
- Smalltalk at: #Browser ifPresent:[:br| br initialize].
- Undeclared isEmpty
- ifFalse: [self halt].
- self garbageCollect.
- self obsoleteClasses isEmpty
- ifFalse: [self halt].
- Symbol rehash.
- self halt: 'Ready to condense changes'.
- self condenseChanges!
Item was removed:
- ----- Method: SmalltalkImage>>discardMVC (in category 'shrinking') -----
- discardMVC
- "After suitable checks, remove all of MVC from the system. Removal will destroy current
- MVC projects. MVC may be reinstalled by loading packages ST80 and ToolBuilder-MVC."
-
- "Smalltalk discardMVC"
-
- self isMorphic
- ifFalse: [^self inform: 'You must be in a Morphic project to discard MVC.'].
- "Check that there are no MVC Projects"
- (Project allProjects allSatisfy: [:proj | proj isMorphic])
- ifFalse: [(self confirm: 'Would you like a chance to remove your
- MVC projects in an orderly manner?')
- ifTrue: [^ self].
- (self confirm: 'If you wish, I can remove all MVC projects,
- make this project be the top project, and place
- all orphaned sub-projects of MVC parents here.
- Would you like be to do this
- and proceed to discard all MVC classes?')
- ifTrue: [self zapMVCprojects]
- ifFalse: [^ self]].
- (MCPackage named: 'ToolBuilder-MVC') unload.
- (MCPackage named: 'ST80') unload.
- ScheduledControllers := nil.
- Smalltalk garbageCollect.
- Undeclared removeUnreferencedKeys.
- SystemOrganization removeEmptyCategories.
- Symbol rehash!
Item was removed:
- ----- Method: SystemDictionary>>setGCSemaphore: (in category 'memory space') -----
- setGCSemaphore: semaIndex
- "Primitive. Indicate the GC semaphore index to be signaled on GC occurance."
- <primitive: 'primitiveSetGCSemaphore'>
- ^self primitiveFailed
- "Example:
-
- | index sema process |
- sema := Semaphore new.
- index := Smalltalk registerExternalObject: sema.
- Smalltalk setGCSemaphore: index.
- process := [
- [[true] whileTrue:[
- sema wait.
- Smalltalk beep.
- ]] ensure:[
- Smalltalk setGCSemaphore: 0.
- Smalltalk unregisterExternalObject: sema.
- ].
- ] fork.
- process inspect.
- "!
More information about the Packages
mailing list