--- a/Smalltalk.st Wed Oct 26 23:35:39 2016 +0100
+++ b/Smalltalk.st Fri Nov 18 20:48:04 2016 +0000
@@ -20,12 +20,12 @@
StartupArguments CommandLine CommandName CommandLineArguments
CachedAbbreviations VerboseStartup VerboseLoading Verbose
SilentLoading Initializing StandAlone HeadlessOperation IsPlugin
- IsSharedLibraryComponent IsSTScript DebuggingStandAlone Debugging
- LogDoits LoadBinaries RealSystemPath ResourcePath SourcePath
- BinaryPath FileInPath PackagePath BinaryDirName ResourceDirName
- SourceDirName BitmapDirName PackageDirName FileInDirName
- ChangeFileName ImageStartTime ImageRestartTime DemoMode
- SaveEmergencyImage SpecialObjectArray CallbackSignal
+ IsSharedLibraryComponent IsSTScript IsRepl DebuggingStandAlone
+ Debugging LogDoits LoadBinaries RealSystemPath ResourcePath
+ SourcePath BinaryPath FileInPath PackagePath BinaryDirName
+ ResourceDirName SourceDirName BitmapDirName PackageDirName
+ FileInDirName ChangeFileName ImageStartTime ImageRestartTime
+ DemoMode SaveEmergencyImage SpecialObjectArray CallbackSignal
ClassesFailedToInitialize HasNoConsole IgnoreHalt
PackageToPathMapping IgnoreAssertions LanguageModifier
LanguageCodeset'
@@ -33,7 +33,7 @@
category:'System-Support'
!
-Smalltalk comment:'documentation'
+Smalltalk comment:''
!
!Smalltalk class methodsFor:'documentation'!
@@ -729,6 +729,18 @@
IgnoreHalt := true.
CommandLineArguments removeIndex:idx
].
+ (idx := CommandLineArguments indexOf:'--noIgnoreHalt') ~~ 0 ifTrue:[
+ IgnoreHalt := false.
+ CommandLineArguments removeIndex:idx
+ ].
+ (idx := CommandLineArguments indexOf:'--ignoreAssert') ~~ 0 ifTrue:[
+ IgnoreAssertions := true.
+ CommandLineArguments removeIndex:idx
+ ].
+ (idx := CommandLineArguments indexOf:'--noIgnoreAssert') ~~ 0 ifTrue:[
+ IgnoreAssertions := false.
+ CommandLineArguments removeIndex:idx
+ ].
(idx := CommandLineArguments indexOf:'--silentStartup') ~~ 0 ifTrue:[
SilentLoading := true.
CommandLineArguments removeIndex:idx
@@ -742,10 +754,25 @@
VerboseStartup := true.
CommandLineArguments removeIndex:idx
].
+
+ "/ reinterpret those, in case given after the VM options.
+ (idx := CommandLineArguments indexOf:'--debugPrint') ~~ 0 ifTrue:[
+ ObjectMemory debugPrinting:true.
+ CommandLineArguments removeIndex:idx
+ ].
+ (idx := CommandLineArguments indexOf:'--infoPrint') ~~ 0 ifTrue:[
+ ObjectMemory infoPrinting:true.
+ CommandLineArguments removeIndex:idx
+ ].
+
(idx := CommandLineArguments indexOf:'--verbose') ~~ 0 ifTrue:[
+ Object infoPrinting:true.
Verbose := true.
VerboseLoading := true.
VerboseStartup := true.
+ Logger notNil ifTrue:[
+ Logger loggingThreshold: Logger severityALL.
+ ].
CommandLineArguments removeIndex:idx
].
!
@@ -972,7 +999,7 @@
"Created: / 07-02-2012 / 15:57:05 / cg"
! !
-!Smalltalk class methodsFor:'Compatibility-VW5.4'!
+!Smalltalk class methodsFor:'Compatibility-VW'!
defineClass:nameSymbol superclass:superclass indexedType:indexed private:private instanceVariableNames:instVars classInstanceVariableNames:classInstVars imports:imports category:category
^ self
@@ -1014,6 +1041,22 @@
newNameSpace := NameSpace name:nameSymbol.
newNameSpace setCategory:category.
^ newNameSpace
+!
+
+dialectName
+ ^ #SmalltalkX
+
+ "
+ Smalltalk dialectName
+ "
+!
+
+dialectReleaseVersion
+ ^ self versionString
+
+ "
+ Smalltalk dialectReleaseVersion
+ "
! !
!Smalltalk class methodsFor:'accessing'!
@@ -1392,7 +1435,7 @@
self at:sym put:nil. "nil it out for compiled accesses"
"/
- "/ see comment in removeKey: on why we dont remove it here
+ "/ see comment in removeKey: on why we don't remove it here
"/
"/ self removeKey:sym. "/ remove key - this actually fails, if there are
"/ still compiled code references."
@@ -1597,24 +1640,24 @@
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.
- ].
+ 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.
@@ -1625,8 +1668,8 @@
privateClasses := aClass privateClassesSorted.
((self at:oldSym) ~~ aClass) ifTrue:[
- 'Smalltalk [warning]: rename failed - name is different from key' errorPrintCR.
- ^ self
+ 'Smalltalk [warning]: rename failed - name is different from key' errorPrintCR.
+ ^ self
].
"/ rename the class
@@ -1635,42 +1678,42 @@
"/ change the owning class
ns isNameSpace ifFalse:[
- aClass isPrivate ifTrue:[
- aClass class setOwningClass:ns.
- ] ifFalse:[
- "/ sigh - must make a PrivateMetaclass from Metaclass
- oldMetaclass := aClass class.
- 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.
- ]
+ aClass isPrivate ifTrue:[
+ aClass class setOwningClass:ns.
+ ] ifFalse:[
+ "/ sigh - must make a PrivateMetaclass from Metaclass
+ oldMetaclass := aClass class.
+ 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:[
- newCategory := aClass topOwningClass category.
-
- "/ sigh - must make a Metaclass from PrivateMetaclass
- oldMetaclass := aClass class.
-
- newMetaclass := Metaclass new.
- newMetaclass flags:(oldMetaclass flags).
- newMetaclass setSuperclass:(oldMetaclass superclass).
- newMetaclass instSize:(oldMetaclass instSize).
- newMetaclass setInstanceVariableString:(oldMetaclass instanceVariableString).
- newMetaclass setMethodDictionary:(oldMetaclass methodDictionary).
- newMetaclass setSoleInstance:aClass.
-
- aClass category:newCategory.
- aClass changeClassTo:newMetaclass.
- ObjectMemory flushCaches.
- ]
+ aClass isPrivate ifTrue:[
+ newCategory := aClass topOwningClass category.
+
+ "/ sigh - must make a Metaclass from PrivateMetaclass
+ oldMetaclass := aClass class.
+
+ newMetaclass := Metaclass new.
+ newMetaclass flags:(oldMetaclass flags).
+ newMetaclass setSuperclass:(oldMetaclass superclass).
+ newMetaclass instSize:(oldMetaclass instSize).
+ newMetaclass setInstanceVariableString:(oldMetaclass instanceVariableString).
+ newMetaclass setMethodDictionary:(oldMetaclass methodDictionary).
+ newMetaclass setSoleInstance:aClass.
+
+ aClass category:newCategory.
+ aClass changeClassTo:newMetaclass.
+ ObjectMemory flushCaches.
+ ]
].
aClass setName:newSym.
@@ -1679,7 +1722,7 @@
self at:oldSym put:nil.
"/
- "/ see comment in #removeKey: on why we dont remove it it here
+ "/ see comment in #removeKey: on why we don't remove it it here
"/
"/ self removeKey:oldSym.
self at:newSym put:aClass.
@@ -1690,32 +1733,32 @@
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.
+ 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 ? ...
+ 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 |
@@ -1738,85 +1781,85 @@
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 , ''' ...'.
- aClass theNonMetaclass recompileMethodsAccessingGlobal:(oldName , '::' , aPrivateClass nameWithoutPrefix) asSymbol.
- aClass theMetaclass recompileMethodsAccessingGlobal:(oldName , '::' , aPrivateClass nameWithoutPrefix) asSymbol.
- aClass theNonMetaclass recompileMethodsAccessingGlobal:(aPrivateClass nameWithoutPrefix) asSymbol.
- aClass theMetaclass recompileMethodsAccessingGlobal:(aPrivateClass nameWithoutPrefix) asSymbol.
+ "/ 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 , ''' ...'.
+ aClass theNonMetaclass recompileMethodsAccessingGlobal:(oldName , '::' , aPrivateClass nameWithoutPrefix) asSymbol.
+ aClass theMetaclass recompileMethodsAccessingGlobal:(oldName , '::' , aPrivateClass nameWithoutPrefix) asSymbol.
+ aClass theNonMetaclass recompileMethodsAccessingGlobal:(aPrivateClass nameWithoutPrefix) asSymbol.
+ aClass theMetaclass recompileMethodsAccessingGlobal:(aPrivateClass nameWithoutPrefix) asSymbol.
"/ 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.
- ].
+ "/ 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.
- ]
+ "/ 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.
+ subClass changed:#definition.
].
"/ because of the change of my superclasses name ...
aClass subclassesDo:[:subClass |
- subClass addChangeRecordForClass:subClass.
+ subClass addChangeRecordForClass:subClass.
].
self changed:#definition.
self changed:#classRename with:(Array with:aClass with:oldName).
@@ -1893,12 +1936,12 @@
exitWithCoreDump
"{ Pragma: +optSpace }"
- "abort program and dump core"
+ "abort the program and dump core"
OperatingSystem exitWithCoreDump
"/ never returns
- "Be careful evaluating this
+ "Be careful evaluating this:
Smalltalk exitWithCoreDump
"
!
@@ -2353,6 +2396,11 @@
|sav|
+ Smalltalk verbose ifTrue:[
+ aBlock value.
+ ^ self.
+ ].
+
sav := SilentLoading.
SilentLoading := true.
aBlock ensure:[ SilentLoading := sav ].
@@ -3637,22 +3685,6 @@
!Smalltalk class methodsFor:'queries-system'!
-dialectName
- ^ #SmalltalkX
-
- "
- Smalltalk dialectName
- "
-!
-
-dialectReleaseVersion
- ^ self versionString
-
- "
- Smalltalk dialectReleaseVersion
- "
-!
-
isAmber
"is this an Amber Smalltalk system ?
Return false here - this may be useful to write portable
@@ -3813,6 +3845,23 @@
"Modified: / 11-09-2010 / 14:06:59 / cg"
!
+defineCommandLineAsWorkspaceVariablesForScripts
+ "/ enable this, so we can provide _$1.._$n in the script
+ ParserFlags allowUnderscoreInIdentifier:true.
+ ParserFlags allowDollarInIdentifier:true.
+ ParserFlags warnDollarInIdentifier:false.
+ ParserFlags warnUnderscoreInIdentifier:false.
+ ParserFlags allowOldStyleAssignment:false.
+
+ "/ add bindings for arguments
+ Workspace workspaceVariableAt:('_$0') put:CommandName.
+ Workspace workspaceVariableAt:('_$n') put:CommandLineArguments size.
+ Workspace workspaceVariableAt:('_$$') put:CommandLineArguments.
+ CommandLineArguments doWithIndex:[:arg :i |
+ Workspace workspaceVariableAt:('_$',i printString) put:arg.
+ ].
+!
+
displayInitializationDone
"inform the restart, that the display has been initialized"
@@ -3851,6 +3900,18 @@
%}
!
+lateOpenDisplay
+ "this is called when a view is opened without a display being already opened."
+
+ Smalltalk openDisplay.
+ Display notNil ifTrue:[
+ IsRepl ifFalse:[
+ Display exitOnLastClose:true.
+ ].
+ "/ Processor exitWhenNoMoreUserProcesses:true.
+ ].
+!
+
mainStartup:graphicalMode
"common start/restart action, if there is a Display, initialize it
and start dispatching; otherwise go into a read-eval-print loop."
@@ -3977,10 +4038,10 @@
self fileIn:(imageName , '.rc')
].
-"/ Display notNil ifTrue:[
-"/ Display exitOnLastClose:true.
-"/ ].
-"/ Processor exitWhenNoMoreUserProcesses:true.
+ Display notNil ifTrue:[
+ Display exitOnLastClose:true.
+ ].
+ Processor exitWhenNoMoreUserProcesses:true.
process := [
'Smalltalk [info]: startup process 2 active.' infoPrintCR.
@@ -4009,7 +4070,7 @@
"/ "/ GUI apps exit after the last user process has finished
"/ "/
"/ Display exitOnLastClose:true.
-"/ Processor exitWhenNoMoreUserProcesses:true.
+ Processor exitWhenNoMoreUserProcesses:true.
] newProcess.
process priority:(Processor userSchedulingPriority).
process name:'main'.
@@ -4026,9 +4087,9 @@
].
].
- Display notNil ifTrue:[
- Display exitOnLastClose:true.
- ].
+"/ Display notNil ifTrue:[
+"/ Display exitOnLastClose:true.
+"/ ].
"
if view-classes exist, start dispatching;
otherwise go into a read-eval-print loop
@@ -4036,14 +4097,15 @@
((Display notNil and:[graphicalMode])
or:[process notNil
or:[HeadlessOperation
- or:[StandAlone]]]) ifTrue:[
+ or:[StandAlone]]]
+ ) ifTrue:[
Processor exitWhenNoMoreUserProcesses:true.
Processor dispatchLoop.
"done - the last process finished"
'Smalltalk [info]: last process finished - exit.' infoPrintCR.
] ifFalse:[
StandAlone ifFalse:[
- self readEvalPrint
+ self readEvalPrintLoop
]
].
@@ -4093,7 +4155,17 @@
"Created: / 06-12-2006 / 15:38:17 / cg"
!
-readEvalPrint
+providingDisplayDo:aBlock
+ "/ provide a Display, if needed
+ (Smalltalk at:#Screen) currentScreenQuerySignal handle:[:ex |
+ Display isNil ifTrue:[ self lateOpenDisplay ].
+ ex proceedWith:Display.
+ ] do:aBlock
+!
+
+readEvalPrintLoop
+ "say hello, then go into a read-eval-print loop"
+
"{ Pragma: +optSpace }"
Transcript showCR:(self hello).
@@ -4102,10 +4174,10 @@
Transcript showCR:'Read-eval-print loop; exit with "#exit"; help with "?"'.
ReadEvalPrintLoop new
- prompt:'ST> ';
- doChunkFormat:false;
- error:Stderr;
- readEvalPrintLoop
+ prompt:'ST> ';
+ doChunkFormat:false;
+ error:Stderr;
+ readEvalPrintLoop
"Modified: / 07-12-2006 / 17:35:19 / cg"
!
@@ -4345,8 +4417,12 @@
!
start
- "main startup, if there is a Display, initialize it
- and start dispatching; otherwise go into a read-eval-print loop."
+ "low level entry from the VM's main.
+ After initializeSystem, this is the very first real entry into the Smalltalk world.
+ Analyzes the command line and checks what to do
+ (i.e. script/repl/eval or full blown IDE).
+ Also handles --load and various debug options.
+ Caveat: this has become too complicated and desperately needs a rewrite."
|idx graphicalMode arg didReadRCFile keepSplashWindow|
@@ -4354,31 +4430,27 @@
Initializing := true.
keepSplashWindow := StartupClass perform:#keepSplashWindowOpen ifNotUnderstood:[false].
-"/ now done AFTER reading smalltalk.rc
-"/ keepSplashWindow ifFalse:[
-"/ self hideSplashWindow. "/ if there is one, it's now time to hide it
-"/ ].
"
while reading patches- and rc-file, do not add things into change-file
"
Class withoutUpdatingChangesDo:[
- |commandFile defaultRC prevCatchSetting
- isEval isPrint isFilter isRepl idxFileArg process|
-
- isEval := isPrint := isFilter := isRepl := false.
+ |commandFiles rcFile defaultRC prevCatchSetting
+ isEval isPrint isFilter isRepl isRunMain idxFileArg process|
+
+ isEval := isPrint := isFilter := isRepl := isRunMain := false.
didReadRCFile := false.
StandAlone ifFalse:[
self initializeVerboseFlags.
-
+
"/
"/ look for any '-q', '-e', '-l' or '-f' command line arguments
"/ and handle them;
"/ read startup and patches file
"/
idx := CommandLineArguments indexOfAny:#('-R' '--repl').
- isRepl := (idx ~~ 0).
+ isRepl := IsRepl := (idx ~~ 0).
idx := CommandLineArguments indexOfAny:#('-q' '--silent').
idx ~~ 0 ifTrue:[
@@ -4394,9 +4466,11 @@
] whileTrue:[
arg := CommandLineArguments at:idx + 1.
CommandLineArguments removeAtIndex:idx+1; removeAtIndex:idx.
- self packagePath addLast:arg.
- VerboseStartup == true ifTrue:[
- ('Smalltalk [info]: add to packagePath: "', arg, '".') infoPrintCR.
+ (arg asCollectionOfSubstringsSeparatedByAny:',;') do:[:each |
+ self packagePath addLast:each.
+ VerboseStartup ifTrue:[
+ ('Smalltalk [info]: add to packagePath: "', arg, '".') infoPrintCR.
+ ].
].
].
@@ -4406,14 +4480,24 @@
] whileTrue:[
arg := CommandLineArguments at:idx + 1.
CommandLineArguments removeAtIndex:idx+1; removeAtIndex:idx.
- arg asFilename exists ifTrue:[
- Smalltalk fileIn:arg
- ] ifFalse:[
- Smalltalk loadPackage:arg
+ Smalltalk silentlyLoadingDo:[
+ (arg asCollectionOfSubstringsSeparatedByAny:',;') do:[:each |
+ each asFilename exists ifTrue:[
+ (VerboseStartup | VerboseLoading) ifTrue:[
+ ('Smalltalk [info]: loading file: "', each, '".') infoPrintCR.
+ ].
+ Smalltalk fileIn:each
+ ] ifFalse:[
+ (VerboseStartup | VerboseLoading) ifTrue:[
+ ('Smalltalk [info]: loading package: "', each, '".') infoPrintCR.
+ ].
+ Smalltalk loadPackage:each
+ ].
+ ].
].
].
- "/ look for a '-e filename' or '--execute filename' argument
+ "/ look for a '-e filename' or '--execute filename' or '--script filename' argument
"/ this will force fileIn of filename only, no standard startup.
idx := CommandLineArguments indexOfAny:#('-e' '--execute' '--script').
@@ -4429,38 +4513,63 @@
Initializing := false.
process := [
- VerboseStartup == true ifTrue:[
- ('Smalltalk [info]: reading script from: "', arg, '".') infoPrintCR.
- ].
- UserInterrupt handle:[:ex |
- Debugging == true ifTrue:[
- 'user interrupt (type "c" to continue; "x" to exit; "?" for help).' errorPrintCR.
- "/ thisContext fullPrintAll.
- MiniDebugger enter.
- ex proceed.
- ].
- self exit:128+(OperatingSystem sigINT).
- ] do:[
- arg = '-' ifTrue:[
- self fileInStream:Stdin
- lazy:nil
- silent:nil
- logged:false
- addPath:nil
- ] ifFalse:[
- IsSTScript := true.
- self fileIn:arg.
+ Processor exitWhenNoMoreUserProcesses:true.
+
+ "/ set workspace variables
+ self defineCommandLineAsWorkspaceVariablesForScripts.
+
+ "/ provide a Display, if needed
+ self providingDisplayDo:[
+ VerboseStartup ifTrue:[
+ ('Smalltalk [info]: reading script from: "', arg, '".') infoPrintCR.
+ ].
+ NoHandlerError handle:[:ex |
+ Debugging == true ifFalse:[
+ ex description _errorPrintCR.
+ (VerboseStartup or:[ObjectMemory debugPrinting]) ifTrue:[
+ ex suspendedContext fullPrintAll.
+ ].
+ self exit:1.
+ ].
+ self exit:1.
+ "/ ex reject.
+ ] do:[
+ UserInterrupt handle:[:ex |
+ Debugging == true ifTrue:[
+ 'user interrupt (type "c" to continue; "x" to exit; "?" for help).' errorPrintCR.
+ "/ thisContext fullPrintAll.
+ MiniDebugger enter.
+ ex proceed.
+ ].
+ self exit:128+(OperatingSystem sigINT).
+ ] do:[
+ arg = '-' ifTrue:[
+ self fileInStream:Stdin
+ lazy:nil
+ silent:nil
+ logged:false
+ addPath:nil
+ ] ifFalse:[
+ IsSTScript := true.
+ Smalltalk silentlyLoadingDo:[
+ self fileIn:arg.
+ ].
+ ].
+ ].
].
].
+
"/ after the script, if Screen has been opened and there are any open windows,
"/ then do not exit
+false ifTrue:[
Display notNil ifTrue:[
- Display exitOnLastClose:true.
- Display checkForEndOfDispatch.
Processor exitWhenNoMoreUserProcesses:true.
+ "/ Display exitOnLastClose:true.
+ "/ Display checkForEndOfDispatch.
] ifFalse:[
self exit.
].
+].
] newProcess.
process priority:(Processor userSchedulingPriority).
process name:'main'.
@@ -4472,11 +4581,14 @@
].
"look for a '-f filename' or '--file filename' argument
- if scripting, this is loaded before -P, -E or -R action.
+ if scripting, these are loaded before -P, -E or -R action.
if not scripting, this will force evaluation of filename instead of smalltalk.rc"
- idxFileArg := CommandLineArguments indexOfAny:#('-f' '--file').
- (idxFileArg ~~ 0) ifTrue:[
- commandFile := CommandLineArguments at:idxFileArg+1.
+ [
+ idxFileArg := CommandLineArguments indexOfAny:#('-f' '--file').
+ (idxFileArg ~~ 0)
+ ] whileTrue:[
+ commandFiles isNil ifTrue:[ commandFiles := OrderedCollection new ].
+ commandFiles add:(CommandLineArguments at:idxFileArg+1).
CommandLineArguments removeAtIndex:idxFileArg+1; removeAtIndex:idxFileArg.
].
@@ -4491,16 +4603,19 @@
idx := CommandLineArguments indexOfAny:#('-F' '--filter').
(isFilter := (idx ~~ 0)) ifFalse:[
idx := CommandLineArguments indexOfAny:#('-R' '--repl').
- isRepl := (idx ~~ 0)
+ (isRepl := (idx ~~ 0)) ifFalse:[
+ idx := CommandLineArguments indexOfAny:#('--run').
+ isRunMain := (idx ~~ 0)
+ ].
].
].
].
- (isEval | isPrint | isFilter | isRepl) ifTrue:[
+ (isEval | isPrint | isFilter | isRepl | isRunMain) ifTrue:[
isRepl ifFalse:[
CommandLineArguments size <= idx ifTrue:[
- 'stx: missing argument after -E/-P/-F' errorPrintCR.
- self exit:1.
+ StandAlone := true.
+ self exitWithErrorMessage:'missing argument after -E/-P/-F/--run.'.
].
arg := CommandLineArguments at:idx + 1.
CommandLineArguments removeAtIndex:idx+1.
@@ -4511,108 +4626,164 @@
keepSplashWindow ifFalse:[ self hideSplashWindow ].
Initializing := false.
- "/ enable this, so we can provide $1..$n in the script
- ParserFlags allowDollarInIdentifier:true.
- ParserFlags warnDollarInIdentifier:false.
-
- "/ add bindings for arguments
- CommandLineArguments doWithIndex:[:arg :i |
- Workspace workspaceVariableAt:('_$',i printString) put:arg.
- ].
+ "/ set workspace variables
+ self defineCommandLineAsWorkspaceVariablesForScripts.
"/ all of the above allow for a -f file to be loaded before any other action
- (commandFile notNil) ifTrue:[
- VerboseStartup == true ifTrue:[
- ('Smalltalk [info]: reading command file from: "', commandFile, '".') infoPrintCR.
- ].
- (self secureFileIn:commandFile) ifFalse:[
- ('Smalltalk [error]: "', commandFile, '" not found.') errorPrintCR.
- OperatingSystem exit:1.
+ (commandFiles notEmptyOrNil) ifTrue:[
+ commandFiles do:[:commandFile |
+ (VerboseStartup | VerboseLoading) ifTrue:[
+ ('Smalltalk [info]: reading command file from: "', commandFile, '".') infoPrintCR.
+ ].
+ Smalltalk silentlyLoadingDo:[
+ (self secureFileIn:commandFile) ifFalse:[
+ StandAlone := true.
+ self exitWithErrorMessage:('"', commandFile, '" not found.').
+ ]
+ ]
]
].
- isRepl ifTrue:[
- self readEvalPrint.
- self exit.
+ isRepl ifFalse:[
+ Debugging == true ifFalse:[
+ "/ remove the Debugger
+ Debugger := nil.
+ ].
].
process := [
- VerboseStartup == true ifTrue:[
- ('Smalltalk [info]: executing expression: "', arg, '".') infoPrintCR.
- ].
- UserInterrupt handle:[:ex |
- Debugging == true ifTrue:[
- 'user interrupt (type "c" to continue; "x" to exit; "?" for help).' errorPrintCR.
- "/ thisContext fullPrintAll.
- MiniDebugger enter.
- ex proceed.
- ].
- self exit:128+(OperatingSystem sigINT).
- ] do:[
- isFilter ifTrue:[
- "/ --filter - apply code to each input line.
- "/ compile code only once
- Compiler
- compile:'doIt:line ',arg
- forClass:String
- notifying:(EvalScriptingErrorHandler new source:arg).
-
- [Stdin atEnd] whileFalse:[
- |line|
-
- line := Stdin nextLine.
- line doIt:line.
+ self providingDisplayDo:[
+ isRepl ifTrue:[
+ Processor exitWhenNoMoreUserProcesses:false.
+ Processor activeProcess name:'repl'.
+ self readEvalPrintLoop.
+ self exit.
+ ].
+
+ Processor exitWhenNoMoreUserProcesses:true.
+
+ NoHandlerError handle:[:ex |
+ Debugging == true ifFalse:[
+ ex description _errorPrintCR.
+ (VerboseStartup or:[ObjectMemory debugPrinting]) ifTrue:[
+ ex suspendedContext fullPrintAll.
+ ].
+ self exit:1.
+ ].
+ self exit:1.
+ "/ ex reject.
+ ] do:[
+ VerboseStartup ifTrue:[
+ ('Smalltalk [info]: executing expression: "', arg, '".') infoPrintCR.
].
- ] ifFalse:[
- "/ --print or --eval
- |rslt|
-
- rslt := Parser new
- evaluate:arg
- notifying:(EvalScriptingErrorHandler new source:arg)
- compile:true.
- isPrint ifTrue:[
- rslt printCR.
+ UserInterrupt handle:[:ex |
+ Debugging == true ifTrue:[
+ 'user interrupt (type "c" to continue; "x" to exit; "?" for help).' errorPrintCR.
+ "/ thisContext fullPrintAll.
+ MiniDebugger enter.
+ ex proceed.
+ ].
+ self exit:128+(OperatingSystem sigINT).
+ ] do:[
+ isFilter ifTrue:[
+ "/ --filter - apply code to each input line.
+ "/ compile code only once
+ Compiler
+ compile:'doIt:line ',arg
+ forClass:String
+ notifying:(EvalScriptingErrorHandler new source:arg).
+
+ [Stdin atEnd] whileFalse:[
+ |line|
+
+ line := Stdin nextLine.
+ line doIt:line.
+ ].
+ ] ifFalse:[
+ (isPrint | isEval) ifTrue:[
+ "/ --print or --eval
+ |rslt|
+
+ rslt := Parser new
+ evaluate:arg
+ notifying:(EvalScriptingErrorHandler new source:arg)
+ compile:true.
+ isPrint ifTrue:[
+ rslt printCR.
+ ].
+ ] ifFalse:[
+ "/ --run <className>
+ |className class|
+
+ className := arg.
+ class := Smalltalk classNamed:className.
+ class isNil ifTrue:[
+ StandAlone := true.
+ self exitWithErrorMessage:'no such class: "', className, '".'
+ ].
+ (class respondsTo:#main:) ifTrue:[
+ class main:CommandLineArguments.
+ ] ifFalse:[
+ (class respondsTo:#main) ifTrue:[
+ class main.
+ ] ifFalse:[
+ (class respondsTo:#start) ifTrue:[
+ class start.
+ ] ifFalse:[
+ StandAlone := true.
+ self exitWithErrorMessage:'class has no "main:", "main" or "start" method.'
+ ].
+ ].
+ ].
+ ].
+ ].
].
].
].
-
+
"/ after the script, if Screen has been opened and there are any open windows,
"/ then do not exit
+false ifTrue:[
Display notNil ifTrue:[
- Display exitOnLastClose:true.
- Display checkForEndOfDispatch.
Processor exitWhenNoMoreUserProcesses:true.
- VerboseStartup == true ifTrue:[
+ "/ Display exitOnLastClose:true.
+ "/ Display checkForEndOfDispatch.
+ VerboseStartup ifTrue:[
('Smalltalk [info]: display opened.') infoPrintCR.
].
] ifFalse:[
- VerboseStartup == true ifTrue:[
+ VerboseStartup ifTrue:[
('Smalltalk [info]: no display - exit after script.') infoPrintCR.
].
self exit.
].
- ] newProcess.
+].
+ VerboseStartup ifTrue:[
+ ('Smalltalk [info]: script/repl/eval finished.') infoPrintCR.
+ ].
+
+ ] newProcess.
process priority:(Processor userSchedulingPriority).
process name:'main'.
process beGroupLeader.
process resume.
Processor dispatchLoop.
- VerboseStartup == true ifTrue:[
+ VerboseStartup ifTrue:[
('Smalltalk [info]: exit normally.') infoPrintCR.
].
self exit
].
].
- commandFile notNil ifTrue:[
+ commandFiles notNil ifTrue:[
SilentLoading := true. "/ suppress the hello & copyright messages
self addStartBlock:
[
- (self secureFileIn:commandFile) ifFalse:[
- ('Smalltalk [error]: startup file "', commandFile, '" not found.') errorPrintCR.
- OperatingSystem exit:1.
+ commandFiles do:[:commandFile |
+ (self secureFileIn:commandFile) ifFalse:[
+ self exitWithErrorMessage:('startup file "', commandFile, '" not found.').
+ ].
].
].
@@ -4628,8 +4799,8 @@
"/ look for <command>.rc
"/ if not found, read smalltalk.rc (or stxapp.rc for standAlone operation)
- commandFile := self commandName asFilename withSuffix:'rc'.
- (didReadRCFile := commandFile exists and:[self secureFileIn:commandFile]) ifFalse:[
+ rcFile := self commandName asFilename withSuffix:'rc'.
+ (didReadRCFile := rcFile exists and:[self secureFileIn:rcFile]) ifFalse:[
StandAlone ifFalse:[
defaultRC := 'smalltalk.rc' "/asFilename
] ifTrue:[
@@ -4871,6 +5042,11 @@
"
self exitOrError:0
"
+!
+
+exitWithErrorMessage:msg
+ ('Smalltalk [error]: ',msg) errorPrintCR.
+ self exitOrError:1
! !
!Smalltalk class methodsFor:'startup queries'!
@@ -5238,7 +5414,7 @@
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."
+ This is being automated - so don't care for now."
|newStream table source pos fileName|
@@ -5251,26 +5427,26 @@
table := IdentityDictionary new:100.
Method allSubInstancesDo:[:aMethod |
- source := nil.
- aMethod sourcePosition notNil ifTrue:[
- aMethod sourceFilename = 'st.src' ifTrue:[
- source := aMethod source.
- ]
- ] ifFalse:[
- source := aMethod source
- ].
-
- source notNil ifTrue:[
- pos := newStream position + 1.
- 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
- ]
+ source := nil.
+ aMethod sourcePosition notNil ifTrue:[
+ aMethod sourceFilename = 'st.src' ifTrue:[
+ source := aMethod source.
+ ]
+ ] ifFalse:[
+ source := aMethod source
+ ].
+
+ source notNil ifTrue:[
+ pos := newStream position + 1.
+ 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 syncData; close.
@@ -5285,7 +5461,7 @@
source reference"
table keysAndValuesDo:[:aMethod :pos |
- aMethod localSourceFilename:fileName position:pos.
+ aMethod localSourceFilename:fileName position:pos.
"/ aMethod printCR.
].
@@ -5313,18 +5489,18 @@
table := IdentityDictionary new:100.
Method allSubInstancesDo:[:aMethod |
- source := aMethod source.
- source notNil ifTrue:[
- pos := newStream position + 1.
- 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
- ]
+ source := aMethod source.
+ source notNil ifTrue:[
+ pos := newStream position + 1.
+ newStream nextChunkPut:source.
+
+ "
+ don't 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 syncData; close.
@@ -5339,7 +5515,7 @@
source reference"
table keysAndValuesDo:[:aMethod :pos |
- aMethod localSourceFilename:fileName position:pos.
+ aMethod localSourceFilename:fileName position:pos.
"/ aMethod printCR.
].
@@ -7471,23 +7647,23 @@
fn := aFileNameOrString asFilename.
nameString := fn name.
fn isAbsolute ifTrue:[
- "dont use path for absolute file names"
-
- ^ nameString
+ "don't use path for absolute file names"
+
+ ^ nameString
].
self realSystemPath do:[:dirName |
- |realName|
-
- realName := dirName asFilename / 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
- ]
+ |realName|
+
+ realName := dirName asFilename / 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
@@ -7916,26 +8092,26 @@
((f := aFileName asFilename) isAbsolute
or:[f isExplicitRelative]) ifTrue:[
- "/
- "/ dont use path for absolute or explicit .-relative file names
- "/
- ^ aFileName
+ "/
+ "/ don't 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 / aDirName / aFileName.
- ] ifFalse:[
- realName := dir / aFileName.
- ].
- (realName isReadable) ifTrue:[
- ^ realName name
- ]
- ].
+ aPath do:[:dirName |
+ |realName dir|
+
+ dir := dirName asFilename.
+ aDirName notNil ifTrue:[
+ realName := dir / aDirName / aFileName.
+ ] ifFalse:[
+ realName := dir / aFileName.
+ ].
+ (realName isReadable) ifTrue:[
+ ^ realName name
+ ]
+ ].
].
"/ not needed - executing dir is always in SearchPath
@@ -8190,6 +8366,69 @@
"
!
+knownLoadablePackagesDo:aBlock
+ "enumerate loadable packages from the packages folder."
+
+ Smalltalk realSystemPath do:[:dirName |
+ |packageDir|
+
+ packageDir := dirName asFilename / 'packages'.
+ (packageDir exists and:[packageDir isDirectory]) ifTrue:[
+ packageDir directoryContentsAsFilenames sort do:[:fn |
+ |item base nm path parentPath parent isLibrary isApplication isAlreadyLoaded
+ defClass target type nameComponents packageName packageID|
+
+ ((fn suffix = 'mcz')
+ or:[ fn isDirectory
+ or:[ (fn baseName startsWith:'.')
+ or:[ (fn baseName = 'README') ]]]) ifFalse:[
+ base := fn withoutSuffix baseName.
+ (base startsWith:'lib') ifTrue:[
+ nm := (base copyFrom:4).
+ fn suffix notEmptyOrNil ifTrue:[
+ type := #library.
+ ] ifFalse:[
+ type := #application.
+ ]
+ ] ifFalse:[
+ nm := base.
+ type := #application.
+ ].
+
+ (base ~= 'librun') ifTrue:[
+ (fn suffix = 'mcz') ifTrue:[
+ packageName := fn withoutSuffix.
+ target := fn.
+ ] ifFalse:[
+ ( #('dll' 'so' 'sl' 'dylib') includes:(fn suffix)) ifTrue:[
+ (base startsWith:'lib') ifTrue:[
+ nm := base copyFrom:4.
+ ] ifFalse:[
+ nm := base.
+ ].
+ ].
+ nameComponents := nm asCollectionOfSubstringsSeparatedBy:$_.
+ packageName := nameComponents first.
+ nameComponents size > 1 ifTrue:[
+ packageName := packageName,':',((nameComponents from:2) asStringWith:'/')
+ ].
+ ].
+ packageName notNil ifTrue:[
+ aBlock value:packageName value:type value:fn .
+ ]
+ ]
+ ]
+ ]
+ ]
+ ]
+
+ "
+ Smalltalk knownLoadablePackagesDo:[:packageID :type :path |
+ Transcript showCR:'%1 (%2) in %3' with:packageID with:type with:path.
+ ]
+ "
+!
+
loadPackage:aPackageIdOrPackage
"make certain, that some particular package is loaded into the system.
Return true if loaded, false otherwise."