"
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.
"
'From Smalltalk/X, Version:5.1.4 on 18-nov-2003 at 02:55:04 pm' !
"{ Package: 'stx:libbasic' }"
Object subclass:#Smalltalk
instanceVariableNames:''
classVariableNames:'StartBlocks ImageStartBlocks ExitBlocks CachedClasses SystemPath
StartupClass StartupSelector StartupArguments CommandLine
CommandName CommandLineArguments CachedAbbreviations
SilentLoading Initializing StandAlone HeadlessOperation
DebuggingStandAlone LogDoits LoadBinaries RealSystemPath
ResourcePath SourcePath BitmapPath BinaryPath FileInPath
PackagePath BinaryDirName ResourceDirName SourceDirName
BitmapDirName PackageDirName FileInDirName ChangeFileName
ImageStartTime ImageRestartTime DemoMode SaveEmergencyImage
SpecialObjectArray CallbackSignal KnownPackages
ClassesFailedToInitialize'
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,
I do not use associations for globals, but instead keep the
name<->value relations in the VM and access globals via utility
functions found there.
However, it provides the known enumeration protocol.
It may change to become a subclass of collection at some time,
to inherit more collection stuff ...
[Instance variables:]
none - all handling is done in the VM
[Class variables:]
StartBlocks <Collection> blocks to be executed in a separate process after
everything has been initialized. These blocks will
be deleted after execution and therefore not be
executed after an image restart. Initial processes
(such as the Launcher) are usually started here.
These blocks are added by smalltalk.rc/private.rc etc.
via #addStartBlock during early initialization.
ImageStartBlocks
<Collection> blocks to be executed in a separate process after
everything has been initialized. These blocks will be
executed after an image restart.
These blocks are usually added by smalltalk_r.rc etc.
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
PackagePath <Collection> path to search for package.
This is going to replace the above systemPath, and a classes
resources will eventually searched in its package directory.
This list defines the path, where packages are searched for,
initially this is something like /opt/smalltalk/packages.
Set to a default here, but typically changed from some
startup.rc file
StartupClass <Class> class and selector, where the system starts up
StartupSelector <Symbol> (right after VM initialization)
StartupArguments <Array> If an image is saved while those being nonNil,
the image will come up there.
Allows for customized images to be generated from a standard ST/X.
StandAlone programs also set those during initialization.
CommandLine <String> Unix (OS-) command line
CommandName <String> the command (i.e. argv[0])
CommandLineArguments <Array> Unix (OS-) command line arguments broken into words
CommandName has been stripped off.
(initially set by the VM)
SilentLoading <Boolean> suppresses messages during fileIn and in compiler
(can be set to true from a customized main.c)
Initializing <Boolean> true while (re-)initializing
Controls the behavior of certain error
reporters (for example: suppress dialogBoxes)
while the system is not yet fit for full operation.
StandAlone <Boolean> true, if this is a standalone app;
if true the process scheduler watches for
which processes are still running, and
exits ST/X, when the last non-background
and non-system process exits.
Can be set in an application-specific startup script,
or, for standAlone programs, by C-code during initialization.
HeadlessOperation if true, a non-existing Display connection
<Boolean> will NOT lead to an error-exit during startup.
Default is false.
Can be set in an application-specific startup script,
or, for standAlone programs, by C-code during initialization.
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.
SaveEmergencyImage <Boolean> if true (the default), an emergency image
is saved, if the main Display looses its
connection. This is useful if you have a
flaky display connection (serial line)
and want to have your stuff saved automatically
in case of a broken connection.
strictly private classVariables (helpers):
CachedClasses <Collection> known classes (cached for faster class enumeration)
CachedAbbreviations
<Dictionary> className to filename mappings
RealSystemPath <Collection> cached collection of directories along the path
which really exist. Caching avoids long checks
for existing directories on broken NFS volumes.
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.
A consequence is that you have to invoke
flushSystemPath, when you create any of those
directories while running
(and want the running ST/X to look there)
[author:]
Claus Gittinger
[see also:]
ObjectMemory
"
! !
!Smalltalk class methodsFor:'initialization'!
initGlobalsFromEnvironment
"setup globals from the shell-environment"
|envString i langString terrString|
StandAlone isNil ifTrue:[
StandAlone := false.
].
HeadlessOperation isNil ifTrue:[
HeadlessOperation := false.
].
"
extract Language and LanguageTerritory from LANG variable.
valid are for example:
en_en / en
en_us
en_gb
de_de / de
de_at (for Austria)
"
Language := #en.
LanguageTerritory := #us.
"Format of LANG is: language[_territory][.codeset][@modifier]
language ISO-639 Language code
territory ISO-3166 Contry code"
envString := OperatingSystem getEnvironment:'LANG'.
envString size > 0 ifTrue:[
i := envString indexOf:$@.
(i ~~ 0) ifTrue:[
envString := envString copyTo:(i - 1).
LanguageModifier := (envString copyFrom:(i + 1)) asLowercase asSymbol.
] ifFalse:[
LanguageModifier := nil.
].
i := envString indexOf:$..
(i ~~ 0) ifTrue:[
envString := envString copyTo:(i - 1).
LanguageCodeset := (envString copyFrom:(i + 1)) asLowercase asSymbol
] ifFalse:[
LanguageCodeset := #'iso8859-1'.
].
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 enableCrashSignalInterrupts.
ObjectMemory userInterruptHandler:self.
ObjectMemory signalInterruptHandler:self.
ObjectMemory recursionInterruptHandler:self.
"
Smalltalk initInterrupts
"
"Modified: 20.8.1997 / 09:35:49 / stefan"
!
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)
$STX_TOPDIR (if defined & existing)
unix:
/opt/smalltalk (if existing)
/opt/smalltalk/release (if existing)
/usr/local/lib/smalltalk (if existing)
/usr/lib/smalltalk (if existing)
/lib/smalltalk (if existing)
win32:
\smalltalk (if existing)
\programs\smalltalk (if existing)
\programs\exept\smalltalk (if existing)
registry info (if present)
vms:
$stx:lib (if existing)
$stx:root (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'.
However, smalltalk.rc itself must be found along the above path.
"
ChangeFileName := 'changes'.
OperatingSystem isVMSlike ifTrue:[
BitmapDirName := 'bitmaps.dir'.
BinaryDirName := 'binary.dir'.
SourceDirName := 'source.dir'.
ResourceDirName := 'resources.dir'.
FileInDirName := 'filein.dir'.
PackageDirName := 'packages.dir'.
] ifFalse:[
BitmapDirName := 'bitmaps'.
BinaryDirName := 'binary'.
SourceDirName := 'source'.
ResourceDirName := 'resources'.
FileInDirName := 'fileIn'.
PackageDirName := 'packages'.
].
SystemPath isNil ifTrue:[
SystemPath := OperatingSystem defaultSystemPath.
self flushPathCaches
].
PackagePath isNil ifTrue:[
PackagePath := OperatingSystem defaultPackagePath.
].
"
Smalltalk initSystemPath
Smalltalk systemPath
"
"Modified: / 24.12.1999 / 00:23:35 / cg"
!
initUserPreferences
"setup other stuff"
LogDoits := false.
LoadBinaries := false.
SaveEmergencyImage := (StandAlone ~~ true).
"Modified: / 24.10.1997 / 18:22:47 / cg"
!
initializeClass:aClass
"sent from VM via #initializeModules"
Error handle:[:ex |
ClassesFailedToInitialize isNil ifTrue:[
ClassesFailedToInitialize := IdentitySet new.
].
ClassesFailedToInitialize add:aClass.
('Smalltalk [warning]: error during initialize of ' , aClass name,': ', ex description printString) errorPrintCR.
(Smalltalk commandLineArguments includes:'--debug') ifTrue:[
ex reject
].
] do:[
aClass initialize
].
!
initializeModules
"perform module specific initialization and
send #initialize to all classes.
Notice: this is not called when an image is restarted"
self initializeModulesOnce.
ClassesFailedToInitialize size > 0 ifTrue:[
('Smalltalk [info]: retry initialization of failed class(es)...') infoPrintCR.
ClassesFailedToInitialize := nil.
self initializeModulesOnce.
ClassesFailedToInitialize size > 0 ifTrue:[
('Smalltalk [error]: class(es) persist to fail during initialize') errorPrintCR.
]
].
!
initializeModulesOnce
"perform module specific initialization and
send #initialize to all classes.
Notice: this is not called when an image is restarted"
%{
__init_registered_modules__(3);
@global(DemoMode) = __getDemoMode() ? true : false;
RETURN (self);
%}.
^ self primitiveFailed
!
initializeSystem
"initialize all other classes; setup dispatcher processes etc.
This one is the very first entry into the smalltalk world,
right after startup, ususally immediately followed by Smalltalk>>start.
Notice:
this is not called when an image is restarted; in this
case the show starts in Smalltalk>>restart."
|idx|
Initializing := true.
AbstractOperatingSystem initializeConcreteClass.
CommandLineArguments isNil ifTrue:[
CommandLineArguments := #('stx').
].
CommandLine := CommandLineArguments copy.
CommandLineArguments := CommandLineArguments asOrderedCollection.
CommandName := CommandLineArguments removeFirst. "/ the command
SilentLoading := (CommandLineArguments includes:'--silentStartup').
DebuggingStandAlone := false.
StandAlone ifTrue:[
InfoPrinting := false.
ObjectMemory infoPrinting:false.
idx := CommandLineArguments indexOf:'--debug'.
idx ~~ 0 ifTrue:[
DebuggingStandAlone := true.
].
DebuggingStandAlone ifTrue:[
Inspector := MiniInspector.
Debugger := MiniDebugger.
].
] ifFalse:[
"/
"/ 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.
Stream initialize.
PositionableStream initialize.
Filename initialize.
ObjectMemory initialize.
OperatingSystem 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.
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
].
"/
"/ another one, to be initialized before others
"/
ProcessorScheduler initialize.
"/
"/ now, finally, initialize all other classes
"/
self initializeModules.
ImageStartTime := AbsoluteTime now.
self initInterrupts.
self initUserPreferences.
"/
"/ give classes a chance to perform 2nd-level initialization
"/ now, we are certain, that all other classes have been initialized
"/ (especially: streams and signals can now be used)
"/
ObjectMemory changed:#initialized.
"Modified: 8.1.1997 / 19:58:12 / stefan"
"Modified: 7.9.1997 / 23:34:44 / 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:'Compatibility-Squeak'!
beep
Screen current beep
!
garbageCollect
ObjectMemory garbageCollect
!
garbageCollectMost
"collect recently created garbage; return the amount of freeSpace.
In ST/X, only the newSpace is collected here, and the sum of
newSpace + freeListSpace is returned."
ObjectMemory scavenge.
^ ObjectMemory freeSpace
+ (ObjectMemory newSpaceSize - ObjectMemory newSpaceUsed)
!
isMorphic
^ false
!
registerExternalObject: anObject
"Register the given object in the external objects array and return its index.
If it is already there, just return its index.
ExternalObjects are protected from GC and can be accessed easily from
primitive code (via the global Smalltalk:SpecialObjectArray)"
| objects firstEmptyIndex obj sz newObjects |
objects := SpecialObjectArray.
objects isNil ifTrue:[
objects := Array new:5.
].
"find the first empty slot and look if already registered"
firstEmptyIndex := 0.
1 to: objects size do: [:i |
obj := objects at: i.
obj == anObject ifTrue: [^ i]. "object already there, just return its index"
(obj == nil and: [firstEmptyIndex = 0]) ifTrue: [
firstEmptyIndex := i
]
].
"if no empty slots, expand the array"
firstEmptyIndex = 0 ifTrue: [
sz := objects size.
newObjects := objects species new: sz + 20. "grow linearly"
newObjects replaceFrom: 1 to: sz with: objects startingAt: 1.
firstEmptyIndex := sz + 1.
SpecialObjectArray := newObjects.
objects := newObjects
].
objects at: firstEmptyIndex put: anObject.
^ firstEmptyIndex
!
unregisterExternalObject: anObject
"Unregister the given object in the external objects array.
Do nothing if it isn't registered."
|objects|
anObject isNil ifTrue:[^ self].
objects := SpecialObjectArray.
1 to: objects size do: [:i |
(objects at: i) == anObject ifTrue: [
objects at: i put: nil
]
].
! !
!Smalltalk class methodsFor:'Compatibility-V''Age'!
allClassesImplementing:aSelector
^ self allClasses select:[:cls | cls implements:aSelector].
! !
!Smalltalk class methodsFor:'Compatibility-VW5.4'!
defineClass:nameSymbol superclass:superclass indexedType:indexed private:private instanceVariableNames:instVars classInstanceVariableNames:classInstVars imports:imports category:category attributes:annotations
|newClass|
indexed == #none ifTrue:[
newClass := superclass
subclass:nameSymbol
instanceVariableNames:instVars
classVariableNames:''
poolDictionaries:''
category:category
inEnvironment:self.
classInstVars size > 0 ifTrue:[
newClass class instanceVariableNames:classInstVars.
].
^ newClass
].
self shouldImplement.
! !
!Smalltalk class methodsFor:'accessing'!
associationAt:aKey
"return a key-value association for aKey.
Since ST/X's Smalltalk as no real dictionary, this is
simulated here."
|val|
val := self at:aKey ifAbsent:nil.
val isNil ifTrue:[^ nil].
^ Association key:aKey value:val
"Created: / 1.11.1997 / 13:27:20 / cg"
!
associationAt:aKey ifAbsent:exceptionBlock
"return a key-value association for aKey, or the value
from exceptionBlock, if no such key is present.
Since ST/X's Smalltalk as no real dictionary, this is
simulated here."
|val|
val := self at:aKey ifAbsent:nil.
val isNil ifTrue:[^ exceptionBlock value].
^ Association key:aKey value:val
"Created: / 18.6.1998 / 17:05:24 / cg"
!
at:aKey
"retrieve the value stored under aKey, a symbol.
Return nil if not present
(this will be changed to trigger an error - better use #at:ifAbsent:)"
aKey class == String ifTrue:[self error:'expected symbol'].
%{ /* NOCONTEXT */
RETURN ( __GLOBAL_GET(aKey) );
%}.
^ self primitiveFailed
!
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 ifPresent:aBlock
"try to retrieve the value stored at aKey.
If there is nothing stored under this key, do nothing.
Otherwise, evaluate aBlock, passing the retrieved value as argument."
(self includesKey:aKey) ifTrue:[
^ aBlock value:(self at:aKey)
].
^ nil
"
Smalltalk at:#fooBar ifPresent:[:what | Transcript showCR:what].
Smalltalk at:#Object ifPresent:[:what | Transcript showCR:what].
"
!
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:[
"/ "/ this should not happen
"/ ('SMALLTALK: store a Metaclass: ' , aValue name , ' as ' , aKey) infoPrintCR.
"/ ].
aValue name == aKey ifTrue:[
CachedClasses add:aValue
] ifFalse:[
CachedClasses := nil
]
].
].
^ aValue.
"/
"/%{ /* NOCONTEXT */
"/ (void) __GLOBAL_SET(aKey, aValue, (OBJ *)0);
"/%}.
"/ CachedClasses := nil.
"/ ^ aValue
"Modified: 19.4.1996 / 11:31:49 / cg"
!
includesKey:aKey
"return true, if the key is known"
"/ for debugging - this is a common mistake,
"/ to try to access a class by nameString, instead
"/ of by symbol.
"/ aKey class == String ifTrue:[self halt].
%{ /* NOCONTEXT */
RETURN ( __GLOBAL_KEYKNOWN(aKey) );
%}.
^ self primitiveFailed
!
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) );
%}.
^ self primitiveFailed
!
values
"return a collection with all values in the Smalltalk dictionary"
|values|
values := OrderedCollection new.
self do:[:v | values add:v].
^ values
"Created: 20.6.1997 / 16:58:28 / cg"
! !
!Smalltalk class methodsFor:'binary storage'!
addGlobalsForBinaryStorageTo:globalDictionary
|pools|
pools := Set new.
self keysAndValuesDo:[:key :value |
(key includes:$:) ifFalse:[ "/ skip classVars
(value ~~ self
and:[value notNil]) ifTrue:[
value isClass ifTrue:[
value addGlobalsForBinaryStorageTo:globalDictionary.
pools addAll:value sharedPools
] ifFalse:[
globalDictionary at:(key->value) put:self
].
value notNil ifTrue:[
globalDictionary at:value put:self
]
]
]
].
pools do:[:poolDictionary|
poolDictionary addGlobalsForBinaryStorageTo:globalDictionary
]
"Modified: 19.3.1997 / 18:15:25 / cg"
"Created: 21.3.1997 / 15:40:31 / cg"
!
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.
stream nextPutBytes:(string size) from:string startingAt:1.
"/ string do:[:char | stream nextPut:char asciiValue]
"Modified: 19.3.1997 / 18:49:14 / cg"
! !
!Smalltalk class methodsFor:'browsing'!
browseAllCallsOn:aSelectorSymbol
"{ Pragma: +optSpace }"
"startup a browser for all methods sending a particular message"
UserPreferences systemBrowserClass browseAllCallsOn:aSelectorSymbol
"
Smalltalk browseAllCallsOn:#at:put:
"
!
browseAllSelect:aBlock
"{ Pragma: +optSpace }"
"startup a browser for all methods for which aBlock returns true"
UserPreferences systemBrowserClass 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
"
!
browseClass:aClass
"{ Pragma: +optSpace }"
"startup a browser on aClass"
UserPreferences systemBrowserClass browseClass:aClass
"
Smalltalk browseClass:Array
"
!
browseImplementorsMatching:aSelectorSymbolOrMatchPattern
"{ Pragma: +optSpace }"
"startup a browser for all methods implementing a message matching"
UserPreferences systemBrowserClass browseImplementorsMatching:aSelectorSymbolOrMatchPattern
"
Smalltalk browseImplementorsOf:#'at:put:'
Smalltalk browseImplementorsMatching:#'at:*'
"
!
browseImplementorsOf:aSelectorSymbol
"{ Pragma: +optSpace }"
"startup a browser for all methods implementing a particular message"
UserPreferences systemBrowserClass browseImplementorsOf:aSelectorSymbol
"
Smalltalk browseImplementorsOf:#at:put:
"
!
browseInClass:aClass
"{ Pragma: +optSpace }"
"startup a full browser showing aClass"
UserPreferences systemBrowserClass openInClass:aClass
"
Smalltalk browseInClass:Array
"
!
browseInClass:aClass selector:selector
"{ Pragma: +optSpace }"
"startup a full browser showing aClass>>selector"
UserPreferences systemBrowserClass openInClass:aClass selector:selector
"
Smalltalk browseInClass:Array selector:#at:
"
! !
!Smalltalk class methodsFor:'class management'!
changeCategoryOf:aClass to:newCategory
"change a classes category, add a change record,
send change notifications"
|ns|
aClass category ~= newCategory ifTrue:[
aClass category:(newCategory withoutSeparators asSymbol).
"notify change of category"
ns := aClass environment ? self.
ns changed:#organization.
ns ~~ self ifTrue:[
self changed:#organization.
]
].
"
Smalltalk changeCategoryOf:NewApplication to:#myApplications
"
"Modified: / 11.2.2000 / 11:36:27 / cg"
!
defineNameSpace: name private: private imports: imports category: category attributes: annotations
NameSpace name:name
!
flushCachedClass:aClass
CachedClasses notNil ifTrue:[
CachedClasses remove:aClass ifAbsent:[]
]
!
flushCachedClasses
CachedClasses := nil.
Class flushSubclassInfo.
"
Smalltalk flushCachedClasses
"
!
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 oldNameSym actualName wrongName ns ons|
aClass isNil ifTrue:[^ self].
oldName := aClass name.
sym := oldNameSym := oldName asSymbol.
((self at:oldNameSym) == aClass) ifFalse:[
"check other name ..."
(self includes:aClass) ifFalse:[
'Smalltalk [warning]: no such class: ' errorPrint. oldName errorPrintCR.
^ self
].
"
the class has changed its name - without telling me ...
what should be done in this case ?
"
'Smalltalk [warning]: class ' errorPrint. oldName errorPrint.
' has changed its name' errorPrintCR.
"/
"/ might be an alias (i.e. removing a compatibility name)
"/
actualName := self keyAtValue:aClass.
('Smalltalk [info]: ' , oldName , ' is actually stored as ' , actualName , '.') infoPrintCR.
sym := actualName asSymbol.
oldName := actualName asString.
wrongName := true.
].
ns := aClass nameSpace.
aClass topOwningClass notNil ifTrue:[
ons := aClass topOwningClass nameSpace
].
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 private classes"
aClass privateClassesSorted do:[:somePrivateClass |
aClass privateClassesAt:(somePrivateClass nameWithoutPrefix) asSymbol put:nil.
].
"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.
self changed:#classRemove with:aClass.
aClass setCategory:#'* removed *'.
self flushCachedClasses.
Class flushSubclassInfo.
wrongName == true ifTrue:[
"/
"/ an alias (i.e. removing a compatibility name)
"/
"/ check if there are more refs to it ...
[self includes:aClass] whileTrue:[
actualName := self keyAtValue:aClass.
('Smalltalk [info]: ' , aClass name , ' is also registered under the name ' , actualName
, ' - remove that binding too.') infoPrintCR.
self at:actualName put:nil.
].
].
ns ~~ Smalltalk ifTrue:[
ons notNil ifTrue:[
ClassBuilder
recompileGlobalAccessorsTo:oldNameSym
in:ons
except:nil
].
(ns notNil and:[ns ~~ ons]) ifTrue:[
ClassBuilder
recompileGlobalAccessorsTo:oldNameSym
in:ns
except:nil
].
].
"Modified: / 20.6.1998 / 13:26:10 / cg"
!
renameClass:aClass to:newName
"rename aClass to newName. Most of the work is in
renaming the classVariables (create & copy over values)
and patching the classes methods to access the new variables."
|oldName oldSym newSym names oldCVSym newCVSym value oldNameToNewName
oldNameSpace newNameSpace oldBaseName newBaseName privateClasses
oldBaseNameWithoutPrefix newBaseNameWithoutPrefix i1 i2 nm ns subns
oldMetaclass newMetaclass|
"/ check for all intermediate namespaces / owning classes
i1 := 1.
i2 := 1.
ns := self.
[i2 ~~ 0] whileTrue:[
i2 := newName indexOfSubCollection:'::' startingAt:i1.
i2 ~~ 0 ifTrue:[
nm := newName copyFrom:i1 to:i2-1.
ns isNameSpace ifTrue:[
subns := ns at:nm asSymbol ifAbsent:nil.
subns isNil ifTrue:[
self error:'Nonexisting namespace: ',nm.
^ nil.
].
] ifFalse:[
subns := ns privateClassesAt:nm asSymbol.
subns isNil ifTrue:[
self error:'Cannot create a namespace below a class'
]
].
ns := subns.
i1 := i2 + 2.
].
].
oldName := aClass name.
oldNameSpace := aClass topNameSpace.
oldBaseName := aClass nameWithoutNameSpacePrefix.
oldBaseNameWithoutPrefix := aClass nameWithoutPrefix.
oldSym := oldName asSymbol.
privateClasses := aClass privateClassesSorted.
((self at:oldSym) ~~ aClass) ifTrue:[
'Smalltalk [warning]: rename failed - name is different from key' errorPrintCR.
^ self
].
"/ rename the class
newSym := newName asSymbol.
aClass setName:newSym.
"/ store it in Smalltalk
self at:oldSym put:nil.
"/ change the owning class
ns isNameSpace ifFalse:[
aClass isPrivate ifTrue:[
aClass class setOwningClass:ns.
] ifFalse:[
oldMetaclass := aClass class.
"/ sigh - must make a PrivateMetaclass from Metaclass
newMetaclass := PrivateMetaclass new.
newMetaclass flags:(oldMetaclass flags).
newMetaclass setSuperclass:(oldMetaclass superclass).
newMetaclass instSize:(oldMetaclass instSize).
newMetaclass setInstanceVariableString:(oldMetaclass instanceVariableString).
newMetaclass setMethodDictionary:(oldMetaclass methodDictionary).
newMetaclass setSoleInstance:aClass.
newMetaclass setOwningClass:ns.
aClass changeClassTo:newMetaclass.
ObjectMemory flushCaches.
]
] ifTrue:[
aClass isPrivate ifTrue:[
aClass class setOwningClass:nil.
]
].
"/
"/ see comment in #removeKey: on why we dont remove it it here
"/
"/ self removeKey:oldSym.
self at:newSym put:aClass.
"/ create new class variables and copy over values
oldNameToNewName := IdentityDictionary new.
names := aClass classVariableString asCollectionOfWords.
names do:[:name |
oldCVSym := (oldSym , ':' , name) asSymbol.
value := self at:oldCVSym.
self at:oldCVSym put:nil.
"/
"/ see comment in #removeKey: on why we dont remove it it here
"/
"/ self removeKey:cSym.
newCVSym := (newSym , ':' , name) asSymbol.
self at:newCVSym put:value.
oldNameToNewName at:oldCVSym put:newCVSym.
].
"/ patch methods literal arrays from oldCVname to newCVname
oldNameToNewName keysAndValuesDo:[:oldNameSym :newNameSym |
aClass withAllSubclasses do:[:aSubClass |
Transcript showCR:'changing global accesses from ''' , oldNameSym , ''' into ''' , newNameSym , ''' in class: ''' , aSubClass name , ''' ...'.
aSubClass instAndClassSelectorsAndMethodsDo:[:sel :aMethod |
aMethod changeLiteral:oldNameSym to:newNameSym
].
].
"/ and also in privateClasses ? ...
"/ privateClasses size > 0 ifTrue:[
"/ privateClasses do:[:aPrivateClass |
"/ aPrivateClass withAllSubclasses do:[:aSubClass |
"/ aSubClass class methodDictionary do:[:aMethod |
"/ aMethod changeLiteral:oldNameSym to:newNameSym
"/ ].
"/ aSubClass methodDictionary do:[:aMethod |
"/ aMethod changeLiteral:oldNameSym to:newNameSym
"/ ]
"/ ].
"/ ]
"/ ]
].
aClass addChangeRecordForClassRename:oldSym to:newSym.
"/ clear the namespace (for namespace query to work)
aClass setEnvironment:nil.
newNameSpace := aClass topNameSpace.
privateClasses size > 0 ifTrue:[
"/ must rename privateClasses as well
Class withoutUpdatingChangesDo:[
privateClasses do:[:aPrivateClass |
self renameClass:aPrivateClass
to:(newSym , '::' , aPrivateClass nameWithoutPrefix).
Transcript showCR:'recompiling methods in ''' , newNameSpace name , ''' accessing ''' , oldName , '::' , aPrivateClass nameWithoutPrefix , ''' ...'.
ClassBuilder
recompileGlobalAccessorsTo:(oldName , '::' , aPrivateClass nameWithoutPrefix) asSymbol
in:newNameSpace
except:nil.
]
]
].
oldNameSpace ~~ newNameSpace ifTrue:[
"/ all those referencing the class from the old nameSpace
"/ must be recompiled ...
"/ (to now access the global from smalltalk)
oldNameSpace ~~ Smalltalk ifTrue:[
Transcript showCR:'recompiling methods in ''' , oldNameSpace name , ''' accessing ''' , oldName , ''' ...'.
ClassBuilder
recompileGlobalAccessorsTo:oldName asSymbol
in:oldNameSpace
except:nil.
].
"/ all referencing the class in the new namespace
"/ as well; to now access the new class.
(newNameSpace notNil and:[newNameSpace ~~ Smalltalk]) ifTrue:[
Transcript showCR:'recompiling methods in ''' , newNameSpace name , ''' accessing ''' , oldBaseName , ''' ...'.
ClassBuilder
recompileGlobalAccessorsTo:oldBaseName asSymbol
in:newNameSpace
except:nil.
].
] ifFalse:[
"/ all references to a global with my new name in my owning class
"/ must now be redirected to myself.
aClass isPrivate ifTrue:[
newBaseName := aClass nameWithoutNameSpacePrefix.
newBaseNameWithoutPrefix := aClass nameWithoutPrefix.
Transcript showCR:'recompiling methods accessing ''' , oldBaseNameWithoutPrefix , ''' in: ''' , aClass owningClass name , ''' ...'.
aClass owningClass recompileMethodsAccessingGlobal:oldBaseNameWithoutPrefix.
aClass owningClass class recompileMethodsAccessingGlobal:oldBaseNameWithoutPrefix.
Transcript showCR:'recompiling methods accessing ''' , oldBaseName , ''' in: ''' , aClass owningClass name , ''' ...'.
aClass owningClass recompileMethodsAccessingGlobal:oldBaseName.
aClass owningClass class recompileMethodsAccessingGlobal:oldBaseName.
Transcript showCR:'recompiling methods accessing ''' , newBaseNameWithoutPrefix , ''' in: ''' , aClass owningClass name , ''' ...'.
aClass owningClass recompileMethodsAccessingGlobal:newBaseNameWithoutPrefix.
aClass owningClass class recompileMethodsAccessingGlobal:newBaseNameWithoutPrefix.
Transcript showCR:'recompiling methods accessing ''' , newBaseName , ''' in: ''' , aClass owningClass name , ''' ...'.
aClass owningClass recompileMethodsAccessingGlobal:newBaseName.
aClass owningClass class recompileMethodsAccessingGlobal:newBaseName.
]
].
aClass changed:#definition.
"/ because of the change of my superclasses name ...
aClass allSubclassesDo:[:subClass |
subClass changed:#definition.
].
self changed:#definition.
Smalltalk changed:#classRename with:(Array with:aClass with:oldName).
"Created: / 29.10.1995 / 19:58:32 / cg"
"Modified: / 18.6.1996 / 14:20:50 / stefan"
"Modified: / 11.2.2000 / 01:12:38 / cg"
! !
!Smalltalk class methodsFor:'copying'!
deepCopy
"redefined to return self - there is only one Smalltalk dictionary"
^ self
"Modified: 18.5.1996 / 12:13:33 / cg"
!
deepCopyUsing:aDictionary
"redefined to return self - there is only one Smalltalk dictionary"
^ self
"Modified: 18.5.1996 / 12:13:36 / cg"
!
shallowCopy
"redefined to return self - there is only one Smalltalk dictionary"
^ self
"Modified: 18.5.1996 / 12:13:39 / cg"
!
simpleDeepCopy
"redefined to return self - there is only one Smalltalk dictionary"
^ self
"Modified: 18.5.1996 / 12:13:42 / cg"
! !
!Smalltalk class methodsFor:'debugging ST/X'!
compileTrace:aBoolean
"dump generated inline code (NOOP if VM was compiled without the trace-debug option)"
%{
extern char __compileTrace__;
__compileTrace__ = (aBoolean == true) ? 1 : 0;
%}
"
Smalltalk compileTrace:true
Smalltalk compileTrace:false
"
!
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__();
%}.
^ self
!
exitWithCoreDump
"{ Pragma: +optSpace }"
"abort program and dump core"
OperatingSystem exitWithCoreDump
"/ never returns
"Be careful evaluating this
Smalltalk exitWithCoreDump
"
!
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 */
%}.
^ self primitiveFailed
!
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 */
%}.
^ self primitiveFailed
!
vmInstructionTrace:aBoolean
! !
!Smalltalk class methodsFor:'enumerating'!
allBehaviorsDo:aBlock
"evaluate the argument, aBlock for all classes and metaclasses in the system"
self allClassesAndMetaclassesDo:aBlock
"
Smalltalk allBehaviorsDo:[:aClass | aClass name printCR]
"
!
allClassCategories
"return a set of all class categories in the system"
|allCategories|
allCategories := Set new.
Smalltalk allClassesDo:[:cls | |category|
category := cls category.
category notNil ifTrue:[
allCategories add:category.
].
].
^ allCategories.
"
Smalltalk allClassCategories
"
"Created: / 17.11.2001 / 12:13:09 / cg"
!
allClassesAndMetaclassesDo:aBlock
"evaluate the argument, aBlock for all classes and metaclasses in the system."
|already|
already := IdentitySet new.
self allClassesDo:[:eachClass | |cls|
cls := eachClass theNonMetaclass.
(already includes:cls) ifFalse:[
aBlock value:cls.
already add:cls.
].
cls := cls class.
(already includes:cls) ifFalse:[
aBlock value:cls.
already add:cls.
].
].
!
allClassesDo:aBlock
"evaluate the argument, aBlock for all classes in the system."
self allClasses do:aBlock
"
Smalltalk allClassesDo:[:aClass | aClass name printCR]
"
!
allClassesInCategory:aCategory
"return a collection of for all classes in aCategory;
The order of the classes is not defined."
|coll|
coll := OrderedCollection new.
self allClassesInCategory:aCategory do:[:aClass |
coll add:aClass
].
^ coll
"
Smalltalk allClassesInCategory:'Views-Basic'
"
"Modified: 25.4.1996 / 18:06:13 / cg"
!
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 allClassesDo:[:aClass |
aClass isMeta ifFalse:[
(aClass category = aCategory) ifTrue:[
aBlock value:aClass
]
]
]
]
"
Smalltalk allClassesInCategory:'Views-Basic' do:[:aClass | aClass name printCR]
"
!
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 allClassesInCategory:aCategory do:[:aClass |
classes add:aClass
].
classes topologicalSort:[:a :b | b isSubclassOf:a].
classes do:aBlock
]
"
Smalltalk allClassesInCategory:'Views-Basic' inOrderDo:[:aClass | aClass name printCR]
"
"Modified: / 17.11.2001 / 12:18:15 / cg"
!
allClassesInOrderDo:aBlock
"evaluate the argument, aBlock for all classes in the system;
Evaluation order is by inheritance: superclasses come first."
|already|
already := IdentitySet new.
self allClassesDo:[:aClass |
(already includes:aClass) ifFalse:[
aClass allSuperclasses reverseDo:[:cls |
(already includes:aClass) ifFalse:[
already add:cls.
aBlock value:cls.
].
].
already add:aClass.
aBlock value:aClass.
]
].
"
Smalltalk allClassesInOrderDo:[:aClass | aClass name printCR]
"
!
allKeysDo:aBlock
"evaluate the argument, aBlock for all keys in the Smalltalk dictionary"
^ self keysDo:aBlock
!
allMethodCategories
"return a set of all method categories in the system"
|allCategories|
allCategories := Set new.
Smalltalk allClassesDo:[:cls |
allCategories addAll:cls categories.
].
^ allCategories.
"
Smalltalk allMethodCategories
"
!
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 printCR]"
!
basicKeys
"for rel > 5 only"
self primitiveFailed
!
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);
RETURN (self);
%}.
self keysDo:[:aKey |
aBlock value:(self at:aKey)
]
!
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);
RETURN (self);
%}.
self basicKeys do:[:aKey |
aBlock value:aKey
]
! !
!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 accessing'!
beHeadless:aBoolean
"set/clear the headlessOperation flag."
HeadlessOperation := aBoolean
!
standAloneApp:aBoolean
"set/clear the StandAlone flag."
StandAlone := aBoolean
! !
!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
]
!
addImageStartBlock:aBlock
"{ Pragma: +optSpace }"
"add a blocks to be executed in a separate process after
everything has been initialized.
These blocks will be executed after an image restart."
ImageStartBlocks isNil ifTrue:[
ImageStartBlocks := OrderedCollection with:aBlock
] ifFalse:[
ImageStartBlocks add:aBlock
]
"Created: 9.9.1996 / 16:48:20 / stefan"
!
addStartBlock:aBlock
"{ Pragma: +optSpace }"
"add a blocks to be executed in a separate process after
everything has been initialized. These blocks will
be deleted after execution and therefore not be
executed after an image restart.
Initial processes are usually started here (see smalltalk.rc / private.rc)."
StartBlocks isNil ifTrue:[
StartBlocks := OrderedCollection with:aBlock
] ifFalse:[
StartBlocks add:aBlock
]
"Created: 9.9.1996 / 16:46:53 / stefan"
!
exit
"{ Pragma: +optSpace }"
"finish the Smalltalk system"
ObjectMemory changed:#aboutToExit. "/ for ST/X backward compatibility
ObjectMemory changed:#aboutToQuit. "/ for ST-80 compatibility
ExitBlocks notNil ifTrue:[
ExitBlocks do:[:aBlock |
aBlock value
]
].
OperatingSystem exit
"/ never returns
"Be careful evaluating this
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
"/ another 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 keysAndValuesDo:[:sym :anObject |
anObject notNil ifTrue:[
anObject isBehavior ifTrue:[
"/ sigh - would like to skip over aliases
"/ but this cannot be done simply by comparing
"/ the classes name against the store-key
"/ i.e. cannot do:
"/ anObject name == sym ifTrue:[
"/ classes add:anObject
"/ ]
"/ because that would lead to ignore all java
"/ classes, which are stored under a different
"/ key.
(anObject name == sym
or:[anObject isJavaClass]) ifTrue:[
classes add:anObject
].
]
]
]
].
^ classes
"CachedClasses := nil.
Smalltalk allClasses
to get the list sorted by name:
Smalltalk allClasses asSortedCollection:[:a :b | a name < b name]
"
"Modified: / 23.2.2000 / 10:49:46 / cg"
!
allClassesAndMetaclasses
"return an unordered collection of all classes with their metaclasses in the system."
|classes|
classes := IdentitySet new.
self allClassesDo:[:eachClass |
classes add:(eachClass theNonMetaclass).
classes add:(eachClass theMetaclass).
].
^ classes
!
allClassesWithAllPrivateClasses
"return an unordered collection of all classes in the Smalltalk namespace.
Only globally anchored classes are returned
(i.e. anonymous ones have to be aquired by Behavior allSubInstances)"
^ self allClasses select:[:aClass |
|owner|
(aClass isNameSpace not
or:[aClass == Smalltalk])
and:[
owner := aClass topOwningClass.
(owner ? aClass) nameSpace == Smalltalk
]
]
"
Smalltalk allClassesWithAllPrivateClasses
"
!
cellAt:aName
"{ Pragma: +optSpace }"
"return the address of a global cell
- used internally for compiler only"
%{ /* NOCONTEXT */
RETURN ( __GLOBAL_GETCELL(aName) );
%}.
^ self primitiveFailed
!
classCategoryCompletion:aPartialCategory
"given a partial class category name, return an array consisting of
2 entries: 1st: collection consisting of matching categories
2nd: the longest match"
|matches best lcName|
matches := IdentitySet new.
"/ search for exact match
self allClassesDo:[:aClass |
|category|
category := aClass category.
(category notNil and:[category startsWith:aPartialCategory]) ifTrue:[
matches add:category
]
].
matches isEmpty ifTrue:[
"/ search for case-ignoring match
lcName := aPartialCategory asLowercase.
self allClassesDo:[:aClass |
|category|
category := aClass category.
(category notNil and:[category asLowercase startsWith:lcName]) ifTrue:[
matches add:category
].
].
].
matches isEmpty ifTrue:[
^ Array with:aPartialCategory with:(Array with:aPartialCategory)
].
matches size == 1 ifTrue:[
^ Array with:matches first with:(matches asArray)
].
matches := matches asSortedCollection.
best := matches longestCommonPrefix.
^ Array with:best with:matches asArray
"
Smalltalk classCategoryCompletion:'Sys'
Smalltalk classCategoryCompletion:'System'
Smalltalk classCategoryCompletion:'System-BinaryStorage'
"
!
classNamed:aString
"return the class with name aString, or nil if absent.
To get to the metaClass, append ' class' to the string.
To get a nameSpace or private class, prefix the name as required."
|cls sym nonMeta idx ns nm|
"be careful, to not invent new symbols ..."
sym := aString asSymbolIfInterned.
sym notNil ifTrue:[
cls := self at:sym ifAbsent:nil.
cls isBehavior ifTrue:[^ cls].
cls isNil ifTrue:[
idx := sym indexOfSubCollection:'::'.
idx ~~ 0 ifTrue:[
ns := sym copyTo:idx-1.
nm := sym copyFrom:idx+2.
ns := Smalltalk at:ns asSymbol.
ns notNil ifTrue:[
ns isNameSpace ifTrue:[
cls := ns at:(nm asSymbol).
] ifFalse:[
ns isBehavior ifTrue:[
cls := ns privateClassesAt:(nm asSymbol).
]
]
].
cls isBehavior ifTrue:[^ cls].
].
].
].
(aString endsWith:' class') ifTrue:[
nonMeta := self classNamed:(aString copyWithoutLast:6).
nonMeta notNil ifTrue:[
^ nonMeta theMetaclass
].
].
^ nil
"
Smalltalk classNamed:'Object'
Smalltalk classNamed:'fooBar'
Smalltalk classNamed:'true'
Smalltalk classNamed:'Object class'
Smalltalk classNamed:'Metaclass'
Smalltalk classNamed:'Array'
Smalltalk classNamed:'Array class'
"
"Created: 24.11.1995 / 17:30:22 / cg"
"Modified: 24.11.1995 / 17:31:29 / cg"
"Modified: 19.6.1996 / 14:22:21 / stefan"
!
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"
^ self
classnameCompletion:aPartialClassName inEnvironment:self
!
classnameCompletion:aPartialClassName inEnvironment:anEnvironment
"given a partial classname, return an array consisting of
2 entries: 1st: collection consisting of matching names
2nd: the best (longest) match"
|searchName matches matchedNamesWithoutPrefix ignCaseMatches best isMatchString cls nsPrefix
others nearBy lcSearchName tryToMatch idx|
aPartialClassName isEmpty ifTrue:[
^ Array with:aPartialClassName with:#()
].
(aPartialClassName startsWith:'Smalltalk::') ifTrue:[
nsPrefix := 'Smalltalk::'.
searchName := aPartialClassName copyFrom:'Smalltalk::' size + 1
] ifFalse:[
nsPrefix := ''.
searchName := aPartialClassName.
].
(searchName at:1) isLowercase ifTrue:[
searchName := searchName copy asUppercaseFirst
].
lcSearchName := searchName asLowercase.
isMatchString := searchName includesMatchCharacters.
matches := OrderedCollection new.
matchedNamesWithoutPrefix := Set new.
ignCaseMatches := OrderedCollection new.
others := OrderedCollection new.
tryToMatch := [:className :fullClassName|
|addIt lcClassName|
isMatchString ifTrue:[
addIt := searchName match:className
] ifFalse:[
addIt := className startsWith:searchName.
].
addIt ifTrue:[
matches add:(nsPrefix , fullClassName).
matchedNamesWithoutPrefix add:className.
] ifFalse:[
"/ try ignoring case
isMatchString ifTrue:[
addIt := searchName match:className ignoreCase:true
] ifFalse:[
lcClassName := className asLowercase.
addIt := lcClassName startsWith:lcSearchName.
addIt ifFalse:[
others add:className
]
].
addIt ifTrue:[
ignCaseMatches add:(nsPrefix , fullClassName).
matchedNamesWithoutPrefix add:className.
].
].
addIt
].
anEnvironment allClassesDo:[:aClass |
|addIt fullClassName classNameWithoutPrefix|
aClass isMeta ifFalse:[
fullClassName := aClass name.
classNameWithoutPrefix := aClass nameWithoutPrefix.
addIt := tryToMatch value:fullClassName value:fullClassName.
addIt ifFalse:[
classNameWithoutPrefix ~~ fullClassName ifTrue:[
tryToMatch value:classNameWithoutPrefix value:fullClassName.
].
].
]
].
matches isEmpty ifTrue:[
matches := ignCaseMatches
].
"/ matches isEmpty ifTrue:[
"/ nearBy := SortedCollection new sortBlock:[:a :b | a key < b key].
"/ others do:[:className |
"/ |lcClassName dist cmpName|
"/
"/ lcClassName := className asLowercase.
"/ dist := lcClassName levenshteinTo:lcSearchName s:9 k:1 c:0 i:9 d:2.
"/
"/ cmpName := lcClassName copyTo:(lcSearchName size min:lcClassName size).
"/ dist := dist min:(cmpName levenshteinTo:lcSearchName s:9 k:1 c:0 i:9 d:2).
"/ cmpName := lcClassName copyTo:(lcSearchName size + 1 min:lcClassName size).
"/ dist := dist min:(cmpName levenshteinTo:lcSearchName s:9 k:1 c:0 i:9 d:2).
"/ dist < 4 ifTrue:[
"/ nearBy add:( dist -> (nsPrefix , className) ).
"/ ]
"/ ].
"/ matches := nearBy collect:[:eachPair | eachPair value].
"/ ].
matches isEmpty ifTrue:[
^ Array with:searchName with:(Array with:searchName)
].
matches size == 1 ifTrue:[
best := matches first.
^ Array with:best with:(matches asArray)
].
matches
sort:[:name1 :name2 |
"name1 comes before:name2 iff"
((name2 includes:$:) and:[(name1 includes:$:) not])
or:[ ((name1 includes:$:) == (name2 includes:$:))
and:[ (name1 size < name2 size)
or: [ name1 < name2 ]]
]
].
isMatchString ifTrue:[
best := searchName.
] ifFalse:[
best := matches longestCommonPrefix.
best size == 0 ifTrue:[
best := matchedNamesWithoutPrefix longestCommonPrefix.
].
best size == 0 ifTrue:[
"if tried again, return next match"
idx := ((matches indexOf:aPartialClassName) + 1) \\ matches size.
idx ~~ 1 ifTrue:[
^ Array with:(matches at:idx) with:(matches asArray)
].
].
best size < aPartialClassName size ifTrue:[
best := aPartialClassName.
].
].
cls := anEnvironment classNamed:best.
(cls isBehavior and:[cls isNameSpace]) ifTrue:[
(matches conform:[:each | each = best
or:[each startsWith:(best , '::')]])
ifTrue:[
best := best , '::'
].
].
^ 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"
"Modified: 3.4.1997 / 18:25:01 / cg"
!
defaultNameSpace
"return the default namespace, where new classes are installed,
if NO special nameSpace handler is present"
|p|
(Project notNil and:[(p := Project current) notNil]) ifTrue:[
^ p defaultNameSpace
].
^ self
"Created: 19.12.1996 / 23:49:25 / cg"
"Modified: 2.1.1997 / 20:01:31 / cg"
!
globalnameCompletion:aPartialGlobalName
"given a partial globalName, return an array consisting of
2 entries: 1st: collection consisting of matching names
2nd: the best (longest) match"
|searchName matches ignCaseMatches best isMatchString|
searchName := aPartialGlobalName.
searchName isEmpty ifTrue:[
^ Array with:searchName with:#()
].
(searchName at:1) isLowercase ifTrue:[
searchName := searchName copy asUppercaseFirst
].
isMatchString := searchName includesMatchCharacters.
matches := OrderedCollection new.
ignCaseMatches := OrderedCollection new.
self keysDo:[:aGlobalName |
| addIt|
isMatchString ifTrue:[
addIt := searchName match:aGlobalName
] ifFalse:[
addIt := aGlobalName startsWith:searchName
].
addIt ifTrue:[
matches add:aGlobalName
] ifFalse:[
"/ try ignoring case
isMatchString ifTrue:[
addIt := searchName match:aGlobalName ignoreCase:true
] ifFalse:[
addIt := aGlobalName asLowercase startsWith:searchName asLowercase
].
addIt ifTrue:[
ignCaseMatches add:aGlobalName
]
]
].
matches isEmpty ifTrue:[
matches := ignCaseMatches
].
matches isEmpty ifTrue:[
^ Array with:searchName with:(Array with:searchName)
].
matches size == 1 ifTrue:[
^ Array with:matches first with:(matches asArray)
].
matches := matches asSortedCollection.
isMatchString ifTrue:[
best := searchName.
] ifFalse:[
best := matches longestCommonPrefix.
].
^ Array with:best with:matches asArray
"
Smalltalk globalnameCompletion:'Arr'
Smalltalk globalnameCompletion:'Arra'
Smalltalk globalnameCompletion:'arra'
Smalltalk globalnameCompletion:'*rray'
"
"Created: 24.11.1995 / 17:24:45 / cg"
"Modified: 3.4.1997 / 18:25:01 / cg"
!
hasNamespaces
"can be redefined by dummy namespaces/environments, to suppress
the namespace display in a browser (PocketSmalltalk)"
^ true
!
includes:something
"this should come from Collection.
will change the inheritance - Smalltalk is actually a collection"
self do:[:element | element = something ifTrue:[^ true]].
^ false
!
isNameSpace
^ true
"Created: 11.10.1996 / 18:10:43 / cg"
!
isTopLevelNameSpace
^ true
!
isTopLevelNamespace
"obsolete - use isTopLevelNameSpace"
<resource:#obsolete>
^ true
"Created: 11.10.1996 / 18:10:43 / cg"
!
methodProtocolCompletion:aPartialProtocolName
"given a partial method protocol name, return an array consisting of
2 entries: 1st: collection consisting of matching protocols
2nd: the longest match"
|matches best lcName|
matches := IdentitySet new.
"/ search for exact match
self allClassesDo:[:aClass |
aClass instAndClassSelectorsAndMethodsDo:[:aSelector :aMethod |
|protocol|
protocol := aMethod category.
(protocol notNil and:[protocol startsWith:aPartialProtocolName]) ifTrue:[
matches add:protocol
]
].
].
matches isEmpty ifTrue:[
"/ search for case-ignoring match
lcName := aPartialProtocolName asLowercase.
self allClassesDo:[:aClass |
aClass instAndClassSelectorsAndMethodsDo:[:aSelector :aMethod |
|protocol|
protocol := aMethod category.
(protocol asLowercase startsWith:lcName) ifTrue:[
matches add:protocol
]
].
].
].
matches isEmpty ifTrue:[
^ Array with:aPartialProtocolName with:(Array with:aPartialProtocolName)
].
matches size == 1 ifTrue:[
^ Array with:matches first with:(matches asArray)
].
matches := matches asSortedCollection.
best := matches longestCommonPrefix.
^ Array with:best with:matches asArray
"
Smalltalk methodProtocolCompletion:'doc'
Smalltalk methodProtocolCompletion:'docu'
Smalltalk methodProtocolCompletion:'documenta'
"
!
numberOfGlobals
"return the number of global variables in the system"
|tally "{ Class: SmallInteger }" |
tally := 0.
self do:[:obj | tally := tally + 1].
^ tally
"Smalltalk numberOfGlobals"
!
referencesAny:aCollection
"redefined, since the references are only kept in the VM's symbol table"
self keysAndValuesDo:[:key :val |
aCollection do:[:anObject |
(key == anObject) ifTrue:[^ true].
(val == anObject ) ifTrue:[^ true].
]
].
^ super referencesAny:aCollection
"Created: / 2.2.1998 / 16:01:20 / cg"
!
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
!
referencesObject: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 referencesObject:anObject
"Modified: / 3.2.1998 / 14:22:46 / cg"
!
resolveName:nameIn inClass:aClass
"resolve aName as if compiled within aClass;
i.e. if it has a private class with this name, return it;
if aName is known within the classes namespace, return that.
Otherwise, return a global with that name.
This should be used whereever Smalltalk>>at: used to be used,
to resolve a global by name."
|aName sym cls ns|
nameIn isNil ifTrue:[^ nil].
nameIn isBehavior ifTrue:[^ nameIn]. "/ already resolved
aName := nameIn.
(aName startsWith:'Smalltalk::') ifTrue:[
aName := aName copyFrom:12.
^ self at:(aName asSymbol) ifAbsent:nil.
].
sym := aName asSymbol.
cls := aClass privateClassesAt:sym.
cls notNil ifTrue:[^ cls].
ns := aClass nameSpace.
(ns notNil and:[ns ~~ Smalltalk]) ifTrue:[
ns isNameSpace ifTrue:[
cls := ns at:sym ifAbsent:nil.
] ifFalse:[
cls := ns privateClassesAt:sym
].
cls notNil ifTrue:[^ cls].
].
^ self at:sym ifAbsent:nil.
"Modified: / 9.7.1999 / 01:18:07 / cg"
!
selectorCompletion:aPartialSymbolName
"given a partial selector, return an array consisting of
2 entries: 1st: collection consisting of matching implemented selectors
2nd: the longest match"
^ self
selectorCompletion:aPartialSymbolName inEnvironment:self
!
selectorCompletion:aPartialSymbolName inEnvironment:anEnvironment
"given a partial selector, return an array consisting of
2 entries: 1st: collection consisting of matching implemented selectors
2nd: the longest match"
|matches best lcSym|
matches := IdentitySet new.
"/ search for exact match
anEnvironment allClassesDo:[:aClass |
aClass instAndClassSelectorsAndMethodsDo:[:aSelector :aMethod |
(aSelector startsWith:aPartialSymbolName) ifTrue:[
matches add:aSelector
]
].
].
matches isEmpty ifTrue:[
"/ search for case-ignoring match
lcSym := aPartialSymbolName asLowercase.
anEnvironment allClassesDo:[:aClass |
aClass instAndClassSelectorsAndMethodsDo:[:aSelector :aMethod |
(aSelector asLowercase startsWith:lcSym) ifTrue:[
matches add:aSelector
]
].
].
].
matches isEmpty ifTrue:[
^ Array with:aPartialSymbolName with:(Array with:aPartialSymbolName)
].
matches size == 1 ifTrue:[
^ Array with:matches first with:(matches asArray)
].
matches := matches asSortedCollection.
best := matches longestCommonPrefix.
^ Array with:best with:matches asArray
"
Smalltalk selectorCompletion:'at:p'
Smalltalk selectorCompletion:'nextP'
Smalltalk selectorCompletion:'nextp'
"
"Modified: / 7.6.1996 / 08:44:33 / stefan"
"Modified: / 14.6.1998 / 15:54:03 / cg"
! !
!Smalltalk class methodsFor:'queries-system'!
dialectName
^ 'SmalltalkX'
"
Smalltalk dialectName
"
!
dialectReleaseVersion
^ self versionString
"
Smalltalk dialectReleaseVersion
"
!
isDolphinSmalltalk
"return false here - this may be useful to write portable
applications - add #isDolphinSmalltalk to your dolphin,
returning true there."
^ false
!
isSmalltalkMT
"return false here - this may be useful to write portable
applications - add #isSmalltalkMT to your smalltalk-MT,
returning true there."
^ false
!
isSmalltalkV
"return false here - this may be useful to write portable
applications - add #isSmalltalkV to your smalltalkV,
returning true there."
^ false
!
isSmalltalkX
"return true here - this may be useful to write portable
applications - add #isSmalltalkX to your other smalltalks,
returning false there."
^ true
!
isSqueak
"return false here - this may be useful to write portable
applications - add #isSqueak to your squeak,
returning true there."
^ false
!
isVisualAge
"return false here - this may be useful to write portable
applications - add #isVisualAge to your visualAge,
returning true there."
^ false
!
isVisualWorks
"return false here - this may be useful to write portable
applications - add #isVisualWorks to your visualWorks,
returning true there."
^ false
! !
!Smalltalk class methodsFor:'startup'!
displayInitializationDone
"inform the restart, that the display has been initialized"
CallbackSignal raiseRequest.
!
mainStartup:graphicalMode
"common start/restart action, if there is a Display, initialize it
and start dispatching; otherwise go into a read-eval-print loop."
|process imageName thisIsARestart|
imageName := ObjectMemory imageName.
thisIsARestart := imageName notNil.
"
if there is a display, start its event dispatcher
"
Display notNil ifTrue:[
Display deviceIOTimeoutErrorSignal handlerBlock:[:ex |
SaveEmergencyImage == true ifTrue:[
'Display [warning]: broken display connection - emergency save in ''crash.img''.' infoPrintCR.
ObjectMemory primSnapShotOn:'crash.img'.
].
'Display [warning]: broken display connection - exit.' infoPrintCR.
Smalltalk exit.
].
Display startDispatch.
].
Initializing := false.
"/ start a process, which evaluates all StartBlocks
"/ this used to be done right here (in this system-process),
"/ but lead to trouble, when it suspended.
"/ Therefore, it is now done by an extra user-process.
process := [
StartBlocks notNil ifTrue:[
StartBlocks do:[:aBlock|
aBlock value
].
StartBlocks := nil.
].
ImageStartBlocks notNil ifTrue:[
ImageStartBlocks do:[:aBlock|
aBlock value
].
].
StandAlone ifFalse:[
(SilentLoading == true) ifFalse:[ "i.e. undefined counts as false"
thisIsARestart ifTrue:[
Transcript cr.
Transcript showCR:('Smalltalk restarted from:'
, imageName
, ' (saved '
, ObjectMemory imageSaveTime printString
, ')' ).
] ifFalse:[
Transcript showCR:(self hello).
Transcript showCR:(self copyrightString).
Transcript cr.
].
Transcript cr.
].
DemoMode==true 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.
].
].
thisIsARestart ifTrue:[
"/
"/ the final late notification - users can now assume that
"/ views, forms etc. have been recreated.
ObjectMemory changed:#returnFromSnapshot.
]
] newProcess.
process priority:8.
process name:'start block handler'.
process beGroupLeader.
process resume.
process := nil.
"/ start a process, which evaluates the startupClass>>startupSelector
"/ message.
(StartupClass notNil and:[StartupSelector notNil]) ifTrue:[
"
allow more customization by reading an image specific rc-file
"
thisIsARestart ifTrue:[
(imageName asFilename hasSuffix:'img') ifTrue:[
imageName := imageName copyWithoutLast:4
].
self fileIn:(imageName , '.rc')
].
"/ Display notNil ifTrue:[
"/ Display exitOnLastClose:true.
"/ ].
"/ Processor exitWhenNoMoreUserProcesses:true.
process := [
StandAlone ifTrue:[
AbortSignal handle:[:ex |
OperatingSystem exit:1
] do:[
StartupClass perform:StartupSelector withArguments:StartupArguments.
]
] ifFalse:[
StartupClass perform:StartupSelector withArguments:StartupArguments.
].
"/
"/ non-GUI apps exit after the startup;
"/ assume that GUI apps have created & opened some view ...
"/
Display isNil ifTrue:[
Smalltalk exit.
].
"/
"/ GUI apps exit after the last user process has finished
"/
Display exitOnLastClose:true.
Processor exitWhenNoMoreUserProcesses:true.
] newProcess.
process priority:8.
process name:'main'.
process beGroupLeader.
process resume.
process := true. "do not refer to process"
].
"
if view-classes exist, start dispatching;
otherwise go into a read-eval-print loop
"
((Display notNil and:[graphicalMode])
or:[process notNil
or:[HeadlessOperation]]) ifTrue:[
Processor dispatchLoop.
] ifFalse:[
StandAlone ifFalse:[
self readEvalPrint
]
].
"done - the last process finished"
self exit
"Created: / 18.7.1996 / 21:07:39 / cg"
"Modified: / 9.9.1996 / 17:42:50 / stefan"
"Modified: / 25.5.1998 / 15:02:57 / cg"
!
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:[
AbortSignal handle:[:ex |
'evaluation aborted' printCR
] do:[
Compiler isNil ifTrue:[
'No evaluator class available (Compiler == nil)' printCR.
^ self
].
(Compiler evaluate:text) printCR.
].
'ST- ' print.
text := Stdin nextChunk
].
].
'' printCR
!
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.
#earlySystemInstallation is sent for ST80 compatibility
#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 transcript idx|
"/
"/ when we arrive here, all objects from our previous life
"/ have been reloaded - however, some may still contain invalid device
"/ handles, display information etc.
"/ also, dynamically loaded modules have not yet been reloaded yet.
"/ and the concrete OS, concrete FileName etc. are still refering to
"/ the previous classes.
Initializing := true.
AbstractOperatingSystem initializeConcreteClass.
ImageRestartTime := AbsoluteTime now.
CommandLine := CommandLineArguments copy.
CommandLineArguments := CommandLineArguments asOrderedCollection.
CommandName := CommandLineArguments removeFirst. "/ the command
idx := CommandLineArguments indexOf:'-q'.
idx == 0 ifTrue:[
idx := CommandLineArguments indexOf:'--silent'.
].
idx ~~ 0 ifTrue:[
Object infoPrinting:false.
ObjectMemory infoPrinting:false.
CommandLineArguments removeAtIndex:idx.
].
"/
"/ start catching SIGSEGV and SIGBUS
OperatingSystem enableHardSignalInterrupts.
"/ reinit Filename
Filename reinitialize.
"/
"/ flush cached path directories (may have changed in the meanwhile)
self flushPathCaches.
"/
"/ reinit the default streams: Stdin, Stdout and Stderr
"/ after that, we can write to stderr.
self reinitStandardStreams.
"/
"/ redirect Transcript to Stderr during startup
transcript := Transcript.
Transcript := Stderr.
"/
"/ 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.
"/ reload any dynamically loaded objects.
"/ this must be done before doing anything else below,
"/ because the Processor may restart processes which use
"/ this code.
"/ Also, a dynamic object might be registered as dependent of
"/ ObjectFileLoader; therefore, must reload before doing any notifications.
ObjectFileLoader notNil ifTrue:[
ObjectFileLoader reloadAllRememberedObjectFiles.
].
"/
"/ invalidate all display connections.
"/ This is required to avoid trouble if someone accesses
"/ a display during early startup.
Screen notNil ifTrue:[
Screen allScreens do:[:aDisplay |
aDisplay invalidateConnection
].
].
ObjectMemory changed:#earlySystemInstallation.
"/
"/ reinitialize the Processor - restartable processes
"/ are now restarted here (but not yet scheduled).
"/
Processor reinitialize.
"/
"/ flush device handles & recreate OS resources (if possible)
"/ (mostly view/GC/color & font stuff)
ObjectMemory
changed:#earlyRestart; changed:#restarted.
"/
"/ start catching SIGINT and SIGQUIT
OperatingSystem enableUserInterrupts.
OperatingSystem enableCrashSignalInterrupts.
"/ give user a chance to re-customize things
"/ reading if smalltalk_r.rc may be suppressed by the
"/ -fastStart argument.
idx := CommandLineArguments indexOf:'--faststart'.
idx ~~ 0 ifTrue:[
CommandLineArguments removeAtIndex:idx.
] ifFalse:[
CallbackSignal := QuerySignal new.
[
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'
].
]
] on:CallbackSignal do:[:ex|
"/ now, display and view-stuff works;
"/ back to the previous debugging interface
Inspector := insp.
Debugger := deb.
"/ reinstall Transcript, if not changed during restart.
"/ if there was no Transcript, go to stderr
(transcript notNil and:[Transcript == Stderr]) ifTrue:[
Transcript := transcript.
].
Initializing := false.
ex proceed.
].
CallbackSignal := nil.
].
"/ reinitialization (restart) of Display is normally performed
"/ in the restart script. If this has not been run for some reason,
"/ do in now.
Initializing ifTrue:[
Display notNil ifTrue:[
[
Display reinitializeFor:Screen defaultDisplayName.
] on:Screen deviceOpenErrorSignal do:[
'Smalltalk [error]: Cannot restart connection to: ' errorPrint.
Screen defaultDisplayName errorPrintCR.
OperatingSystem exit:1.
].
].
"/ now, display and view-stuff works;
"/ back to the previous debugging interface
Inspector := insp.
Debugger := deb.
"/ reinstall Transcript, if not changed during restart.
"/ if there was no Transcript, go to stderr
(transcript notNil and:[Transcript == Stderr]) ifTrue:[
Transcript := transcript.
].
Initializing := false.
].
self mainStartup:true
"Modified: / 7.6.1998 / 02:48:00 / cg"
"Modified: / 3.8.1999 / 09:42:21 / stefan"
!
start
"main startup, if there is a Display, initialize it
and start dispatching; otherwise go into a read-eval-print loop."
|idx graphicalMode arg didReadRCFile|
graphicalMode := true.
Initializing := true.
"
while reading patches- and rc-file, do not add things into change-file
"
Class withoutUpdatingChangesDo:[
|myName defaultRC prevCatchSetting|
"/
"/ look for any '-q', '-e' or '-f' command line arguments
"/ and handle them;
"/ read startup and patches file
"/
idx := CommandLineArguments indexOf:'-q'.
idx == 0 ifTrue:[
idx := CommandLineArguments indexOf:'--silent'.
].
idx ~~ 0 ifTrue:[
Object infoPrinting:false.
ObjectMemory infoPrinting:false.
CommandLineArguments removeAtIndex:idx.
].
StandAlone ifFalse:[
"/ look for a '-e filename' or '--execute filename' argument
"/ this will force fileIn of filename only, no standard startup.
idx := CommandLineArguments indexOf:'-e'.
idx == 0 ifTrue:[
idx := CommandLineArguments indexOf:'--execute'.
].
idx ~~ 0 ifTrue:[
arg := CommandLineArguments at:idx + 1.
CommandLineArguments
removeAtIndex:idx+1; removeAtIndex:idx.
arg = '-' ifTrue:[
self fileInStream:Stdin
lazy:nil
silent:nil
logged:false
addPath:nil
] ifFalse:[
self fileIn:arg.
].
self exit
].
"/ look for a '-E expr' or '--eval expr' argument
"/ this will force evaluation of expr only, no standard startup
idx := CommandLineArguments indexOf:'-E'.
idx == 0 ifTrue:[
idx := CommandLineArguments indexOf:'--eval'.
].
idx ~~ 0 ifTrue:[
arg := CommandLineArguments at:idx + 1.
CommandLineArguments
removeAtIndex:idx+1; removeAtIndex:idx.
self
fileInStream:arg readStream
lazy:nil
silent:nil
logged:false
addPath:nil.
self exit
].
].
"/ look for a '-f filename' or '--file filename' argument
"/ this will force evaluation of filename instead of smalltalk.rc
idx := CommandLineArguments indexOf:'-f'.
idx == 0 ifTrue:[
idx := CommandLineArguments indexOf:'--file'.
].
idx ~~ 0 ifTrue:[
myName := (CommandLineArguments at:idx + 1).
CommandLineArguments
removeAtIndex:idx+1; removeAtIndex:idx.
CommandLine at:1 put:myName.
CommandName := myName.
(self secureFileIn:myName) ifFalse:[
('Smalltalk [error]: startup file ', myName, ' not found.') errorPrintCR.
OperatingSystem exit:1.
].
] ifFalse:[
"/ look for <command>.rc
"/ if not found, read smalltalk.rc (or stxapp.rc for standAlone operation)
didReadRCFile := false.
myName := self commandName asFilename withSuffix:'rc'.
(didReadRCFile := self secureFileIn:myName) ifFalse:[
StandAlone ifFalse:[
defaultRC := 'smalltalk.rc'
] ifTrue:[
defaultRC := 'stxapp.rc'
].
didReadRCFile := self secureFileIn:defaultRC.
didReadRCFile ifFalse:[
StandAlone ifFalse:[
'Smalltalk [warning]: no startup rc-file found. Going into line-by-line interpreter.' infoPrintCR.
graphicalMode := false.
]
]
].
"/ ('StandAlone is %1' bindWith:StandAlone) printCR.
"/ ('Headless is %1' bindWith:HeadlessOperation) printCR.
"/ ('Display is %1' bindWith:Display) printCR.
"/ ('Screen is %1' bindWith:Screen) printCR.
didReadRCFile ifFalse:[
StandAlone ifFalse:[
"/ its a smalltalk - proceed in interpreter.
'Smalltalk [warning]: no startup rc-file found. Going into line-by-line interpreter.' infoPrintCR.
graphicalMode := false.
] ifTrue:[
"/ its an application - try harder
Screen notNil ifTrue:[
[
Screen openDefaultDisplay:nil.
] on:Screen deviceOpenErrorSignal do:[:ex|
('Smalltalk [error]: No Display connection to: ', ex parameter printString) errorPrintCR.
'Smalltalk [info]: Either set the DISPLAY environment variable,' infoPrintCR.
'Smalltalk [info]: or start smalltalk with a -display argument.' infoPrintCR.
HeadlessOperation == true ifFalse:[
OperatingSystem exit:1.
].
].
Display notNil ifTrue:[
(self secureFileIn:'display.rc') ifFalse:[
'Smalltalk [warning]: no display.rc found; screen setting might be wrong.' infoPrintCR.
]
].
]
]
].
].
].
StandAlone ifFalse:[
"
enable the graphical debugger/inspector
(they could have been (re)defined as autoloaded in the patches file)
"
self initStandardTools.
].
(Display isNil or:[HeadlessOperation]) ifTrue:[
graphicalMode := false.
].
self mainStartup:graphicalMode
"Modified: / 24.12.1999 / 00:26:54 / cg"
! !
!Smalltalk class methodsFor:'startup queries'!
commandLine
"return the full command line arguments (with which ST/X was started)"
^ CommandLine
"Created: 19.7.1996 / 11:09:06 / cg"
!
commandLineArgumentNamed:aString
"extract a named argument from the command line arguments."
|args index|
args := self commandLineArguments.
index := args indexOf:aString.
(index between:1 and:(args size - 1)) ifTrue:[
^ args at:index+1
].
^ nil.
"
self commandLineArgumentNamed:'-display'
"
!
commandLineArguments
"return the user command line arguments;
This is a collection of strings (separated command line words),
from which the internal startup arguments have already been removed.
I.e. if started with: 'smalltalk -I -f xxx foo bar baz',
the commandLineArguments will be #('foo' 'bar' 'baz').
In contrast, the value returned by #commandLine will be the full set of words."
^ CommandLineArguments
"Modified: 19.7.1996 / 11:11:03 / cg"
!
commandName
"return the excutables name - this is normally 'smalltalk', but
can be something else for standAlone apps."
^ CommandName.
"Modified: 19.7.1996 / 11:11:16 / cg"
!
isHeadless
"return true, if this is a headless application
i.e. no default Display connection is required/used"
^ HeadlessOperation
!
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
"
Smalltalk language
"
"Modified: 26.4.1996 / 17:10:05 / cg"
!
language:aLanguageSymbol
"set the language"
Language := aLanguageSymbol.
self changed:#Language
"
Smalltalk language:#de
"
"Modified: 26.4.1996 / 17:13:34 / cg"
!
languageTerritory
"return the language territory setting"
^ LanguageTerritory
!
languageTerritory:aTerritorySymbol
"set the language territory"
LanguageTerritory := aTerritorySymbol.
self changed:#LanguageTerritory
"
Time now
Smalltalk languageTerritory:#us.
Time now
Smalltalk languageTerritory:#de.
Time now
"
"Modified: 26.4.1996 / 17:12:39 / cg"
! !
!Smalltalk class methodsFor:'system management'!
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."
|newStream table source pos fileName|
"
first, find all methods which contain either a string-ref
or an external string in the 'st.src' file
"
newStream := 'src.tmp' asFilename writeStream.
newStream checkNilFileStream.
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 position1Based.
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.
"good - now go over all changed methods, and change their
source reference"
table keysAndValuesDo:[:aMethod :pos |
aMethod localSourceFilename:fileName position:pos.
"/ aMethod printCR.
].
"
Smalltalk compressSources
"
"Modified: 16.1.1997 / 01:25:58 / cg"
!
generateSingleSourceFile
"{ Pragma: +optSpace }"
"generate 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 makes the image independent from the per-class source files
and makes transportation of endUser applications easier, since
only 3 files (executable, image and sourceFile) need to be
transported."
|newStream table source pos fileName|
newStream := 'src.tmp' asFilename writeStream.
newStream checkNilFileStream.
table := IdentityDictionary new:100.
Method allSubInstancesDo:[:aMethod |
source := aMethod source.
source notNil ifTrue:[
pos := newStream position1Based.
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.
"good - now go over all changed methods, and change their
source reference"
table keysAndValuesDo:[:aMethod :pos |
aMethod localSourceFilename:fileName position:pos.
"/ aMethod printCR.
].
"
Smalltalk generateSingleSourceFile
"
"Modified: 16.1.1997 / 01:25:58 / cg"
"Created: 17.10.1997 / 13:00:56 / cg"
!
installAutoloadedClassNamed:clsName category:cat package:package revision:revisionOrNil
"create & install an autoload stub for a class named: clsName,
to be loaded from package.
If revisionOrNil is non-nil, set it up to load exactly that revision
(otherwise, the newest revision will be loaded"
self
installAutoloadedClassNamed:clsName
category:cat
package:package
revision:revisionOrNil
numClassInstVars:nil.
!
installAutoloadedClassNamed:clsName category:cat package:package revision:revisionOrNil numClassInstVars:numClassInstVarsOrNil
"create & install an autoload stub for a class named: clsName,
to be loaded from package.
If revisionOrNil is non-nil, set it up to load exactly that revision
(otherwise, the newest revision will be loaded"
|clsSym cls|
clsSym := clsName asSymbol.
"/ install if not already compiled-in
(cls := self at:clsSym) isNil ifTrue:[
Autoload subclass:clsSym
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
category:cat
inEnvironment:Smalltalk.
cls := self at:clsSym.
cls isNil ifTrue:[
('Smalltalk [warning]: failed to install ' , clsName , ' as autoloaded.') infoPrintCR.
] ifFalse:[
cls package:package asSymbol.
revisionOrNil notNil ifTrue:[
cls setBinaryRevision:revisionOrNil
]
]
] ifFalse:[
"/ class already present - however, check for category/package change
package ~= cls package ifTrue:[
cls package:package asSymbol.
].
cat ~= cls category ifTrue:[
cls category:cat.
].
].
"Created: / 5.11.1998 / 15:10:25 / cg"
!
installAutoloadedClasses
"read the standard abbreviation file; install all classes found there as
autoloaded. This takes some time ..."
|dirsConsulted p|
"/ new scheme: look for a directory called 'packages'
"/ and enumerate its abbrev.stc files...
dirsConsulted := Set new.
"/ along the package-path
(p := self packagePath) do:[:aPath |
(dirsConsulted includes:aPath) ifFalse:[
('Smalltalk [info]: installing autoloaded classes found under ''' , aPath ,'''') infoPrintCR.
self
recursiveInstallAutoloadedClassesFrom:aPath
rememberIn:dirsConsulted
maxLevels:15
noAutoload:false
packageTop:aPath.
]
].
p size == 0 ifTrue:[
('Smalltalk [info]: installing autoloaded classes found under ''../../..''') infoPrintCR.
self
recursiveInstallAutoloadedClassesFrom:'../../..'
rememberIn:dirsConsulted
maxLevels:15
noAutoload:false
packageTop:'../../..'.
].
"
Smalltalk installAutoloadedClasses
"
"Created: / 14.2.1997 / 17:32:57 / cg"
"Modified: / 13.12.1999 / 11:56:50 / cg"
!
installAutoloadedClassesFrom:anAbbrevFilePath
"read the given abbreviation file; install all classes found there as
autoloaded. This takes some time ..."
|f s|
f := self getSystemFileName:anAbbrevFilePath.
f isNil ifTrue:[f := self getPackageFileName:anAbbrevFilePath].
f notNil ifTrue:[
f := f asFilename.
f isDirectory ifTrue:[
f := f construct:'abbrev.stc'
].
[
s := f readStream.
self installAutoloadedClassesFromStream:s.
s close.
] on:FileStream openErrorSignal do:[:ex| "do nothing"].
]
"
Smalltalk installAutoloadedClassesFrom:'include/abbrev.stc'
"
"Modified: / 5.11.1998 / 15:10:51 / cg"
!
installAutoloadedClassesFromStream:anAbbrevFileStream
"read the given abbreviation file;
install all classes found there as autoloaded, and also update the
abbreviation (className-to-fileName mapping) table.
This takes some time ..."
|s2 l clsName abbrev package cat numClassInstVars cls words w abbrevs oldAbbrev nameKey|
"/ on the fly, update the abbreviations
CachedAbbreviations isNil ifTrue:[
CachedAbbreviations := IdentityDictionary new.
].
abbrevs := CachedAbbreviations.
KnownPackages isNil ifTrue:[
KnownPackages := Set new.
].
"/ yes, create any required nameSpace, without asking user.
Class createNameSpaceQuerySignal answer:true do:[
[anAbbrevFileStream atEnd] whileFalse:[
l := anAbbrevFileStream nextLine withoutSeparators.
l notEmpty ifTrue:[
"/ must do it manually, caring for quoted strings.
"/ words := line asCollectionOfWords.
words := OrderedCollection new.
s2 := l readStream.
[s2 atEnd] whileFalse:[
s2 skipSeparators.
s2 peek == $' ifTrue:[
s2 next.
w := s2 upTo:$'.
s2 skipSeparators.
] ifFalse:[
w := s2 upToSeparator
].
words add:w
].
words size < 3 ifTrue:[
'Smalltalk [warning]: bad abbrev entry' errorPrint.
anAbbrevFileStream isFileStream ifTrue:[
' (in ''' errorPrint.
anAbbrevFileStream pathName errorPrint.
''')' errorPrint
].
': ' errorPrint. l errorPrintCR
] ifFalse:[
clsName := (words at:1) asSymbol.
abbrev := (words at:2).
package := (words at:3) asSymbol.
cat := words at:4 ifAbsent:nil.
numClassInstVars := words at:5 ifAbsent:'0'.
numClassInstVars := Integer readFrom:numClassInstVars onError:[0].
"/ KnownPackages add:package.
(cat size == 0) ifTrue:[
cat := 'autoloaded'
].
"/ on the fly, update the abbreviations
clsName ~= abbrev ifTrue:[
nameKey := clsName asSymbol.
oldAbbrev := abbrevs at:nameKey ifAbsent:nil.
(oldAbbrev notNil and:[oldAbbrev ~= abbrev]) ifTrue:[
StandAlone ifFalse:[
('Smalltalk [warning]: conflict for: ' , clsName , ' in ' , (anAbbrevFileStream pathName)) infoPrintCR.
('Smalltalk [warning]: (' , oldAbbrev , ' <-> ' , abbrev , ')') infoPrintCR
].
] ifFalse:[
cls := self classNamed:abbrev.
cls notNil ifTrue:[
cls name ~= clsName ifTrue:[
"/ ok, there is a class named after this abbrev ...
"/ this is only a conflict, if the other class has no
"/ abbreviation (or the same).
(abbrevs at:(cls name asSymbol) ifAbsent:cls name) = abbrev ifTrue:[
cls isNameSpace ifFalse:[
package = cls package ifTrue:[
StandAlone ifFalse:[
('Smalltalk [warning]: conflict for: ' , cls name , ' in ' , (anAbbrevFileStream pathName)) infoPrintCR.
('Smalltalk [warning]: (' , clsName , ' -> ' , abbrev , ')') infoPrintCR
]
]
]
]
]
].
].
abbrevs at:nameKey put:abbrev.
].
"/ ' autoloaded: ' print. clsName print. ' in ' print. cat printCR.
self installAutoloadedClassNamed:clsName category:cat package:package revision:nil numClassInstVars:numClassInstVars.
]
]
]
]
!
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 [info]: this system does not support binary loading' infoPrintCR.
].
LoadBinaries := false
"Modified: 10.1.1997 / 15:11:00 / cg"
!
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
!
makeBytecodeMethods
"{ Pragma: +optSpace }"
"walk over all methods and make each a bytecode method
iff it does not contain primitive C code.
Experimental and not yet used."
Method allSubInstancesDo:[:aMethod |
|newMethod|
aMethod hasPrimitiveCode ifFalse:[
newMethod := aMethod asByteCodeMethod.
newMethod ~~ aMethod ifTrue:[
aMethod becomeSameAs:newMethod
]
].
].
"
Smalltalk makeBytecodeMethods
"
"Modified: 16.1.1997 / 01:25:58 / cg"
"Created: 17.10.1997 / 13:52:19 / cg"
!
recursiveInstallAutoloadedClassesFrom:aDirectory rememberIn:dirsConsulted maxLevels:maxLevels noAutoload:noAutoloadIn packageTop:packageTopPath
"read all abbrev.stc files from and under aDirectory
and install autoloaded classes.
If a file called NOAUTOLOAD is found, no classes there and below are installed as autoloaded
(however, the directories are searched for packages)
If a file called NOPACKAGES is found, no further searching is done in that directory or below."
|abbrevStream dir noAutoloadHere dirName pkgName directoryContents|
maxLevels == 0 ifTrue:[
"/ 'Smalltalk [warning]: max directory nesting reached.' infoPrintCR.
^ self
].
dir := aDirectory asFilename.
(dirsConsulted includes:dir pathName) ifTrue:[
^ self
].
dirsConsulted add:dir pathName.
(dir construct:'NOPACKAGES') exists ifTrue:[
^ self.
].
(dir construct:'NOSUBAUTOLOAD') exists ifTrue:[
^ self.
].
noAutoloadHere := noAutoloadIn.
noAutoloadHere ifFalse:[
(dir construct:'NOAUTOLOAD') exists ifTrue:[
noAutoloadHere := true.
].
] ifTrue:[
(dir construct:'AUTOLOAD') exists ifTrue:[
noAutoloadHere := false.
].
].
((dir construct:'loadAll') exists
or:[(dir construct:'abbrev.stc') exists
or:[(dir construct:(dir baseName , '.prj')) exists]]) ifTrue:[
KnownPackages isNil ifTrue:[
KnownPackages := Set new.
].
dirName := dir pathName.
pkgName := dirName copyFrom:(packageTopPath asFilename pathName) size + 1 + 1.
KnownPackages add:pkgName
].
"/
"/ suppress installation as autoloaded in this and everything
"/ below; however, still traverse the directories to find packages ...
"/
noAutoloadHere ifFalse:[
[
abbrevStream := (dir construct:'abbrev.stc') asFilename readStream.
self installAutoloadedClassesFromStream:abbrevStream.
abbrevStream close.
] on:FileStream openErrorSignal do:[:ex| "ignore this file"].
].
[
directoryContents := dir directoryContents.
] on:FileStream openErrorSignal do:[:ex|
"non-accessable directory: we are done"
^ self
].
directoryContents do:[:aFilename |
|f|
(#(
'doc'
'CVS'
'bitmaps'
'resources'
'source'
) includes:aFilename) ifFalse:[
((dir baseName ~= 'stx')
or:[
(#(
'configurations'
'include'
'rules'
'stc'
'support'
) includes:aFilename) not])
ifTrue:[
f := dir construct:aFilename.
f isDirectory ifTrue:[
self
recursiveInstallAutoloadedClassesFrom:f
rememberIn:dirsConsulted
maxLevels:maxLevels-1
noAutoload:noAutoloadHere
packageTop:packageTopPath.
]
]
].
].
"
Smalltalk installAutoloadedClasses
"
!
replaceReferencesTo:anObject with:newRef
|toAdd|
toAdd := OrderedCollection new.
self keysAndValuesDo:[:key :val |
(key == anObject) ifTrue:[
self shouldImplement.
].
(val == anObject ) ifTrue:[
toAdd add:(key -> newRef)
].
].
toAdd do:[:each |
self at:(each key) put:(each value)
].
!
saveEmergencyImage:aBoolean
"set/clear the flag which controls if ST/X should save an
emergency image in case of a broken display connection.
The default is true.
This may be useful, if you work with an unsecure display
(serial line), and want to have a chance of proceeding after
a crash. In multiheaded applications, this only affects
crashes of the master Display connection (the initial connection);
errors on other displays are reported to the views and treated
like window destroy from the windowManager."
SaveEmergencyImage := aBoolean
"Modified: / 24.10.1997 / 18:22:26 / cg"
!
systemOrganization
"for partial ST80 compatibility;
In ST80, Smalltalk organization returns a systemOrganizer, which
keeps track of class-categories, while all classes return a classOrganizer
from #organization, which keeps track of method categories of that class.
Since in ST/X, Smalltalk is a class, there is now a conflict.
To make a workaround possible, use #systemOrganization when porting
VW apps to ST/X to get the class-categories.
Read the documentation in SystemOrganizer for more info."
^ SystemOrganizer for:nil
"Created: / 20.6.1998 / 12:24:02 / cg"
"Modified: / 20.6.1998 / 12:41:34 / cg"
! !
!Smalltalk class methodsFor:'system management-fileIn'!
fileIn:aFileName
"read in the named file - look for it in some standard places;
return true if ok, false if failed.
This method can load almost anything which makes sense:
.st - source files
.cls - binary smalltalk bytecode files
.so - binary compiled machine code class libraries
[.class - java bytecode -- soon to come]"
^ self fileIn:aFileName lazy:nil silent:nil logged:false
"
Smalltalk fileIn:'source/TicTacToe.st'
Smalltalk fileIn:'binary/TicTacToe.cls'
Smalltalk fileIn:'binary/TicTacToe.so'
"
"Created: 28.10.1995 / 17:06:28 / cg"
!
fileIn:aFileName inPackage:aPackageID
"read in the named file in a packages directory."
|dir|
dir := self getPackageDirectoryForPackage:aPackageID.
dir isNil ifTrue:[^ false].
dir := dir asFilename.
^ (self fileIn:(dir construct:aFileName))
or:[ self fileIn:((dir construct:'source') construct:aFileName) ]
!
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:aFileNameOrString 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.
This method can load almost anything which makes sense:
.st - source files
.cls - binary smalltalk bytecode files
.so - binary compiled machine code class libraries
[.class - java bytecode -- soon to come]"
|fileNameString aStream path morePath bos|
fileNameString := aFileNameOrString asString.
"
an object or shared object ?
"
(ObjectFileLoader notNil
and:[ObjectFileLoader hasValidBinaryExtension:fileNameString]) ifTrue:[
"/ LoadBinaries ifFalse:[^ false].
path := self getBinaryFileName:fileNameString.
path isNil ifTrue:[
path := self getSystemFileName:fileNameString.
].
path isNil ifTrue:[^ false].
^ (ObjectFileLoader loadObjectFile:path) notNil
].
(fileNameString asFilename hasSuffix:'cls') ifTrue:[
BinaryObjectStorage notNil ifTrue:[
aStream := self systemFileStreamFor:fileNameString.
"/ path := self getBinaryFileName:fileNameString.
"/ path isNil ifTrue:[^ false].
"/ aStream := path asFilename readStream.
aStream notNil ifTrue:[
aStream binary.
bos := BinaryObjectStorage onOld:aStream.
bos next.
bos close.
^ true
].
^ false
]
].
(fileNameString startsWith:'source/') ifTrue:[
aStream := self sourceFileStreamFor:(fileNameString copyFrom:8)
] ifFalse:[
(fileNameString startsWith:'fileIn/') ifTrue:[
aStream := self fileInFileStreamFor:(fileNameString copyFrom:8)
] ifFalse:[
aStream := self systemFileStreamFor:fileNameString.
aStream isNil ifTrue:[
OperatingSystem isUNIXlike ifTrue:[
(fileNameString startsWith:'/') ifFalse:[
aStream := self systemFileStreamFor:('lib/' , fileNameString).
]
]
].
(aStream notNil and:[fileNameString 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
"
"Modified: / 16.2.1999 / 10:03:26 / cg"
!
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:ChangeFileName 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
package:nil
initialize:true
lazy:false
silent:nil
"Modified: / 9.1.1998 / 14:41:46 / cg"
!
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:[
SilentLoading ifFalse:[
Transcript show:' loaded ' , aClassName , ' from ' ; showCR:aFileName.
]
].
^ ok
"
Smalltalk fileInClass:'AbstractPath' fromObject:'../../goodies/Paths/AbstrPath.so'
Smalltalk fileInClass:'ClockView' fromObject:'../../libwidg3/libwidg3.so'
"
"Modified: 10.9.1996 / 20:43:52 / cg"
!
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
package:nil
initialize:doInit
lazy:false
silent:nil
"Modified: / 9.1.1998 / 14:42:02 / cg"
!
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
package:nil
initialize:doInit
lazy:loadLazy
silent:nil
"Modified: / 9.1.1998 / 14:42:19 / cg"
!
fileInClass:aClassName initialize:doInit lazy:loadLazy silent:beSilent
"find a source/object file for aClassName and -if found - load it.
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; it can be true, false or nil, where
nil uses the value from SilentLoading."
^ self
fileInClass:aClassName
package:nil
initialize:doInit
lazy:loadLazy
silent:beSilent
"Modified: / 9.1.1998 / 14:42:28 / cg"
!
fileInClass:aClassName package:package 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; it can be true, false or nil, where
nil uses the value from SilentLoading."
|shortName longName libName newClass ok wasLazy wasSilent sharedLibExtension inStream mgr
fn packageDir packageFile bos|
wasLazy := Compiler compileLazy:loadLazy.
beSilent notNil ifTrue:[
wasSilent := self silentLoading:beSilent.
].
longName := Smalltalk fileNameForClass:aClassName.
longName := longName copyReplaceAll:$: with:$_.
[
Class withoutUpdatingChangesDo:
[
|zarFn zar entry|
ok := false.
shortName := self fileNameForClass:aClassName.
package notNil ifTrue:[
packageDir := package asString.
packageDir := packageDir copyReplaceAll:$: with:$/.
].
Class packageQuerySignal answer:package
do:[
"
first, look for a loader-driver file (in fileIn/xxx.ld)
"
(ok := self fileIn:('fileIn/' , shortName , '.ld') lazy:loadLazy silent:beSilent)
ifFalse:[
"
try abbreviated driver-file (in fileIn/xxx.ld)
"
shortName ~= aClassName ifTrue:[
ok := self fileIn:('fileIn/' , longName , '.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:(shortName, sharedLibExtension))
ifFalse:[
sharedLibExtension ~= '.o' ifTrue:[
ok := self fileInClass:aClassName fromObject:(shortName, '.o')
].
ok ifFalse:[
shortName ~= aClassName ifTrue:[
(ok := self fileInClass:aClassName fromObject:(longName, sharedLibExtension))
ifFalse:[
sharedLibExtension ~= '.o' ifTrue:[
ok := self fileInClass:aClassName fromObject:(longName, '.o')
]
]
].
].
].
].
].
"
if that did not work, look for a compiled-bytecode file ...
"
ok ifFalse:[
(ok := self fileIn:(shortName , '.cls') lazy:loadLazy silent:beSilent)
ifFalse:[
shortName ~= aClassName ifTrue:[
ok := self fileIn:(longName , '.cls') lazy:loadLazy silent:beSilent
]
]
].
"
if that did not work, and the classes package is known,
look for an st-cls file
in a package subdir of the source-directory ...
"
ok ifFalse:[
(packageDir notNil and:[BinaryObjectStorage notNil]) ifTrue:[
packageFile := self getPackageFileName:(packageDir , '/classes/' , shortName , '.cls').
packageFile isNil ifTrue:[
packageFile := (packageDir , '/classes/' , shortName , '.cls').
].
(ok := self fileIn:packageFile lazy:loadLazy silent:beSilent)
ifFalse:[
shortName ~= aClassName ifTrue:[
packageFile := self getPackageFileName:(packageDir , '/classes/' , longName , '.cls').
packageFile isNil ifTrue:[
packageFile := (packageDir , '/classes/' , longName , '.cls').
].
ok := self fileIn:packageFile lazy:loadLazy silent:beSilent
]
].
zarFn := self getPackageFileName:(packageDir , '/classes.zip').
zarFn notNil ifTrue:[
zar := ZipArchive oldFileNamed:zarFn.
zar notNil ifTrue:[
entry := zar extract:(shortName , '.cls').
(entry isNil and:[shortName ~= longName]) ifTrue:[
entry := zar extract:(longName , '.cls').
].
entry notNil ifTrue:[
bos := BinaryObjectStorage onOld:(entry asByteArray readStream).
bos next.
bos close.
ok := true
].
]
]
]
].
"
if that did not work, look for an st-source file ...
"
ok ifFalse:[
fn := shortName , '.st'.
(ok := self fileIn:fn lazy:loadLazy silent:beSilent)
ifFalse:[
shortName ~= longName ifTrue:[
fn := longName , '.st'.
ok := self fileIn:fn lazy:loadLazy silent:beSilent
].
ok ifFalse:[
"
... and in the standard source-directory
"
fn := 'source/' , shortName , '.st'.
(ok := self fileIn:fn lazy:loadLazy silent:beSilent)
ifFalse:[
shortName ~= longName ifTrue:[
fn := 'source/' , longName , '.st'.
ok := self fileIn:fn lazy:loadLazy silent:beSilent
]
]
]
].
"
if that did not work, and the classes package is known,
look for an st-source file
in a package subdir of the source-directory ...
"
ok ifFalse:[
packageDir notNil ifTrue:[
packageFile := self getPackageFileName:(packageDir , '/source/' , shortName , '.st').
packageFile isNil ifTrue:[
packageFile := (packageDir , '/source/' , shortName , '.st').
].
fn := packageFile.
(ok := self fileIn:packageFile lazy:loadLazy silent:beSilent)
ifFalse:[
shortName ~= aClassName ifTrue:[
packageFile := self getPackageFileName:(packageDir , '/source/' , longName , '.st').
packageFile isNil ifTrue:[
packageFile := (packageDir , '/source/' , longName , '.st').
].
fn := packageFile.
ok := self fileIn:packageFile lazy:loadLazy silent:beSilent
].
ok ifFalse:[
packageFile := self getPackageFileName:(packageDir , '/' , shortName , '.st').
packageFile isNil ifTrue:[
packageFile := (packageDir , '/' , shortName , '.st').
].
fn := packageFile.
(ok := self fileIn:packageFile lazy:loadLazy silent:beSilent)
ifFalse:[
shortName ~= aClassName ifTrue:[
packageFile := self getPackageFileName:(packageDir , '/' , longName , '.st').
packageFile isNil ifTrue:[
packageFile := (packageDir , '/' , longName , '.st').
].
fn := packageFile.
ok := self fileIn:packageFile lazy:loadLazy silent:beSilent
].
ok ifFalse:[
"
... and in the standard source-directory
"
fn := 'source/' , packageDir , '/' , shortName , '.st'.
(ok := self fileIn:fn lazy:loadLazy silent:beSilent)
ifFalse:[
shortName ~= aClassName ifTrue:[
fn := 'source/' , packageDir , '/' , longName , '.st'.
ok := self fileIn:fn lazy:loadLazy silent:beSilent
]
]
]
].
].
].
]
].
"
if that did not work, and the classes package is known,
look for a zipArchive containing a class entry.
"
ok ifFalse:[
packageDir notNil ifTrue:[
zarFn := self getPackageFileName:(packageDir , '/source.zip').
zarFn isNil ifTrue:[
zarFn := packageDir asFilename withSuffix:'zip'.
zarFn := self getSourceFileName:zarFn.
].
zarFn notNil ifTrue:[
zar := ZipArchive oldFileNamed:zarFn.
zar notNil ifTrue:[
entry := zar extract:(shortName , '.st').
(entry isNil and:[shortName ~= longName]) ifTrue:[
entry := zar extract:(longName , '.st').
].
entry notNil ifTrue:[
fn := zarFn.
ok := self
fileInStream:(entry asString readStream)
lazy:loadLazy
silent:beSilent
logged:false
addPath:nil
].
]
]
]
].
"
if that did not work,
look for a zipArchive containing a class entry.
"
ok ifFalse:[
zarFn := self getSourceFileName:'source.zip'.
zarFn notNil ifTrue:[
zar := ZipArchive oldFileNamed:zarFn.
zar notNil ifTrue:[
entry := zar extract:(zarFn := shortName , '.st').
(entry isNil and:[shortName ~= longName]) ifTrue:[
entry := zar extract:(zarFn := longName , '.st').
].
entry notNil ifTrue:[
fn := zarFn.
ok := self
fileInStream:(entry asString readStream)
lazy:loadLazy
silent:beSilent
logged:false
addPath:nil
].
]
]
].
ok ifFalse:[
"
new: if there is a sourceCodeManager, ask it for the classes sourceCode
"
(mgr := Smalltalk at:#SourceCodeManager) notNil ifTrue:[
inStream := mgr getMostRecentSourceStreamForClassNamed:aClassName.
inStream notNil ifTrue:[
fn := nil.
ok := self fileInStream:inStream lazy:loadLazy silent:beSilent logged:false addPath:nil.
]
].
].
].
].
]
]
].
ok ifTrue:[
newClass := self at:(aClassName asSymbol).
newClass notNil ifTrue:[
fn notNil ifTrue:[
newClass classFilename isNil ifTrue:[
newClass setClassFilename:fn
].
].
doInit ifTrue:[
newClass initialize
]
]
].
] ensure:[
Compiler compileLazy:wasLazy.
wasSilent notNil ifTrue:[
self silentLoading:wasSilent
]
].
^ newClass
"Created: / 9.1.1998 / 14:40:32 / cg"
"Modified: / 5.6.1999 / 14:53:01 / 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.
Notice: the argument may not have an extension (by purpose);
the sharedLib extension (.dll / .so / .sl) is added here, to
make the caller independent of the underlying operatingSystem."
|path fn|
ObjectFileLoader isNil ifTrue:[^ false].
fn := aClassLibraryName asFilename withSuffix:(ObjectFileLoader sharedLibrarySuffix).
fn := fn pathName.
path := self getBinaryFileName:fn.
path isNil ifTrue:[
path := self getSystemFileName:fn.
].
path isNil ifTrue:[^ false].
^ (ObjectFileLoader loadObjectFile:path) notNil
"
Smalltalk fileInClassLibrary:'libtable'
Smalltalk fileInClassLibrary:'binary/libwidg3'
"
"Modified: 8.1.1997 / 17:58:56 / cg"
!
fileInClassLibrary:aClassLibraryName inPackage:packageID
"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.
Notice: the argument may not have an extension (by purpose);
the sharedLib extension (.dll / .so / .sl) is added here, to
make the caller independent of the underlying operatingSystem."
|path fn|
ObjectFileLoader isNil ifTrue:[^ false].
fn := aClassLibraryName asFilename withSuffix:(ObjectFileLoader sharedLibrarySuffix).
fn := fn pathName.
path := self getPackageDirectoryForPackage:packageID.
path isNil ifTrue:[^ false].
path := path asFilename construct:fn.
path exists ifFalse:[^ false].
^ (ObjectFileLoader loadObjectFile:path pathName) notNil
"
Smalltalk fileInClassLibrary:'libtable'
Smalltalk fileInClassLibrary:'binary/libwidg3'
Smalltalk fileInClassLibrary:'refactoryBrowser' inPackage:'stx:goodies/refactoryBrowser'
"
"Modified: 8.1.1997 / 17:58:56 / cg"
!
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 answer:logged do:[
Class updateChangeListQuerySignal answer:logged do:[
oldSystemPath := SystemPath copy.
[
morePath notNil ifTrue:[
SystemPath addFirst:morePath.
oldRealPath := RealSystemPath.
RealSystemPath := nil.
].
aStream fileIn
] ensure:[
morePath notNil ifTrue:[
SystemPath := oldSystemPath.
RealSystemPath := oldRealPath.
].
].
]
]
] ensure:[
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
"
"Modified: 5.11.1996 / 20:03:35 / cg"
!
isClassLibraryLoaded:name
"return true, if a particular class library is already loaded"
ObjectMemory
binaryModuleInfo
do:[:entry |
entry type == #classLibrary ifTrue:[
entry libraryName = name ifTrue:[
^ true "/ already loaded
]
].
].
^ false
"
Smalltalk isClassLibraryLoaded:'libbasic'
Smalltalk isClassLibraryLoaded:'libwidg3'
"
!
loadClassLibraryIfAbsent:name
"dynamically load a classLibrary, if not already loaded
and the system supports dynamic loading.
Return true, if the library is loaded, false if not.
This entry is called without system specific filename
extensions - it is portable among different architectures
as long as corresponding files (x.so / x.dll / x.sl / x.o)
are be present ..."
(self isClassLibraryLoaded:name) ifTrue:[ ^ true ]. "/ already loaded
^ self fileInClassLibrary:name
"
Smalltalk loadClassLibraryIfAbsent:'libbasic'
Smalltalk loadClassLibraryIfAbsent:'libwidg3'
"
"Modified: 31.10.1996 / 16:57:24 / cg"
!
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
] ensure:[
self silentLoading:wasSilent
]
! !
!Smalltalk class methodsFor:'system management-files'!
bitmapFileStreamFor:aFileName
"search aFileName in some standard places;
return a readonly fileStream or nil if not found.
Searches in subdirectories named 'bitmaps' in the SystemPath.
Notice: this does not look in the package-specific bitmaps directories."
|aString|
aString := self getBitmapFileName:aFileName.
aString notNil ifTrue:[
^ aString asFilename readStreamOrNil
].
^ nil
!
bitmapFromFileNamed:aFileName forClass:aClass
"search aFileName in some standard places:
first in the redefinable bitmaps path,
then in the classes own package directory if existing.
Return an image or nil."
^ self imageFromFileNamed:aFileName inPackage:(aClass package)
"
Smalltalk bitmapFromFileNamed:'SmalltalkX.xbm' forClass:View
"
!
bitmapFromFileNamed:aFileName inPackage:aPackage
"search aFileName in some standard places:
first in the redefinable bitmaps path,
then in the package directory if existing.
Return an image or nil."
^ self imageFromFileNamed:aFileName inPackage:aPackage
"
Smalltalk bitmapFromFileNamed:'SmalltalkX.xbm' inPackage:'stx:libview'
Smalltalk bitmapFromFileNamed:'SmalltalkX.xbm' inPackage:'stx:libtool'
"
!
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 asFilename hasSuffix:'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"
!
constructPathFor:aDirectoryName
"search for aDirectory in SystemPath;
return a collection of pathes which include that directory."
^ self realSystemPath select:[:dirName |
|fullPath|
fullPath := dirName asFilename construct:aDirectoryName.
"/ fullPath exists and:[fullPath isDirectory and:[fullPath isReadable]]
fullPath isDirectory and:[fullPath isReadable]
].
!
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:[
^ aString asFilename readStreamOrNil
].
^ nil
!
fileNameForClass:aClassOrClassName
"return a filename for aClassOrClassName"
|cls nm1 nm2|
aClassOrClassName isBehavior ifTrue:[
nm1 := aClassOrClassName theNonMetaclass name.
nm2 := aClassOrClassName theNonMetaclass nameWithoutPrefix.
] ifFalse:[
cls := Smalltalk classNamed:aClassOrClassName.
cls notNil ifTrue:[
nm1 := cls theNonMetaclass name.
nm2 := cls theNonMetaclass nameWithoutPrefix.
] ifFalse:[
nm1 := aClassOrClassName.
nm2 := (aClassOrClassName copyFrom:(aClassOrClassName lastIndexOf:$:)+1).
].
].
nm1 := nm1 asSymbol.
nm2 := nm2 asSymbol.
CachedAbbreviations notNil ifTrue:[
(CachedAbbreviations includesKey:nm1) ifTrue:[
^ CachedAbbreviations at:nm1
].
nm2 notNil ifTrue:[
^ CachedAbbreviations at:nm2 ifAbsent:nm1
].
].
^ nm1
"/ "return a good filename for aClassOrClassName -
"/ using the abbreviation file if there is one"
"/
"/ |fileName abbrev cls fullClassName shortClassName|
"/
"/ aClassOrClassName isBehavior ifTrue:[
"/ cls := aClassOrClassName theNonMetaclass.
"/ fullClassName := cls name.
"/ shortClassName := cls nameWithoutPrefix.
"/ ] ifFalse:[
"/ fullClassName := shortClassName := aClassOrClassName.
"/ shortClassName := shortClassName copyFrom:(shortClassName lastIndexOf:$:)+1.
"/ ].
"/
"/ fileName := fullClassName asSymbol.
"/
"/ "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"
"/ ('Smalltalk [info]: cant find short for ' , fileName , ' in abbreviation file') infoPrintCR.
"/ ].
"/
"/ fileName := shortClassName asSymbol.
"/ ^ fileName asString
"
Smalltalk fileNameForClass:#Complex
Smalltalk fileNameForClass:'SmallInteger'
Smalltalk fileNameForClass:'UnixOperatingSystem'
Smalltalk fileNameForClass:'Launcher'
Smalltalk fileNameForClass:'SomeUnknownClass'
Smalltalk fileNameForClass:OSI::FTAMOperation
Smalltalk fileNameForClass:'OSI::Foobar'
"
"Modified: / 5.11.2001 / 16:49:17 / 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 }"
"forget pathCaches - these are collections containing valid directory names,
where system files (resource, bitmaps etc.) are found.
A flush is only required, if a new system directory has been created while
the system is active, and those files should override the others
(for example, if you created a private resource directory)"
RealSystemPath := ResourcePath := SourcePath :=
BitmapPath := BinaryPath := FileInPath := nil
"
Smalltalk flushPathCaches
"
!
getBinaryFileName:aFileName
"search aFileName in some standard places
(subdirectories named 'binary' in SystemPath);
return the absolute filename or nil if none is found."
BinaryPath isNil ifTrue:[
BinaryPath := self constructPathFor:BinaryDirName
].
^ self searchPath:BinaryPath for:aFileName in:BinaryDirName
"Modified: 18.7.1996 / 15:53:49 / cg"
!
getBitmapFileName:aFileName
"search aFileName in some standard places
(subdirectories named 'bitmaps' in SystemPath);
return the absolute filename or nil if none is found."
|f|
BitmapPath isNil ifTrue:[
BitmapPath := self constructPathFor:BitmapDirName
].
"/ first, try a bitmaps subdir along the path.
f := self searchPath:BitmapPath for:aFileName in:BitmapDirName.
f isNil ifTrue:[
"/ then, try it itself along the path.
f := self searchPath:self realSystemPath for:aFileName in:nil
].
^ f
"
Smalltalk getBitmapFileName:'SBrowser.xbm'
"
"Modified: 18.7.1996 / 15:53:55 / cg"
!
getFileInFileName:aFileName
"search aFileName in some standard places
(subdirectories named 'fileIn' in SystemPath);
return the absolute filename or nil if none is found."
FileInPath isNil ifTrue:[
FileInPath := self constructPathFor:FileInDirName
].
^ self searchPath:FileInPath for:aFileName in:FileInDirName
"Modified: 18.7.1996 / 15:53:59 / cg"
!
getPackageDirectoryForPackage:aPackageID
"search for a particular package; return its directory, or nil"
|packageDir|
packageDir := aPackageID copyReplaceAll:$: with:$/.
self packagePath do:[:aPath |
|dir|
dir := aPath asFilename construct:packageDir.
(dir exists and:[dir isDirectory]) ifTrue:[^ dir].
].
"/ not found - special case for the stx package ...
(aPackageID upTo:$:) = 'stx' ifTrue:[
packageDir := aPackageID copyFrom:(aPackageID indexOf:$:) + 1.
packageDir := '../../' , packageDir.
packageDir := packageDir asFilename.
(packageDir exists and:[packageDir isDirectory]) ifTrue:[^ packageDir].
].
^ nil
"
Smalltalk getPackageDirectoryForPackage:(Array package)
Smalltalk getPackageDirectoryForPackage:'stx:goodies/bitmaps'
Smalltalk getPackageDirectoryForPackage:'stx:libview'
"
!
getPackageFileName:aFileName
"search aFileName in some standard places
(packagePath and subdirectories named 'packages' in SystemPath);
return the absolute filename or nil if none is found."
|f|
"/ search along packagePath ...
f := self searchPath:self packagePath for:aFileName in:nil.
f isNil ifTrue:[
"/ search under packages-directory along systemPath ...
f := self searchPath:self realSystemPath for:aFileName in:PackageDirName.
"/ kludge - allow for stx-directory to be named differently
f isNil ifTrue:[
(aFileName startsWith:'stx') ifTrue:[
(aFileName startsWith:'stx' , Filename separator) ifTrue:[
f := '../..' asFilename construct:(aFileName copyFrom:5).
f exists ifTrue:[
^ f pathName
].
]
].
].
].
(f notNil and:[(f := f asFilename) exists]) ifTrue:[
^ f pathName
].
^ nil
"
Smalltalk getPackageFileName:'stx/libview/resources/normal.style'
Smalltalk getPackageFileName:'stx/libview/source.zip'
"
!
getResourceFileName:aFileName
"search aFileName in some standard places
(subdirectories named 'resource' in SystemPath);
return the absolute filename or nil if none is found."
|f|
ResourcePath isNil ifTrue:[
ResourcePath := self constructPathFor:ResourceDirName
].
"/ first, try a resource subdir along the path.
f := self searchPath:ResourcePath for:aFileName in:ResourceDirName.
f isNil ifTrue:[
"/ then, try it itself along the path.
f := self searchPath:self realSystemPath for:aFileName in:nil
].
^ f
"
Smalltalk getResourceFileName:'SystemBrowser.rs'
"
"Modified: 18.7.1996 / 15:54:03 / cg"
!
getResourceFileName:aFileName forClass:aClassOrNil
"search aFileName in some standard places
(subdirectories named 'resource' in SystemPath);
and in aClasses package directory.
Return the absolute filename or nil if none is found."
|pkgOrNil|
aClassOrNil notNil ifTrue:[
pkgOrNil := aClassOrNil package.
].
^ self getResourceFileName:aFileName forPackage:pkgOrNil.
"
Smalltalk getResourceFileName:'SystemBrowser.rs' forClass:SystemBrowser
"
!
getResourceFileName:aFileName forPackage:aPackageIDOrNil
"search aFileName in some standard places
(subdirectories named 'resource' in SystemPath);
and in a packages directory.
Return the absolute filename or nil if none is found."
|f dir packageDir|
f := self getResourceFileName:aFileName.
f notNil ifTrue:[^ f].
aPackageIDOrNil notNil ifTrue:[
packageDir := aPackageIDOrNil copyReplaceAll:$: with:$/.
self packagePath do:[:aPath |
|pD|
pD := aPath asFilename construct:packageDir.
pD exists ifTrue:[
f := pD construct:aFileName.
f exists ifTrue:[
^ f pathName
].
f := (pD construct:'resources') construct:aFileName.
f exists ifTrue:[
^ f pathName
].
].
].
dir := Smalltalk getPackageDirectoryForPackage:(aPackageIDOrNil ? 'stx:libview').
dir notNil ifTrue:[
f := (dir asFilename construct:'resources') construct:aFileName.
f exists ifTrue:[
^ f pathName
].
f := (dir asFilename construct:'styles') construct:aFileName.
f exists ifTrue:[
^ f pathName
].
].
].
^ nil
"
Smalltalk getResourceFileName:'SystemBrowser.rs' forPackage:'stx:libtool'
Smalltalk getResourceFileName:'normal.style' forPackage:'stx:libview'
"
!
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."
|f|
SourcePath isNil ifTrue:[
SourcePath := self constructPathFor:SourceDirName
].
"/ first, try a source subdir along the path.
SourcePath notNil ifTrue:[
f := self searchPath:SourcePath for:aFileName in:SourceDirName.
].
f isNil ifTrue:[
"/ then, try it itself along the path.
f := self searchPath:self realSystemPath for:aFileName in:nil
].
^ f
"
Smalltalk getSourceFileName:'Smalltalk.st'
Smalltalk getSourceFileName:'ArrColl.st'
"
"Modified: 18.7.1996 / 15:54:07 / cg"
!
getSystemFileName:aFileNameOrString
"search aFileNameOrString in some standard places;
return the absolute filename or nil if none is found.
see comment in Smalltalk>>initSystemPath.
This should be used to access resources such as bitmaps, doc-files,
and other help files.
"
"credits for this method go to Markus ...."
|fn nameString|
fn := aFileNameOrString asFilename.
nameString := fn name.
fn isAbsolute ifTrue:[
"dont use path for absolute file names"
^ nameString
].
self realSystemPath do:[:dirName |
|realName|
realName := dirName asFilename construct:nameString.
"/
"/ here, we also return true if its a directory
"/ (Even if unreadable).
"/ It could be that the file itself is still readable.
"/
(realName isDirectory or:[realName isReadable]) ifTrue: [
^ realName name
]
].
^ nil
"
Smalltalk getSystemFileName:'doc/online/english/TOP.html'
Smalltalk getSystemFileName:'bitmaps/SBrowser.xbm'
Smalltalk getSystemFileName:'bitmaps/foo'
Smalltalk getSystemFileName:'resources/View.rs'
Smalltalk getSystemFileName:'resources/iris.style'
"
"Modified: / 6.5.1999 / 10:40:37 / cg"
!
imageFromFileNamed:aFileName forClass:aClass
"search aFileName in some standard places:
first in the redefinable bitmaps path, then in the classes
own package directory if existing.
Return an image or nil."
|package nm img|
package := aClass package.
img := self imageFromFileNamed:aFileName inPackage:package.
img isNil ifTrue:[
package ~= 'stx:goodies' ifTrue:[
"/ try under the goodies package ...
img := Smalltalk imageFromFileNamed:aFileName inPackage:'stx:goodies'.
].
img isNil ifTrue:[
(aFileName startsWith:'bitmaps') ifFalse:[
nm := 'bitmaps/' , aFileName.
img := Smalltalk imageFromFileNamed:nm forClass:self.
img isNil ifTrue:[
img := Smalltalk imageFromFileNamed:nm inPackage:'stx:goodies'.
]
].
img isNil ifTrue:[
img := Smalltalk imageFromFileNamed:aFileName inPackage:'stx:goodies'.
].
]
].
^ img
"
Smalltalk imageFromFileNamed:'SmalltalkX.xbm' forClass:View
"
!
imageFromFileNamed:aFileName inPackage:aPackage
"search aFileName in some standard places:
first in the redefinable bitmaps path, then in the
package directory if existing.
Return an image or nil."
|i f dir|
i := Image fromFile:aFileName resolution:100.
i notNil ifTrue:[^ i].
f := self getBitmapFileName:aFileName.
f notNil ifTrue:[
i := Image fromFile:f.
i notNil ifTrue:[^ i].
].
dir := self projectDirectoryForPackage:aPackage.
dir isNil ifTrue:[^ nil].
((f := aFileName) startsWith:'bitmaps/') ifFalse:[
i := Image fromFile:(dir asFilename construct:f).
i notNil ifTrue:[^ i].
f := 'bitmaps/' , aFileName.
].
^ Image fromFile:(dir asFilename construct:f).
"
Smalltalk imageFromFileNamed:'SmalltalkX.xbm' inPackage:'stx:libview'
Smalltalk imageFromFileNamed:'SmalltalkX.xbm' inPackage:'stx:libtool'
Smalltalk imageFromFileNamed:'bitmaps/gifImages/garfield.gif' inPackage:'stx:goodies'
"
!
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:[
aStream close.
^ (words at:col) withoutSeparators
]
]
]
]
]
].
aStream close
].
].
^ nil
"
Smalltalk libraryFileNameOfClass:'ClockView'
Smalltalk libraryFileNameOfClass:'Bag'
"
"Modified: 6.11.1995 / 15:41:39 / cg"
!
packagePath
"return a collection of additional directorynames, where smalltalk
looks for package directories.
Notice, that directories named 'packages' under the systemPath are
always consulted - even if not in the packagePath"
^ PackagePath
"
Smalltalk packagePath
Smalltalk packagePath addLast:'/opt/smalltalk'
Smalltalk packagePath addFirst:'/usr/local/otherPackages'
"
!
packagePath:aPath
"set the packagePath;
a collection of additional directorynames, where smalltalk
looks for package directories.
Notice, that directories named 'packages' under the systemPath are
always consulted - even if not in the packagePath"
PackagePath := aPath asOrderedCollection
"
Smalltalk packagePath:#( '.' '/opt/stx' '/opt/smalltalk' '/usr/local/otherPackages')
"
!
projectDirectoryForClass:aClass
"given a class, return the path to its package directory;
nil if not found."
|pkg|
pkg := aClass package.
pkg isNil ifTrue:[^ nil].
^ self projectDirectoryForPackage:pkg.
"
Smalltalk projectDirectoryForClass:Array
Smalltalk projectDirectoryForClass:View
"
!
projectDirectoryForPackage:aPackage
"given a packageID, return the path to its package directory;
nil if not found."
|prj prjDir|
"/ there might be a package specific resource directory ...
"/ in the directory, from which the project was loaded
prj := Project projectWithId:aPackage.
prj notNil ifTrue:[
prjDir := prj directory.
].
(prjDir notNil and:[prjDir asFilename exists]) ifFalse:[
prjDir := Smalltalk getPackageFileName:(aPackage copyReplaceAll:$: with:$/).
].
^ prjDir
"
Smalltalk projectDirectoryForPackage:'stx:libbasic'
Smalltalk projectDirectoryForPackage:'exept:smartcard'
"
!
readAbbreviations
"read classname to filename mappings from include/abbrev.stc.
sigh - all for those poor sys5.3 or MSDOS people with short filenames ..."
"since installAutoloadedClasses also reads all abbreviations, use it"
CachedAbbreviations := IdentityDictionary new.
self installAutoloadedClasses.
^ CachedAbbreviations.
"/ |aStream f dirsConsulted|
"/
"/ CachedAbbreviations := IdentityDictionary new.
"/
"/ "/ new scheme: look for a directory called 'packages'
"/ "/ and enumerate its abbrev.stc files...
"/ dirsConsulted := Set new.
"/ f := Smalltalk getSystemFileName:'packages'.
"/ f notNil ifTrue:[
"/ f := f asFilename.
"/ f isDirectory ifTrue:[
"/ ('Smalltalk [info]: reading all class abbreviations found under ''' , f pathName ,'''') infoPrintCR.
"/ self recursiveReadAllAbbreviationsFrom:f.
"/ dirsConsulted add:f pathName.
"/ ].
"/ ].
"/
"/ "/ and along the package-path
"/ self packagePath do:[:aPath |
"/ (dirsConsulted includes:aPath) ifFalse:[
"/ ('Smalltalk [info]: reading all class abbreviations found under ''' , aPath ,'''') infoPrintCR.
"/ self recursiveReadAllAbbreviationsFrom:aPath.
"/ dirsConsulted add:aPath
"/ ]
"/ ].
"/
"/ "/ old scheme: look for a single file called 'abbrev.stc' in the
"/ "/ include directory. This will vanish.
"/
"/ aStream := self systemFileStreamFor:'include/abbrev.stc'.
"/ aStream notNil ifTrue:[
"/ ('Smalltalk [info]: reading additional abbreviations from ''' , aStream pathName ,'''') infoPrintCR.
"/ self readAbbreviationsFromStream:aStream.
"/ aStream close.
"/"/ ] ifFalse:[
"/"/ ('Smalltalk [warning]: no global''include/abbrev.stc'' file found') infoPrintCR
"/ ].
"/ ^ CachedAbbreviations
"
Smalltalk readAbbreviations
"
"Modified: / 10.12.1999 / 17:48:53 / cg"
!
readAbbreviationsFromStream:aStream
"read classname to filename mappings from aStream.
sigh - all for those poor sys5.3 or MSDOS people with short filenames ..."
|abbrevs line words nm abbrev pkg key oldAbbrev cls s w|
abbrevs := CachedAbbreviations.
[aStream atEnd] whileFalse:[
line := aStream nextLine.
line notNil ifTrue:[
(line startsWith:'#') ifFalse:[
"/ must do it manually, caring for quoted strings.
"/ words := line asCollectionOfWords.
words := OrderedCollection new.
s := line readStream.
[s atEnd] whileFalse:[
s skipSeparators.
s peek == $' ifTrue:[
s next.
w := s upTo:$'.
s skipSeparators.
] ifFalse:[
w := s upToSeparator
].
words add:w
].
words size >= 3 ifTrue:[
nm := (words at:1) withoutSeparators.
abbrev := (words at:2) withoutSeparators.
pkg := (words at:3) withoutSeparators.
nm ~= abbrev ifTrue:[
key := nm asSymbol.
oldAbbrev := abbrevs at:key ifAbsent:nil.
oldAbbrev notNil ifTrue:[
oldAbbrev ~= abbrev ifTrue:[
StandAlone ifFalse:[
('Smalltalk [warning]: conflict for: ' , nm , ' in ' , (aStream pathName)) infoPrintCR.
('Smalltalk [warning]: (' , oldAbbrev , ' <-> ' , abbrev , ')') infoPrintCR
]
].
] ifFalse:[
cls := self classNamed:abbrev.
cls notNil ifTrue:[
cls name ~= nm ifTrue:[
"/ ok, there is a class named after this abbrev ...
"/ this is only a conflict, if the other class has no
"/ abbreviation (or the same).
(abbrevs at:(cls name asSymbol) ifAbsent:cls name) = abbrev ifTrue:[
cls isNameSpace ifFalse:[
pkg = cls package ifTrue:[
StandAlone ifFalse:[
('Smalltalk [warning]: conflict for: ' , cls name , ' in ' , (aStream pathName)) infoPrintCR.
('Smalltalk [warning]: (' , nm , ' -> ' , abbrev , ')') infoPrintCR
]
]
]
]
]
].
abbrevs at:nm asSymbol put:abbrev.
]
]
] ifFalse:[
('Smalltalk [warning]: malformed line in ' , (aStream pathName)) infoPrintCR.
]
]
]
].
"Modified: / 13.12.1999 / 11:54:17 / cg"
!
realSystemPath
"return the realSystemPath - thats the directorynames from
SystemPath which exist and are readable"
|nP|
RealSystemPath isNil ifTrue:[
OperatingSystem isVMSlike ifTrue:[
"/ temporary kludge: since we cannot currently
"/ check for existance of a name like 'volume:',
"/ leave those in the Path without a check.
RealSystemPath := SystemPath select:[:dirName |
|f|
f := dirName asFilename.
f isVolumeOnly ifTrue:[
true
] ifFalse:[
(f isDirectory) and:[f isReadable]
]
]
] ifFalse:[
RealSystemPath := SystemPath select:[:dirName |
|f|
f := dirName asFilename.
(f isDirectory) and:[f isReadable]
].
RealSystemPath := RealSystemPath collect:[:dirName |
|f|
f := dirName asFilename pathName.
].
"/ remove duplicates (but keep order)
nP := OrderedCollection new.
RealSystemPath do:[:p |
(nP includes:p) ifFalse:[
nP add:p
]
].
RealSystemPath := nP.
].
].
^ RealSystemPath
!
recursiveReadAllAbbreviationsFrom:aDirectory
self recursiveReadAllAbbreviationsFrom:aDirectory maxLevels:15
!
recursiveReadAllAbbreviationsFrom:aDirectory maxLevels:maxLevels
"read all abbreviations from and under aDirectory."
|abbrevStream dir directoryContents|
maxLevels == 0 ifTrue:[
"/ 'Smalltalk [warning]: max directory nesting reached.' infoPrintCR.
^ self
].
dir := aDirectory asFilename.
dir exists ifFalse:[^ self].
[
abbrevStream := (dir construct:'abbrev.stc') asFilename readStream.
self readAbbreviationsFromStream:abbrevStream.
abbrevStream close.
] on:FileStream openErrorSignal do:[:ex| "ignore this file"].
[
directoryContents := dir directoryContents.
] on:FileStream openErrorSignal do:[:ex|
"non-accessable directory: we are done"
^ self
].
directoryContents do:[:aFilename |
|f|
(#(
'doc'
'CVS'
'bitmaps'
'resources'
'source'
) includes:aFilename) ifFalse:[
f := dir construct:aFilename.
f isDirectory ifTrue:[
self recursiveReadAllAbbreviationsFrom:f maxLevels:maxLevels-1
]
].
].
!
resourceFileStreamFor:aFileName
"search aFileName in some standard places;
return a readonly fileStream or nil if not found.
Searches in subdirectories named 'resource' in SystemPath"
^ self resourceFileStreamFor:aFileName forClass:nil
!
resourceFileStreamFor:aFileName forClass:aClassOrNil
"search aFileName in some standard places and in the classes
package-resource directory.
Return a readonly fileStream or nil if not found.
Searches in subdirectories named 'resource' in SystemPath"
|aString|
aString := self getResourceFileName:aFileName forClass:aClassOrNil.
aString notNil ifTrue:[
^ aString asFilename readStreamOrNil
].
^ nil
!
searchPath:aPath for:aFileName in:aDirName
"search aPath for a subdirectory named aDirectory with a file
named aFileName"
|f|
((f := aFileName asFilename) isAbsolute
or:[f isExplicitRelative]) ifTrue:[
"/
"/ dont use path for absolute or explicit .-relative file names
"/
^ aFileName
].
aPath notNil ifTrue:[
aPath do:[:dirName |
|realName dir|
dir := dirName asFilename.
aDirName notNil ifTrue:[
realName := (dir construct:aDirName) construct:aFileName.
] ifFalse:[
realName := dir construct:aFileName.
].
(realName isReadable) ifTrue:[
^ realName name
]
].
].
^ nil.
"Modified: / 29.4.1999 / 15:06:43 / cg"
!
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:[
aStream close.
^ (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"
"Modified: 3.1.1997 / 11:26:44 / stefan"
!
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:[
^ aString asFilename readStreamOrNil
].
^ 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:[
^ aString asFilename readStreamOrNil
].
^ 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:'system management-packages'!
knownPackages
^ KnownPackages ? #()
!
loadExtensionsForPackage:aPackageId
|packageDirName|
packageDirName := aPackageId copyReplaceAll:$: with:$/.
packageDirName := self getPackageFileName:packageDirName.
packageDirName isNil ifTrue:[
^ false
].
^ self loadExtensionsFromDirectory:packageDirName
!
loadExtensionsFromDirectory:packageDirOrString
|packageDir f|
packageDir := packageDirOrString asFilename.
f := packageDir construct:'extensions.st'.
f exists ifTrue:[
f fileIn.
SilentLoading ifFalse:[
Transcript showCR:('loaded extensions: ' , f pathName).
].
^ true
].
^ false
!
loadPackage:aPackageIdOrPackage
"make certain, that some particular package is loaded into the system.
Experimental."
(aPackageIdOrPackage isSymbol
or:[aPackageIdOrPackage isString]) ifTrue:[
^ self loadPackageWithId:aPackageIdOrPackage asAutoloaded:false
].
self shouldImplement.
"
Smalltalk loadPackage:'stx:libbasic'
Smalltalk loadPackage:'stx:goodies/persistency'
Smalltalk loadPackage:'cg:cparser'
Smalltalk loadPackage:'cg:rose'
"
!
loadPackage:packageId fromAllSourceFilesInDirectory:aDirectory
"load all source files found in aDirectory and treat them like
a package. Allows for initial import of alien ST-code as a new package.
Experimental."
|p t new anyFail|
"/ problem: dependencies.
"/ solution: repeat twice, so that superclasses are present the second time
Class packageQuerySignal answer:packageId asSymbol do:[
|any|
2 timesRepeat:[
anyFail := false.
aDirectory directoryContents do:[:file |
|fn|
fn := aDirectory construct:file.
(fn hasSuffix:'st') ifTrue:[
Metaclass confirmationQuerySignal answer:false do:[
(self fileIn:fn) ifFalse:[
anyFail := true
] ifTrue:[
any := true.
]
]
]
].
any ifFalse:[
^ false "/ no file found
]
].
].
new := (p := Project projectWithId:packageId) isNil.
new ifTrue:[ p := Project new].
p name:packageId.
p directory:aDirectory.
p package:packageId.
t := packageId asCollectionOfSubstringsSeparatedByAny:'/\:'.
p repositoryModule:(t first).
p repositoryDirectory:(packageId copyFrom:t first size + 2).
p isLoaded:true.
new ifTrue:[Project addLoadedProject:p].
^ anyFail not
!
loadPackage:packageId fromClassLibrary:aFilename
"load a package from a compiled classLib.
Experimental."
|p t new|
(self fileIn:aFilename) ifFalse:[
(self fileInClassLibrary:aFilename) ifFalse:[
self warn:'Failed to load the package ', packageId printString.
^ false.
]
].
new := (p := Project projectWithId:packageId) isNil.
new ifTrue:[ p := Project new].
p name:packageId.
p directory:aFilename directory.
p package:packageId.
t := packageId asCollectionOfSubstringsSeparatedByAny:'/\:'.
p repositoryModule:(t first).
p repositoryDirectory:(packageId copyFrom:t first size + 2).
p isLoaded:true.
new ifTrue:[Project addLoadedProject:p].
^ true
!
loadPackage:packageId fromLoadAllFile:aFilename
"load a package from a loadAll - loader script.
Experimental."
|p t new|
Metaclass confirmationQuerySignal answer:false
do:[
(self fileIn:aFilename) ifFalse:[
self warn:'Failed to load the package ', packageId printString.
^ false.
]
].
new := (p := Project projectWithId:packageId) isNil.
new ifTrue:[ p := Project new].
p name:packageId.
p directory:aFilename directory.
p package:packageId.
t := packageId asCollectionOfSubstringsSeparatedByAny:'/\:'.
p repositoryModule:(t first).
p repositoryDirectory:(packageId copyFrom:t first size + 2).
p isLoaded:true.
new ifTrue:[Project addLoadedProject:p].
^ true
!
loadPackage:aPackageId fromProjectFile:f asAutoloaded:doLoadAsAutoloaded
"load a package from a .prj spec.
Experimental."
"/ not yet implemented ...
^ false.
"/ |prj fn|
"/
"/ prj := Project new loadFromProjectFile:f asFilename pathName.
"/ "/ no - also allow for applications to be loaded this way
"/ "/ prj type == #library ifFalse:[ ^ false].
"/ self halt.
"/ "/ load all prerequisites ...
"/ prj prerequisites do:[:aRequiredPackage |
"/ self halt.
"/ ].
"/
"/ "/ see if there is a class library ...
"/ fn := prj directory asFilename construct:(prj name , ObjectFileLoader sharedLibraryExtension).
"/ fn exists ifTrue:[
"/ "/ load that classLibrary ...
"/ self fileIn:fn pathName.
"/ ].
"/
"/ "/ now, for all other classes, file-them in
"/ "/ or declare as autoloaded ...
"/
"/ prj classes do:[:aClassOrName | |ns|
"/ aClassOrName isBehavior ifFalse:[
"/ ((self includesKey:aClassOrName) not
"/ and:[(ns := prj defaultNameSpace) isNil
"/ or:[ns == self
"/ or:[(ns includesKey:aClassOrName) not]]])
"/ ifTrue:[
"/ "/ must load a corresponding source or cls-file
"/ self halt.
"/ ]
"/ ]
"/ ].
"/ prj isLoaded:true.
"/ prj directory:f asFilename directoryName.
"/ Project addLoadedProject:prj.
"/ ^ true
"
Smalltalk loadPackage:'exept:osi/asn1'
Smalltalk
loadPackage:'exept:osi/asn1'
fromProjectFile:'../../../exept/osi/asn1/asn1.prj'
asAutoloaded:false
"
!
loadPackage:aPackageId fromZIPArchive:f asAutoloaded:doLoadAsAutoloaded
"load a package from a .zip delivery file.
Experimental."
"/ not yet implemented ...
^ false
!
loadPackageWithId:aPackageId
"make certain, that some particular package is loaded into the system.
Experimental."
^ self loadPackageWithId:aPackageId asAutoloaded:false
"
Smalltalk loadPackageWithId:'stx:libbasic'
Smalltalk loadPackageWithId:'stx:goodies/persistency'
Smalltalk loadPackageWithId:'cg:cparser'
Smalltalk loadPackageWithId:'cg:rose'
Smalltalk loadPackageWithId:'detemobil:smc'
"
!
loadPackageWithId:aPackageId asAutoloaded:doLoadAsAutoloaded
"make certain, that some particular package is loaded into the system.
Experimental."
|pkg packageDirName packageBaseName packageDir|
pkg := Project projectWithId:aPackageId.
(pkg notNil and:[pkg isLoaded]) ifTrue:[
"/ ('Smalltalk [info]: Package ' , aPackageId , ' already loaded.') infoPrintCR.
(doLoadAsAutoloaded
or:[pkg areAllClassesLoaded]) ifTrue:[
^ true
].
].
"/ ok; not yet loaded.
"/ try to locate the package; try the following:
"/ $(packagePath)/<packageDir>/...
"/ $(SYSPATH)/packages/<packageDir>
packageDirName := aPackageId copyReplaceAll:$: with:$/.
packageBaseName := packageDirName asFilename baseName.
packageDir := self getPackageFileName:packageDirName.
packageDir isNil ifTrue:[
"/ for convenience: try ../../.. as well
"/ (when executing in thedevelopment environment)
packageDir := '../../..' asFilename construct:packageDirName.
packageDir exists ifTrue:[
packageDir := packageDir pathName
] ifFalse:[
('Smalltalk [warning]: cannot find packageDirectory: ' , packageDirName) errorPrintCR.
^ false
]
].
^ self
loadPackageWithId:aPackageId
name:packageBaseName
fromDirectory:packageDir
asAutoloaded:doLoadAsAutoloaded
"
Smalltalk loadPackageWithId:'stx:libbasic'
Smalltalk loadPackageWithId:'stx:goodies/persistency'
Smalltalk loadPackageWithId:'exept:ctypes'
"
!
loadPackageWithId:aPackageId name:packageName fromDirectory:packageDirOrString asAutoloaded:doLoadAsAutoloaded
|f s packageDir shLibName|
packageDir := packageDirOrString asFilename.
"/ .prj ?
f := (packageDir construct:packageName) withSuffix:'prj'.
f exists ifTrue:[
(self loadPackage:aPackageId fromProjectFile:f asAutoloaded:doLoadAsAutoloaded) ifTrue:[
SilentLoading ifFalse:[
Transcript showCR:('Smalltalk [info]: loaded package: ' , aPackageId , ' from project file: ' , f pathName).
].
^ true
]
].
"/ loadAll ?
f := packageDir construct:'loadAll'.
f exists ifTrue:[
(self loadPackage:aPackageId fromLoadAllFile:f) ifTrue:[
SilentLoading ifFalse:[
Transcript showCR:('loaded package: ' , aPackageId , ' from loadAll file: ' , f pathName).
].
^ true
]
].
"/ .zip ?
f := (packageDir construct:packageName) withSuffix:'zip'.
f exists ifTrue:[
(self loadPackage:aPackageId fromZIPArchive:f asAutoloaded:doLoadAsAutoloaded) ifTrue:[
SilentLoading ifFalse:[
Transcript showCR:('loaded package: ' , aPackageId , ' from zip file: ' , f pathName).
].
^ true
]
].
shLibName := packageName , ObjectFileLoader sharedLibraryExtension.
"/ .so ?
f := packageDir construct:shLibName.
f exists ifTrue:[
(self loadPackage:aPackageId fromClassLibrary:f) ifTrue:[
SilentLoading ifFalse:[
Transcript showCR:('loaded package: ' , aPackageId , ' from binary classLib file: ' , f pathName).
].
doLoadAsAutoloaded ifFalse:[
"/ force autoloading...
Smalltalk allClassesDo:[:eachClass |
eachClass package == aPackageId ifTrue:[ eachClass autoload].
].
].
^ true
]
].
"/ abbrev.stc ?
f := packageDir construct:'abbrev.stc'.
f exists ifTrue:[
Smalltalk installAutoloadedClassesFrom:f pathName.
doLoadAsAutoloaded ifFalse:[
"/ force autoloading...
Smalltalk allClassesDo:[:eachClass |
eachClass package == aPackageId ifTrue:[ eachClass autoload].
].
].
self loadExtensionsFromDirectory:packageDirOrString.
SilentLoading ifFalse:[
Transcript showCR:('loaded package: ' , aPackageId , ' from abbrev file: ' , f pathName).
].
^ true
].
"/ "/ lib/loadAll ? (will vanish)
"/ f := (packageDir construct:'lib') construct:'loadAll'.
"/ f exists ifTrue:[
"/ (self loadPackage:aPackageId fromLoadAllFile:f) ifTrue:[
"/ SilentLoading ifFalse:[
"/ Transcript showCR:('loaded package: ' , aPackageId , ' from loadAll file: ' , f pathName).
"/ ].
"/ ^ true
"/ ]
"/ ].
"/
"/ "/ /lib/.so ? (will vanish)
"/ f := (packageDir construct:'lib') construct:shLibName.
"/ f exists ifTrue:[
"/ (self loadPackage:aPackageId fromClassLibrary:f) ifTrue:[
"/ SilentLoading ifFalse:[
"/ Transcript showCR:('loaded package: ' , aPackageId , ' from binary classLib file: ' , f pathName).
"/ ].
"/ ^ true
"/ ]
"/ ].
"/ any .so ? -> load the first one found (maybe not a good idea)
packageDir directoryContentsAsFilenamesDo:[:aFilename |
(aFilename hasSuffix:ObjectFileLoader sharedLibrarySuffix) ifTrue:[
(self loadPackage:aPackageId fromClassLibrary:aFilename) ifTrue:[
SilentLoading ifFalse:[
Transcript showCR:('loaded package: ' , aPackageId , ' from binary classLib file: ' , aFilename pathName).
].
doLoadAsAutoloaded ifFalse:[
"/ force autoloading...
Smalltalk allClassesDo:[:eachClass |
eachClass package == aPackageId ifTrue:[ eachClass autoload].
].
].
^ true
]
]
].
"/ source files
(self loadPackage:aPackageId fromAllSourceFilesInDirectory:packageDir) ifTrue:[
SilentLoading ifFalse:[
Transcript showCR:('loaded package: ' , aPackageId , ' from source files in:' , packageDir pathName).
].
^ true
].
^ false
"
Smalltalk loadPackageWithId:'stx:libbasic'
Smalltalk loadPackageWithId:'stx:goodies/persistency'
Smalltalk loadPackageWithId:'exept:ctypes'
"
! !
!Smalltalk class methodsFor:'system management-undeclared variables'!
clearUndeclaredVariables
"remove all undeclared variables"
(Smalltalk at:#Undeclared) do:[:eachKey |
Smalltalk removeKey:(self undeclaredPrefix , eachKey) asSymbol.
].
(Smalltalk at:#Undeclared) removeAll.
Smalltalk removeKey:#Undeclared.
!
undeclaredPrefix
"the prefix used for undeclared variables"
^ 'Undeclared:::'
"Created: / 31.10.1997 / 01:13:10 / cg"
! !
!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));
%}.
^ 'unknownOS/unknownCONF:unknownPACK'
"
Smalltalk configuration
"
!
copyrightString
"{ Pragma: +optSpace }"
"return a copyright string"
%{ /* NOCONTEXT */
#ifndef __getCopyrightString
extern OBJ __getCopyrightString();
#endif
RETURN (__getCopyrightString());
%}.
^ self primitiveFailed
"
Smalltalk copyrightString
"
!
distributorString
"{ Pragma: +optSpace }"
"return a string describing the distributor of this software"
%{ /* NOCONTEXT */
#ifndef __getDistributorString
extern OBJ __getDistributorString();
#endif
RETURN (__getDistributorString());
%}.
^ 'eXept Software AG, Germany'
"
Smalltalk distributorString
"
!
expirationTime
"{ Pragma: +optSpace }"
"for developers only: return the time when the system will expire.
after this time it will not run any longer.
It returns nil, if no expiration time has been set (system runs forever :-))"
|exp|
%{
extern unsigned int __getExpirationTime();
exp = __MKUINT(__getExpirationTime());
%}.
exp == 0 ifTrue:[
^ nil
].
^ AbsoluteTime new fromOSTime:(exp * 1000). "OSTime is ms since 1970"
"
Smalltalk expirationTime
"
!
fullVersionString
"{ Pragma: +optSpace }"
"return a full version string"
^ 'Smalltalk/X release ' , self versionString , ' of ' , self versionDate
"
Smalltalk fullVersionString
"
"Created: / 27.10.1997 / 17:03:09 / cg"
"Modified: / 27.10.1997 / 17:04:02 / cg"
!
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."
|proto lang|
lang := Language.
(lang == #de) ifTrue:[
proto := 'Willkommen bei %1 (Version %2 vom %3)'
] ifFalse:[ (lang == #fr) ifTrue:[
proto := 'Salut, Bienvenue à %1 (version %2 de %3)'
] ifFalse:[ (lang == #it) ifTrue:[
proto := 'Ciao, benvenuto al %1 (versione %2 di %3)'
] ifFalse:[ (lang == #es) ifTrue:[
"/ proto := 'Hola, bienvenida a %1 (versión %2 de %3)'
] ifFalse:[ (lang == #es) ifTrue:[
"/ proto := 'Oi, benvindo a %1 (versão %2 de %3)'
] ifFalse:[ (lang == #no) ifTrue:[
proto := 'Hei, verdenmottakelse til %1 (versjon %2 av %3)'
]]]]]].
"/ ... more needed here ...
proto isNil ifTrue:[
proto := 'Hello World - here is %1 version %2 of %3'.
].
^ proto bindWith:('SmallTalk/X' allBold)
with:(self versionString)
with:(self versionDate)
"
Smalltalk language:#us.
Smalltalk hello
Smalltalk language:#de.
Smalltalk hello
Smalltalk language:#no.
Smalltalk hello
Transcript showCR:(Smalltalk hello)
Stdout showCR:(Smalltalk hello)
"
"Modified: 18.5.1996 / 14:25:13 / cg"
!
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
"{ Pragma: +optSpace }"
"return a timestamp for the moment when this image was saved"
^ ObjectMemory imageSaveTime
!
imageStartTime
"{ Pragma: +optSpace }"
"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).
ST/X revision Naming is:
<major>.<minor>.<revision>.<release>"
^ 5
"
Smalltalk majorVersionNr
"
"Modified: 8.11.1996 / 19:59:21 / cg"
!
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.
ST/X revision Naming is:
<major>.<minor>.<revision>.<release>"
^ 1
"
Smalltalk minorVersionNr
"
"Modified: / 3.11.1997 / 14:49:48 / cg"
!
releaseIdentification
"{ Pragma: +optSpace }"
"for developers only: return the release
(to further identify the version in case of errors)"
%{ /* NOCONTEXT */
extern OBJ __getRel();
RETURN (__getRel());
%}.
^ 'ST/X_experimental'
"
Smalltalk releaseIdentification
"
!
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.
ST/X revision Naming is:
<major>.<minor>.<revision>.<release>"
^ 1
"
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.
ST/X revision Naming is:
<major>.<minor>.<revision>.<release>"
^ 4
"
Smalltalk revisionNr
Smalltalk hello
"
"Modified: / 19.6.1998 / 04:29:10 / cg"
!
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)."
^ ('''' , self timeStampString , '''') paddedTo:80 with:(Character space)
!
timeStamp:aStream
"write a string useful for timestamping a file onto aStream.
ST80 compatibility"
aStream nextPutAll:(self timeStamp).
"Created: / 18.6.1998 / 17:22:58 / cg"
!
timeStampString
"return a string useful for timestamping a file."
^ ('From Smalltalk/X, Version:' , (Smalltalk versionString) , ' on '
, Date today printString , ' at ' , Time now printString
)
!
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) );
%}.
^ 'today'
"
Smalltalk versionDate
"
!
versionString
"{ Pragma: +optSpace }"
"return the version string"
^ (self majorVersionNr printString ,
'.',
self minorVersionNr printString ,
'.',
self revisionNr printString)
"
Smalltalk versionString
"
!
vmMajorVersionNr
"{ Pragma: +optSpace }"
"return the VMs major version number."
%{
RETURN (__MKSMALLINT(4));
%}.
^ 4
"
Smalltalk vmMajorVersionNr
"
! !
!Smalltalk class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libbasic/Smalltalk.st,v 1.620 2003-11-18 13:55:34 penk Exp $'
! !