"
 COPYRIGHT (c) 1988-93 by Claus Gittinger
              All Rights Reserved

 This software is furnished under a license and may be used
 only in accordance with the terms of that license and with the
 inclusion of the above copyright notice.   This software may not
 be provided or otherwise made available to, or used by, any
 other person.  No title to or ownership of the software is
 hereby transferred.
"

Object subclass:#Smalltalk
       instanceVariableNames:''
       classVariableNames:'exitBlocks CachedClasses'
       poolDictionaries:''
       category:'System-Support'
!

Smalltalk comment:'

COPYRIGHT (c) 1988-93 by Claus Gittinger
             All Rights Reserved

This is one of the central classes in the system;
it provides all system-startup, shutdown and maintenance support.
Also global variables are kept here.

As you will notice, this is NOT a Dictionary
 - my implementation of globals is totally different
   (due to the need to be able to access globals from c-code as well).

$Header: /cvs/stx/stx/libbasic/Smalltalk.st,v 1.3 1993-10-13 00:18:22 claus Exp $
'!

Smalltalk at:#ErrorNumber put:nil!
Smalltalk at:#ErrorString put:nil!
Smalltalk at:#Language put:#english!
Smalltalk at:#LanguageTerritory put:#usa!
Smalltalk at:#Initializing put:false!
Smalltalk at:#SilentLoading put:false!
Smalltalk at:#RecursionLimit put:nil!
Smalltalk at:#MemoryLimit put:nil!
Smalltalk at:#SystemPath put:nil!
Smalltalk at:#StartupClass put:nil!
Smalltalk at:#StartupSelector put:nil!
Smalltalk at:#StartupArguments put:nil!
Smalltalk at:#SignalCatchBlock put:nil!

!Smalltalk class methodsFor:'time-versions'!

majorVersion
    "return the major version number"

    ^ 2

    "Smalltalk majorVersion"
!

minorVersion
    "return the minor version number"

    ^ 7

    "Smalltalk minorVersion"
!

revision
    "return the revision number"

    ^ 2

    "Smalltalk revision"
!

version
    "return the version string"

    ^ (self majorVersion printString ,
       '.',
       self minorVersion printString ,
       '.',
       self revision printString)

    "Smalltalk version"
!

versionDate
    "return the version date"

    ^ '9-Sep-1993'

    "Smalltalk versionDate"
!

copyright
    "return a copyright string"

    ^ 'Copyright (c) 1988-93 by Claus Gittinger'

    "Smalltalk copyright"
!

hello
    "return a greeting string"

    (Language == #german) ifTrue:[
        ^ 'Willkommen bei Smalltalk/X version '
          , self version , ' vom ' , self versionDate
    ].
    (Language == #french) ifTrue:[
        ^ 'Bienvenue a Smalltalk/X version '
          , self version , ' de ' , self versionDate
    ].
    ^ 'Hello World - here is Smalltalk/X version '
      , self version , ' of ' , self versionDate

    "Smalltalk hello"
!

timeStamp
    "return a string useful for timestamping a file"

    ^ '''From Smalltalk/X, Version:' , (Smalltalk version) , ' on '
      , Date today printString , ' at ' , Time now printString
      , ''''
! !

!Smalltalk class methodsFor:'initialization'!

initialize
    "this one is called from init - initialize all other classes"

    self initGlobalsFromEnvironment.

    "sorry - there are some, which MUST be initialized before ..
     reason: if any error happens during init, we need Stdout to be there"

    Object initialize.

    ExternalStream initialize.
    self initStandardStreams.

    "sorry, path must be set before ...
     reason: some classes need it during initialize"

    self initSystemPath.

    "must init display here - some classes (Color) need it during
     initialize"

    Workstation notNil ifTrue:[
        Workstation initialize
    ].

    Inspector := MiniInspector.
    Debugger := MiniDebugger.
    Compiler := ByteCodeCompiler.
    Compiler isNil ifTrue:[
        "this allows at least immediate evaluations"
        Compiler := Parser
    ].

    self allBehaviorsDo:[:aClass |
        "aviod never-ending story ..."
        (aClass ~~ Smalltalk) ifTrue:[
            aClass initialize
        ]
    ].
    self initStandardTools.
    self initInterrupts

    "Smalltalk initialize"
!

initGlobalsFromEnvironment
    "setup globals from the shell-environment"

    |envString firstChar i langString terrString|

    "extract Language and LanguageTerritory from LANG variable.
     the language and territory must not be abbreviated,
     valid is for example: english_usa
                           english
                           german
                           german_austria"

    envString := OperatingSystem getEnvironment:'LANG'.
    envString notNil ifTrue:[
        i := envString indexOf:$_.
        (i == 0) ifTrue:[
            langString := envString.
            terrString := envString
        ] ifFalse:[
            langString := envString copyFrom:1 to:(i - 1).
            terrString := envString copyFrom:(i + 1)
        ].
        Language := langString asSymbol.
        LanguageTerritory := terrString asSymbol
    ].

    envString := OperatingSystem getEnvironment:'VIEW3D'.
    envString notNil ifTrue:[
        firstChar := (envString at:1) asLowercase.
        (firstChar == $t) ifTrue:[
            Smalltalk at:#View3D put:true
        ] ifFalse: [
            Smalltalk at:#View3D put:false
        ]
    ]
    "Smalltalk initGlobalsFromEnvironment"
!

initStandardTools
    "predefine some tools 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"

    (Smalltalk at:#Display) notNil ifTrue:[
        (Smalltalk at:#InspectorView) notNil ifTrue:[
            Inspector := Smalltalk at:#InspectorView
        ].
        (Smalltalk at:#DebugView) notNil ifTrue:[
            Debugger := Smalltalk at:#DebugView
        ].
        Display initialize
    ]
    "Smalltalk initStandardTools"
!

initStandardStreams
    "initialize some well-known streams"

    Stdout := NonPositionableExternalStream forStdout.
    Stderr := NonPositionableExternalStream forStderr.
    Stdin := NonPositionableExternalStream forStdin.
    Printer := PrinterStream.
    Transcript := Stderr

    "Smalltalk initStandardStreams"
!

initInterrupts
    "initialize interrupts"

    OperatingSystem enableUserInterrupts.
    OperatingSystem enableSignalInterrupts.
    OperatingSystem enableFpExceptionInterrupts.

    ObjectMemory userInterruptHandler:self.

    "Smalltalk initInterrupts"
!

initSystemPath
    "setup path to search for system files"

    |p|

    "the path is set to search files first locally
     - this allows private stuff to override global stuff"

    SystemPath := OrderedCollection new.
    SystemPath add:'.'.
    SystemPath add:'..'.
    SystemPath add:(OperatingSystem getHomeDirectory).
    (OperatingSystem isDirectory:(OperatingSystem getHomeDirectory , '/.smalltalk')) ifTrue:[
        SystemPath add:(OperatingSystem getHomeDirectory , '/.smalltalk')
    ].
    p := OperatingSystem getEnvironment:'SMALLTALK_LIBDIR'.
    p notNil ifTrue:[
        SystemPath add:p
    ].
    (OperatingSystem isDirectory:'/usr/local/lib/smalltalk') ifTrue:[
        SystemPath add:'/usr/local/lib/smalltalk'
    ].
    (OperatingSystem isDirectory:'/usr/lib/smalltalk') ifTrue:[
        SystemPath add:'/usr/lib/smalltalk'
    ].

    "Smalltalk initSystemPath"
    "SystemPath"
!

start
    "main startup, if there is a Display, initialize it
     and start dispatching; otherwise go into a read-eval-print loop"

    Initializing := true.

    "read patches- and rc-file, do not add things into change-file"

    Class updateChanges:false.
    [
        self fileIn:'patches'.

        (self fileIn:((Arguments at:1) , '.rc')) ifFalse:[
            "no .rc file where executable is; try default smalltalk.rc"
            self fileIn:'smalltalk.rc'
        ]
    ] valueNowOrOnUnwindDo:[Class updateChanges:true].

    SilentLoading ifFalse:[
        Transcript showCr:(self hello).
        Transcript showCr:(self copyright).
        Transcript cr
    ].

    Initializing := false.
    DemoMode ifTrue:[
        Transcript showCr:'Unlicensed demo mode with limitations.'
    ].

    [self saveMainLoop] whileTrue:[ ].

    "done"

    self exit
!

restart
    "startup after an image has been loaded 
     "
    |deb insp|

    Initializing := true.

    "temporary switch back to dumb interface"

    insp := Inspector.
    deb := Debugger.
    Inspector := MiniInspector.
    Debugger := MiniDebugger.

    ObjectMemory changed:#restarted.

    "
     some must be reinitialized before ...
     - sorry, but order is important
    "

    Workstation reinitialize.
    View reinitialize.

    ObjectMemory changed:#returnFromSnapshot.

    OperatingSystem enableUserInterrupts.
    OperatingSystem enableSignalInterrupts.

    Inspector := insp.
    Debugger := deb.

    Initializing := false.


    "
     if there is no Transcript, go to stderr
    "
    Transcript isNil ifTrue:[
        self initStandardStreams.
        Transcript := Stderr
    ].

    Transcript cr.
    Transcript showCr:('Smalltalk restarted from:' , ImageName).
    DemoMode ifTrue:[
        Transcript showCr:'Unlicensed demo mode with limitations.'
    ].

    "this allows firing an application by defining
     these two globals during snapshot ..."

    StartupClass notNil ifTrue:[
        StartupSelector notNil ifTrue:[

            "allow customization by reading an image specific rc-file"
            ImageName notNil ifTrue:[
                (ImageName endsWith:'.img') ifTrue:[
                    self fileIn:((ImageName copyFrom:1 to:(ImageName size - 4)), '.rc')
                ] ifFalse:[
                    self fileIn:(ImageName , '.rc')
                ]
            ].
            StartupClass perform:StartupSelector withArguments:StartupArguments
        ]
    ].

    Display notNil ifTrue:[
        Display dispatch
    ] ifFalse:[
        self readEvalPrint
    ].

    self exit
!

saveMainLoop
    "main dispatching loop - exits with true for a bad exit (to restart),
     false for real exit"

    Smalltalk at:#SignalCatchBlock put:[^ true].

    "if view-classes exist, start dispatching;
     otherwise go into a read-eval-print loop"

    Display notNil ifTrue:[
        Display dispatch
    ] ifFalse:[
        self readEvalPrint
    ].
    ^ false
!

readEvalPrint
    "simple read-eval-print loop for non-graphical Tinytalk"

    |text|

    'ST- ' print.
    Stdin skipSeparators.
    text := Stdin nextChunk.
    [text notNil] whileTrue:[
        (Compiler evaluate:text) printNewline.
        'ST- ' print.
        text := Stdin nextChunk
    ].
    '' printNewline
! !

!Smalltalk class methodsFor:'accessing'!

at:aKey
    "retrieve the value stored under aKey, a symbol"

%{  /* NOCONTEXT */
    extern OBJ _GETGLOBAL();

    RETURN ( _GETGLOBAL(aKey) );
%}
!

at:aKey ifAbsent:aBlock
    "retrieve the value stored under aKey.
     If there is none stored this key, return the value of
     the evaluation of aBlock"

    (self includesKey:aKey) ifTrue:[
        ^ self at:aKey
    ].
    ^ aBlock value
!

at:aKey put:aValue
    "store the argument aValue under aKey, a symbol"

    CachedClasses := nil.

%{  /* NOCONTEXT */
    extern OBJ _SETGLOBAL();

    RETURN ( _SETGLOBAL(aKey, aValue, (OBJ *)0) );
%}
!

removeKey:aKey
    "remove the argument from the globals dictionary"

    CachedClasses := nil.

%{  /* NOCONTEXT */
    extern OBJ _REMOVEGLOBAL();

    RETURN ( _REMOVEGLOBAL(aKey) );
%}
!

includesKey:aKey
    "return true, if the key is known"

%{  /* NOCONTEXT */
    extern OBJ _KEYKNOWN();

    RETURN ( _KEYKNOWN(aKey) );
%}
!

keyAtValue:anObject
    "return the symbol under which anObject is stored - or nil"

    self allKeysDo:[:aKey |
        (self at:aKey) == anObject ifTrue:[^ aKey]
    ]

    "Smalltalk keyAtValue:Object"
!

keys
    "return a collection with all keys in the Smalltalk dictionary"

    |keys|

    keys := OrderedCollection new.
    self allKeysDo:[:k | keys add:k].
    ^ keys
! !

!Smalltalk class methodsFor:'copying'!

shallowCopy
    "redefine copy - there is only one Smalltalk dictionary"

    ^ self
!

deepCopy
    "redefine copy - there is only one Smalltalk dictionary"

    ^ self
! !

!Smalltalk class methodsFor:'inspecting'!

inspect
    "redefined to launch a DictionaryInspector on the receiver
     (instead of the default InspectorView)."

    DictionaryInspectorView isNil ifTrue:[
        super inspect
    ] ifFalse:[
        DictionaryInspectorView openOn:self
    ]
! !

!Smalltalk class methodsFor:'misc stuff'!

addExitBlock:aBlock
    "add a block to be executed when Smalltalk finishes"

    exitBlocks isNil ifTrue:[
        exitBlocks := Array with:aBlock
    ] ifFalse:[
        exitBlocks add:aBlock
    ]
!

exit
    "finish Smalltalk system"

    exitBlocks notNil ifTrue:[
        exitBlocks do:[:aBlock |
            aBlock value
        ]
    ].
%{
    mainExit(0);
%}
.
    OperatingSystem exit

    "Smalltalk exit"
!

sleep:aDelay
    "wait for aDelay seconds"

    OperatingSystem sleep:aDelay
! !

!Smalltalk class methodsFor:'debugging'!

printStackBacktrace
    "print a stack backtrace"

%{
    printStack(__context);
%}
!

fatalAbort
    "abort program and dump core"
%{
    fatal0(__context, "abort");
%}
!

statistic
    "print some statistic data"
%{
    statistic();
%}
!

debugOn
    "temporary"

    "LookupTrace := true.   "
    MessageTrace := true.
    "AllocTrace := true.     "
    ObjectMemory flushInlineCaches
!

debugOff
    "temporary"

    LookupTrace := nil.    
    MessageTrace := nil
    ". AllocTrace := nil     "
!

allocDebugOn
    "temporary"

    AllocTrace := true
!

allocDebugOff
    "temporary"

    AllocTrace := nil
!

executionDebugOn
    "temporary"

    ExecutionTrace := true
!

executionDebugOff
    "temporary"

    ExecutionTrace := nil
! !

!Smalltalk class methodsFor:'looping'!

do:aBlock
    "evaluate the argument, aBlock for all values in the Smalltalk dictionary"
%{
    __allGlobalsDo(&aBlock COMMA_CON);
%}
!

allKeysDo:aBlock
    "evaluate the argument, aBlock for all keys in the Smalltalk dictionary"
%{
    __allKeysDo(&aBlock COMMA_CON);
%}
!

allBehaviorsDo:aBlock
    "evaluate the argument, aBlock for all classes in the system"

    self allClasses do:aBlock
!

allClassesDo:aBlock
    "evaluate the argument, aBlock for all classes in the system.
     Backward compatibility - use allBehaviorsDo: for ST-80 compatibility."

    ^ self allBehaviorsDo:aBlock
!

associationsDo:aBlock
    "evaluate the argument, aBlock for all key/value pairs 
     in the Smalltalk dictionary"

    self allKeysDo:[:aKey |
        aBlock value:(aKey -> (self at:aKey))
    ]

    "Smalltalk associationsDo:[:assoc | assoc printNewline]"
! !

!Smalltalk class methodsFor:'queries'!

numberOfGlobals
    "return the number of global variables in the system"

    |tally|

    tally := 0.
    self do:[:obj | tally := tally + 1].
    ^ tally

    "Smalltalk numberOfGlobals"
!

cellAt:aName
    "return the address of a global cell
     - used internally for compiler only"

%{  /* NOCONTEXT */
    extern OBJ _GETGLOBALCELL();

    RETURN ( _GETGLOBALCELL(aName) );
%}
!

references:anObject
    "return true, if I refer to the argument, anObject
     must be reimplemented since Smalltalk is no real collection"

    self do:[:o |
        (o == anObject) ifTrue:[^ true]
    ].
    ^ false
!

allClasses
    "return a collection of all classes in the system"

    CachedClasses isNil ifTrue:[
        CachedClasses := IdentitySet new:400.
        self do:[:anObject |
            anObject notNil ifTrue:[
                (anObject isBehavior) ifTrue:[
                    CachedClasses add:anObject
                ]
            ]
        ]
    ].
    ^ CachedClasses

    "Smalltalk allClasses"
!

classNames
    "return a collection of all classNames in the system"


    ^ self allClasses collect:[:aClass | aClass name]
! !

!Smalltalk class methodsFor:'system management'!

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|

    sym := aClass name asSymbol.
    ((self at:sym) == aClass) ifTrue:[
        self at:sym put:nil. "nil it out for compiled accesses"
        self removeKey:sym. 

        "remove class variables"

        names := aClass classVariableString asCollectionOfWords.
        names do:[:name |
            cSym := (sym , ':' , name) asSymbol.
            self at:cSym asSymbol put:nil.
            self removeKey:cSym
        ].
"
        actually could get along with less flushing
        (entries for aClass and subclasses only)

        ObjectMemory flushInlineCachesForClass:aClass.
        ObjectMemory flushMethodCacheFor:aClass
"
        ObjectMemory flushInlineCaches.
        ObjectMemory flushMethodCache
    ]
!

browseChanges
    "startup a changes browser"

    (self at:#ChangesBrowser) notNil ifTrue:[
        ChangesBrowser start
    ] ifFalse:[
        self error:'no ChangesBrowser'
    ]

    "Smalltalk browseChanges "
!

browseAllSelect:aBlock
    "startup a browser for all methods for which aBlock returns true"

    SystemBrowser browseAllSelect:aBlock

    " Smalltalk browseAllSelect:[:m | m literals isNil] "
!

browseImplementorsOf:aSelectorSymbol
    "startup a browser for all methods implementing a particular message"

    SystemBrowser browseImplementorsOf:aSelectorSymbol

    " Smalltalk browseImplementorsOf:#at:put: "
!

browseAllCallsOn:aSelectorSymbol
    "startup a browser for all methods sending a particular message"

    SystemBrowser browseAllCallsOn:aSelectorSymbol

    " Smalltalk browseAllCallsOn:#at:put: "
!

systemFileStreamFor:aFileName
    "search aFileName in some standard places;
     return a fileStream or nil if not found"

    |aStream|

    SystemPath do:[:dirName |
        aStream := FileStream readonlyFileNamed:(dirName , '/' , aFileName).
        aStream notNil ifTrue:[^ aStream]
    ].
    ^ nil
!

fileNameForClass:aClassName
    "return a good filename for aClassName -
     using abbreviation file if there is one"

    |fileName aStream abbrev line thisName index|

    fileName := aClassName.

    fileName size < 10 ifTrue:[^ fileName].

    "too bad - look for abbreviation"

    aStream := self systemFileStreamFor:'abbrev.stc'.
    aStream notNil ifTrue:[
        [aStream atEnd] whileFalse:[
            line := aStream nextLine.
            line notNil ifTrue:[
                (line countWords == 2) ifTrue:[
                    index := line indexOfSeparatorStartingAt:1.
                    (index ~~ 0) ifTrue:[
                        thisName := line copyFrom:1 to:(index - 1).
                        (thisName = fileName) ifTrue:[
                            abbrev := (line copyFrom:index) withoutSeparators.
                            aStream close.
                            ^ abbrev
                        ]
                    ]
                ]
            ]
        ].
        aStream close
    ].

    "no file found"
    OperatingSystem maxFileNameLength >= (fileName size + 3) ifTrue:[
        " self warn:'filename ' , fileName , ' will not work on sys5 machines' "
    ] ifFalse:[
        self error:'cant find short for ' , fileName , ' in abbreviation file'
    ].
    ^ fileName
!

classNameForFile:aFileName
    "return the className which corresponds to an 
     abbreviated fileName"

    |fileName aStream abbrev line thisName index|

    "too bad - look for abbreviation"

    aStream := self systemFileStreamFor:'abbrev.stc'.
    aStream notNil ifTrue:[
        [aStream atEnd] whileFalse:[
            line := aStream nextLine.
            line notNil ifTrue:[
                (line countWords == 2) ifTrue:[
                    index := line indexOfSeparatorStartingAt:1.
                    (index ~~ 0) ifTrue:[
                        thisName := line copyFrom:1 to:(index - 1).
                        abbrev := (line copyFrom:index) withoutSeparators.
                        (abbrev = aFileName) ifTrue:[
                            aStream close.
                            ^ thisName
                        ]
                    ]
                ]
            ]
        ].
        aStream close
    ].

    ^ thisName

    "Smalltalk classNameForFile:'DrawObj'"
!

fileInClassObject:aClassName from:aFileName
    "read in the named object file - look for it in some standard places;
     return true if ok, false if failed"

    |aStream|

    aStream := self systemFileStreamFor:aFileName.
    aStream isNil ifTrue:[^ false].
    aStream close.

    (ObjectFileLoader loadClass:aClassName fromObjectFile:aFileName) isNil ifTrue:[^ false].
    ^ true

    " Smalltalk fileInClassObject:'AbstractPath' from:'../goodies/Paths/AbstrPath.o' "
!

fileIn:aFileName
    "read in the named file - look for it in some standard places;
     return true if ok, false if failed"

    |aStream|

    aStream := self systemFileStreamFor:aFileName.
    aStream isNil ifTrue:[^ false].

    [aStream fileIn] valueNowOrOnUnwindDo:[aStream close].
    ^ true

    " Smalltalk fileIn:'games/TicTacToe.st' "
!

fileInChanges
    "read in the last changes file - bringing the system to the state it
     had when left the last time"

    |upd|

    "tell Class to NOT update the changes file now ..."
    upd := Class updateChanges:false.
    [self fileIn:'changes'] valueNowOrOnUnwindDo:[Class updateChanges:upd]

    "Smalltalk fileInChanges "
!

fileInClass:aClassName
    "find a source/object file for aClassName and -if found - load it"

    |fName newClass upd|

    fName := self fileNameForClass:aClassName.
    fName notNil ifTrue:[
        upd := Class updateChanges:false.
        [
            (self fileIn:('fileIn/' , fName , '.ld')) ifFalse:[
                (self fileInClassObject:aClassName from:('binary/' , fName, '.so')) ifFalse:[
                    (self fileInClassObject:aClassName from:('binary/' , fName, '.o')) ifFalse:[
                        (self fileIn:(fName , '.st')) ifFalse:[
                            self fileIn:('source/' , fName , '.st')
                        ]
                    ]
                ]
            ]
        ] valueNowOrOnUnwindDo:[Class updateChanges:upd].
        newClass := self at:(aClassName asSymbol).
        (newClass notNil
         and:[newClass implements:#initialize]) ifTrue:[newClass initialize]
    ]
! !

!Smalltalk class methodsFor: 'binary storage'!

addGlobalsTo: globalDictionary manager: manager
    | pools |
    pools _ Set new.
    self associationsDo: [:assoc|
        assoc value == self ifFalse:[
            assoc value isClass ifTrue: [
                assoc value addGlobalsTo: globalDictionary manager: manager.
                "pools addAll: assoc value sharedPools"
            ] ifFalse: [
                globalDictionary at: assoc put: self
            ].
            assoc value isNil ifFalse:[
                globalDictionary at: assoc value put: self
            ]
        ]
    ].

    pools do: [:poolDictionary|
        poolDictionary addGlobalsTo: globalDictionary manager: manager
    ]
!

storeBinaryDefinitionOf: anObject on: stream manager: manager
    | string |

    anObject class == Association ifTrue: [
        string := 'Smalltalk associationAt: ', anObject key storeString
    ] ifFalse: [
        string := 'Smalltalk at: ', (self keyAtValue: anObject) storeString
    ].
    stream nextNumber: 2 put: string size.
    string do: [:char| stream nextPut: char asciiValue]
! !