--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/cli/TCompilerCommand.st Fri Sep 25 03:51:15 2015 +0100
@@ -0,0 +1,486 @@
+"
+ Copyright (C) 2015-now Jan Vrany
+
+ This code is not an open-source (yet). You may use this code
+ for your own experiments and projects, given that:
+
+ * all modification to the code will be sent to the
+ original author for inclusion in future releases
+ * this is not used in any commercial software
+
+ This license is provisional and may (will) change in
+ a future.
+"
+"{ Package: 'jv:tea/compiler/cli' }"
+
+"{ NameSpace: Smalltalk }"
+
+StandaloneStartup subclass:#TCompilerCommand
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Languages-Tea-Compiler'
+!
+
+TCompilerCommand class instanceVariableNames:'debugging includes options'
+
+"
+ The following class instance variables are inherited by this class:
+
+ StandaloneStartup - MutexHandle
+ Object -
+"
+!
+
+!TCompilerCommand class methodsFor:'documentation'!
+
+copyright
+"
+ Copyright (C) 2015-now Jan Vrany
+
+ This code is not an open-source (yet). You may use this code
+ for your own experiments and projects, given that:
+
+ * all modification to the code will be sent to the
+ original author for inclusion in future releases
+ * this is not used in any commercial software
+
+ This license is provisional and may (will) change in
+ a future.
+"
+! !
+
+!TCompilerCommand class methodsFor:'initialization'!
+
+initialize
+
+ super initialize.
+ debugging := Transcript notNil and:[Transcript isView].
+ self setupSignalHandlers.
+
+ "Created: / 06-11-2011 / 22:07:14 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 01-09-2015 / 18:42:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!TCompilerCommand class methodsFor:'compiling'!
+
+process: files
+ "Actually compile files using `options` and `includes`."
+
+ | env ctx compiler units |
+
+ env := TEnvironment new.
+ env provider classpath addAll: includes.
+
+ ctx := TCompilerContext new.
+ ctx options: options.
+ ctx environment: env.
+
+ compiler := TCompiler new.
+ compiler context: ctx.
+
+ files isEmpty ifTrue:[
+ TCompilerError raiseErrorString:'no input files'.
+ ].
+ units := OrderedCollection new: files size.
+ files do:[:filename |
+ | file |
+
+ file := filename asFilename.
+ file isRegularFile ifFalse:[
+ TCompilerError raiseErrorString: ('file does not exist: %1' bindWith: filename).
+ ].
+ file isReadable ifFalse:[
+ TCompilerError raiseErrorString: ('file not readable: %1' bindWith: filename).
+ ].
+ file readingFileDo:[ :stream |
+ units add: (TSourceReader read: stream).
+ ].
+ ].
+ files with: units do:[:infile :unit |
+ compiler compile: unit.
+ options output isNil ifTrue:[
+ | outfile |
+
+ outfile := infile asFilename withSuffix: (options emitIR ifTrue:[ 'll' ] ifFalse: [ 'bc' ]).
+ self write: ctx llvmModule as: outfile.
+ ctx llvmModule: nil.
+ ].
+ ].
+ options output notNil ifTrue:[
+ self write: ctx llvmModule as: options output.
+ ].
+
+ "Created: / 24-09-2015 / 16:46:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 24-09-2015 / 18:45:53 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+write: anLLVMModule as: aString
+ options emitIR ifTrue:[
+ aString asFilename writingFileDo:[:s|anLLVMModule dumpOn: s].
+ ] ifFalse:[
+ anLLVMModule writeBitcodeToFile: aString
+ ]
+
+ "Created: / 24-09-2015 / 17:06:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!TCompilerCommand class methodsFor:'debugging'!
+
+dumpProcess: aProcess
+ Stderr cr; cr
+
+ "Created: / 27-06-2013 / 23:41:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+dumpProcess: aProcess on: aStream
+ | ctx |
+ aStream cr; cr.
+ aStream nextPutAll: '== ['; nextPutAll: aProcess id printString; nextPutAll:'] '; nextPutAll: aProcess name; nextPutAll: ' =='; cr.
+ aStream cr.
+ aStream nextPutAll: ' State: '; nextPutAll: aProcess state printString; cr.
+ aStream nextPutAll: ' Group: '; nextPutAll: aProcess processGroupId printString; cr.
+ aStream nextPutAll: ' Creator: '; nextPutAll: aProcess processGroupId printString; cr.
+ aStream nextPutAll: ' Stack: '; cr; cr.
+
+ aProcess == Processor activeProcess ifTrue:[ctx := thisContext] ifFalse:[ctx := aProcess suspendedContext].
+ [ ctx notNil ] whileTrue:[
+ aStream nextPutAll: ' '.
+ ctx fullPrintOn: aStream.
+ aStream cr.
+ ctx := ctx sender.
+ ].
+ aStream cr.
+
+ "
+ self dumpProcess: Processor activeProcess on: Transcript.
+ "
+
+ "Created: / 28-06-2013 / 01:00:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 06-06-2014 / 09:14:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+dumpProcesses
+ self dumpProcessesOn: Stderr
+
+ "
+ self dumpProcessesOn: Transcript.
+ "
+
+ "Created: / 27-06-2013 / 23:41:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified (comment): / 28-06-2013 / 01:06:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+dumpProcessesOn: aStream
+ Process allInstancesDo:[:process|
+ process isDead ifFalse:[
+ self dumpProcess: process on: aStream
+ ]
+ ]
+
+ "Created: / 27-06-2013 / 23:42:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!TCompilerCommand class methodsFor:'defaults'!
+
+allowCoverageMeasurementOption
+
+ ^false "CoverageReport will do that"
+
+ "Created: / 13-01-2012 / 11:48:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+allowDebugOption
+
+ ^true
+
+ "Created: / 21-07-2011 / 09:48:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!TCompilerCommand class methodsFor:'multiple applications support'!
+
+applicationRegistryPath
+ "the key under which this application stores its process ID in the registry
+ as a collection of path-components.
+ i.e. if #('foo' 'bar' 'baz') is returned here, the current applications ID will be stored
+ in HKEY_CURRENT_USER\Software\foo\bar\baz\CurrentID.
+ (would also be used as a relative path for a temporary lock file under unix).
+ Used to detect if another instance of this application is already running."
+
+ ^ #('jv' 'tea' 'compiler')
+
+ "Modified: / 01-09-2015 / 18:33:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+applicationUUID
+ "answer an application-specific unique uuid.
+ This is used as the name of some exclusive OS-resource, which is used to find out,
+ if another instance of this application is already running.
+ Under win32, a mutex is used; under unix, an exclusive file in the tempDir could be used."
+
+ ^ '8a084bc0-50cf-11e5-bf6b-606720e43e2c' asUUID
+
+ "Modified: / 01-09-2015 / 18:33:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!TCompilerCommand class methodsFor:'options'!
+
+cmdlineOptionEmitLLVMIR
+ ^CmdLineOption new
+ long: 'emit-llvm-ir';
+ description: 'Emit LLVM IR (.ll) instead of bitcode (.bc)';
+ action:[options emitIR: true];
+ yourself
+
+ "Created: / 24-09-2015 / 16:35:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 24-09-2015 / 18:46:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+cmdlineOptionOutput
+ ^CmdLineOption new
+ short: $o;
+ long: 'output';
+ description: 'Place output in specified file';
+ action:[:file | options output: file];
+ yourself
+
+ "Created: / 24-09-2015 / 16:32:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!TCompilerCommand class methodsFor:'startup'!
+
+handleSIGTERM
+ self dumpProcesses.
+ debugging ifFalse:[
+ Smalltalk exit:127.
+ ].
+
+ "Created: / 27-06-2013 / 23:10:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 28-06-2013 / 01:08:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+handleSIGUSR2
+ self dumpProcesses
+
+ "Created: / 27-06-2013 / 23:10:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+setupSignalHandlers
+ "On UNIX, this sets up a custom signal handler on SIGUSR2 and SIGTERM that
+ dumps stacks on all threads"
+
+ | sigusr2 sigterm |
+
+ OperatingSystem isUNIXlike ifTrue:[
+ sigterm := Signal new.
+ sigterm handlerBlock: [:ex | self handleSIGTERM].
+ OperatingSystem operatingSystemSignal:OperatingSystem sigTERM install: sigterm.
+ OperatingSystem enableSignal: OperatingSystem sigTERM.
+
+ sigusr2 := Signal new.
+ sigusr2 handlerBlock: [:ex | self handleSIGUSR2].
+ OperatingSystem operatingSystemSignal:OperatingSystem sigUSR2 install: sigusr2.
+ OperatingSystem enableSignal: OperatingSystem sigUSR2.
+ ].
+
+ "
+ OperatingSystem sendSignal: OperatingSystem sigUSR2 to: OperatingSystem getProcessId
+ "
+
+ "Created: / 27-06-2013 / 20:57:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 28-06-2013 / 01:11:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified (format): / 01-09-2015 / 18:34:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+setupToolsForDebug
+
+ super setupToolsForDebug.
+ debugging := true.
+
+ "Created: / 06-11-2011 / 22:06:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+start
+ Smalltalk silentLoading: true.
+ ^ super start.
+
+ "Created: / 22-01-2014 / 09:17:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+usage
+
+ Stderr nextPutAll:'usage: tc';
+ nextPutAll: '[options] [FILE1 [FILE2 [...]]]'; cr.
+
+ Stderr nextPutLine:'Common options:'; cr.
+
+ Stderr nextPutLine:' --help .................. output this message'.
+"/ Stderr nextPutLine:' --verbose ............... verbose startup'.
+"/ Stderr nextPutLine:' --noBanner .............. no splash screen'.
+"/ Stderr nextPutLine:' --newAppInstance ........ start as its own application process (do not reuse'.
+"/ Stderr nextPutLine:' a running instance)'.
+"/ self allowScriptingOption ifTrue:[
+"/ Stderr nextPutLine:' --scripting portNr ...enable scripting via port (or stdin/stdOut if 0)'.
+"/ ].
+ self allowDebugOption ifTrue:[
+ Stderr nextPutLine:' --debug ................. enable Debugger'.
+ ].
+ "/ ' ......................... '
+ Stderr nextPutLine:' -I<dir> ................. adds <dir> to the list of directories searched for'.
+ Stderr nextPutLine:' sources'.
+ Stderr nextPutLine:' -o'.
+ Stderr nextPutLine:' --output <file> ........ place output to file <file>'.
+ Stderr nextPutLine:' --emit-llvm-ir .......... emit LLVM IR (.ll) instead of LLVM bitcode (.bc, default)'.
+ debugging ifFalse:[
+ Smalltalk exit:1.
+ ].
+ "
+ self usage
+ "
+
+ "Created: / 13-01-2012 / 11:48:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 24-09-2015 / 16:35:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+usageForReportClass: class
+ | options |
+
+ "/ '.........................' size 25
+ options := CmdLineOption optionsFor: class new.
+ options := options reject:[:option | 'pF' includes: option short ].
+ options notEmptyOrNil ifTrue:[
+ Stderr cr.
+ Stderr nextPutAll: class name; nextPutLine:' options:'; cr.
+ options do:[:option |
+ | optlen |
+
+ option short notNil ifTrue:[
+ Stderr nextPutAll: ' '.
+ Stderr nextPut: $-; nextPut: option short; space.
+ optlen := 2.
+ option hasParam ifTrue:[
+ | paramName |
+
+ paramName := 'val'.
+ Stderr nextPut:$<; nextPutAll: paramName; nextPut:$>; space.
+ optlen := optlen + 3 + paramName size.
+ ].
+ ].
+ option long notNil ifTrue:[
+ option short notNil ifTrue:[
+ Stderr cr.
+ ].
+ Stderr nextPutAll: ' --'.
+ Stderr nextPutAll: option long.
+ optlen := option long size + 2.
+ option hasParam ifTrue:[
+ | paramName |
+
+ paramName := 'val'.
+ Stderr nextPut:$=; nextPut:$<; nextPutAll: paramName; nextPut:$>.
+ optlen := optlen + 3 + paramName size.
+ ].
+ Stderr space.
+ ].
+ Stderr next: (26 - 1"space" -2"--" - optlen) put: $..
+ Stderr space.
+ option description notNil ifTrue:[
+ Stderr nextPutAll: option description
+ ].
+ Stderr cr.
+ ]
+ ]
+
+ "
+ ReportRunner usageForReportClass: TestReport.
+ "
+
+ "Created: / 27-05-2014 / 16:42:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 16-06-2014 / 11:25:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!TCompilerCommand class methodsFor:'startup-to be redefined'!
+
+main:argv0
+ "Process command line arguments"
+
+ | argv parser i files |
+
+
+ argv := argv0 asOrderedCollection.
+ argv isEmpty ifTrue:[
+ self usage.
+ ].
+ argv remove: '--abortOnSEGV' ifAbsent:[nil].
+ parser := CmdLineParser new.
+ CmdLineOptionError autoload.
+ includes := OrderedCollection new.
+ options := TCompilerOptions new.
+ [
+ "/ Parse -I as they cannot be handled by option parser, sigh
+ i := 1.
+ [ i <= argv size ] whileTrue:[
+ | option |
+
+ option := argv at: i.
+ (option = '-I') ifTrue:[
+ i = argv size ifTrue:[
+ Stderr nextPutAll:'Error: -I must be followed by path'.
+ ] ifFalse:[
+ includes add: (argv at: i + 1)
+ ].
+ argv removeAtIndex: i + 1.
+ argv removeAtIndex: i.
+ ] ifFalse:[
+ (option startsWith: '-I') ifTrue:[
+ | include |
+
+ include := option copyFrom: 3.
+ include isEmptyOrNil ifTrue:[
+ Stderr nextPutAll:'Error: -I must be followed by path'.
+ ] ifFalse:[
+ includes add: include.
+ ].
+ argv removeAtIndex: i.
+ ] ifFalse:[
+ i := i + 1.
+ ].
+ ]
+ ].
+ files := parser parse: argv for: self.
+ ] on:CmdLineOptionError do:[:ex|
+ Stderr nextPutLine:'Error when processing options: ', ex description.
+ debugging ifFalse:[
+ ex suspendedContext fullPrintAllOn: Stderr.
+ Stderr nextPutLine:'Exiting'.
+ Smalltalk exit:1.
+ ] ifTrue:[
+ ex pass
+ ]
+ ].
+
+ debugging ifFalse:[
+ NoHandlerError emergencyHandler:(NoHandlerError abortingEmergencyHandler)
+ ].
+
+ [
+ self process: files.
+ debugging ifFalse:[
+ Smalltalk exit:0.
+ ].
+ ] on: Error do:[:ex|
+ Stderr nextPutAll:'Error when compiling: '.
+ Stderr nextPutAll:ex description; cr.
+ ex suspendedContext printAllOn:Stderr.
+ debugging ifFalse:[
+ Smalltalk exit:1.
+ ] ifTrue:[
+ ex pass
+ ]
+ ]
+
+ "Modified: / 24-09-2015 / 16:40:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+
+TCompilerCommand initialize!