"
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
Object subclass:#Smalltalk
instanceVariableNames:''
classVariableNames:'ExitBlocks CachedClasses SystemPath
StartupClass StartupSelector StartupArguments
CachedAbbreviations
SilentLoading Initializing
StandAlone
LogDoits'
poolDictionaries:''
category:'System-Support'
!
Smalltalk comment:'
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
$Header: /cvs/stx/stx/libbasic/Smalltalk.st,v 1.28 1994-11-28 20:34:16 claus Exp $
'!
"
dont depend on these being global - they will become
class variables of some class ...
Being global is a historical leftover ...
"
Smalltalk at:#Language put:#english!
Smalltalk at:#LanguageTerritory put:#usa!
!Smalltalk class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
!
version
"
$Header: /cvs/stx/stx/libbasic/Smalltalk.st,v 1.28 1994-11-28 20:34:16 claus Exp $
"
!
documentation
"
This is one of the central classes in the system;
it provides all system-startup, shutdown and maintenance support.
Also global variables are kept here.
As you will notice, this is NOT a Dictionary
- my implementation of globals is totally different
(due to the need to be able to access globals from c-code as well).
However, it provides the known enumeration protocol.
It may change to become a subclass of collection at some time ...
Instance variables:
none - all handling is done in the VM
Class variables:
ExitBlocks <Collection> blocks to evaluate before system is
left. Not currently used.
CachedClasses <Collection> known classes (cached for faster enumeration)
SystemPath <Collection> path to search for system files (sources, bitmaps etc)
StartupClass <Class> class, which gets initial message
(right after VM initialization)
StartupSelector <Symbol> message sent to StartupClass
CachedAbbreviations
<Dictionary> className to filename mappings
SilentLoading <Boolean> suppresses messages during fileIn and in compiler
(can be set to true from a customized main)
LogDoits <Boolean> if true, doits are also logged in the changes
file. Default is false, since the changes file
may become huge ...
"
! !
!Smalltalk class methodsFor:'time-versions'!
majorVersion
"return the major version number.
This is only incremented for very fundamental changes,
which make old object files totally incompatible
(for example, if the layout/representation of fundamental
classes changes)."
^ 2
"
Smalltalk majorVersion
"
!
minorVersion
"return the minor version number.
This is incremented for changes which make some old object
files incompatible, or the protocol changes such that some
classes need rework."
^ 10
"
Smalltalk minorVersion
"
!
revision
"return the revision number.
Incremented for releases which fix bugs/add features."
^ 4
"
Smalltalk revision
"
!
versionString
"return the version string"
^ (self majorVersion printString ,
'.',
self minorVersion printString ,
'.',
self revision printString)
"
Smalltalk versionString
"
"
$Header: /cvs/stx/stx/libbasic/Smalltalk.st,v 1.28 1994-11-28 20:34:16 claus Exp $
"
!
versionDate
"return the version date - thats the date when the smalltalk
executable was linked."
%{
#ifdef VERSIONDATE_STRING
RETURN ( _MKSTRING(VERSIONDATE_STRING COMMA_SND) );
#endif
%}.
^ '22-nov-1994'
"
Smalltalk versionDate
"
!
configuration
"for developers only: return the configuration, with which
this smalltalk was compiled."
%{
#ifdef CONFIGURATION_STRING
RETURN ( _MKSTRING(CONFIGURATION_STRING COMMA_SND) );
#endif
%}.
^ 'unknown'
"
Smalltalk configuration
"
!
copyrightString
"return a copyright string"
^ 'Copyright (c) 1988-94 by Claus Gittinger'
"
Smalltalk copyrightString
"
!
hello
"return a greeting string"
"stupid: this should come from a resource file ...
but I dont use it here, to allow mini-systems without
Resource-stuff."
(Language == #german) ifTrue:[
^ 'Willkommen bei SmallTalk/X version '
, self versionString , ' vom ' , self versionDate
].
(Language == #french) ifTrue:[
^ 'Bienvenue a SmallTalk/X version '
, self versionString , ' de ' , self versionDate
].
^ 'Hello World - here is SmallTalk/X version '
, self versionString , ' of ' , self versionDate
"
Smalltalk hello
"
!
timeStamp
"return a string useful for timestamping a file"
^ '''From Smalltalk/X, Version:' , (Smalltalk versionString) , ' on '
, Date today printString , ' at ' , Time now printString
, ''''
! !
!Smalltalk class methodsFor:'initialization'!
initialize
"initialize all other classes; setup dispatcher processes etc.
This one is the first entry into the smalltalk world right after startup,
ususally followed by Smalltalk>>start.
Notice: this is not called when an image is restarted; in this
case the show starts in Smalltalk>>restart."
"
define low-level debugging tools - graphical classes are not prepared yet
to handle things.
This will bring us into the MiniDebugger when an error occurs
during startup
"
Inspector := MiniInspector.
Debugger := MiniDebugger.
self initGlobalsFromEnvironment.
"
sorry - there are some, which MUST be initialized before ..
reason: if any error happens during init, we need Signals, Stdout etc. to be there
"
Object initialize.
ExternalStream initialize.
self initStandardStreams. "/ setup Stdin, Stdout etc.
"
sorry, path must be set before ...
reason: some classes need it during initialize (they might need resources, bitmaps etc)
"
self initSystemPath.
"
must init display here - some classes (Color, Form) need it during initialize
"
Workstation notNil ifTrue:[
Workstation initialize
].
Compiler := ByteCodeCompiler.
Compiler isNil ifTrue:[
"
ByteCodeCompiler is not in the system (i.e. has not been linked in)
this allows at least immediate evaluations for runtime systems without compiler
NOTICE: a parser is always needed, otherwise we cannot read resource files etc.
"
Compiler := Parser
].
"
now, finally, initialize all leftover classes
"
"/ Object allSubclassesInOrderDo:[:aClass |
self allBehaviorsDo:[:aClass |
"
avoid never-ending story ...
"
(aClass ~~ Smalltalk) ifTrue:[
"/ 'init ' print. aClass name printNL.
aClass initialize
]
].
"
now we can enable the graphical debugger/inspector
"
self initStandardTools.
self initInterrupts.
self initUserPreferences.
!
initUserPreferences
"setup other stuff"
LogDoits := false
!
initGlobalsFromEnvironment
"setup globals from the shell-environment"
|envString i langString terrString|
"
extract Language and LanguageTerritory from LANG variable.
the language and territory must not be abbreviated,
valid are for example: english_usa
english
german
german_austria
"
Language := #english.
LanguageTerritory := #usa.
envString := OperatingSystem getEnvironment:'LANG'.
envString notNil ifTrue:[
i := envString indexOf:$_.
(i == 0) ifTrue:[
langString := envString.
terrString := envString
] ifFalse:[
langString := envString copyTo:(i - 1).
terrString := envString copyFrom:(i + 1)
].
Language := langString asSymbol.
LanguageTerritory := terrString asSymbol
].
"
Smalltalk initGlobalsFromEnvironment
"
!
initStandardTools
"predefine some tools which we will need later
- if the view-classes exist,
they will redefine Inspector and Debugger for graphical interfaces"
"redefine debug-tools, if view-classes exist"
Display notNil ifTrue:[
InspectorView notNil ifTrue:[
Inspector := InspectorView
].
DebugView notNil ifTrue:[
Debugger := DebugView
].
Display initialize
]
"Smalltalk initStandardTools"
!
initStandardStreams
"initialize some well-known streams"
Stdout := NonPositionableExternalStream forStdout.
Stderr := NonPositionableExternalStream forStderr.
Stdin := NonPositionableExternalStream forStdin.
Printer := PrinterStream.
Transcript := Stderr
"Smalltalk initStandardStreams"
!
initInterrupts
"initialize interrupts"
OperatingSystem enableUserInterrupts.
OperatingSystem enableHardSignalInterrupts.
OperatingSystem enableFpExceptionInterrupts.
ObjectMemory userInterruptHandler:self.
ObjectMemory signalInterruptHandler:self.
ObjectMemory recursionInterruptHandler:self.
"Smalltalk initInterrupts"
!
initSystemPath
"setup path where system files are searched for.
the default path is set to:
.
..
$HOME (if defined)
$HOME/.smalltalk (if defined & existing)
$SMALLTALK_LIBDIR (if defined & existing)
/usr/local/lib/smalltalk (if existing)
/usr/lib/smalltalk (if existing)
of course, it is possible to add entries from the 'smalltalk.rc'
startup file; add expressions such as:
Smalltalk systemPath addFirst:'/foo/bar/baz'.
or:
Smalltalk systemPath addLast:'/fee/foe/foo'.
"
|p homePath|
homePath := OperatingSystem getHomeDirectory.
"
the path is set to search files first locally
- this allows private stuff to override global stuff
"
SystemPath := OrderedCollection new.
SystemPath add:'.'.
SystemPath add:'..'.
SystemPath add:homePath.
(OperatingSystem isDirectory:(p := homePath , '/.smalltalk')) ifTrue:[
SystemPath add:p
].
p := OperatingSystem getEnvironment:'SMALLTALK_LIBDIR'.
p notNil ifTrue:[
SystemPath add:p
].
(OperatingSystem isDirectory:'/usr/local/lib/smalltalk') ifTrue:[
SystemPath add:'/usr/local/lib/smalltalk'
].
(OperatingSystem isDirectory:'/usr/lib/smalltalk') ifTrue:[
SystemPath add:'/usr/lib/smalltalk'
].
"
Smalltalk initSystemPath
Smalltalk systemPath
"
!
isInitialized
"this returns true, if the system is properly initialized;
i.e. false during startup. Especially, the whole viewing stuff is
not working correctly until initialized."
^ Initializing not
! !
!Smalltalk class methodsFor:'startup'!
start
"main startup, if there is a Display, initialize it
and start dispatching; otherwise go into a read-eval-print loop"
|idx|
Initializing := true.
"/ Processor := ProcessorScheduler new.
"
while reading patches- and rc-file, do not add things into change-file
"
Class updateChanges:false.
self fileIn:'patches'.
"
look for a '-e filename' argument - this will force evaluation of
filename only, no standard startup
"
idx := Arguments indexOf:'-e'.
idx ~~ 0 ifTrue:[
self fileIn:(Arguments at:idx + 1).
self exit
].
(self fileIn:((Arguments at:1) , '.rc')) ifFalse:[
"no .rc file where executable is; try default smalltalk.rc"
(self fileIn:'smalltalk.rc') ifFalse:[
Transcript showCr:'no startup rc-file found'
]
].
Class updateChanges:true.
(SilentLoading == true) ifFalse:[ "i.e. undefined counts as false"
Transcript showCr:(self hello).
Transcript showCr:(self copyrightString).
Transcript cr.
DemoMode ifTrue:[
Transcript showCr:'*** Restricted use: ***'.
Transcript showCr:'*** This program may be used for education only. ***'.
Transcript showCr:'*** Please read the files COPYRIGHT and LICENSE ***'.
Transcript showCr:'*** for more details. ***'.
Transcript cr.
].
].
"
reenable the graphical debugger/inspector (they could have been
defined as autoloaded in the patches file)
"
self initStandardTools.
"
if there is a display, start its event dispatcher
"
Display notNil ifTrue:[
Display startDispatch.
"this is a leftover - will vanish"
" "
ModalDisplay notNil ifTrue:[
ModalDisplay startDispatch
]
" "
].
Initializing := false.
(StartupClass notNil and:[StartupSelector notNil]) ifTrue:[
StartupClass perform:StartupSelector withArguments:StartupArguments.
].
"
if view-classes exist, start dispatching;
otherwise go into a read-eval-print loop
"
Display notNil ifTrue:[
Processor dispatchLoop
] ifFalse:[
self readEvalPrint
].
"done"
self exit
!
restart
"startup after an image has been loaded;
there are three change-notifications made to dependents of ObjectMemory,
which allow a stepwise re-init: #earlyRestart, #restarted and #returnFromSnapshot.
#earlyRestart is send first, nothing has been setup yet.
(should be used to flush all device dependent entries)
#restarted is send right after.
(should be used to recreate external resources (fds, bitmaps etc)
#returnFromSnapshot is sent last
(should be used to restart processes, reOpen Streams which cannot
be automatically be reopened (i.e. Sockets, Pipes) and so on.
"
|deb insp imageName|
Initializing := true.
Processor reinitialize.
"temporary switch back to dumb interface -
to handle errors while view-stuff is not yet reinitialized"
insp := Inspector.
deb := Debugger.
Inspector := MiniInspector.
Debugger := MiniDebugger.
ObjectMemory changed:#earlyRestart.
ObjectMemory changed:#restarted.
"
some must be reinitialized before ...
- sorry, but order is important
"
Workstation notNil ifTrue:[
Workstation reinitialize.
].
ObjectMemory changed:#returnFromSnapshot.
OperatingSystem enableUserInterrupts.
OperatingSystem enableHardSignalInterrupts.
"and back to real interface"
Inspector := insp.
Debugger := deb.
Initializing := false.
"
if there is no Transcript, go to stderr
"
Transcript isNil ifTrue:[
self initStandardStreams.
Transcript := Stderr
].
(SilentLoading == true) ifFalse:[
Transcript cr.
Transcript showCr:('Smalltalk restarted from:' , ObjectMemory imageName).
Transcript cr.
DemoMode ifTrue:[
Transcript showCr:'*** Restricted use: ***'.
Transcript showCr:'*** This program may be used for education only. ***'.
Transcript showCr:'*** Please read the files COPYRIGHT and LICENSE ***'.
Transcript showCr:'*** for more details. ***'.
Transcript cr.
].
].
"
give user a chance to re-customize things
"
(Arguments includes:'-faststart') ifFalse:[
Class updateChanges:false.
(self fileIn:((Arguments at:1) , '_r.rc')) ifFalse:[
"no _r.rc file where executable is; try default smalltalk_r.rc"
self fileIn:'smalltalk_r.rc'
].
Class updateChanges:true.
].
"
if there is a display, start its event dispatcher
"
Display notNil ifTrue:[
Display startDispatch.
" "
ModalDisplay notNil ifTrue:[
ModalDisplay startDispatch
]
" "
].
"
this allows firing an application by defining
these two globals during snapshot ... or in main
"
(StartupClass notNil and:[StartupSelector notNil]) ifTrue:[
"allow customization by reading an image specific rc-file"
imageName := ObjectMemory imageName.
imageName notNil ifTrue:[
(imageName endsWith:'.img') ifTrue:[
self fileIn:((imageName copyTo:(imageName size - 4)), '.rc')
] ifFalse:[
self fileIn:(imageName , '.rc')
]
].
StartupClass perform:StartupSelector withArguments:StartupArguments.
].
"
if view-classes exist, start dispatching;
otherwise go into a read-eval-print loop
"
Display notNil ifTrue:[
Processor dispatchLoop
] ifFalse:[
self readEvalPrint
].
self exit
!
readEvalPrint
"simple read-eval-print loop for non-graphical Minitalk"
|text|
'ST- ' print.
Stdin skipSeparators.
text := Stdin nextChunk.
[text notNil] whileTrue:[
(Compiler evaluate:text) printNL.
'ST- ' print.
text := Stdin nextChunk
].
'' printNL
!
startupClass:aClass selector:aSymbol arguments:anArrayOrNil
"set the class, selector and arguments to be performed when smalltalk
starts. Setting those before saving a snapshot, will make the saved
image come up executing your application (instead of the normal mainloop)"
StartupClass := aClass.
StartupSelector := aSymbol.
StartupArguments := anArrayOrNil
!
startupClass
"return the class, that will get the start message when smalltalk
starts and its non-nil. Usually this is nil, but saving an image
with a non-nil StartupClass allows stand-alone applications"
^ StartupClass
!
startupSelector
"return the selector, that will be sent to StartupClass"
^ StartupSelector
!
startupArguments
"return the arguments passed to StartupClass"
^ StartupArguments
! !
!Smalltalk class methodsFor:'accessing'!
at:aKey
"retrieve the value stored under aKey, a symbol
- return nil if not present"
%{ /* NOCONTEXT */
extern OBJ _GLOBAL_GET();
RETURN ( _GLOBAL_GET(aKey) );
%}
!
at:aKey ifAbsent:aBlock
"retrieve the value stored at aKey.
If there is nothing stored under this key, return the value of
the evaluation of aBlock."
(self includesKey:aKey) ifTrue:[
^ self at:aKey
].
^ aBlock value
"
Smalltalk at:#fooBar <- leads to an error
Smalltalk at:#fooBar ifAbsent:['sorry'] <- no error
"
!
at:aKey put:aValue
"store the argument aValue under aKey, a symbol"
CachedClasses := nil.
%{ /* NOCONTEXT */
_GLOBAL_SET(aKey, aValue, (OBJ *)0);
%}.
^ aValue
!
removeKey:aKey
"remove the argument from the globals dictionary"
CachedClasses := nil.
%{ /* NOCONTEXT */
extern OBJ _GLOBAL_REMOVE();
RETURN ( _GLOBAL_REMOVE(aKey) );
%}
!
includesKey:aKey
"return true, if the key is known"
%{ /* NOCONTEXT */
extern OBJ _GLOBAL_KEYKNOWN();
RETURN ( _GLOBAL_KEYKNOWN(aKey) );
%}
!
keyAtValue:anObject
"return the symbol under which anObject is stored - or nil"
self allKeysDo:[:aKey |
(self at:aKey) == anObject ifTrue:[^ aKey]
]
"Smalltalk keyAtValue:Object"
!
keys
"return a collection with all keys in the Smalltalk dictionary"
|keys|
keys := IdentitySet new.
self allKeysDo:[:k | keys add:k].
^ keys
! !
!Smalltalk class methodsFor:'copying'!
shallowCopy
"redefine copy - there is only one Smalltalk dictionary"
^ self
!
simpleDeepCopy
"redefine copy - there is only one Smalltalk dictionary"
^ self
!
deepCopyUsing:aDictionary
"redefine copy - there is only one Smalltalk dictionary"
^ self
!
deepCopy
"redefine copy - there is only one Smalltalk dictionary"
^ self
! !
!Smalltalk class methodsFor:'inspecting'!
inspect
"redefined to launch a DictionaryInspector on the receiver
(instead of the default InspectorView)."
DictionaryInspectorView isNil ifTrue:[
super inspect
] ifFalse:[
DictionaryInspectorView openOn:self
]
! !
!Smalltalk class methodsFor:'misc stuff'!
addExitBlock:aBlock
"add a block to be executed when Smalltalk finishes.
This feature is currently not used anywhere - but could be useful for
cleanup in stand alone applications."
ExitBlocks isNil ifTrue:[
ExitBlocks := OrderedCollection with:aBlock
] ifFalse:[
ExitBlocks add:aBlock
]
!
exit
"finish Smalltalk system"
ExitBlocks notNil ifTrue:[
ExitBlocks do:[:aBlock |
aBlock value
]
].
OperatingSystem exit
"Smalltalk exit"
!
sleep:aDelay
"wait for aDelay seconds.
WARNING: this is historical leftover and will be removed"
OperatingSystem sleep:aDelay
! !
!Smalltalk class methodsFor:'message control'!
silentLoading:aBoolean
"allows access to the Silentloading class variable, which controls
messages from all kinds of system onto the transcript.
You can save a snapshot with this flag set to true, which makes
the image come up silent. Can also be set, to read in files unlogged."
|prev|
prev := SilentLoading.
SilentLoading := aBoolean.
^ prev
!
silentLoading
"returns the Silentloading class variable."
^ SilentLoading
! !
!Smalltalk class methodsFor:'debugging'!
debugBreakPoint
"call the dummy debug function, on which a breakpoint
can be put in adb, sdb, dbx or gdb.
This method will not be present in the future."
%{
_PATCHUPCONTEXTS(__context);
debugBreakPoint();
%}
!
printStackBacktrace
"print a stack backtrace - then continue.
WARNING: this method is for debugging only
it may be removed without notice"
%{
printStack(__context);
%}
"Smalltalk printStackBacktrace"
!
fatalAbort:aMessage
"report a fatal-error; print a stack backtrace and exit with core dump"
%{
char *msg;
if (__isString(aMessage))
msg = (char *) _stringVal(aMessage);
else
msg = "fatalAbort";
fatal0(__context, msg);
/* NEVER RETURNS */
%}
!
fatalAbort
"report a fatal-error, print a stack backtrace and exit with core dump"
%{
fatal0(__context, "fatalAbort");
/* NEVER RETURNS */
%}
!
exitWithCoreDump
"abort program and dump core"
%{ /* NOCONTEXT */
abort();
/* NEVER RETURNS */
%}
!
statistic
"print some statistic data.
WARNING: this method is for debugging only
it may be removed without notice"
%{ /* NOCONTEXT */
__STATISTIC__();
%}
!
debugOn
"turns some tracing on.
WARNING: this method is for debugging only
it may be removed without notice"
"LookupTrace := true. "
MessageTrace := true.
"AllocTrace := true. "
ObjectMemory flushInlineCaches
!
debugOff
"turns tracing off.
WARNING: this method is for debugging only
it may be removed without notice"
LookupTrace := nil.
MessageTrace := nil
". AllocTrace := nil "
!
executionDebugOn
"turns tracing of interpreter on.
WARNING: this method is for debugging only
it may be removed without notice"
ExecutionTrace := true
!
executionDebugOff
"turns tracing of interpreter off.
WARNING: this method is for debugging only
it may be removed without notice"
ExecutionTrace := nil
! !
!Smalltalk class methodsFor:'enumeration'!
do:aBlock
"evaluate the argument, aBlock for all values in the Smalltalk dictionary"
%{
_GLOBALS_DO(&aBlock COMMA_CON);
%}
!
allKeysDo:aBlock
"evaluate the argument, aBlock for all keys in the Smalltalk dictionary"
%{
_GLOBALKEYS_DO(&aBlock COMMA_CON);
%}
!
associationsDo:aBlock
"evaluate the argument, aBlock for all key/value pairs
in the Smalltalk dictionary"
self allKeysDo:[:aKey |
aBlock value:(aKey -> (self at:aKey))
]
"Smalltalk associationsDo:[:assoc | assoc printNL]"
!
keysAndValuesDo:aBlock
"evaluate the two-arg block, aBlock for all keys and values"
self allKeysDo:[:aKey |
aBlock value:aKey value:(self at:aKey)
]
!
allBehaviorsDo:aBlock
"evaluate the argument, aBlock for all classes in the system"
CachedClasses isNil ifTrue:[
self allClasses
].
CachedClasses do:aBlock
!
allClassesDo:aBlock
"evaluate the argument, aBlock for all classes in the system.
Backward compatibility - use allBehaviorsDo: for ST-80 compatibility."
^ self allBehaviorsDo:aBlock
! !
!Smalltalk class methodsFor:'queries'!
numberOfGlobals
"return the number of global variables in the system"
|tally "{ Class: SmallInteger }" |
tally := 0.
self do:[:obj | tally := tally + 1].
^ tally
"Smalltalk numberOfGlobals"
!
cellAt:aName
"return the address of a global cell
- used internally for compiler only"
%{ /* NOCONTEXT */
extern OBJ _GLOBAL_GETCELL();
RETURN ( _GLOBAL_GETCELL(aName) );
%}
!
references:anObject
"return true, if I refer to the argument, anObject
must be reimplemented since Smalltalk is no real collection."
self do:[:o |
(o == anObject) ifTrue:[^ true]
].
^ false
!
allClasses
"return a collection of all classes in the system"
CachedClasses isNil ifTrue:[
CachedClasses := IdentitySet new:800.
self do:[:anObject |
anObject notNil ifTrue:[
anObject isBehavior ifTrue:[
CachedClasses add:anObject
]
]
]
].
^ CachedClasses
"Smalltalk allClasses"
!
classNames
"return a collection of all classNames in the system"
^ self allClasses collect:[:aClass | aClass name]
"Smalltalk classNames"
!
classNamed:aString
"return the class with name aString, or nil if absent.
To get to the metaClass, append 'class' to the string."
|cls str|
"be careful, to not invent new symbols ..."
aString knownAsSymbol ifTrue:[
cls := self at:(aString asSymbol) ifAbsent:[^ nil].
cls isBehavior ifTrue:[^ cls]
].
(aString endsWith:'class') ifTrue:[
str := aString copyTo:(aString size - 5).
str knownAsSymbol ifTrue:[
cls := self at:(str asSymbol) ifAbsent:[^ nil].
cls isBehavior ifTrue:[^ cls]
]
].
^ nil
"
Smalltalk classNamed:'Object'
Smalltalk classNamed:'fooBar'
Smalltalk classNamed:'true'
Smalltalk classNamed:'Objectclass'
Smalltalk classNamed:'Metaclass'
"
!
includes:something
"this should come from Collection.
will change the inheritance - Smalltalk is actually a collection"
self do:[:element | element = something ifTrue:[^ true]].
^ false
! !
!Smalltalk class methodsFor:'class management'!
renameClass:aClass to:newName
"rename aClass to newName"
|oldName oldSym newSym names cSym value|
oldName := aClass name.
oldSym := oldName asSymbol.
((self at:oldSym) == aClass) ifFalse:[^ self].
"rename the class"
aClass setName:newName.
"and its meta"
aClass class setName:(newName , 'class').
"store it in Smalltalk"
newSym := newName asSymbol.
self at:oldSym put:nil.
self removeKey:oldSym.
self at:newSym put:aClass.
"rename class variables"
names := aClass classVariableString asCollectionOfWords.
names do:[:name |
cSym := (oldSym , ':' , name) asSymbol.
value := self at:cSym.
self at:cSym put:nil.
self removeKey:cSym.
cSym := (newSym , ':' , name) asSymbol.
self at:cSym put:value.
].
aClass addChangeRecordForClassRename:oldName to:newName
!
removeClass:aClass
"remove the argument, aClass from the smalltalk dictionary;
we have to flush the caches since these methods are now void.
Also, class variables of aClass are removed."
|sym cSym names oldName|
oldName := aClass name.
sym := oldName asSymbol.
((self at:sym) == aClass) ifFalse:[
"check other name ..."
(self includes:aClass) ifFalse:[
'no such class' errorPrintNL.
^ self
].
"
the class has changed its name - without telling me ...
what should be done in this case ?
"
'class ' errorPrint. oldName errorPrint.
' has changed its name' errorPrintNL.
^ self
].
self at:sym put:nil. "nil it out for compiled accesses"
self removeKey:sym. "remove key - this actually fails, if there are
still compiled code references."
"remove class variables"
names := aClass classVariableString asCollectionOfWords.
names do:[:name |
cSym := (sym , ':' , name) asSymbol.
self at:cSym asSymbol put:nil.
self removeKey:cSym
].
"
actually could get along with less flushing
(entries for aClass and subclasses only)
but we have to delay this, until we have the set of subclasses
at hand - for now, searching for all subclasses is way more
expensive then cache flushing.
aClass allSubclassesDo:[:aSubclass |
ObjectMemory flushInlineCachesForClass:aSubclass.
ObjectMemory flushMethodCacheFor:aSubclass
].
ObjectMemory flushInlineCachesForClass:aClass.
ObjectMemory flushMethodCacheFor:aClass
"
ObjectMemory flushInlineCaches.
ObjectMemory flushMethodCache.
aClass addChangeRecordForClassRemove:oldName.
self changed:#classRemove with:aClass.
aClass category:#removed.
! !
!Smalltalk class methodsFor:'browsing'!
browseChanges
"startup a changes browser"
ChangesBrowser notNil ifTrue:[
ChangesBrowser open
] ifFalse:[
self warn:'no ChangesBrowser built in'
]
"
Smalltalk browseChanges
"
!
browseAllSelect:aBlock
"startup a browser for all methods for which aBlock returns true"
SystemBrowser browseAllSelect:aBlock
"
Smalltalk browseAllSelect:[:m | m literals isNil]
"
!
browseImplementorsOf:aSelectorSymbol
"startup a browser for all methods implementing a particular message"
SystemBrowser browseImplementorsOf:aSelectorSymbol
"
Smalltalk browseImplementorsOf:#at:put:
"
!
browseAllCallsOn:aSelectorSymbol
"startup a browser for all methods sending a particular message"
SystemBrowser browseAllCallsOn:aSelectorSymbol
"
Smalltalk browseAllCallsOn:#at:put:
"
! !
!Smalltalk class methodsFor:'system management'!
language
"return the language setting"
^ Language
!
languageTerritory
"return the language territory setting"
^ LanguageTerritory
!
logDoits
"return true if doits should go into the changes file
as well as changes - by default, this is off, since
it can blow up the changes file enormously ...
"
^ LogDoits
"
LogDoits := false
LogDoits := true
"
!
logDoits:aBoolean
"turn on/off logging of doits in the changes file.
By default, this is off, since it can blow up the
changes file enormously ...
"
LogDoits := aBoolean
!
systemPath
"return a collection of directorynames, where smalltalk
looks for system files
(usually in subdirs such as resources, bitmaps, source etc.)
see comment in Smalltalk>>initSystemPath."
^ SystemPath
"
Smalltalk systemPath
Smalltalk systemPath addLast:'someOtherDirectoryPath'
"
!
getSystemFileName:aFileName
"search aFileName in some standard places;
return the absolute filename or nil if none is found.
see comment in Smalltalk>>initSystemPath."
"credits for this method go to Markus ...."
|realName|
(aFileName startsWith:'/') ifTrue:[
"dont use path for absolute file names"
^ aFileName
].
SystemPath do:[:dirName |
(OperatingSystem isReadable:
(realName := dirName , '/' , aFileName))
ifTrue: [^ realName]].
^ nil
!
systemFileStreamFor:aFileName
"search aFileName in some standard places;
return a readonly fileStream or nil if not found.
see comment in Smalltalk>>initSystemPath"
|aString|
aString := self getSystemFileName:aFileName.
aString notNil ifTrue:[
^ FileStream readonlyFileNamed:aString
].
^ nil
!
readAbbreviations
"read classname to filename mappings from include/abbrev.stc.
sigh - all for those poor sys5.3 people ..."
|aStream line index thisName abbrev|
CachedAbbreviations := IdentityDictionary new.
"/ aStream := self systemFileStreamFor:'abbrev.stc'.
aStream isNil ifTrue:[
aStream := self systemFileStreamFor:'include/abbrev.stc'.
].
aStream notNil ifTrue:[
[aStream atEnd] whileFalse:[
line := aStream nextLine.
line notNil ifTrue:[
(line startsWith:'#') ifFalse:[
(line countWords == 2) ifTrue:[
index := line indexOfSeparatorStartingAt:1.
(index ~~ 0) ifTrue:[
thisName := line copyTo:(index - 1).
abbrev := (line copyFrom:index) withoutSeparators.
CachedAbbreviations at:thisName asSymbol put:abbrev.
]
]
]
]
].
aStream close
]
!
filenameAbbreviations
"return a dictionary containing the classname-to-filename
mappings. (needed for sys5.3 users, where filenames are limited
to 14 chars)"
CachedAbbreviations isNil ifTrue:[
self readAbbreviations
].
^ CachedAbbreviations
"flush with:
CachedAbbreviations := nil
"
"
Smalltalk filenameAbbreviations
"
!
fileNameForClass:aClassName
"return a good filename for aClassName -
using abbreviation file if there is one"
|fileName abbrev|
fileName := aClassName.
"first look, if the class exists and has a fileName"
" later ... - compiler should put the source file name into the class
Symbol hasInterned:aClassName ifTrue:[:sym |
|class|
(Smalltalk includesKey:sym) ifTrue:[
class := Smalltalk at:sym.
class isClass ifTrue:[
abbrev := class classFileName.
]
]
].
"
"look for abbreviation"
abbrev := self filenameAbbreviations at:fileName ifAbsent:[nil].
abbrev notNil ifTrue:[^ abbrev].
"no abbreviation found - if its a short name, take it"
OperatingSystem maxFileNameLength < (fileName size + 3) ifTrue:[
"this will only be triggered on sys5.3 type systems"
self error:'cant find short for ' , fileName , ' in abbreviation file'
].
^ fileName
!
classNameForFile:aFileName
"return the className which corresponds to an abbreviated fileName,
or nil if no special translation applies. The given filename arg should
NOT include any suffix such as '.st'."
^ self filenameAbbreviations keyAtValue:aFileName ifAbsent:[aFileName].
"Smalltalk classNameForFile:'DrawObj'"
!
fileInClassObject:aClassName from:aFileName
"read in the named object file and dynamic-link it into the system
- look for it in some standard places;
return true if ok, false if failed."
"
check if the dynamic loader class is in
"
ObjectFileLoader isNil ifTrue:[^ false].
(self getSystemFileName:aFileName) isNil ifTrue:[^ false].
^ (ObjectFileLoader loadClass:aClassName fromObjectFile:aFileName) notNil
"
Smalltalk fileInClassObject:'AbstractPath' from:'../goodies/Paths/AbstrPath.o'
"
!
fileIn:aFileName
"read in the named file - look for it in some standard places;
return true if ok, false if failed"
|aStream path|
"
an object or shared object ?
"
((aFileName endsWith:'.o')
or:[(aFileName endsWith:'.obj')
or:[aFileName endsWith:'.so']]) ifTrue:[
ObjectFileLoader isNil ifTrue:[^ false].
path := self getSystemFileName:aFileName.
path isNil ifTrue:[^ false].
^ ObjectFileLoader loadObjectFile:aFileName
].
aStream := self systemFileStreamFor:aFileName.
aStream isNil ifTrue:[^ false].
[aStream fileIn] valueNowOrOnUnwindDo:[aStream close].
^ true
"
Smalltalk fileIn:'games/TicTacToe.st'
"
!
fileInChanges
"read in the last changes file - bringing the system to the state it
had when left the last time.
WARNING: this method is rubbish: it should only read things after the
last '**snapshot**' - entry."
"
tell Class to NOT update the changes file now ...
"
Class withoutUpdatingChangesDo:
[
self fileIn:'changes'
]
"
Smalltalk fileInChanges
"
!
fileInClass:aClassName
"find a source/object file for aClassName and -if found - load it.
search is in some standard places trying driver-file (.ld), object-file (.o) and
finally source file (.st) in that order.
The file is first searched for using the class name, then the abbreviated name."
|shortName newClass ok nm|
Class withoutUpdatingChangesDo:
[
"
first, look for a loader-driver file (in fileIn/xxx.ld)
"
(self fileIn:('fileIn/' , aClassName , '.ld'))
ifFalse:[
shortName := self fileNameForClass:aClassName.
"
try abbreviated driver-file (in fileIn/xxx.ld)
"
(self fileIn:('fileIn/' , shortName , '.ld'))
ifFalse:[
"
then, if dynamic linking is available, look for a shared binary in binary/xxx.o
"
ObjectFileLoader notNil ifTrue:[
nm := 'binary/' , aClassName.
(self fileInClassObject:aClassName from:(nm , '.so'))
ifFalse:[
(self fileInClassObject:aClassName from:(nm , '.o'))
ifFalse:[
nm := 'binary/' , shortName.
(self fileInClassObject:aClassName from:(nm , '.so'))
ifFalse:[
ok := self fileInClassObject:aClassName from:(nm , '.o')
].
].
].
].
"
if that did not work, look for an st-source file ...
"
ok ifFalse:[
(self fileIn:(aClassName , '.st'))
ifFalse:[
(self fileIn:(shortName , '.st'))
ifFalse:[
"
... and in the standard source-directory
"
(self fileIn:('source/' , aClassName , '.st'))
ifFalse:[
ok := self fileIn:('source/' , shortName , '.st')
]
]
]
]
].
]
].
newClass := self at:(aClassName asSymbol).
newClass notNil ifTrue:[newClass initialize]
!
silentFileIn:aFilename
"same as fileIn:, but do not output 'compiled...'-messages on Transcript.
Main use is during startup."
|wasSilent|
wasSilent := self silentLoading:true.
[
self fileIn:aFilename
] valueNowOrOnUnwindDo:[
self silentLoading:wasSilent
]
!
compressSources
"compress the sources file, and remove all method source strings
from the system and replace them by refs to a string in the source file.
This is a bit different in ST/X than in other smalltalks,
since we use per-class sourcefiles for the compiled classes,
and a mix of in-memory strings and one-for-all sourceFile for
incremental compiled methods.
Therefore, only those sources which are not coming from compiled
methods are put into the 'st.src' file - all others are untouched.
This is being automated - so dont care for now."
"
first, find all methods which contain either a string-ref
or an external string in the 'st.src' file
"
|newStream table source pos fileName|
newStream := 'src.tmp' asFilename writeStream.
newStream isNil ifTrue:[
self error:'cannot create new temporary source file'.
^ self
].
table := IdentityDictionary new:100.
Method allDerivedInstancesDo:[:aMethod |
source := nil.
aMethod sourcePosition notNil ifTrue:[
aMethod sourceFilename = 'st.src' ifTrue:[
source := aMethod source.
]
] ifFalse:[
source := aMethod source
].
source notNil ifTrue:[
pos := newStream position.
newStream nextChunkPut:source.
"
dont change the methods info - maybe some write error
occurs later, in that case we abort and leave everything
untouched.
"
table at:aMethod put:pos
]
].
newStream close.
"
now, rename the new source file,
"
fileName := (ObjectMemory nameForSources).
('src.tmp' asFilename renameTo:fileName) ifFalse:[
self error:'cannot rename temporary file to new source file'.
^ self
].
"good - now go over all changed methods, and change their
source reference"
table keysAndValuesDo:[:aMethod :pos |
aMethod sourceFilename:fileName position:pos.
aMethod printNL.
].
"
Smalltalk compressSources
"
! !
!Smalltalk class methodsFor: 'binary storage'!
addGlobalsTo: globalDictionary manager: manager
|pools|
pools := Set new.
self associationsDo:[:assoc |
assoc value == self ifFalse:[
assoc value isClass ifTrue:[
assoc value addGlobalsTo:globalDictionary manager:manager.
pools addAll:assoc value sharedPools
] ifFalse:[
globalDictionary at:assoc put:self
].
assoc value isNil ifFalse:[
globalDictionary at:assoc value put:self
]
]
].
pools do:[:poolDictionary|
poolDictionary addGlobalsTo:globalDictionary manager:manager
]
!
storeBinaryDefinitionOf: anObject on: stream manager: manager
|string|
anObject class == Association ifTrue:[
string := 'Smalltalk associationAt: ', anObject key storeString
] ifFalse: [
string := 'Smalltalk at: ', (self keyAtValue: anObject) storeString
].
stream nextNumber:2 put:string size.
string do:[:char | stream nextPut:char asciiValue]
! !