[Pkg] The Trunk: System-ar.277.mcz
commits at source.squeak.org
commits at source.squeak.org
Sat Mar 6 03:48:03 UTC 2010
Andreas Raab uploaded a new version of System to project The Trunk:
http://source.squeak.org/trunk/System-ar.277.mcz
==================== Summary ====================
Name: System-ar.277
Author: ar
Time: 5 March 2010, 7:43:29.632 pm
UUID: ab4819fd-c36c-a845-a851-c394d5754172
Ancestors: System-cmm.276
First part of Smalltalk/SystemDictionary conversion:
- Copy all missing methods from SystemDictionary to SmalltalkImage
- Convert Smalltalk to SmalltalkImage current globals
- Convert SmalltalkImage current to Smalltalk
This leaves the system in a state where a *lot* of methods are intentionally duplicated between SmalltalkImage and SystemDictionary to give us room to clean up things once we have the basics in place.
=============== Diff against System-cmm.276 ===============
Item was added:
+ ----- Method: SmalltalkImage class>>initializeShutDownList (in category 'class initialization') -----
+ initializeShutDownList
+ "SmalltalkImage initialize"
+
+ | oldList |
+ 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 added:
+ ----- Method: SmalltalkImage>>associationOrUndeclaredAt: (in category 'dictionary access') -----
+ associationOrUndeclaredAt: key
+ "return an association or install in undeclared. Used for mating up ImageSegments."
+
+ ^ globals associationAt: key ifAbsent: [
+ Undeclared at: key put: nil.
+ Undeclared associationAt: key]!
Item was changed:
+ ----- Method: SmalltalkImage>>platformSubtype (in category 'system attributes') -----
- ----- Method: SmalltalkImage>>platformSubtype (in category 'system attribute') -----
platformSubtype
"Return the subType of the platform we're running on"
^self getSystemAttribute: 1003!
Item was added:
+ ----- 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>>windowSystemName (in category 'system attributes') -----
- ----- Method: SmalltalkImage>>windowSystemName (in category 'system attribute') -----
windowSystemName
"Return the name of the window system currently being used for display."
"SmalltalkImage current windowSystemName"
^self getSystemAttribute: 1005!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>specialSelectorSize (in category 'special objects') -----
+ specialSelectorSize
+ "Answer the number of special selectors in the system."
+
+ ^ (self specialObjectsArray at: 24) size // 2!
Item was added:
+ ----- Method: SmalltalkImage>>createStackOverflow (in category 'memory space') -----
+ createStackOverflow
+ "For testing the low space handler..."
+ "Smalltalk installLowSpaceWatcher; createStackOverflow"
+
+ self createStackOverflow. "infinite recursion"!
Item was added:
+ ----- Method: SmalltalkImage class>>cleanUp (in category 'class initialization') -----
+ cleanUp
+ "Flush caches"
+
+ Smalltalk flushClassNameCache.
+ Smalltalk cleanUpUndoCommands.
+ Undeclared removeUnreferencedKeys.
+ Smalltalk forgetDoIts.!
Item was changed:
----- Method: SystemNavigation>>allCallsOn:from: (in category 'query') -----
allCallsOn: aSymbol from: aClass
"Answer a SortedCollection of all the methods that call on aSymbol."
| aSortedCollection special byte |
aSortedCollection := SortedCollection new.
+ special := Smalltalk hasSpecialSelector: aSymbol ifTrueSetByte: [:b | byte := b ].
- special := aClass environment hasSpecialSelector: aSymbol ifTrueSetByte: [:b | byte := b ].
aClass withAllSubclassesDo: [ :class |
(class whichSelectorsReferTo: aSymbol special: special byte: byte) do: [:sel |
sel isDoIt ifFalse: [
aSortedCollection add: (
MethodReference new
setStandardClass: class
methodSymbol: sel
)
]
]
].
^aSortedCollection!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>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 changed:
Object subclass: #SmalltalkImage
+ instanceVariableNames: 'globals'
+ classVariableNames: 'EndianCache LastImageName LastQuitLogPosition LastStats LowSpaceProcess LowSpaceSemaphore MemoryHogs ShutDownList SourceFileVersionString SpecialSelectors StartUpList StartupStamp WordSize'
- instanceVariableNames: ''
- classVariableNames: 'EndianCache LastImageName LastQuitLogPosition LastStats SourceFileVersionString StartupStamp'
poolDictionaries: ''
category: 'System-Support'!
SmalltalkImage class
instanceVariableNames: 'current'!
!SmalltalkImage commentStamp: 'sd 7/2/2003 21:50' prior: 0!
I represent the SmalltalkImage and partly the VM. Using my current instance you can
- get the value of some VM parameters, system arguments, vm profiling,
endianess status, external objects,....
- save the image, manage sources
As you will notice browsing my code I'm a fat class having still too much responsibility.
But this is life. sd-2 July 2003
PS: if someone wants to split me go ahead.!
SmalltalkImage class
instanceVariableNames: 'current'!
Item was added:
+ ----- Method: SmalltalkImage>>verifyChanges (in category 'housekeeping') -----
+ verifyChanges "Smalltalk verifyChanges"
+ "Recompile all methods in the changes file."
+ self systemNavigation allBehaviorsDo: [:class | class recompileChanges].
+ !
Item was added:
+ ----- Method: SmalltalkImage>>discardMIDI (in category 'shrinking') -----
+ discardMIDI
+
+ "this seems to have gone away"!
Item was changed:
+ ----- Method: SmalltalkImage>>setPlatformPreferences (in category 'snapshot and quit') -----
- ----- Method: SmalltalkImage>>setPlatformPreferences (in category 'preferences') -----
setPlatformPreferences
"Set some platform specific preferences on system startup"
| platform specs |
Preferences automaticPlatformSettings ifFalse:[^self].
platform := self platformName.
specs := #(
(soundStopWhenDone false)
(soundQuickStart false)
).
platform = 'Win32' ifTrue:[
specs := #(
(soundStopWhenDone true)
(soundQuickStart false)
)].
platform = 'Mac OS' ifTrue:[
specs := #(
(soundStopWhenDone false)
(soundQuickStart true)
)].
specs do:[:tuple|
Preferences setPreference: tuple first toValue: (tuple last == true).
].
!
Item was added:
+ ----- Method: SmalltalkImage>>removeKey:ifAbsent: (in category 'dictionary access') -----
+ removeKey: key ifAbsent: aBlock
+ "delegate to globals"
+ ^globals removeKey: key ifAbsent: aBlock!
Item was added:
+ ----- 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 added:
+ ----- 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 added:
+ ----- Method: SmalltalkImage>>do: (in category 'dictionary access') -----
+ do: aBlock
+ "delegate to globals"
+ ^globals do: aBlock!
Item was added:
+ ----- 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 added:
+ ----- Method: SmalltalkImage>>discardNetworking (in category 'shrinking') -----
+ discardNetworking
+ "Discard the support for TCP/IP networking."
+
+ SystemOrganization removeCategoriesMatching: 'Network-*'.
+
+ !
Item was added:
+ ----- Method: SmalltalkImage>>copyright (in category 'sources, changes 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 added:
+ ----- 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 added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>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 changed:
+ ----- Method: SmalltalkImage>>unbindExternalPrimitives (in category 'modules') -----
- ----- Method: SmalltalkImage>>unbindExternalPrimitives (in category 'external') -----
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."
<primitive: 570>
"Do nothing if the primitive fails for compatibility with older VMs"
!
Item was added:
+ ----- 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 added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>addToStartUpList:after: (in category 'snapshot and quit') -----
+ addToStartUpList: aClass after: predecessor
+
+ self add: aClass toList: StartUpList after: predecessor!
Item was added:
+ ----- Method: SmalltalkImage>>writeRecentToFile (in category 'sources, changes 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 added:
+ ----- 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 added:
+ ----- Method: SmalltalkImage>>allClassesAndTraitsDo: (in category 'classes and traits') -----
+ allClassesAndTraitsDo: aBlock
+ "Evaluate the argument, aBlock, for each class and trait in the system."
+
+ self allClassesDo: aBlock.
+ self allTraitsDo: aBlock.
+ !
Item was added:
+ ----- Method: SmalltalkImage>>includes: (in category 'dictionary access') -----
+ includes: element
+ "delegate to globals"
+ ^globals includes: element!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- 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 added:
+ ----- 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 added:
+ ----- Method: SmalltalkImage>>forgetDoIts (in category 'housekeeping') -----
+ forgetDoIts
+ "Smalltalk forgetDoIts"
+ "get rid of old DoIt methods"
+
+ self systemNavigation allBehaviorsDo:
+ [:cl | cl forgetDoIts]
+
+ !
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>renameClassNamed:as: (in category 'classes and traits') -----
+ renameClassNamed: oldName as: newName
+ "DO NOT DEPRECATE - 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. "
+
+ ^globals renameClassNamed: oldName as: newName!
Item was added:
+ ----- Method: SmalltalkImage>>associationAt: (in category 'dictionary access') -----
+ associationAt: key
+ "delegate to globals"
+ ^globals associationAt: key!
Item was added:
+ ----- Method: SmalltalkImage>>handleUserInterrupt (in category 'miscellaneous') -----
+ handleUserInterrupt
+ Preferences cmdDotEnabled ifTrue:
+ [[Project current interruptName: 'User Interrupt'] fork]
+ !
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>allClassesAndTraits (in category 'classes and traits') -----
+ allClassesAndTraits
+ "Return all the classes and traits defined in the system"
+
+ ^Array streamContents:[:s| self allClassesAndTraitsDo:[:each| s nextPut: each]].!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>bindingOf: (in category 'dictionary access') -----
+ bindingOf: aString
+ "delegate to globals"
+ ^globals bindingOf: aString!
Item was added:
+ ----- Method: SmalltalkImage>>renameClass:as: (in category 'classes and traits') -----
+ renameClass: aClass as: newName
+ "Rename the class, aClass, to have the title newName."
+ "Original one I want to keep but needs to be fixed"
+
+ | oldref oldName category |
+ oldName := aClass name.
+ category := aClass category.
+ SystemOrganization classify: newName under: aClass category.
+ SystemOrganization removeElement: aClass name.
+ oldref := self associationAt: aClass name.
+ self removeKey: aClass name.
+ oldref key: newName.
+ self add: oldref. "Old association preserves old refs"
+ (Array with: StartUpList with: ShutDownList) do:
+ [:list | | i | i := list indexOf: aClass name ifAbsent: [0].
+ i > 0 ifTrue: [list at: i put: newName]].
+ self flushClassNameCache.
+ SystemChangeNotifier uniqueInstance classRenamed: aClass from: oldName to: newName inCategory: category!
Item was changed:
+ ----- Method: SmalltalkImage>>calcEndianness (in category 'system attributes') -----
- ----- Method: SmalltalkImage>>calcEndianness (in category 'endian') -----
calcEndianness
| bytes word blt |
"What endian-ness is the current hardware? The String '1234' will be stored into a machine word. On BigEndian machines (the Mac), $1 will be the high byte if the word. On LittleEndian machines (the PC), $4 will be the high byte."
"SmalltalkImage current endianness"
bytes := ByteArray withAll: #(0 0 0 0). "(1 2 3 4) or (4 3 2 1)"
word := WordArray with: 16r01020304.
blt := (BitBlt toForm: (Form new hackBits: bytes))
sourceForm: (Form new hackBits: word).
blt combinationRule: Form over. "store"
blt sourceY: 0; destY: 0; height: 1; width: 4.
blt sourceX: 0; destX: 0.
blt copyBits. "paste the word into the bytes"
bytes first = 1 ifTrue: [^ #big].
bytes first = 4 ifTrue: [^ #little].
self error: 'Ted is confused'.!
Item was added:
+ ----- Method: SmalltalkImage>>at:put: (in category 'dictionary access') -----
+ 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 added:
+ ----- Method: SmalltalkImage>>rootTableAt: (in category 'memory space') -----
+ rootTableAt: index
+ "Primitive. Answer the nth element of the VMs root table"
+ <primitive: 'primitiveRootTableAt'>
+ ^nil!
Item was added:
+ ----- Method: SmalltalkImage>>removeKey: (in category 'dictionary access') -----
+ removeKey: key
+ "delegate to globals"
+ ^globals removeKey: key!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- 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 added:
+ ----- 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 added:
+ ----- Method: SmalltalkImage>>at:ifAbsent: (in category 'dictionary access') -----
+ at: key ifAbsent: aBlock
+ "delegate to globals"
+ ^globals at: key ifAbsent: aBlock!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>bytesLeft (in category 'memory space') -----
+ bytesLeft
+ "Answer the number of bytes of space available. Does a full garbage collection."
+
+ ^ self garbageCollect
+ !
Item was added:
+ ----- Method: SmalltalkImage>>classNames (in category 'classes and traits') -----
+ classNames
+ "Answer a collection of all class names in the system."
+
+ ^self allClasses collect:[:aClass| aClass name].!
Item was added:
+ ----- Method: SmalltalkImage>>globals (in category 'accessing') -----
+ globals
+ "Answer the global SystemDictionary"
+ ^globals!
Item was changed:
+ ----- Method: SmalltalkImage>>extractParameters (in category 'system attributes') -----
- ----- Method: SmalltalkImage>>extractParameters (in category 'system attribute') -----
extractParameters
| pName value index globals |
globals := Dictionary new.
index := 3. "Muss bei 3 starten, da 2 documentName ist"
[pName := self getSystemAttribute: index.
pName isEmptyOrNil] whileFalse:[
index := index + 1.
value := self getSystemAttribute: index.
value ifNil: [value := ''].
globals at: pName asUppercase put: value.
index := index + 1].
^globals!
Item was added:
+ ----- Method: SmalltalkImage>>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.
+ "!
Item was added:
+ ----- Method: SmalltalkImage>>allTraits (in category 'classes and traits') -----
+ allTraits
+ "Return all traits defined in the system"
+
+ ^Array streamContents:[:s| self allTraitsDo:[:aTrait| s nextPut: aTrait]].!
Item was changed:
+ ----- Method: SmalltalkImage>>logChange: (in category 'sources, changes log') -----
- ----- Method: SmalltalkImage>>logChange: (in category 'sources, change log') -----
logChange: aStringOrText
"Write the argument, aString, onto the changes file."
| aString changesFile |
(SourceFiles isNil or: [(SourceFiles at: 2) == nil]) ifTrue: [^ self].
self assureStartupStampLogged.
aString := aStringOrText asString.
(aString findFirst: [:char | char isSeparator not]) = 0
ifTrue: [^ self]. "null doits confuse replay"
(changesFile := SourceFiles at: 2).
changesFile isReadOnly ifTrue:[^self].
changesFile setToEnd; cr; cr.
changesFile nextChunkPut: aString.
"If want style changes in DoIt, use nextChunkPutWithStyle:, and allow Texts to get here"
self forceChangesToDisk.!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- 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 added:
+ ----- Method: SmalltalkImage>>objectForDataStream: (in category 'miscellaneous') -----
+ objectForDataStream: refStrm
+ | dp |
+ "I am about to be written on an object file. Write a reference to Smalltalk instead."
+
+ dp := DiskProxy global: #Smalltalk selector: #yourself
+ args: #().
+ refStrm replace: self with: dp.
+ ^ dp!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>size (in category 'dictionary access') -----
+ size
+ "delegate to globals"
+ ^globals size!
Item was added:
+ ----- Method: SmalltalkImage>>organization (in category 'accessing') -----
+ organization
+ "Return the organizer for the receiver"
+ ^SystemOrganization!
Item was added:
+ ----- Method: SmalltalkImage>>allTraitsDo: (in category 'classes and traits') -----
+ allTraitsDo: aBlock
+ "Evaluate the argument, aBlock, for each trait in the system."
+
+ ^globals allTraitsDo: aBlock!
Item was added:
+ ----- 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 changed:
+ ----- Method: SmalltalkImage>>platformName (in category 'system attributes') -----
- ----- Method: SmalltalkImage>>platformName (in category 'system attribute') -----
platformName
"Return the name of the platform we're running on"
^self getSystemAttribute: 1001!
Item was added:
+ ----- 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 added:
+ ----- Method: SmalltalkImage>>removeFromShutDownList: (in category 'snapshot and quit') -----
+ removeFromShutDownList: aClass
+
+ ShutDownList remove: aClass name ifAbsent: []!
Item was added:
+ ----- Method: SmalltalkImage>>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 changed:
+ ----- Method: SmalltalkImage>>fixObsoleteReferences (in category 'housekeeping') -----
- ----- Method: SmalltalkImage>>fixObsoleteReferences (in category 'image cleanup') -----
fixObsoleteReferences
"SmalltalkImage current fixObsoleteReferences"
Smalltalk garbageCollect; garbageCollect.
Preference allInstances do: [:each | | informee |
informee := each instVarNamed: #changeInformee.
((informee isKindOf: Behavior)
and: [informee isObsolete])
ifTrue: [
Transcript show: 'Preference: '; show: each name; cr.
each instVarNamed: #changeInformee put: (Smalltalk at: (informee name copyReplaceAll: 'AnObsolete' with: '') asSymbol)]].
CompiledMethod allInstances do: [:method |
| obsoleteBindings |
obsoleteBindings := method literals select: [:literal |
literal isVariableBinding
and: [literal value isBehavior
and: [literal value isObsolete]]].
obsoleteBindings do: [:binding |
| obsName realName realClass |
obsName := binding value name.
Transcript show: 'Binding: '; show: obsName; cr.
realName := obsName copyReplaceAll: 'AnObsolete' with: ''.
realClass := Smalltalk at: realName asSymbol ifAbsent: [UndefinedObject].
binding isSpecialWriteBinding
ifTrue: [binding privateSetKey: binding key value: realClass]
ifFalse: [binding key: binding key value: realClass]]].
Behavior flushObsoleteSubclasses.
Smalltalk garbageCollect; garbageCollect.
SystemNavigation default obsoleteBehaviors size > 0
ifTrue: [
SystemNavigation default obsoleteBehaviors inspect.
self error:'Still have obsolete behaviors. See inspector'].
!
Item was added:
+ ----- 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 added:
+ ----- Method: SmalltalkImage>>version (in category 'sources, changes log') -----
+ version
+ "Answer the version of this release."
+
+ ^SystemVersion current version!
Item was added:
+ ----- 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 added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>useUpMemoryWithContexts (in category 'memory space') -----
+ useUpMemoryWithContexts
+ "For testing the low space handler..."
+ "Smalltalk installLowSpaceWatcher; useUpMemoryWithContexts"
+
+ self useUpMemoryWithContexts!
Item was added:
+ ----- 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 added:
+ ----- Method: SmalltalkImage>>keyAtIdentityValue:ifAbsent: (in category 'dictionary access') -----
+ keyAtIdentityValue: anObject ifAbsent: aBlock
+ "delegate to globals"
+ ^globals keyAtIdentityValue: anObject ifAbsent: aBlock!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>specialSelectors (in category 'special objects') -----
+ specialSelectors
+ "Used by SystemTracer only."
+
+ ^SpecialSelectors!
Item was added:
+ ----- 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 added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SystemDictionary>>environment (in category 'accessing') -----
+ environment
+ "For conversion from Smalltalk to SystemDictionary"
+ ^self!
Item was added:
+ ----- Method: SmalltalkImage>>printOn: (in category 'miscellaneous') -----
+ printOn: aStream
+ self == Smalltalk
+ ifTrue: [aStream nextPutAll: #Smalltalk]
+ ifFalse: [super printOn: aStream]!
Item was added:
+ ----- Method: SmalltalkImage>>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 changed:
+ ----- Method: SmalltalkImage>>isLittleEndian (in category 'system attributes') -----
- ----- Method: SmalltalkImage>>isLittleEndian (in category 'endian') -----
isLittleEndian
^self endianness == #little!
Item was added:
+ ----- Method: SmalltalkImage>>currentProjectDo: (in category 'sources, changes log') -----
+ currentProjectDo: aBlock
+ "So that code can work after removal of Projects"
+ self
+ at: #Project
+ ifPresent: [:projClass | aBlock value: projClass current]!
Item was changed:
----- Method: SmalltalkImage class>>startUp (in category 'class initialization') -----
startUp
+ "XXXX: This is broken. SmalltalkImage startUp happens quite late in the startup sequence; earlier startups may very well need the information about the endianness of the platform."
-
EndianCache := nil.
!
Item was added:
+ ----- Method: SmalltalkImage>>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 changed:
+ ----- Method: SmalltalkImage>>exitToDebugger (in category 'snapshot and quit') -----
- ----- Method: SmalltalkImage>>exitToDebugger (in category 'external') -----
exitToDebugger
"Primitive. Enter the machine language debugger, if one exists. Essential.
See Object documentation whatIsAPrimitive. This primitive is to access the
debugger when debugging the vm or a plugging in C"
<primitive: 114>
self primitiveFailed!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>cleanUp (in category 'housekeeping') -----
+ cleanUp "Smalltalk cleanUp"
+ "Gently clean up"
+ ^self cleanUp: false!
Item was added:
+ ----- Method: SmalltalkImage>>scanFor: (in category 'dictionary access') -----
+ scanFor: aKey
+ "delegate to globals"
+ ^globals scanFor: aKey!
Item was added:
+ ----- Method: SmalltalkImage>>scopeFor:from:envtAndPathIfFound: (in category 'accessing') -----
+ scopeFor: varName from: lower envtAndPathIfFound: envtAndPathBlock
+ "Null compatibility with partitioning into environments."
+
+ (globals includesKey: varName)
+ ifTrue: [^ envtAndPathBlock value: self value: String new]
+ ifFalse: [^ nil]!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>removeFromStartUpList: (in category 'snapshot and quit') -----
+ removeFromStartUpList: aClass
+
+ StartUpList remove: aClass name ifAbsent: []!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>addToShutDownList:after: (in category 'snapshot and quit') -----
+ addToShutDownList: aClass after: predecessor
+
+ self add: aClass toList: ShutDownList after: predecessor!
Item was added:
+ ----- Method: SmalltalkImage>>renameClass:from: (in category 'classes and traits') -----
+ renameClass: aClass from: oldName
+ "Rename the class, aClass, to have the title newName."
+ | oldref newName category |
+ newName := aClass name.
+ category := SystemOrganization categoryOfElement: oldName.
+ SystemOrganization classify: newName under: category.
+ SystemOrganization removeElement: oldName.
+ oldref := self associationAt: oldName.
+ self removeKey: oldName.
+ oldref key: newName.
+ self add: oldref. "Old association preserves old refs"
+ (Array with: StartUpList with: ShutDownList) do:
+ [:list | | i | i := list indexOf: oldName ifAbsent: [0].
+ i > 0 ifTrue: [list at: i put: newName]].
+ self flushClassNameCache.
+
+ SystemChangeNotifier uniqueInstance classRenamed: aClass from: oldName to: newName inCategory: category!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>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 changed:
+ ----- Method: SmalltalkImage>>isBigEndian (in category 'system attributes') -----
- ----- Method: SmalltalkImage>>isBigEndian (in category 'endian') -----
isBigEndian
^self endianness == #big!
Item was added:
+ ----- 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 added:
+ ----- Method: SmalltalkImage>>discardFlash (in category 'shrinking') -----
+ discardFlash
+ "Discard Flash support."
+
+ SystemOrganization removeCategoriesMatching: 'Balloon-MMFlash*'
+ !
Item was added:
+ ----- Method: SmalltalkImage>>discardTrueType (in category 'shrinking') -----
+ discardTrueType
+ "Discard TrueType support."
+
+ SystemOrganization removeCategoriesMatching: 'Balloon-TrueType*'.
+
+ !
Item was added:
+ ----- 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 added:
+ ----- Method: SmalltalkImage>>classOrTraitNamed: (in category 'classes and traits') -----
+ classOrTraitNamed: aString
+ "Answer the global with the given name"
+
+ ^globals classOrTraitNamed: aString!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>at:ifPresentAndInMemory: (in category 'dictionary access') -----
+ at: key ifPresentAndInMemory: aBlock
+ "delegate to globals"
+ ^globals at: key ifPresentAndInMemory: aBlock!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- 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 added:
+ ----- Method: SmalltalkImage>>hasClassNamed: (in category 'classes and traits') -----
+ hasClassNamed: aString
+ "Answer whether there is a class of the given name"
+
+ ^globals hasClassNamed: aString!
Item was added:
+ ----- Method: SmalltalkImage>>keys (in category 'dictionary access') -----
+ keys
+ "delegate to globals"
+ ^globals keys!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>includesKey: (in category 'dictionary access') -----
+ includesKey: key
+ "delegate to globals"
+ ^globals includesKey: key!
Item was changed:
+ ----- Method: SmalltalkImage>>sourceFileVersionString: (in category 'miscellaneous') -----
- ----- Method: SmalltalkImage>>sourceFileVersionString: (in category 'private source file') -----
sourceFileVersionString: aString
SourceFileVersionString := aString!
Item was added:
+ ----- Method: SmalltalkImage>>associationAt:ifAbsent: (in category 'dictionary access') -----
+ associationAt: key ifAbsent: aBlock
+ "delegate to globals"
+ ^globals associationAt: key ifAbsent: aBlock!
Item was added:
+ ----- Method: SmalltalkImage>>removeClassNamed: (in category 'classes and traits') -----
+ removeClassNamed: aName
+ "DO NOT DEPRECATE - 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. "
+
+ ^globals removeClassNamed: aName!
Item was added:
+ ----- Method: SmalltalkImage>>allClassesDo: (in category 'classes and traits') -----
+ allClassesDo: aBlock
+ "Evaluate the argument, aBlock, for each class in the system."
+
+ ^globals allClassesDo: aBlock!
Item was added:
+ ----- Method: SmalltalkImage>>wordSize (in category 'sources, changes 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 added:
+ ----- Method: SmalltalkImage>>traitNames (in category 'classes and traits') -----
+ traitNames
+ "Answer a SortedCollection of all traits (not including class-traits) names."
+
+ ^self allTraits collect:[:aTrait| aTrait name].!
Item was changed:
+ ----- Method: SmalltalkImage>>vmVersion (in category 'system attributes') -----
- ----- Method: SmalltalkImage>>vmVersion (in category 'system attribute') -----
vmVersion
"Return a string identifying the interpreter version"
"SmalltalkImage current vmVersion"
^self getSystemAttribute: 1004!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>classNamed: (in category 'classes and traits') -----
+ classNamed: className
+ "Answer the global with the given name."
+
+ ^self classOrTraitNamed: className.!
Item was added:
+ ----- 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 changed:
+ ----- Method: SmalltalkImage>>endianness (in category 'system attributes') -----
- ----- Method: SmalltalkImage>>endianness (in category 'endian') -----
endianness
EndianCache ifNil: [EndianCache := self calcEndianness].
^ EndianCache.
!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>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 changed:
+ ----- Method: SmalltalkImage>>getSystemAttribute: (in category 'system attributes') -----
- ----- Method: SmalltalkImage>>getSystemAttribute: (in category 'system attribute') -----
getSystemAttribute: attributeID
"Optional. Answer the string for the system attribute with the given
integer ID. Answer nil if the given attribute is not defined on this
platform. On platforms that support invoking programs from command
lines (e.g., Unix), this mechanism can be used to pass command line
arguments to programs written in Squeak.
By convention, the first command line argument that is not a VM
configuration option is considered a 'document' to be filed in. Such a
document can add methods and classes, can contain a serialized object,
can include code to be executed, or any combination of these.
Currently defined attributes include:
-1000...-1 - command line arguments that specify VM options
0 - the full path name for currently executing VM
(or, on some platforms, just the path name of the VM's directory)
1 - full path name of this image
2 - a Squeak document to open, if any
3...1000 - command line arguments for Squeak programs
1001 - this platform's operating system
1002 - operating system version
1003 - this platform's processor type
1004 - vm version"
<primitive: 149>
^ nil!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>reclaimDependents (in category 'housekeeping') -----
+ reclaimDependents
+ "No-opped due to weak dictionary in use"
+ self garbageCollect!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- 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 added:
+ ----- Method: SmalltalkImage>>cleanOutUndeclared (in category 'housekeeping') -----
+ cleanOutUndeclared
+ Undeclared removeUnreferencedKeys!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage class>>initializeStartUpList (in category 'class initialization') -----
+ initializeStartUpList
+ "SmalltalkImage 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].
+ ].
+ !
Item was added:
+ ----- 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 added:
+ ----- Method: SmalltalkImage>>allClasses (in category 'classes and traits') -----
+ allClasses
+ "Return all the class defined in the system"
+
+ ^Array streamContents:[:s| self allClassesDo:[:aClass| s nextPut: aClass]].!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>signalLowSpace (in category 'memory space') -----
+ signalLowSpace
+ "Signal the low-space semaphore to alert the user that space is running low."
+
+ LowSpaceSemaphore signal.!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- 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 added:
+ ----- 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 added:
+ ----- Method: SmalltalkImage>>environment (in category 'accessing') -----
+ environment
+ "For conversion from Smalltalk to SystemDictionary"
+ ^globals!
Item was added:
+ ----- Method: SmalltalkImage>>at: (in category 'dictionary access') -----
+ at: aKey
+ "delegate to globals"
+ ^globals at: aKey!
Item was added:
+ ----- Method: SmalltalkImage>>flushClassNameCache (in category 'classes and traits') -----
+ flushClassNameCache
+ "Forse recomputation of the cached list of class names."
+
+ ^globals flushClassNameCache!
Item was changed:
----- Method: SmalltalkImage class>>initialize (in category 'class initialization') -----
initialize
+ "SmalltalkImage initialize"
+
+ SmalltalkImage current == Smalltalk
+ ifFalse:[self convertFromSystemDictionary].
+
+ self initializeStartUpList.
+ self initializeShutDownList.
- "
- self initialize
- "
- Smalltalk addToStartUpList: SmalltalkImage.
- SmalltalkImage startUp.
!
Item was added:
+ ----- Method: SmalltalkImage>>removeEmptyMessageCategories (in category 'housekeeping') -----
+ removeEmptyMessageCategories
+ "Smalltalk removeEmptyMessageCategories"
+ self garbageCollect.
+ (ClassOrganizer allInstances copyWith: SystemOrganization)
+ do: [:org | org removeEmptyCategories]!
Item was added:
+ ----- Method: SmalltalkImage>>isRoot: (in category 'memory space') -----
+ isRoot: oop
+ "Primitive. Answer whether the object is currently a root for youngSpace."
+ <primitive: 'primitiveIsRoot'>
+ ^self primitiveFailed!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- 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 added:
+ ----- Method: SmalltalkImage>>isYoung: (in category 'memory space') -----
+ isYoung: oop
+ "Primitive. Answer whether the object currently resides in youngSpace."
+ <primitive: 'primitiveIsYoung'>
+ ^self primitiveFailed!
Item was changed:
+ ----- Method: SmalltalkImage>>osVersion (in category 'system attributes') -----
- ----- Method: SmalltalkImage>>osVersion (in category 'system attribute') -----
osVersion
"Return the version number string of the platform we're running on"
"SmalltalkImage current osVersion"
^(self getSystemAttribute: 1002) asString!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>lowSpaceWatcherProcess (in category 'memory space') -----
+ lowSpaceWatcherProcess
+ ^LowSpaceProcess!
Item was added:
+ ----- Method: SmalltalkImage>>specialObjectsArray (in category 'special objects') -----
+ specialObjectsArray "Smalltalk specialObjectsArray at: 1"
+ <primitive: 129>
+ ^ self primitiveFailed!
Item was added:
+ ----- Method: SmalltalkImage>>shutDownSound (in category 'snapshot and quit') -----
+ shutDownSound
+ "No longer used in the release, but retained for backward compatibility."
+
+ SoundService default shutDown
+ !
Item was added:
+ ----- Method: SmalltalkImage>>writeRecentCharacters:toFileNamed: (in category 'sources, changes 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 added:
+ ----- Method: SmalltalkImage>>forgetClass:logged: (in category 'classes and traits') -----
+ 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].
+ SystemOrganization removeElement: aClass name.
+ self removeFromStartUpList: aClass.
+ self removeFromShutDownList: aClass.
+ self removeKey: aClass name ifAbsent: [].
+ self flushClassNameCache!
Item was added:
+ ----- 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 added:
+ ----- Method: SmalltalkImage>>storeDataOn: (in category 'miscellaneous') -----
+ storeDataOn: aDataStream
+ "I don't get stored. Use a DiskProxy"
+
+ self error: 'use a DiskProxy to store me'!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>at:ifPresent: (in category 'dictionary access') -----
+ at: key ifPresent: aBlock
+ "delegate to globals"
+ ^globals at: key ifPresent: aBlock!
Item was added:
+ ----- Method: SmalltalkImage>>discardSpeech (in category 'shrinking') -----
+ discardSpeech
+ "Discard support for speech synthesis"
+
+ SystemOrganization removeCategoriesMatching: 'Speech*'.
+ !
Item was added:
+ ----- Method: SmalltalkImage>>hasBindingThatBeginsWith: (in category 'dictionary access') -----
+ hasBindingThatBeginsWith: aString
+ "delegate to globals"
+ ^globals hasBindingThatBeginsWith: aString!
Item was added:
+ ----- 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 changed:
+ ----- Method: SmalltalkImage>>quitPrimitive (in category 'snapshot and quit') -----
- ----- Method: SmalltalkImage>>quitPrimitive (in category '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 added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- Method: SmalltalkImage>>veryDeepCopyWith: (in category 'miscellaneous') -----
+ veryDeepCopyWith: deepCopier
+ "Return self. I can't be copied. Do not record me."!
Item was added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- 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 added:
+ ----- Method: SmalltalkImage>>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 added:
+ ----- 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: SmalltalkImage>>stripMethods:messageCode: (in category 'utilities') -----
- stripMethods: tripletList messageCode: messageString
- "Used to 'cap' methods that need to be protected for proprietary reasons, etc.; call this with a list of triplets of symbols of the form (<class name> <#instance or #class> <selector name>), and with a string to be produced as part of the error msg if any of the methods affected is reached"
-
-
- tripletList do:
- [:triplet | | codeString keywords aClass sel |
- (aClass := (Smalltalk at: triplet first ifAbsent: [nil])) notNil ifTrue:
- [triplet second == #class ifTrue:
- [aClass := aClass class].
- sel := triplet third.
- keywords := sel keywords.
- (keywords size == 1 and: [keywords first asSymbol isKeyword not])
- ifTrue:
- [codeString := keywords first asString]
- ifFalse:
- [codeString := ''.
- keywords withIndexDo:
- [:kwd :index |
- codeString := codeString, ' ', (keywords at: index), ' ',
- 'arg', index printString]].
- codeString := codeString, '
- self codeStrippedOut: ', (messageString surroundedBySingleQuotes).
-
- aClass compile: codeString classified: 'stripped']]!
More information about the Packages
mailing list