'From Squeak3.11alpha of 13 February 2010 [latest update: #9483] on 9 March 2010 at 11:11:23 am'! Object subclass: #SmalltalkImage instanceVariableNames: 'globals ' classVariableNames: 'EndianCache LastImageName LastQuitLogPosition LastStats SourceFileVersionString StartupStamp LowSpaceSemaphore LowSpaceProcess StartUpList SpecialSelectors MemoryHogs ShutDownList WordSize ' poolDictionaries: '' category: 'System-Support'! !SmalltalkImage commentStamp: 'dtl 3/6/2010 14:00' prior: 0! I represent the current image and runtime environment, including system organization, the virtual machine, object memory, plugins and source files. My instance variable #globals is a reference to the system dictionary of global variables and class names. My singleton instance is called Smalltalk.! !Locale class methodsFor: 'private' stamp: 'brp 5/25/2005 11:00'! resetKnownLocales KnownLocales := nil ! ! !NaturalLanguageTranslator class methodsFor: 'class initialization' stamp: 'brp 9/16/2005 10:43'! startUp: resuming resuming ifTrue: [ self loadAvailableLocales ]! ! !NaturalLanguageTranslator class methodsFor: 'private loading' stamp: 'cmm 3/3/2010 14:28'! loadAvailableExternalLocales "private - register locales IDs based on the content of the /locale/ directory" | localeDir | localeDir := self localeDirCreate: false. localeDir ifNil: [^ #()]. localeDir directoryNames do: [:langDirName | | langDir | langDir := localeDir directoryNamed: langDirName. (langDir fileNamesMatching: '*.' , self translationSuffix) ifNotEmpty: [self loadTranslatorForIsoLanguage: langDirName isoCountry: nil]. langDir directoryNames do: [:countryDirName | | countryDir | countryDir := langDir directoryNamed: countryDirName. (countryDir fileNamesMatching: '*.' , self translationSuffix) ifNotEmpty: [self loadTranslatorForIsoLanguage: langDirName isoCountry: countryDirName] ] ]. ! ! !NaturalLanguageTranslator class methodsFor: 'private loading' stamp: 'brp 9/16/2005 10:42'! loadAvailableLocales "This loads the default locale and all external locales" | defaultID | defaultID := LocaleID current. self cachedTranslations at: defaultID ifAbsent: [self localeID: defaultID]. self loadAvailableExternalLocales.! ! !SmalltalkImage methodsFor: 'housekeeping'! cleanOutUndeclared Undeclared removeUnreferencedKeys! ! !SmalltalkImage methodsFor: 'housekeeping' stamp: 'ar 2/27/2010 00:02'! cleanUp "Smalltalk cleanUp" "Gently clean up" ^self cleanUp: false! ! !SmalltalkImage methodsFor: 'housekeeping' stamp: 'ar 2/28/2010 02:28'! 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: #()! ! !SmalltalkImage methodsFor: 'housekeeping' stamp: 'ar 2/28/2010 02:19'! 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].! ! !SmalltalkImage methodsFor: 'housekeeping' stamp: 'bf 1/14/2010 13:33'! 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.'! ! !SmalltalkImage methodsFor: 'housekeeping' stamp: 'nice 12/27/2009 03:10'! 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)! ! !SmalltalkImage methodsFor: 'housekeeping' stamp: 'laza 2/25/2010 22:56'! 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! ! !SmalltalkImage methodsFor: 'housekeeping' stamp: 'nice 1/1/2010 21:56'! 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']. ! ! !SmalltalkImage methodsFor: 'housekeeping' stamp: 'sd 4/17/2003 20:59'! forgetDoIts "Smalltalk forgetDoIts" "get rid of old DoIt methods" self systemNavigation allBehaviorsDo: [:cl | cl forgetDoIts] ! ! !SmalltalkImage methodsFor: 'housekeeping' stamp: 'sd 9/29/2004 18:15'! reclaimDependents "No-opped due to weak dictionary in use" self garbageCollect! ! !SmalltalkImage methodsFor: 'housekeeping' stamp: 'sd 9/29/2004 18:15'! removeEmptyMessageCategories "Smalltalk removeEmptyMessageCategories" self garbageCollect. (ClassOrganizer allInstances copyWith: SystemOrganization) do: [:org | org removeEmptyCategories]! ! !SmalltalkImage methodsFor: 'housekeeping' stamp: 'sd 4/17/2003 21:01'! verifyChanges "Smalltalk verifyChanges" "Recompile all methods in the changes file." self systemNavigation allBehaviorsDo: [:class | class recompileChanges]. ! ! !SmalltalkImage methodsFor: 'modules' stamp: 'sd 6/28/2003 17:38'! 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." "Do nothing if the primitive fails for compatibility with older VMs" ! ! !SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'ar 11/19/1999 22:36'! 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]! ! !SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'di 2/4/1999 15:38'! addToShutDownList: aClass "This will add a ref to this class at the BEGINNING of the shutDown list." self addToShutDownList: aClass after: nil! ! !SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'di 2/3/1999 22:04'! addToShutDownList: aClass after: predecessor self add: aClass toList: ShutDownList after: predecessor! ! !SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'di 2/4/1999 15:37'! addToStartUpList: aClass "This will add a ref to this class at the END of the startUp list." self addToStartUpList: aClass after: nil! ! !SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'di 2/3/1999 22:04'! addToStartUpList: aClass after: predecessor self add: aClass toList: StartUpList after: predecessor! ! !SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'sd 6/28/2003 18:23'! 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" self primitiveFailed! ! !SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'RAA 6/14/2000 17:21'! 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]"! ! !SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'ar 11/16/1999 20:12'! processShutDownList: quitting "Send #shutDown to each class that needs to wrap up before a snapshot." self send: #shutDown: toClassesNamedIn: ShutDownList with: quitting. ! ! !SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'ar 11/16/1999 20:12'! processStartUpList: resuming "Send #startUp to each class that needs to run initialization after a snapshot." self send: #startUp: toClassesNamedIn: StartUpList with: resuming. ! ! !SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'sd 6/28/2003 17:32'! 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." self primitiveFailed! ! !SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'di 2/3/1999 22:22'! removeFromShutDownList: aClass ShutDownList remove: aClass name ifAbsent: []! ! !SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'di 2/3/1999 22:22'! removeFromStartUpList: aClass StartUpList remove: aClass name ifAbsent: []! ! !SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'nice 12/27/2009 03:10'! 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! ! !SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'sd 9/30/2003 13:47'! 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" ! ! !SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'laza 12/6/2004 13:55'! 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). ]. ! ! !SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'gk 2/23/2004 20:51'! shutDownSound "No longer used in the release, but retained for backward compatibility." SoundService default shutDown ! ! !SmalltalkImage methodsFor: '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.'! ! !SmalltalkImage methodsFor: 'sources, changes log' stamp: 'sd 9/29/2004 18:27'! currentProjectDo: aBlock "So that code can work after removal of Projects" self at: #Project ifPresent: [:projClass | aBlock value: projClass current]! ! !SmalltalkImage methodsFor: 'sources, changes log' stamp: 'ar 4/10/2005 18:02'! 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.! ! !SmalltalkImage methodsFor: 'sources, changes log' stamp: 'md 5/16/2006 12:34'! version "Answer the version of this release." ^SystemVersion current version! ! !SmalltalkImage methodsFor: 'sources, changes log' stamp: 'dtl 1/4/2010 21:40'! 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]]! ! !SmalltalkImage methodsFor: 'sources, changes log' stamp: 'adrian-lienhard 5/27/2009 21:28'! 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! ! !SmalltalkImage methodsFor: 'sources, changes log' stamp: 'ar 9/27/2005 22:38'! 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]! ! !SmalltalkImage methodsFor: 'shrinking' stamp: 'nice 1/15/2010 23:05'! 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! ! !SmalltalkImage methodsFor: 'shrinking' stamp: 'nice 1/15/2010 22:49'! 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! ! !SmalltalkImage methodsFor: 'shrinking' stamp: 'nice 12/27/2009 03:10'! 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! ! !SmalltalkImage methodsFor: 'shrinking' stamp: 'dtl 1/24/2010 21:09'! 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! ! !SmalltalkImage methodsFor: 'shrinking' stamp: 'dtl 1/24/2010 21:11'! 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! ! !SmalltalkImage methodsFor: 'shrinking' stamp: 'sd 9/29/2004 18:26'! 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! ! !SmalltalkImage methodsFor: 'shrinking' stamp: 'ar 3/6/2010 11:26'! 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. MorphicProject defaultFill: (Color gray: 0.9). World color: (Color gray: 0.9). ! ! !SmalltalkImage methodsFor: 'shrinking' stamp: 'sd 4/29/2003 19:06'! 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: {{}. {}}! ! !SmalltalkImage methodsFor: 'shrinking' stamp: 'ar 9/27/2005 20:12'! 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]! ! !SmalltalkImage methodsFor: 'shrinking' stamp: 'nice 12/27/2009 03:10'! 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]]]! ! !SmalltalkImage methodsFor: 'classes and traits' stamp: 'ar 3/5/2010 18:12'! allClasses "Return all the class defined in the system" ^Array streamContents:[:s| self allClassesDo:[:aClass| s nextPut: aClass]].! ! !SmalltalkImage methodsFor: 'classes and traits' stamp: 'ar 3/5/2010 18:10'! allClassesAndTraits "Return all the classes and traits defined in the system" ^Array streamContents:[:s| self allClassesAndTraitsDo:[:each| s nextPut: each]].! ! !SmalltalkImage methodsFor: 'classes and traits' stamp: 'ar 3/5/2010 18:11'! allClassesAndTraitsDo: aBlock "Evaluate the argument, aBlock, for each class and trait in the system." self allClassesDo: aBlock. self allTraitsDo: aBlock. ! ! !SmalltalkImage methodsFor: 'classes and traits' stamp: 'ar 3/5/2010 18:09'! allClassesDo: aBlock "Evaluate the argument, aBlock, for each class in the system." ^globals allClassesDo: aBlock! ! !SmalltalkImage methodsFor: 'classes and traits' stamp: 'ar 3/5/2010 18:11'! allTraits "Return all traits defined in the system" ^Array streamContents:[:s| self allTraitsDo:[:aTrait| s nextPut: aTrait]].! ! !SmalltalkImage methodsFor: 'classes and traits' stamp: 'ar 3/5/2010 18:10'! allTraitsDo: aBlock "Evaluate the argument, aBlock, for each trait in the system." ^globals allTraitsDo: aBlock! ! !SmalltalkImage methodsFor: 'classes and traits' stamp: 'ar 3/5/2010 20:36'! classNamed: className "Answer the global with the given name." ^globals classNamed: className! ! !SmalltalkImage methodsFor: 'classes and traits' stamp: 'ar 3/5/2010 18:21'! classNames "Answer a collection of all class names in the system." ^self allClasses collect:[:aClass| aClass name].! ! !SmalltalkImage methodsFor: 'classes and traits' stamp: 'ar 3/5/2010 18:22'! classOrTraitNamed: aString "Answer the global with the given name" ^globals classOrTraitNamed: aString! ! !SmalltalkImage methodsFor: 'classes and traits' stamp: 'ar 3/5/2010 18:23'! flushClassNameCache "Forse recomputation of the cached list of class names." ^globals flushClassNameCache! ! !SmalltalkImage methodsFor: 'classes and traits' stamp: 'ar 3/5/2010 19:58'! forgetClass: aClass logged: aBool "Delete the class, aClass, from the system." ^globals forgetClass: aClass logged: aBool! ! !SmalltalkImage methodsFor: 'classes and traits' stamp: 'ar 3/5/2010 18:30'! hasClassNamed: aString "Answer whether there is a class of the given name" ^globals hasClassNamed: aString! ! !SmalltalkImage methodsFor: 'classes and traits' stamp: 'ar 3/5/2010 18:27'! 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! ! !SmalltalkImage methodsFor: 'classes and traits' stamp: 'ar 3/5/2010 20:02'! renameClass: aClass as: newName "Rename the class, aClass, to have the title newName." ^globals renameClass: aClass as: newName! ! !SmalltalkImage methodsFor: 'classes and traits' stamp: 'ar 3/5/2010 20:10'! renameClass: aClass from: oldName "Rename the class, aClass, to have the title newName." ^globals renameClass: aClass from: oldName! ! !SmalltalkImage methodsFor: 'classes and traits' stamp: 'ar 3/5/2010 18:29'! 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! ! !SmalltalkImage methodsFor: 'classes and traits' stamp: 'ar 3/5/2010 18:23'! traitNames "Answer a SortedCollection of all traits (not including class-traits) names." ^self allTraits collect:[:aTrait| aTrait name].! ! !SmalltalkImage methodsFor: 'dictionary access' stamp: 'ar 3/5/2010 21:18'! associationAt: aKey "DO NOT DEPRECATE - used by ImageSegments" ^globals associationAt: aKey! ! !SmalltalkImage methodsFor: 'dictionary access' stamp: 'ar 3/5/2010 21:17'! associationAt: key ifAbsent: aBlock "Obsoleted." self deprecated: 'Use Smalltalk globals'. ^globals associationAt: key ifAbsent: aBlock! ! !SmalltalkImage methodsFor: 'dictionary access' stamp: 'ar 3/5/2010 21:19'! associationOrUndeclaredAt: aKey "DO NOT DEPRECATE - used by binary storage" ^globals associationOrUndeclaredAt: aKey! ! !SmalltalkImage methodsFor: 'dictionary access' stamp: 'ar 3/5/2010 21:17'! do: aBlock "Obsoleted." self deprecated: 'Use Smalltalk globals'. ^globals do: aBlock! ! !SmalltalkImage methodsFor: 'dictionary access' stamp: 'ar 3/5/2010 21:17'! includes: element "Obsoleted." self deprecated: 'Use Smalltalk globals'. ^globals includes: element! ! !SmalltalkImage methodsFor: 'dictionary access' stamp: 'ar 3/5/2010 21:21'! includesKey: key "Answer whether the receiver has a key equal to the argument, key." ^globals includesKey: key! ! !SmalltalkImage methodsFor: 'dictionary access' stamp: 'ar 3/5/2010 21:17'! keyAtIdentityValue: anObject ifAbsent: aBlock "Obsoleted." self deprecated: 'Use Smalltalk globals'. ^globals keyAtIdentityValue: anObject ifAbsent: aBlock! ! !SmalltalkImage methodsFor: 'dictionary access' stamp: 'ar 3/5/2010 21:17'! keys "Obsoleted." self deprecated: 'Use Smalltalk globals'. ^globals keys! ! !SmalltalkImage methodsFor: 'dictionary access' stamp: 'ar 3/5/2010 21:17'! removeKey: key "Obsoleted." self deprecated: 'Use Smalltalk globals'. ^globals removeKey: key! ! !SmalltalkImage methodsFor: 'dictionary access' stamp: 'ar 3/5/2010 21:17'! removeKey: key ifAbsent: aBlock "Obsoleted." self deprecated: 'Use Smalltalk globals'. ^globals removeKey: key ifAbsent: aBlock! ! !SmalltalkImage methodsFor: 'dictionary access' stamp: 'ar 3/5/2010 21:22'! scopeFor: varName from: lower envtAndPathIfFound: envtAndPathBlock "Obsoleted." self deprecated: 'Use Smalltalk globals'. (globals includesKey: varName) ifTrue: [^ envtAndPathBlock value: self value: String new] ifFalse: [^ nil]! ! !SmalltalkImage methodsFor: 'dictionary access' stamp: 'ar 3/5/2010 21:18'! size "Obsoleted." self deprecated: 'Use Smalltalk globals'. ^globals size! ! !SmalltalkImage methodsFor: 'memory space'! bytesLeft "Answer the number of bytes of space available. Does a full garbage collection." ^ self garbageCollect ! ! !SmalltalkImage methodsFor: 'memory space' stamp: 'ar 2/25/2001 17:55'! 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." ^self primBytesLeft! ! !SmalltalkImage methodsFor: 'memory space' stamp: 'ar 2/25/2001 18:00'! 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) '].! ! !SmalltalkImage methodsFor: 'memory space'! createStackOverflow "For testing the low space handler..." "Smalltalk installLowSpaceWatcher; createStackOverflow" self createStackOverflow. "infinite recursion"! ! !SmalltalkImage methodsFor: 'memory space' stamp: 'JMM 1/27/2005 13:23'! forceTenure "Primitive. Tell the GC logic to force a tenure on the next increment GC." ^self primitiveFailed! ! !SmalltalkImage methodsFor: 'memory space' stamp: 'ar 2/11/2001 02:36'! garbageCollect "Primitive. Reclaims all garbage and answers the number of bytes of available space." Object flushDependents. Object flushEvents. ^self primitiveGarbageCollect! ! !SmalltalkImage methodsFor: '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." ^ self primBytesLeft! ! !SmalltalkImage methodsFor: '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. ! ! !SmalltalkImage methodsFor: 'memory space' stamp: 'ar 1/18/2005 16:46'! isRoot: oop "Primitive. Answer whether the object is currently a root for youngSpace." ^self primitiveFailed! ! !SmalltalkImage methodsFor: 'memory space' stamp: 'ar 1/18/2005 16:47'! isYoung: oop "Primitive. Answer whether the object currently resides in youngSpace." ^self primitiveFailed! ! !SmalltalkImage methodsFor: 'memory space' stamp: 'di 8/18/2000 16:49'! 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"]! ! !SmalltalkImage methodsFor: 'memory space' stamp: 'dtl 11/23/2009 15:10'! 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 ! ! !SmalltalkImage methodsFor: 'memory space' stamp: 'nk 10/28/2000 20:37'! lowSpaceWatcherProcess ^LowSpaceProcess! ! !SmalltalkImage methodsFor: 'memory space' stamp: 'sma 4/22/2000 19:03'! memoryHogs "Answer the list of objects to notify with #freeSomeSpace if memory gets full." ^ MemoryHogs ifNil: [MemoryHogs := OrderedCollection new]! ! !SmalltalkImage methodsFor: '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?' ! ! !SmalltalkImage methodsFor: '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." ^ 0! ! !SmalltalkImage methodsFor: '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." self primitiveFailed! ! !SmalltalkImage methodsFor: '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." self primitiveFailed! ! !SmalltalkImage methodsFor: 'memory space' stamp: 'ar 2/11/2001 02:16'! primitiveGarbageCollect "Primitive. Reclaims all garbage and answers the number of bytes of available space." ^ self primBytesLeft! ! !SmalltalkImage methodsFor: 'memory space' stamp: 'ar 1/18/2005 16:48'! rootTable "Primitive. Answer a snapshot of the VMs root table. Keep in mind that the primitive may itself cause GC." ^self primitiveFailed! ! !SmalltalkImage methodsFor: 'memory space' stamp: 'ar 1/18/2005 16:49'! rootTableAt: index "Primitive. Answer the nth element of the VMs root table" ^nil! ! !SmalltalkImage methodsFor: 'memory space' stamp: 'JMM 1/27/2005 13:12'! setGCBiasToGrow: aNumber "Primitive. Indicate that the GC logic should be bias to grow" ^self primitiveFailed "Example: Smalltalk setGCBiasToGrowGCLimit: 16*1024*1024. Smalltalk setGCBiasToGrow: 1. "! ! !SmalltalkImage methodsFor: 'memory space' stamp: 'JMM 1/27/2005 12:27'! setGCBiasToGrowGCLimit: aNumber "Primitive. Indicate that the bias to grow logic should do a GC after aNumber Bytes" ^self primitiveFailed "Example: Smalltalk setGCBiasToGrowGCLimit: 16*1024*1024. "! ! !SmalltalkImage methodsFor: 'memory space' stamp: 'ar 1/18/2005 16:54'! setGCSemaphore: semaIndex "Primitive. Indicate the GC semaphore index to be signaled on GC occurance." ^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. "! ! !SmalltalkImage methodsFor: 'memory space'! signalLowSpace "Signal the low-space semaphore to alert the user that space is running low." LowSpaceSemaphore signal.! ! !SmalltalkImage methodsFor: 'memory space' stamp: 'apb 10/3/2000 16:40'! useUpMemory "For testing the low space handler..." "Smalltalk installLowSpaceWatcher; useUpMemory" | lst | lst := nil. [true] whileTrue: [ lst := Link nextLink: lst. ].! ! !SmalltalkImage methodsFor: 'memory space' stamp: 'di 8/18/2000 21:15'! 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]! ! !SmalltalkImage methodsFor: 'memory space' stamp: 'di 8/18/2000 16:49'! useUpMemoryWithContexts "For testing the low space handler..." "Smalltalk installLowSpaceWatcher; useUpMemoryWithContexts" self useUpMemoryWithContexts! ! !SmalltalkImage methodsFor: 'memory space' stamp: 'di 8/18/2000 16:50'! 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]! ! !SmalltalkImage methodsFor: 'system attributes' stamp: 'yo 2/18/2004 18:24'! 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'.! ! !SmalltalkImage methodsFor: 'system attributes' stamp: 'yo 2/18/2004 18:24'! endianness EndianCache ifNil: [EndianCache := self calcEndianness]. ^ EndianCache. ! ! !SmalltalkImage methodsFor: 'system attributes' stamp: 'sd 6/27/2003 23:25'! isBigEndian ^self endianness == #big! ! !SmalltalkImage methodsFor: 'system attributes' stamp: 'sd 6/27/2003 23:25'! isLittleEndian ^self endianness == #little! ! !SmalltalkImage methodsFor: 'system attributes' stamp: 'dtl 8/5/2006 09:47'! vmVersion "Return a string identifying the interpreter version" "SmalltalkImage current vmVersion" ^self getSystemAttribute: 1004! ! !SmalltalkImage methodsFor: 'special objects' stamp: 'JMM 6/6/2000 20:36'! clearExternalObjects "Clear the array of objects that have been registered for use in non-Smalltalk code." "Smalltalk clearExternalObjects" ExternalSemaphoreTable clearExternalObjects ! ! !SmalltalkImage methodsFor: 'special objects' stamp: 'sd 9/29/2004 18:30'! compactClassesArray "Smalltalk compactClassesArray" "Return the array of 31 classes whose instances may be represented compactly" ^ self specialObjectsArray at: 29! ! !SmalltalkImage methodsFor: 'special objects' stamp: 'JMM 6/6/2000 21:01'! 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 ! ! !SmalltalkImage methodsFor: 'special objects'! hasSpecialSelector: aLiteral ifTrueSetByte: aBlock 1 to: self specialSelectorSize do: [:index | (self specialSelectorAt: index) == aLiteral ifTrue: [aBlock value: index + 16rAF. ^true]]. ^false! ! !SmalltalkImage methodsFor: 'special objects' stamp: 'eem 7/22/2008 18:37'! 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! ! !SmalltalkImage methodsFor: 'special objects' stamp: 'JMM 6/6/2000 20:39'! 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! ! !SmalltalkImage methodsFor: 'special objects'! specialNargsAt: anInteger "Answer the number of arguments for the special selector at: anInteger." ^ (self specialObjectsArray at: 24) at: anInteger * 2! ! !SmalltalkImage methodsFor: 'special objects'! specialObjectsArray "Smalltalk specialObjectsArray at: 1" ^ self primitiveFailed! ! !SmalltalkImage methodsFor: 'special objects'! specialSelectorAt: anInteger "Answer the special message selector from the interleaved specialSelectors array." ^ (self specialObjectsArray at: 24) at: anInteger * 2 - 1! ! !SmalltalkImage methodsFor: 'special objects'! specialSelectorSize "Answer the number of special selectors in the system." ^ (self specialObjectsArray at: 24) size // 2! ! !SmalltalkImage methodsFor: 'special objects'! specialSelectors "Used by SystemTracer only." ^SpecialSelectors! ! !SmalltalkImage methodsFor: 'special objects' stamp: 'JMM 6/6/2000 20:40'! unregisterExternalObject: anObject "Unregister the given object in the external objects array. Do nothing if it isn't registered." ExternalSemaphoreTable unregisterExternalObject: anObject! ! !SmalltalkImage methodsFor: 'accessing' stamp: 'ar 3/5/2010 21:19'! at: aKey "Answer the global associated with the key." ^globals at: aKey! ! !SmalltalkImage methodsFor: 'accessing' stamp: 'ar 3/5/2010 21:20'! at: key ifAbsent: aBlock "Answer the global associated with the key or, if key isn't found, answer the result of evaluating aBlock." ^globals at: key ifAbsent: aBlock! ! !SmalltalkImage methodsFor: 'accessing' stamp: 'ar 3/5/2010 21:20'! at: key ifPresent: aBlock "Lookup the given key in the globals. If it is present, answer the value of evaluating the given block with the value associated with the key. Otherwise, answer nil." ^globals at: key ifPresent: aBlock! ! !SmalltalkImage methodsFor: 'accessing' stamp: 'ar 3/5/2010 21:21'! at: aKey put: anObject "Set the global at key to be anObject. If key is not found, create a new entry for key and set is value to anObject. Answer anObject." ^globals at: aKey put: anObject! ! !SmalltalkImage methodsFor: 'accessing' stamp: 'ar 3/5/2010 20:34'! bindingOf: varName "Answer the binding of some variable resolved in the scope of the receiver" ^globals bindingOf: varName! ! !SmalltalkImage methodsFor: 'accessing' stamp: 'ar 3/5/2010 21:21'! environment "For conversion from Smalltalk to SystemDictionary" ^globals! ! !SmalltalkImage methodsFor: 'accessing' stamp: 'ar 3/5/2010 21:39'! globals "Answer the global SystemDictionary" ^globals! ! !SmalltalkImage methodsFor: 'accessing' stamp: 'ar 3/5/2010 21:40'! globals: aSystemDictionary "Sets the system-wide globals" globals ifNotNil:[self error: 'Cannot overwrite existing globals']. globals := aSystemDictionary! ! !SmalltalkImage methodsFor: 'accessing' stamp: 'ar 3/5/2010 21:40'! organization "Return the organizer for the receiver" ^globals organization! ! !SmalltalkImage methodsFor: 'miscellaneous' stamp: 'dtl 11/23/2009 15:01'! handleUserInterrupt Preferences cmdDotEnabled ifTrue: [[Project current interruptName: 'User Interrupt'] fork] ! ! !SmalltalkImage methodsFor: 'miscellaneous' stamp: 'sd 9/29/2004 18:17'! 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! ! !SmalltalkImage methodsFor: 'miscellaneous' stamp: 'tk 10/16/2001 19:24'! 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.! ! !SmalltalkImage methodsFor: 'miscellaneous' stamp: 'tk 9/28/2000 15:50'! 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! ! !SmalltalkImage methodsFor: 'miscellaneous' stamp: 'ar 3/4/2010 11:14'! printOn: aStream self == Smalltalk ifTrue: [aStream nextPutAll: #Smalltalk] ifFalse: [super printOn: aStream]! ! !SmalltalkImage methodsFor: 'miscellaneous' stamp: 'MPH 10/24/2000 14:27'! setMacFileInfoOn: aString "On Mac, set the file type and creator (noop on other platforms)" FileDirectory default setMacFileNamed: aString type: 'STch' creator: 'FAST'.! ! !SmalltalkImage methodsFor: 'miscellaneous' stamp: 'sd 9/24/2003 12:42'! sourceFileVersionString: aString SourceFileVersionString := aString! ! !SmalltalkImage methodsFor: 'miscellaneous' stamp: 'tk 3/7/2000 18:40'! storeDataOn: aDataStream "I don't get stored. Use a DiskProxy" self error: 'use a DiskProxy to store me'! ! !SmalltalkImage methodsFor: 'miscellaneous' stamp: 'nb 6/17/2003 12:25'! 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! ! !SmalltalkImage methodsFor: 'miscellaneous' stamp: 'tk 10/20/2000 11:35'! veryDeepCopyWith: deepCopier "Return self. I can't be copied. Do not record me."! ! !SmalltalkImage methodsFor: 'command line' stamp: 'nice 3/7/2010 00:18'! extractParameters "This method is used by Seaside 2.8.3" | pName value index paramNameValueDictionary | paramNameValueDictionary := 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 := '']. paramNameValueDictionary at: pName asUppercase put: value. index := index + 1]. ^paramNameValueDictionary! ! !SmalltalkImage methodsFor: 'private' stamp: 'md 10/26/2003 13:08'! 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" ^ nil! ! !SmalltalkImage methodsFor: 'os' stamp: 'nice 3/7/2010 01:36'! osVersion "Return the version number string of the platform we're running on" "Smalltalk osVersion" ^(self getSystemAttribute: 1002) asString! ! !SmalltalkImage methodsFor: 'os' stamp: 'nice 3/7/2010 01:21'! platformName "Return the name of the platform we're running on." "Smalltalk os platformName" ^self getSystemAttribute: 1001! ! !SmalltalkImage methodsFor: 'os' stamp: 'nice 3/7/2010 01:21'! platformSubtype "Return the subType of the platform we're running on." "Smalltalk os platformSubtype" ^self getSystemAttribute: 1003! ! !SmalltalkImage methodsFor: 'os' stamp: 'nice 3/7/2010 01:20'! windowSystemName "Return the name of the window system currently being used for display." "Smalltalk os windowSystemName" ^self getSystemAttribute: 1005! ! !SmalltalkImage class methodsFor: 'class initialization' stamp: 'ar 3/4/2010 11:27'! cleanUp "Flush caches" Smalltalk flushClassNameCache. Smalltalk cleanUpUndoCommands. Undeclared removeUnreferencedKeys. Smalltalk forgetDoIts.! ! !SmalltalkImage class methodsFor: 'class initialization' stamp: 'ar 3/5/2010 21:52'! initialize "SmalltalkImage initialize" self initializeStartUpList. self initializeShutDownList. ! ! !SmalltalkImage class methodsFor: 'class initialization' stamp: 'ar 3/4/2010 11:26'! 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]]]. ! ! !SmalltalkImage class methodsFor: 'class initialization' stamp: 'ar 3/4/2010 11:30'! 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]. ]. ! ! !SmalltalkImage class methodsFor: 'class initialization' stamp: 'ar 3/4/2010 11:30'! 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. ! ! !SystemDictionary methodsFor: 'accessing' stamp: 'ar 3/5/2010 14:38'! environment "For conversion from Smalltalk to SystemDictionary" ^self! ! !SystemDictionary methodsFor: 'classes and traits' stamp: 'ar 3/5/2010 18:09'! allTraitsDo: aBlock "Evaluate the argument, aBlock, for each trait in the system." (self traitNames collect: [:name | self at: name]) do: aBlock! ! !SystemNavigation methodsFor: 'query' stamp: 'ar 3/5/2010 14:43'! 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 ]. aClass withAllSubclassesDo: [ :class | (class whichSelectorsReferTo: aSymbol special: special byte: byte) do: [:sel | sel isDoIt ifFalse: [ aSortedCollection add: ( MethodReference new setStandardClass: class methodSymbol: sel ) ] ] ]. ^aSortedCollection! ! SmalltalkImage initialize! SmalltalkImage removeSelector: #stripMethods:messageCode:! Object subclass: #SmalltalkImage instanceVariableNames: 'globals' classVariableNames: 'EndianCache LastImageName LastQuitLogPosition LastStats LowSpaceProcess LowSpaceSemaphore MemoryHogs ShutDownList SourceFileVersionString SpecialSelectors StartUpList StartupStamp WordSize' poolDictionaries: '' category: 'System-Support'!