"
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 CommandLineArguments CachedAbbreviations
SilentLoading Initializing StandAlone LogDoits LoadBinaries
RealSystemPath ResourcePath SourcePath BitmapPath BinaryPath
FileInPath ImageStartTime ImageRestartTime DemoMode'
poolDictionaries:''
category:'System-Support'
!
!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.
"
!
documentation
"
This is one of the central classes in the system;
it provides all system-startup, shutdown and maintenance support.
Also global variables are (conceptionally) 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 (GNU-ST compatibility).
SystemPath <Collection> path to search for system files (sources, bitmaps etc)
Set to a default here, but typically changed from some
startup.rc file
StartupClass <Class>
StartupSelector <Symbol>
StartupArguments <Array>
class and selector, where the system starts up
(right after VM initialization)
If an image is saved while this is nonNil, the image will come up
there.
CommandLineArguments <Array> command line broken into words
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 if every tiny doIt is saved there ...
LoadBinaries <Boolean> if true, we attempt to load classes rom a binary
file, if present. If false, this is always suppressed.
ImageStartTime <AbsoluteTime> timestamp when this system was started the very first time
(i.e. the time of the initial start without an image)
ImageRestartTime
<AbsoluteTIme> timestamp when this image was started
strictly private classVariables (helpers):
CachedClasses <Collection> known classes (cached for faster class enumeration)
CachedAbbreviations
<Dictionary> className to filename mappings
SourcePath <Collection> cached names of really existing directories
BitmapPath These are remembered, since in NFS systems,
ResourcePath the time to lookup files may become long
BinaryPath (especially, if some directories are on machines
FileInPath which are not up ...). Therefore, the set of really
existing directories is cached when the SystemPath
is walked the first time.
[author:]
Claus Gittinger
"
! !
!Smalltalk class methodsFor:'initialization'!
initGlobalsFromEnvironment
"setup globals from the shell-environment"
|envString i langString terrString|
"
extract Language and LanguageTerritory from LANG variable.
valid are for example: english_us / us_us / us
english / en_en / en
german / de_de / de
german_austria
"
Language := #english.
LanguageTerritory := #us.
envString := OperatingSystem getEnvironment:'LANG'.
envString notNil ifTrue:[
envString isEmpty ifFalse:[
i := envString indexOf:$_.
(i == 0) ifTrue:[
langString := envString.
terrString := envString
] ifFalse:[
langString := envString copyTo:(i - 1).
terrString := envString copyFrom:(i + 1)
].
Language := langString asLowercase asSymbol.
LanguageTerritory := terrString asLowercase asSymbol
]
].
"
Smalltalk initGlobalsFromEnvironment
"
"Modified: 22.2.1996 / 16:59:12 / cg"
!
initInterrupts
"initialize interrupts"
OperatingSystem enableUserInterrupts.
OperatingSystem enableHardSignalInterrupts.
OperatingSystem enableFpExceptionInterrupts.
ObjectMemory userInterruptHandler:self.
ObjectMemory signalInterruptHandler:self.
ObjectMemory recursionInterruptHandler:self.
"
Smalltalk initInterrupts
"
!
initStandardStreams
"initialize some well-known streams"
Stdout := NonPositionableExternalStream forStdout.
Stderr := NonPositionableExternalStream forStderr.
Stdin := NonPositionableExternalStream forStdin.
Printer := PrinterStream.
Transcript := Stderr
"
Smalltalk initStandardStreams
"
!
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
"
!
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)
$STX_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|
SystemPath isNil ifTrue:[
homePath := OperatingSystem getHomeDirectory.
homePath isNil ifTrue:[
homePath := '.'
].
"
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
].
p := OperatingSystem getEnvironment:'STX_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'
].
self flushPathCaches
]
"
Smalltalk initSystemPath
Smalltalk systemPath
"
!
initUserPreferences
"setup other stuff"
LogDoits := false.
LoadBinaries := false.
!
initializeModules
"perform module specific initialization and
send #initialize to all classes.
Notice: this is not called when an image is restarted"
%{
__init_registered_modules__(3 COMMA_CON);
@global(DemoMode) = __getDemoMode__() ? true : false;
%}
!
initializeSystem
"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."
%{
#ifdef WIN32
printf("here initializeSystem\n");
#endif
%}.
SilentLoading := false.
Initializing := true.
"
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.
"
start catching SIGSEGV and SIGBUS
"
OperatingSystem enableHardSignalInterrupts.
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.
Signal initialize.
ObjectMemory initialize.
Stream 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 other classes
"
self initializeModules.
"/ self allBehaviorsDo:[:aClass |
"/ 'init ' print. aClass name printNL.
"/ aClass initialize
"/ ].
ImageStartTime := AbsoluteTime now.
Display notNil ifTrue:[
Display initialize.
].
self initInterrupts.
self initUserPreferences.
"Modified: 13.12.1995 / 17:43:27 / cg"
!
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
!
reinitStandardStreams
"reinitialize some well-known streams.
Tis must be done very early during startup, to allow for
debug and trace messages to be output
(otherwise, the file-descriptors are invalid)"
Stdout reOpen. Stderr reOpen. Stdin reOpen.
! !
!Smalltalk class methodsFor:'accessing'!
at:aKey
"retrieve the value stored under aKey, a symbol.
Return nil if not present (this will be changed to trigger an error)"
%{ /* NOCONTEXT */
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 <- returns nil
Smalltalk at:#fooBar ifAbsent:['sorry'] <- no error
"
!
at:aKey put:aValue
"store the argument aValue under aKey, a symbol.
Return aValue (sigh)."
" "
|oldValue|
%{
oldValue = __GLOBAL_SET(aKey, aValue, (OBJ *)0);
%}.
CachedClasses notNil ifTrue:[
oldValue isBehavior ifTrue:[
oldValue name == aKey ifTrue:[
CachedClasses remove:oldValue ifAbsent:[]
]
].
aValue isBehavior ifTrue:[
aValue isMeta ifTrue:[
self halt
].
CachedClasses add:aValue
].
].
^ aValue.
" "
%{ /* NOCONTEXT */
(void) __GLOBAL_SET(aKey, aValue, (OBJ *)0);
%}.
CachedClasses := nil.
^ aValue
"Modified: 19.4.1996 / 11:31:49 / cg"
!
currentNameSpace
^ self
!
includesKey:aKey
"return true, if the key is known"
%{ /* NOCONTEXT */
RETURN ( __GLOBAL_KEYKNOWN(aKey) );
%}
!
keyAtValue:anObject
"return the symbol under which anObject is stored - or nil"
self keysDo:[:aKey |
(self at:aKey) == anObject ifTrue:[^ aKey]
].
^ nil
"Smalltalk keyAtValue:Object"
!
keys
"return a collection with all keys in the Smalltalk dictionary"
|keys|
keys := IdentitySet new.
self keysDo:[:k | keys add:k].
^ keys
!
removeKey:aKey
"remove the association stored under the key-argument from the globals dictionary.
WARNING:
this is somewhat dangerous: conceptionally, the association is removed,
to which machine & byte compiled code refers if it accesses a global.
If there are still global accesses in some literalArray or from machine-compiled code,
it continues to reference the globals value via that obsolete association and gets a nil
value. (which is correct)
However, if that global is later reintroduced, a new association will be created and
the new global now referenced via the new association.
The old accesses will still see nil, although the globals value is actually non-nil
(this is questionable).
To avoid this problem, the #removeClass: method never removed the key."
CachedClasses := nil.
%{ /* NOCONTEXT */
RETURN ( __GLOBAL_REMOVE(aKey) );
%}
! !
!Smalltalk class methodsFor:'binary storage'!
addGlobalsTo:globalDictionary manager:manager
|pools|
pools := Set new.
self keysAndValuesDo:[:key :value |
(key includes:$:) ifFalse:[ "/ skip classVars
value ~~ self ifTrue:[
value isClass ifTrue:[
value addGlobalsTo:globalDictionary manager:manager.
pools addAll:value sharedPools
] ifFalse:[
globalDictionary at:(key->value) put:self
].
value notNil ifTrue:[
globalDictionary at: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]
! !
!Smalltalk class methodsFor:'browsing'!
browseAllCallsOn:aSelectorSymbol
"{ Pragma: +optSpace }"
"startup a browser for all methods sending a particular message"
SystemBrowser browseAllCallsOn:aSelectorSymbol
"
Smalltalk browseAllCallsOn:#at:put:
"
!
browseAllSelect:aBlock
"{ Pragma: +optSpace }"
"startup a browser for all methods for which aBlock returns true"
SystemBrowser browseAllSelect:aBlock
"
Smalltalk browseAllSelect:[:m | m literals isNil]
"
!
browseChanges
"{ Pragma: +optSpace }"
"startup a changes browser"
ChangesBrowser notNil ifTrue:[
ChangesBrowser open
] ifFalse:[
self warn:'no ChangesBrowser built in'
]
"
Smalltalk browseChanges
"
!
browseImplementorsOf:aSelectorSymbol
"{ Pragma: +optSpace }"
"startup a browser for all methods implementing a particular message"
SystemBrowser browseImplementorsOf:aSelectorSymbol
"
Smalltalk browseImplementorsOf:#at:put:
"
! !
!Smalltalk class methodsFor:'class management'!
flushCachedClasses
CachedClasses := nil
!
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:[
'SMALLTALK: no such class: ' errorPrint. oldName errorPrintNL.
^ self
].
"
the class has changed its name - without telling me ...
what should be done in this case ?
"
'SMALLTALK: class ' errorPrint. oldName errorPrint.
' has changed its name' errorPrintNL.
^ self
].
self at:sym put:nil. "nil it out for compiled accesses"
"/
"/ see comment in removeKey: on why we dont remove it here
"/
"/ 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.
"/
"/ see comment in removeKey: on why we dont remove it here
"/
"/ 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.
!
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.
"/
"/ see comment in #removeKey: on why we dont do it here
"/
"/ 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.
"/
"/ see comment in #removeKey: on why we dont do it here
"/
"/ self removeKey:cSym.
cSym := (newSym , ':' , name) asSymbol.
self at:cSym put:value.
].
aClass addChangeRecordForClassRename:oldName to:newName
"Created: 29.10.1995 / 19:58:32 / cg"
! !
!Smalltalk class methodsFor:'copying'!
deepCopy
"redefine copy - there is only one Smalltalk dictionary"
^ self
!
deepCopyUsing:aDictionary
"redefine copy - there is only one Smalltalk dictionary"
^ self
!
shallowCopy
"redefine copy - there is only one Smalltalk dictionary"
^ self
!
simpleDeepCopy
"redefine copy - there is only one Smalltalk dictionary"
^ self
! !
!Smalltalk class methodsFor:'debugging ST/X'!
debugBreakPoint
"{ Pragma: +optSpace }"
"call the dummy debug function, on which a breakpoint
can be put in adb, sdb, dbx or gdb.
WARNING: this method is for debugging only
it will be removed without notice."
%{
_PATCHUPCONTEXTS(__context);
__debugBreakPoint__();
%}
!
exitWithCoreDump
"{ Pragma: +optSpace }"
"abort program and dump core"
%{ /* NOCONTEXT */
abort();
/* NEVER RETURNS */
%}
!
fatalAbort
"{ Pragma: +optSpace }"
"report a fatal-error, print a stack backtrace and exit with core dump.
(You may turn off the stack print with debugPrinting:false)"
%{
__fatal0(__context, "fatalAbort");
/* NEVER RETURNS */
%}
!
fatalAbort:aMessage
"{ Pragma: +optSpace }"
"report a fatal-error; print a stack backtrace and exit with core dump
(You may turn off the stack print with debugPrinting:false)"
%{
char *msg;
if (__isString(aMessage))
msg = (char *) __stringVal(aMessage);
else
msg = "fatalAbort";
__fatal0(__context, msg);
/* NEVER RETURNS */
%}
!
printPolyCaches
"{ Pragma: +optSpace }"
"dump poly caches.
WARNING: this method is for debugging only
it will be removed without notice"
%{
__dumpILCCaches();
%}
!
printStackBacktrace
"{ Pragma: +optSpace }"
"print a stack backtrace - then continue.
(You may turn off the stack print with debugPrinting:false)
WARNING: this method is for debugging only
it will be removed without notice"
%{
__printStack(__context);
%}
"Smalltalk printStackBacktrace"
!
printSymbols
"{ Pragma: +optSpace }"
"dump the internal symbol table.
WARNING: this method is for debugging only
it will be removed without notice"
%{
#ifdef DEBUG
__dumpSymbols();
#endif
%}
!
sendTraceOff
"{ Pragma: +optSpace }"
"turns tracing of message sends off.
WARNING: this method is for debugging only
it may be removed without notice"
%{ /* NOCONTEXT */
__setMessageTrace__(0);
%}
!
sendTraceOn
"{ Pragma: +optSpace }"
"turns tracing of message sends on.
WARNING: this method is for debugging only
it may be removed without notice"
%{ /* NOCONTEXT */
__setMessageTrace__(1);
%}
!
statistic
"{ Pragma: +optSpace }"
"print some statistic data.
WARNING: this method is for debugging only
it may be removed without notice"
%{ /* NOCONTEXT */
__STATISTIC__();
%}
! !
!Smalltalk class methodsFor:'enumerating'!
allBehaviorsDo:aBlock
"evaluate the argument, aBlock for all classes in the system"
CachedClasses isNil ifTrue:[
self allClasses
].
CachedClasses do:aBlock
"
Smalltalk allBehaviorsDo:[:aClass | aClass name printNL]
"
!
allClassesDo:aBlock
"evaluate the argument, aBlock for all classes in the system.
Backward compatibility - use #allBehaviorsDo: for ST-80 compatibility."
^ self allBehaviorsDo:aBlock
"
Smalltalk allClassesDo:[:aClass | aClass name printNL]
"
!
allClassesInCategory:aCategory do:aBlock
"evaluate the argument, aBlock for all classes in the aCategory;
The order of the classes is not defined."
aCategory notNil ifTrue:[
self allBehaviorsDo:[:aClass |
aClass isMeta ifFalse:[
(aClass category = aCategory) ifTrue:[
aBlock value:aClass
]
]
]
]
"
Smalltalk allClassesInCategory:'Views-Basic' do:[:aClass | aClass name printNL]
"
!
allClassesInCategory:aCategory inOrderDo:aBlock
"evaluate the argument, aBlock for all classes in aCategory;
superclasses come first - then subclasses"
|classes|
aCategory notNil ifTrue:[
classes := OrderedCollection new.
self allBehaviorsDo:[:aClass |
aClass isMeta ifFalse:[
(aClass category = aCategory) ifTrue:[
classes add:aClass
]
]
].
classes topologicalSort:[:a :b | b isSubclassOf:a].
classes do:aBlock
]
"
Smalltalk allClassesInCategory:'Views-Basic' inOrderDo:[:aClass | aClass name printNL]
"
!
allKeysDo:aBlock
"evaluate the argument, aBlock for all keys in the Smalltalk dictionary"
^ self keysDo:aBlock
!
associationsDo:aBlock
"evaluate the argument, aBlock for all key/value pairs
in the Smalltalk dictionary"
self keysDo:[:aKey |
aBlock value:(aKey -> (self at:aKey))
]
"Smalltalk associationsDo:[:assoc | assoc printNL]"
!
do:aBlock
"evaluate the argument, aBlock for all values in the Smalltalk dictionary"
|work|
%{ /* NOREGISTER - work may not be placed into a register here */
__GLOBALS_DO(&aBlock, &work COMMA_CON);
%}
!
keysAndValuesDo:aBlock
"evaluate the two-arg block, aBlock for all keys and values"
self keysDo:[:aKey |
aBlock value:aKey value:(self at:aKey)
]
!
keysDo:aBlock
"evaluate the argument, aBlock for all keys in the Smalltalk dictionary"
|work|
%{ /* NOREGISTER - work may not be placed into a register here */
__GLOBALKEYS_DO(&aBlock, &work COMMA_CON);
%}
! !
!Smalltalk class methodsFor:'inspecting'!
inspectorClass
"{ Pragma: +optSpace }"
"redefined to launch a DictionaryInspector
(instead of the default Inspector)."
^ DictionaryInspectorView
! !
!Smalltalk class methodsFor:'message control'!
silentLoading
"returns the Silentloading class variable."
^ SilentLoading
!
silentLoading:aBoolean
"{ Pragma: +optSpace }"
"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
! !
!Smalltalk class methodsFor:'misc stuff'!
addExitBlock:aBlock
"{ Pragma: +optSpace }"
"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
"{ Pragma: +optSpace }"
"finish Smalltalk system"
ObjectMemory changed:#aboutToQuit. "/ for ST-80 compatibility
ExitBlocks notNil ifTrue:[
ExitBlocks do:[:aBlock |
aBlock value
]
].
OperatingSystem exit
"
Smalltalk exit
"
!
sleep:aDelay
"{ Pragma: +optSpace }"
"wait for aDelay seconds.
OBSOLETE: this is historical leftover and will be removed"
OperatingSystem sleep:aDelay
! !
!Smalltalk class methodsFor:'queries'!
allClasses
"return an unordered collection of all classes in the system.
Only globally anchored classes are returned
(i.e. anonymous ones have to be aquired by Behavior allSubInstances)"
|classes|
"/ you may wonder, what this while is for, here ...
"/ the reason is that if we modify the class hierarchy in
"/ anothe view (background fileIn), while building up the
"/ cachedClasses set, this may be flushed (invalidated) by the
"/ other process in the meanwhile.
"/ If that happens, we restart the set-building here
"/
[(classes := CachedClasses) isNil] whileTrue:[
CachedClasses := classes := IdentitySet new:800.
self do:[:anObject |
anObject notNil ifTrue:[
anObject isBehavior ifTrue:[
classes add:anObject
]
]
]
].
^ classes
"
Smalltalk allClasses
to get the list sorted by name:
Smalltalk allClasses asSortedCollection:[:a :b | a name < b name]
"
"Modified: 13.12.1995 / 14:52:50 / cg"
!
cellAt:aName
"{ Pragma: +optSpace }"
"return the address of a global cell
- used internally for compiler only"
%{ /* NOCONTEXT */
RETURN ( __GLOBAL_GETCELL(aName) );
%}
!
classNamed:aString
"return the class with name aString, or nil if absent.
To get to the metaClass, append 'class' to the string."
|cls sym meta|
"be careful, to not invent new symbols ..."
sym := aString asSymbolIfInterned.
sym notNil ifTrue:[
cls := self at:sym ifAbsent:[].
cls isBehavior ifTrue:[^ cls]
].
(aString endsWith:'class') ifTrue:[
meta := self classNamed:(aString copyWithoutLast:5).
meta notNil ifTrue:[
^ meta class
].
].
^ nil
"
Smalltalk classNamed:'Object'
Smalltalk classNamed:'fooBar'
Smalltalk classNamed:'true'
Smalltalk classNamed:'Objectclass'
Smalltalk classNamed:'Metaclass'
Smalltalk classNamed:'Array'
Smalltalk classNamed:'Arrayclass'
"
"Created: 24.11.1995 / 17:30:22 / cg"
"Modified: 24.11.1995 / 17:31:29 / cg"
!
classNames
"return a collection of all classNames in the system"
^ self allClasses collect:[:aClass | aClass name]
"
Smalltalk classNames
"
!
classnameCompletion:aPartialClassName
"given a partial classname, return an array consisting of
2 entries: 1st: collection consisting of matching names
2nd: the best (longest) match"
|searchName matches best isMatchString|
searchName := aPartialClassName.
(searchName at:1) isLowercase ifTrue:[
searchName := searchName copy asUppercaseFirst
].
isMatchString := searchName includesMatchCharacters.
matches := SortedCollection new.
self allClassesDo:[:aClass |
|className addIt|
className := aClass name.
aClass isMeta ifFalse:[
isMatchString ifTrue:[
addIt := searchName match:className
] ifFalse:[
addIt := className startsWith:searchName
].
addIt ifTrue:[
matches add:aClass name
]
]
].
matches isEmpty ifTrue:[
^ Array with:searchName with:(Array with:searchName)
].
matches size == 1 ifTrue:[
^ Array with:matches first with:(matches asArray)
].
isMatchString ifTrue:[
best := searchName.
] ifFalse:[
best := matches longestCommonPrefix.
].
^ Array with:best with:matches asArray
"
Smalltalk classnameCompletion:'Arr'
Smalltalk classnameCompletion:'Arra'
Smalltalk classnameCompletion:'arra'
Smalltalk classnameCompletion:'*rray'
"
"Created: 24.11.1995 / 17:24:45 / cg"
!
includes:something
"this should come from Collection.
will change the inheritance - Smalltalk is actually a collection"
self do:[:element | element = something ifTrue:[^ true]].
^ false
!
numberOfGlobals
"return the number of global variables in the system"
|tally "{ Class: SmallInteger }" |
tally := 0.
self do:[:obj | tally := tally + 1].
^ tally
"Smalltalk numberOfGlobals"
!
references:anObject
"redefined, since the references are only kept in the VM's symbol table"
self keysAndValuesDo:[:key :val |
(key == anObject) ifTrue:[^ true].
(val == anObject ) ifTrue:[^ true].
].
^ super references:anObject
!
referencesDerivedInstanceOf:aClass
"redefined, since the references are only kept in the VM's symbol table"
self keysAndValuesDo:[:key :val |
(key isKindOf:aClass) ifTrue:[^ true].
(val isKindOf:aClass) ifTrue:[^ true].
].
^ super referencesDerivedInstanceOf:aClass
!
referencesInstanceOf:aClass
"redefined, since the references are only kept in the VM's symbol table"
self keysAndValuesDo:[:key :val |
(key isMemberOf:aClass) ifTrue:[^ true].
(val isMemberOf:aClass) ifTrue:[^ true].
].
^ super referencesInstanceOf:aClass
!
selectorCompletion:aPartialSymbolName
"given a partial selector, return an array consisting of
2 entries: 1st: collection consisting of matching implemented selectors
2nd: the longest match"
|matches best|
matches := IdentitySet new.
self allClassesDo:[:aClass |
aClass selectorArray do:[:aSelector |
(aSelector startsWith:aPartialSymbolName) ifTrue:[
matches add:aSelector
]
].
aClass class selectorArray do:[:aSelector |
(aSelector startsWith:aPartialSymbolName) ifTrue:[
matches add:aSelector
]
]
].
matches := matches asSortedCollection.
matches isEmpty ifTrue:[
^ Array with:aPartialSymbolName with:(Array with:aPartialSymbolName)
].
matches size == 1 ifTrue:[
^ Array with:matches first with:(matches asArray)
].
best := matches longestCommonPrefix.
^ Array with:best with:matches asArray
"
Smalltalk selectorCompletion:'at:p'
Smalltalk selectorCompletion:'nextP'
"
! !
!Smalltalk class methodsFor:'startup'!
readEvalPrint
"{ Pragma: +optSpace }"
"simple read-eval-print loop for non-graphical Minitalk"
|text|
'ST- ' print.
Stdin skipSeparators.
Stdin atEnd ifFalse:[
text := Stdin nextChunk.
[text notNil] whileTrue:[
(Compiler evaluate:text) printNL.
'ST- ' print.
text := Stdin nextChunk
].
].
'' printNL
!
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.
(Notice that positionable fileStreams are already reopened and repositioned)
"
|deb insp imageName|
Initializing := true.
ImageRestartTime := AbsoluteTime now.
"
invalidate the display connection.
This is required to avoid trouble if someone accesses
the Display during early startup
"
Display notNil ifTrue:[
Display invalidateConnection
].
"
start catching SIGSEGV and SIGBUS
"
OperatingSystem enableHardSignalInterrupts.
"
flush cached path directories (may have changed in the meanwhile)
"
self flushPathCaches.
"
reinit the default streams: Stdin, Stdout and Stderr
"
self reinitStandardStreams.
"temporary switch back to dumb interface -
to handle errors while view-stuff is not yet reinitialized"
insp := Inspector.
deb := Debugger.
deb notNil ifTrue:[
deb reinitialize
].
Inspector := MiniInspector.
Debugger := MiniDebugger.
"
reinitialize the Processor
"
Processor reinitialize.
ObjectFileLoader notNil ifTrue:[
ObjectFileLoader reloadAllRememberedObjectFiles.
].
"
flush device handles & recreate OS resources (if possible)
(mostly view/GC/color & font stuff)
"
ObjectMemory changed:#earlyRestart.
ObjectMemory changed:#restarted.
"
some class must be reinitialized before all others ...
- sorry, but order is important
"
Workstation notNil ifTrue:[
Workstation reinitialize.
].
"
start catching SIGINT and SIGQUIT
"
OperatingSystem enableUserInterrupts.
ObjectMemory changed:#returnFromSnapshot.
"now, display and view-stuff works;
back to the previous debugging interface
"
Inspector := insp.
Debugger := deb.
Initializing := false.
"
if there is no Transcript, go to stderr
"
Transcript isNil ifTrue:[
Transcript := Stderr
].
(SilentLoading == true) ifFalse:[
Transcript cr.
Transcript showCr:('Smalltalk restarted from:'
, ObjectMemory imageName
, ' (saved '
, ObjectMemory imageSaveTime printString
, ')' ).
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
reading if smalltalk_r.rc may be suppressed by the
-fastStart argument.
"
(CommandLineArguments includes:'-faststart') ifFalse:[
Class withoutUpdatingChangesDo:[
(self fileIn:(self commandName , '_r.rc')) ifFalse:[
"no _r.rc file where executable is; try default smalltalk_r.rc"
self fileIn:'smalltalk_r.rc'
].
]
].
"
if there is a display, start its event dispatcher
"
Display notNil ifTrue:[
Display startDispatch.
].
"
this allows firing an application by defining
these two globals during snapshot ... or in main
"
(StartupClass notNil and:[StartupSelector notNil]) ifTrue:[
"
allow more customization by reading an image specific rc-file
"
imageName := ObjectMemory imageName.
imageName notNil ifTrue:[
(imageName endsWith:'.img') ifTrue:[
imageName := imageName copyWithoutLast:4
].
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:[
StandAlone ifFalse:[
self readEvalPrint
]
].
self exit
"Modified: 8.3.1996 / 23:36:24 / cg"
!
start
"main startup, if there is a Display, initialize it
and start dispatching; otherwise go into a read-eval-print loop."
|idx graphicalMode|
graphicalMode := true.
Initializing := true.
"/
"/ turn off info messages in standAlone app
"/
StandAlone ifTrue:[
InfoPrinting := false.
ObjectMemory infoPrinting:false.
].
"
while reading patches- and rc-file, do not add things into change-file
"
Class withoutUpdatingChangesDo:[
|myName defaultRC|
StandAlone ifFalse:[
"/ look for a '-e filename' argument - this will force evaluation of
"/ filename only, no standard startup
idx := CommandLineArguments indexOf:'-e'.
idx ~~ 0 ifTrue:[
self fileIn:(CommandLineArguments at:idx + 1).
self exit
].
].
"/ if there is a <command>.pch, that patches file is read.
"/ otherwise, look for a patches file.
"/ BUT: the patches file is not read in StandAlone operation
myName := self commandName.
(self secureFileIn:(myName , '.pch')) ifFalse:[
StandAlone ifFalse:[
self secureFileIn:'patches'.
].
].
"/ then look for <command>.rc
"/ if not found, read smalltalk.rc (or stxapp.rc for standAlone operation)
(self secureFileIn:(myName , '.rc')) ifFalse:[
StandAlone ifFalse:[
defaultRC := 'smalltalk.rc'
] ifTrue:[
defaultRC := 'stxapp.rc'
].
"/ no .rc file where executable is; try default smalltalk.rc (or stxapp.rc)
(self secureFileIn:defaultRC) ifFalse:[
StandAlone ifFalse:[
Transcript showCr:'SMALLTALK: no startup rc-file found. Going into line-by-line interpreter.'.
graphicalMode := false.
]
]
].
].
(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.
].
].
StandAlone ifTrue:[
Debugger := Inspector := nil
] ifFalse:[
"
enable the graphical debugger/inspector
(they could have been (re)defined as autoloaded in the patches file)
"
self initStandardTools.
].
"
if there is a display, start its event dispatcher
"
Display notNil ifTrue:[
Display startDispatch.
].
Initializing := false.
(StartupClass notNil and:[StartupSelector notNil]) ifTrue:[
Display notNil ifTrue:[
Display class exitOnLastClose:true.
].
Processor exitWhenNoMoreUserProcesses:true.
StartupClass perform:StartupSelector withArguments:StartupArguments.
].
"
if view-classes exist, start dispatching;
otherwise go into a read-eval-print loop
"
(Display notNil and:[graphicalMode]) ifTrue:[
Processor dispatchLoop.
] ifFalse:[
StandAlone ifFalse:[
self readEvalPrint
]
].
"done - the last process finished"
self exit
! !
!Smalltalk class methodsFor:'startup queries'!
commandLineArguments
"return the command line arguments (with which ST/X was started)"
^ CommandLineArguments
!
commandName
"return the excutables name - this is normally 'smalltalk', but
can be something else for standAlone apps"
^ CommandLineArguments at:1.
!
isStandAloneApp
"return true, if this is a standAlone application
(in contrast to a full smalltalk system)."
^ StandAlone
!
startupArguments
"return the arguments passed to StartupClass"
^ StartupArguments
!
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
!
startupClass:aClass selector:aSymbol arguments:anArrayOrNil
"{ Pragma: +optSpace }"
"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
!
startupSelector
"return the selector, that will be sent to StartupClass"
^ StartupSelector
! !
!Smalltalk class methodsFor:'system environment'!
language
"return the language setting"
^ Language
!
languageTerritory
"return the language territory setting"
^ LanguageTerritory
! !
!Smalltalk class methodsFor:'system management'!
bitmapFileStreamFor:aFileName
"search aFileName in some standard places;
return a readonly fileStream or nil if not found.
Searches in subdirectories named 'bitmaps' in SystemPath"
|aString|
aString := self getBitmapFileName:aFileName.
aString notNil ifTrue:[
^ FileStream readonlyFileNamed:aString
].
^ nil
!
classNameForFile:aFileName
"return the className which corresponds to an abbreviated fileName,
or nil if no special translation applies. The given filename arg may
include a '.st' suffix (but no other)."
|fn|
(aFileName endsWith:'.st') ifTrue:[
fn := aFileName copyWithoutLast:3
] ifFalse:[
fn := aFileName
].
^ self filenameAbbreviations keyAtEqualValue:fn ifAbsent:[fn].
"
Smalltalk classNameForFile:'DrawObj'
Smalltalk classNameForFile:'DrawObj.st'
Smalltalk classNameForFile:'ArrColl.st'
Smalltalk classNameForFile:'ArrColl.chg'
"
"Modified: 11.12.1995 / 14:51:10 / cg"
!
compressSources
"{ Pragma: +optSpace }"
"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 allSubInstancesDo:[: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
"
!
constructPathFor:aDirectoryName
"search for aDirectory in SystemPath"
^ self realSystemPath select:[:dirName |
OperatingSystem isDirectory:(dirName , '/' , aDirectoryName)
].
!
fileIn:aFileName
"read in the named file - look for it in some standard places;
return true if ok, false if failed"
^ self fileIn:aFileName lazy:nil silent:nil logged:false
"
Smalltalk fileIn:'source/TicTacToe.st'
"
"Created: 28.10.1995 / 17:06:28 / cg"
!
fileIn:aFileName lazy:lazy
"read in the named file - look for it in some standard places;
return true if ok, false if failed.
If lazy is true, no code is generated for methods, instead stubs
are created which compile themself when first executed. This allows
for much faster fileIn (but slows down the first execution later).
Since no syntax checks are done when doing lazy fileIn, use this only for
code which is known to be syntactically correct."
^ self fileIn:aFileName lazy:lazy silent:nil logged:false
"
Smalltalk fileIn:'source/TicTacToe.st' lazy:true
"
"Created: 28.10.1995 / 17:06:36 / cg"
!
fileIn:aFileName lazy:lazy silent:silent
"read in the named file - look for it in some standard places;
return true if ok, false if failed.
If lazy is true, no code is generated for methods, instead stubs
are created which compile themself when first executed. This allows
for much faster fileIn (but slows down the first execution later).
Since no syntax checks are done when doing lazy fileIn, use this only for
code which is known to be syntactically correct.
If silent is true, no compiler messages are output to the transcript.
Giving nil for silent/lazy will use the current settings."
^ self fileIn:aFileName lazy:lazy silent:silent logged:false
"Created: 28.10.1995 / 17:06:41 / cg"
!
fileIn:aFileName lazy:lazy silent:silent logged:logged
"read in the named file - look for it in some standard places;
return true if ok, false if failed.
If lazy is true, no code is generated for methods, instead stubs
are created which compile themself when first executed. This allows
for much faster fileIn (but slows down the first execution later).
Since no syntax checks are done when doing lazy fileIn, use this only for
code which is known to be syntactically correct.
If silent is true, no compiler messages are output to the transcript.
Giving nil for silent/lazy will use the current settings."
|aStream path morePath bos|
"
an object or shared object ?
"
(ObjectFileLoader notNil
and:[ObjectFileLoader hasValidBinaryExtension:aFileName]) ifTrue:[
LoadBinaries ifFalse:[^ false].
path := self getBinaryFileName:aFileName.
path isNil ifTrue:[^ false].
^ ObjectFileLoader loadObjectFile:aFileName
].
(aFileName endsWith:'.cls') ifTrue:[
BinaryObjectStorage notNil ifTrue:[
path := self getBinaryFileName:aFileName.
path isNil ifTrue:[^ false].
aStream := path asFilename readStream.
aStream notNil ifTrue:[
bos := BinaryObjectStorage onOld:aStream.
bos next.
bos close.
^ true
].
^ false
]
].
(aFileName startsWith:'source/') ifTrue:[
aStream := self sourceFileStreamFor:(aFileName copyFrom:8)
] ifFalse:[
(aFileName startsWith:'fileIn/') ifTrue:[
aStream := self fileInFileStreamFor:(aFileName copyFrom:8)
] ifFalse:[
aStream := self systemFileStreamFor:aFileName.
(aStream notNil and:[aFileName includes:$/]) ifTrue:[
"/ temporarily prepend the files directory
"/ to the searchPath.
"/ This allows fileIn-driver files to refer to local
"/ files via a relative path, and drivers to fileIn other
"/ drivers ...
morePath := aStream pathName asFilename directoryName.
]
]
].
aStream isNil ifTrue:[^ false].
^ self fileInStream:aStream lazy:lazy silent:silent logged:logged addPath:morePath
"
Smalltalk fileIn:'source/TicTacToe.st' lazy:true silent:true
"
!
fileIn:aFileName logged:logged
"read in the named file - look for it in some standard places;
return true if ok, false if failed.
The argument logged controls, if the changefile is to be updated."
^ self fileIn:aFileName lazy:nil silent:nil logged:logged
"
Smalltalk fileIn:'source/TicTacToe.st' logged:false
"
!
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
(instead of the complete changes file)."
"
do NOT update the changes file now ...
"
self fileIn:'changes' logged:false
"
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."
^ self fileInClass:aClassName initialize:true lazy:false silent:false
!
fileInClass:aClassName fromObject:aFileName
"read in the named object file and dynamic-link it into the system
- look for it in some standard places.
Only install the named class from this object file.
Return true if ok, false if failed."
|path ok|
"
check if the dynamic loader class is in
"
(LoadBinaries not or:[ObjectFileLoader isNil]) ifTrue:[^ false].
(path := self getBinaryFileName:aFileName) isNil ifTrue:[^ false].
ok := (ObjectFileLoader loadClass:aClassName fromObjectFile:path) notNil.
ok ifTrue:[
Transcript show:' loaded ' , aClassName , ' from ' ; showCr:aFileName.
].
^ ok
"
Smalltalk fileInClass:'AbstractPath' fromObject:'../../goodies/Paths/AbstrPath.so'
Smalltalk fileInClass:'ClockView' fromObject:'../../libwidg3/libwidg3.so'
"
!
fileInClass:aClassName initialize:doInit
"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."
^ self fileInClass:aClassName initialize:doInit lazy:false silent:false
!
fileInClass:aClassName initialize:doInit lazy:loadLazy
"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."
^ self fileInClass:aClassName initialize:doInit lazy:loadLazy silent:false
!
fileInClass:aClassName initialize:doInit lazy:loadLazy silent:beSilent
"find a source/object file for aClassName and -if found - load it.
This is the workhorse for autoloading.
Search is in some standard places, trying driver-file (.ld), object-file (.so / .o) and
finally source file (.st), in that order.
The file is first searched for using the class name, then the abbreviated name.
The argument doInit controlls if the class should be sent a #initialize after the
load; loadLazy tells if it should be loaded lazyly. beSilent tells if the compiler
should not send notes to the transcript."
|shortName libName newClass ok wasLazy wasSilent sharedLibExtension inStream mgr|
wasLazy := Compiler compileLazy:loadLazy.
wasSilent := self silentLoading:beSilent.
[
Class withoutUpdatingChangesDo:
[
ok := false.
"
first, look for a loader-driver file (in fileIn/xxx.ld)
"
(ok := self fileIn:('fileIn/' , aClassName , '.ld') lazy:loadLazy silent:beSilent)
ifFalse:[
shortName := self fileNameForClass:aClassName.
"
try abbreviated driver-file (in fileIn/xxx.ld)
"
shortName ~= aClassName ifTrue:[
ok := self fileIn:('fileIn/' , shortName , '.ld') lazy:loadLazy silent:beSilent
].
ok ifFalse:[
"
then, if dynamic linking is available,
"
(LoadBinaries and:[ObjectFileLoader notNil]) ifTrue:[
sharedLibExtension := ObjectFileLoader sharedLibraryExtension.
"
first look for a class packages shared binary in binary/xxx.o
"
libName := self libraryFileNameOfClass:aClassName.
libName notNil ifTrue:[
(ok := self fileInClass:aClassName fromObject:(libName, sharedLibExtension))
ifFalse:[
sharedLibExtension ~= '.o' ifTrue:[
ok := self fileInClass:aClassName fromObject:(libName, '.o')
]
].
].
"
then, look for a shared binary in binary/xxx.o
"
ok ifFalse:[
(ok := self fileInClass:aClassName fromObject:(aClassName, sharedLibExtension))
ifFalse:[
sharedLibExtension ~= '.o' ifTrue:[
ok := self fileInClass:aClassName fromObject:(aClassName, '.o')
].
ok ifFalse:[
shortName ~= aClassName ifTrue:[
(ok := self fileInClass:aClassName fromObject:(shortName, sharedLibExtension))
ifFalse:[
sharedLibExtension ~= '.o' ifTrue:[
ok := self fileInClass:aClassName fromObject:(shortName, '.o')
]
]
].
].
].
].
].
"
if that did not work, look for a compiled-bytecode file ...
"
ok ifFalse:[
(ok := self fileIn:(aClassName , '.cls') lazy:loadLazy silent:beSilent)
ifFalse:[
shortName ~= aClassName ifTrue:[
ok := self fileIn:(shortName , '.cls') lazy:loadLazy silent:beSilent
]
]
].
"
if that did not work, look for an st-source file ...
"
ok ifFalse:[
(ok := self fileIn:(aClassName , '.st') lazy:loadLazy silent:beSilent)
ifFalse:[
shortName ~= aClassName ifTrue:[
ok := self fileIn:(shortName , '.st') lazy:loadLazy silent:beSilent
].
ok ifFalse:[
"
... and in the standard source-directory
"
(ok := self fileIn:('source/' , aClassName , '.st') lazy:loadLazy silent:beSilent)
ifFalse:[
shortName ~= aClassName ifTrue:[
ok := self fileIn:('source/' , shortName , '.st') lazy:loadLazy silent:beSilent
]
]
]
].
ok ifFalse:[
"
new: if there is a sourceCodeManager, ask it for the classes sourceCode
"
(mgr := Smalltalk at:#SourceCodeManager) notNil ifTrue:[
inStream := mgr mostRecentSourceStreamForClassNamed:aClassName.
inStream notNil ifTrue:[
ok := self fileInStream:inStream lazy:loadLazy silent:beSilent logged:false addPath:nil.
]
].
].
].
].
]
].
ok ifTrue:[
newClass := self at:(aClassName asSymbol).
newClass notNil ifTrue:[
doInit ifTrue:[
newClass initialize
]
]
].
] valueNowOrOnUnwindDo:[
Compiler compileLazy:wasLazy.
self silentLoading:wasSilent
].
^ newClass
"Modified: 6.11.1995 / 15:36:02 / cg"
!
fileInClassLibrary:aClassLibraryName
"find an object file containing a binary class library in some standard places
and load it. This install all of its contained classes.
Return true if ok, false if not."
ObjectFileLoader isNil ifTrue:[^ false].
^ ObjectFileLoader loadObjectFile:(aClassLibraryName , (ObjectFileLoader sharedLibraryExtension))
"
Smalltalk fileInClassLibrary:'libtable'
Smalltalk fileInClassLibrary:'binary/libwidg3'
"
!
fileInFileStreamFor:aFileName
"search aFileName in some standard places;
return a readonly fileStream or nil if not found.
Searches in subdirectories named 'fileIn' in SystemPath"
|aString|
aString := self getFileInFileName:aFileName.
aString notNil ifTrue:[
^ FileStream readonlyFileNamed:aString
].
^ nil
!
fileInStream:aStream lazy:lazy silent:silent logged:logged addPath:morePath
"read sourceCode from aStream;
return true if ok, false if failed.
If lazy is true, no code is generated for methods, instead stubs
are created which compile themself when first executed. This allows
for much faster fileIn (but slows down the first execution later).
Since no syntax checks are done when doing lazy fileIn, use this only for
code which is known to be syntactically correct.
If silent is true, no compiler messages are output to the transcript.
Giving nil for silent/lazy will use the current settings.
If morePath is nonNil, it is prepended to the systemPath temporarily during the
fileIn. This allows for st-expressions to refer to more files (i.e. fileIn more)
using a relative path."
|wasLazy wasSilent oldSystemPath oldRealPath|
aStream isNil ifTrue:[^ false].
lazy notNil ifTrue:[wasLazy := Compiler compileLazy:lazy].
silent notNil ifTrue:[wasSilent := self silentLoading:silent].
[
Class updateChangeFileQuerySignal handle:[:ex |
ex proceedWith:logged
] do:[
oldSystemPath := SystemPath copy.
morePath notNil ifTrue:[
SystemPath addFirst:morePath.
oldRealPath := RealSystemPath.
RealSystemPath := nil.
].
aStream fileIn
]
] valueNowOrOnUnwindDo:[
morePath notNil ifTrue:[
SystemPath := oldSystemPath.
RealSystemPath := oldRealPath.
].
lazy notNil ifTrue:[Compiler compileLazy:wasLazy].
silent notNil ifTrue:[self silentLoading:wasSilent].
aStream close
].
^ true
"
Smalltalk fileInStream:('source/TicTacToe.st' asFilename readStream) lazy:true silent:true
"
!
fileNameForClass:aClassOrClassName
"return a good filename for aClassOrClassName -
using the abbreviation file if there is one"
|fileName abbrev aClassName|
aClassOrClassName isBehavior ifTrue:[
aClassOrClassName isMeta ifTrue:[
aClassName := aClassOrClassName soleInstance name
] ifFalse:[
aClassName := aClassOrClassName name
]
] ifFalse:[
aClassName := aClassOrClassName
].
fileName := aClassName asSymbol.
"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/DOS type systems"
self warn:'cant find short for ' , fileName , ' in abbreviation file'
].
^ fileName asString
"
Smalltalk fileNameForClass:SmallInteger
Smalltalk fileNameForClass:'SmallInteger'
Smalltalk fileNameForClass:'OperatingSystem'
Smalltalk fileNameForClass:'SomeUnknownClass'
"
"Modified: 6.11.1995 / 15:37:33 / cg"
!
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
"
!
flushPathCaches
"{ Pragma: +optSpace }"
RealSystemPath := ResourcePath := SourcePath := BitmapPath := BinaryPath := FileInPath := nil
!
getBinaryFileName:aFileName
"search aFileName in some standard places
(subdirectories named 'binary' in SystemPath);
return the absolute filename or nil if none is found."
(aFileName startsWith:'/') ifTrue:[
"dont use path for absolute file names"
^ aFileName
].
BinaryPath isNil ifTrue:[
BinaryPath := self constructPathFor:'binary'
].
^ self searchPath:BinaryPath for:aFileName in:'binary'
!
getBitmapFileName:aFileName
"search aFileName in some standard places
(subdirectories named 'bitmaps' in SystemPath);
return the absolute filename or nil if none is found."
(aFileName startsWith:'/') ifTrue:[
"dont use path for absolute file names"
^ aFileName
].
BitmapPath isNil ifTrue:[
BitmapPath := self constructPathFor:'bitmaps'
].
^ self searchPath:BitmapPath for:aFileName in:'bitmaps'
"
Smalltalk getBitmapFileName:'SBrowser.xbm'
"
!
getFileInFileName:aFileName
"search aFileName in some standard places
(subdirectories named 'fileIn' in SystemPath);
return the absolute filename or nil if none is found."
(aFileName startsWith:'/') ifTrue:[
"dont use path for absolute file names"
^ aFileName
].
FileInPath isNil ifTrue:[
FileInPath := self constructPathFor:'fileIn'
].
^ self searchPath:FileInPath for:aFileName in:'fileIn'
!
getResourceFileName:aFileName
"search aFileName in some standard places
(subdirectories named 'resource' in SystemPath);
return the absolute filename or nil if none is found."
(aFileName startsWith:'/') ifTrue:[
"dont use path for absolute file names"
^ aFileName
].
ResourcePath isNil ifTrue:[
ResourcePath := self constructPathFor:'resources'
].
^ self searchPath:ResourcePath for:aFileName in:'resources'
"
Smalltalk getResourceFileName:'SBrowser.rs'
"
!
getSourceFileName:aFileName
"search aFileName in some standard places
(subdirectories named 'source' in SystemPath);
return the absolute filename or nil if none is found.
This is used to find a sourceFile for a methods source,
if no sourceCodeManager is available."
(aFileName startsWith:'/') ifTrue:[
"dont use path for absolute file names"
^ aFileName
].
SourcePath isNil ifTrue:[
SourcePath := self constructPathFor:'source'
].
^ self searchPath:SourcePath for:aFileName in:'source'
"
Smalltalk getSourceFileName:'Smalltalk.st'
Smalltalk getSourceFileName:'ArrColl.st'
"
!
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 ...."
(aFileName startsWith:'/') ifTrue:[
"dont use path for absolute file names"
^ aFileName
].
self realSystemPath do:[:dirName |
|realName|
realName := dirName , '/' , aFileName.
(OperatingSystem isReadable:realName) ifTrue: [
^ realName
]
].
^ nil
!
libraryFileNameOfClass:aClassOrClassName
"for a given class, return the name of a classLibrary which contains
binary code for it.
Read the libinfo file 'liblist.stc' (which is created during the compilation process)
for an entry for aClassOrClassName.
Search for the className in the first col, and return the value found in
the 2nd col.
Return nil if no entry is found.
A nil returns means that this class is either built-in or not present
in a package-class library (i.e. either as separate .o or separate .st file).
Otherwise, the returned name is the classLibrary object of that class.
The classes code can be loaded from that file if binary loading is supported."
|aStream line words n aClassName|
aClassOrClassName isBehavior ifTrue:[
aClassName := aClassOrClassName name
] ifFalse:[
aClassName := aClassOrClassName
].
aClassName := aClassName asString.
#('include/liblist.stc') "/ filenames
with:#(2) "/ column
do:[:fileName :col |
aStream := self systemFileStreamFor:fileName.
aStream notNil ifTrue:[
[aStream atEnd] whileFalse:[
line := aStream nextLine.
line notNil ifTrue:[
(line startsWith:'#') ifFalse:[
words := line asCollectionOfWords.
(n := words size) > 1 ifTrue:[
(words at:1) = aClassName ifTrue:[
n >= col ifTrue:[
^ (words at:col) withoutSeparators
]
]
]
]
]
].
aStream close
].
].
^ nil
"
Smalltalk libraryFileNameOfClass:'ClockView'
Smalltalk libraryFileNameOfClass:'Bag'
"
"Modified: 6.11.1995 / 15:41:39 / cg"
!
loadBinaries
"return true, if binaries should be loaded into the system,
false if this should be suppressed. The default is false (for now)."
^ LoadBinaries
!
loadBinaries:aBoolean
"{ Pragma: +optSpace }"
"turn on/off loading of binary objects"
aBoolean ifTrue:[
(ObjectFileLoader notNil and:[ObjectFileLoader canLoadObjectFiles]) ifTrue:[
LoadBinaries := true.
^ self
].
'SMALLTALK: this system does not support binary loading' infoPrintNL.
].
LoadBinaries := false
!
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
"{ Pragma: +optSpace }"
"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
!
readAbbreviations
"read classname to filename mappings from include/abbrev.stc.
sigh - all for those poor sys5.3 or MSDOS people with short filenames ..."
|abbrevs aStream line words nm abbrev key oldAbbrev cls|
CachedAbbreviations := abbrevs := IdentityDictionary new.
aStream := self systemFileStreamFor:'include/abbrev.stc'.
aStream notNil ifTrue:[
[aStream atEnd] whileFalse:[
line := aStream nextLine.
line notNil ifTrue:[
(line startsWith:'#') ifFalse:[
words := line asCollectionOfWords.
words size >= 2 ifTrue:[
nm := (words at:1) withoutSeparators.
abbrev := (words at:2) withoutSeparators.
nm ~= abbrev ifTrue:[
key := nm asSymbol.
oldAbbrev := abbrevs at:key ifAbsent:nil.
oldAbbrev notNil ifTrue:[
oldAbbrev ~= abbrev ifTrue:[
StandAlone ifFalse:[
('SMALLTALK: conflict for: ' , nm , ' in abbrev.stc (' , oldAbbrev , ' <-> ' , abbrev , ')') errorPrintNL
]
].
] ifFalse:[
cls := self classNamed:abbrev.
cls notNil ifTrue:[
cls name ~= nm ifTrue:[
StandAlone ifFalse:[
('SMALLTALK: conflict for: ' , cls name , ' in abbrev.stc (' , nm , ' -> ' , abbrev , ')') errorPrintNL
]
]
].
abbrevs at:nm asSymbol put:abbrev.
]
]
]
]
]
].
aStream close
].
^ abbrevs
"
Smalltalk readAbbreviations
"
"Modified: 30.3.1996 / 15:08:22 / cg"
!
realSystemPath
"return the realSystemPath - thats the directorynames from
SystemPath which exist and are readable"
RealSystemPath isNil ifTrue:[
RealSystemPath := SystemPath select:[:dirName |
(OperatingSystem isDirectory:dirName)
and:[OperatingSystem isReadable:dirName]
].
].
^ RealSystemPath
!
resourceFileStreamFor:aFileName
"search aFileName in some standard places;
return a readonly fileStream or nil if not found.
Searches in subdirectories named 'resource' in SystemPath"
|aString|
aString := self getResourceFileName:aFileName.
aString notNil ifTrue:[
^ FileStream readonlyFileNamed:aString
].
^ nil
!
searchPath:aPath for:aFileName in:aDirName
"search aPath for a subdirectory named aDirectory with a file
named aFileName"
aPath do:[:dirName |
|realName|
(OperatingSystem isReadable:(realName := dirName , '/' , aDirName , '/' , aFileName)) ifTrue: [
^ realName
]
].
^ nil
!
secureFileIn:aFileName
"read in the named file, looking for it at standard places.
Catch any error during fileIn. Return true if ok, false if failed"
|retVal|
retVal := false.
(SignalSet with:AbortSignal with:Process terminateSignal)
handle:[:ex |
ex return
] do:[
retVal := self fileIn:aFileName
].
^ retVal
!
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
]
!
sourceDirectoryNameOfClass:aClassOrClassName
"for a given class, return the pathname relative to TOP of the classes source code.
Read the files 'abbrev.stc' and 'liblist.stc' (which are created during the compilation process)
for an entry for aClassOrClassName.
Search for the className in the first col, and return the value found in
the 3rd col.
Return nil if no entry is found."
|aStream line words n aClassName|
aClassOrClassName isBehavior ifTrue:[
aClassName := aClassOrClassName name
] ifFalse:[
aClassName := aClassOrClassName
].
aClassName := aClassName asString.
#('include/abbrev.stc' 'include/liblist.stc') "/ filenames
with:#(3 2) "/ column
do:[:fileName :col |
aStream := self systemFileStreamFor:fileName.
aStream notNil ifTrue:[
[aStream atEnd] whileFalse:[
line := aStream nextLine.
line notNil ifTrue:[
(line startsWith:'#') ifFalse:[
words := line asCollectionOfWords.
(n := words size) > 1 ifTrue:[
(words at:1) = aClassName ifTrue:[
n >= col ifTrue:[
^ (words at:col) withoutSeparators
]
]
]
]
]
].
aStream close
].
].
^ nil
"
Smalltalk sourceDirectoryNameOfClass:'ClockView'
Smalltalk sourceDirectoryNameOfClass:'Bag'
Smalltalk sourceDirectoryNameOfClass:'GLWireCubeDemoView'
Smalltalk sourceDirectoryNameOfClass:'SomeNonExistingClass'
"
"Created: 6.11.1995 / 15:43:30 / cg"
"Modified: 9.12.1995 / 23:54:14 / cg"
!
sourceFileStreamFor:aFileName
"search aFileName in some standard places;
return a readonly fileStream or nil if not found.
Searches in subdirectories named 'source' in SystemPath"
|aString|
aString := self getSourceFileName:aFileName.
aString notNil ifTrue:[
^ FileStream readonlyFileNamed:aString
].
^ 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
!
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'
"
!
systemPath:aPath
"set the collection of directorynames, where smalltalk
looks for system files
(usually in subdirs such as resources, bitmaps, source etc.)
see comment in Smalltalk>>initSystemPath."
SystemPath := aPath.
self flushPathCaches
"
Smalltalk systemPath
Smalltalk systemPath:(Smalltalk systemPath copy addLast:'someOtherDirectoryPath')
"
! !
!Smalltalk class methodsFor:'time-versions'!
configuration
"{ Pragma: +optSpace }"
"for developers only: return the configuration, with which
this smalltalk was compiled."
%{ /* NOCONTEXT */
extern char *__getConfigurationString();
RETURN (__MKSTRING(__getConfigurationString() COMMA_SND));
%}
"
Smalltalk configuration
"
!
copyrightString
"{ Pragma: +optSpace }"
"return a copyright string"
%{ /* NOCONTEXT */
#ifndef __getCopyrightString
extern OBJ __getCopyrightString();
#endif
RETURN (__getCopyrightString());
%}
"
Smalltalk copyrightString
"
!
distributorString
"{ Pragma: +optSpace }"
"return a string describing the distributor of this software"
%{ /* NOCONTEXT */
#ifndef __getDistributorString
extern OBJ __getDistributorString();
#endif
RETURN (__getDistributorString());
%}
"
Smalltalk distributorString
"
!
hello
"{ Pragma: +optSpace }"
"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 ` SmallTalk/X - version '
, self versionString , ' de ' , self versionDate
].
^ 'Hello World - here is SmallTalk/X version '
, self versionString , ' of ' , self versionDate
"
Smalltalk hello
"
!
imageRestartTime
"return a timestamp for the moment when this image was restarted.
If we do not execute from an image (i.e. fresh start), return nil."
^ ImageRestartTime
"
Smalltalk imageStartTime
Smalltalk imageRestartTime
"
"Created: 13.12.1995 / 17:44:20 / cg"
"Modified: 6.3.1996 / 11:56:35 / cg"
!
imageSaveTime
"return a timestamp for the moment when this image was saved"
^ ObjectMemory imageSaveTime
!
imageStartTime
"return a timestamp for the moment when this system started the first time
(i.e. the first initial start without an image)"
^ ImageStartTime
"
Smalltalk imageStartTime
Smalltalk imageRestartTime
"
"Created: 13.12.1995 / 17:44:14 / cg"
"Modified: 13.12.1995 / 17:45:47 / cg"
!
majorVersionNr
"{ Pragma: +optSpace }"
"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 majorVersionNr
"
!
minorVersionNr
"{ Pragma: +optSpace }"
"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 minorVersionNr
"
!
releaseNr
"{ Pragma: +optSpace }"
"return the revision number.
Incremented for releases which fix bugs/add features but did not find
their way to the outside world."
^ 5
"
Smalltalk releaseNr
"
"Created: 10.12.1995 / 01:42:19 / cg"
!
revisionNr
"{ Pragma: +optSpace }"
"return the revision number.
Incremented for releases which fix bugs/add features
and represent a stable workable version which got published
to the outside world."
^ 9
"
Smalltalk revisionNr
"
!
timeStamp
"return a string useful for timestamping a file.
The returned string is padded with spaces for a constant
length (to avoid changing a files size in fileOut with unchanged
class)."
^ ('''From Smalltalk/X, Version:' , (Smalltalk versionString) , ' on '
, Date today printString , ' at ' , Time now printString
, '''') paddedTo:80 with:(Character space)
!
versionDate
"{ Pragma: +optSpace }"
"return the executables build date - thats the date when the smalltalk
executable was built"
%{ /* NOCONTEXT */
extern char *__getBuildDateString();
RETURN (__MKSTRING(__getBuildDateString() COMMA_SND) );
%}
"
Smalltalk versionDate
"
!
versionString
"{ Pragma: +optSpace }"
"return the version string"
^ (self majorVersionNr printString ,
'.',
self minorVersionNr printString ,
'.',
self revisionNr printString)
"
Smalltalk versionString
"
! !
!Smalltalk class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libbasic/Smalltalk.st,v 1.136 1996-04-25 16:02:18 cg Exp $'
! !