"

 COPYRIGHT (c) 1989 by Claus Gittinger

 COPYRIGHT (c) 2006 by eXept Software AG

              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.

"

"{ Package: 'stx:libcomp' }"

Object subclass:#STCCompilerInterface

	instanceVariableNames:'originator parserFlags initName theNonMetaclassToCompileFor

		classToCompileFor stFileName cFileName oFileName stcFlags cFlags

		stcPath ccPath requestor methodCategory executionStatus package'

	classVariableNames:'SequenceNumber Verbose'

	poolDictionaries:''

	category:'System-Compiler'

!

!STCCompilerInterface class methodsFor:'documentation'!

copyright

"

 COPYRIGHT (c) 1989 by Claus Gittinger

 COPYRIGHT (c) 2006 by eXept Software AG

              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

"

    a refactored complex method - originally found in ByteCodeCompiler.

"

! !

!STCCompilerInterface class methodsFor:'accessing'!

stcPathOf:command 

    "return the path to an stc command, or nil if not found."

    |f d reqdSuffix cmd|

    "/

    "/ care for executable suffix

    "/

    cmd := command.

    OperatingSystem isMSDOSlike ifTrue:[

        reqdSuffix := 'exe'

    ] ifFalse:[

        OperatingSystem isVMSlike ifTrue:[

            reqdSuffix := 'EXE'

        ].

    ].

    reqdSuffix notNil ifTrue:[

        (f := cmd asFilename) suffix isEmpty ifTrue:[

            cmd := (f withSuffix:reqdSuffix) name

        ]

    ].

    "/

    "/ for our convenience, also check in current

    "/ and parent directories; even if PATH does not

    "/ include them ...

    "/

    "/ look in current ...

    d := Filename currentDirectory.

    (f := d construct:cmd) isExecutable ifTrue:[

        ^ f pathName

    ].

    "/ look in ../stc ...

    d := d construct:'..'.

    (f := (d construct:'stc') construct:cmd) isExecutable ifTrue:[

        ^ f pathName

    ].

    "/ look in ../../stc ...

    d := d construct:'..'.

    (f := (d construct:'stc') construct:cmd) isExecutable ifTrue:[

        ^ f pathName

    ].

    "/

    "/ ok, stc must be installed in some directory along the PATH

    "/

    ^ OperatingSystem pathOfCommand:command

    "

     STCCompilerInterface stcPathOf:'stc'     

    "

    "Created: 13.9.1995 / 14:37:16 / claus"

! !

!STCCompilerInterface class methodsFor:'class initialization'!

initialize

    Verbose := false.

! !

!STCCompilerInterface methodsFor:'accessing'!

cFileName:something

    cFileName := something.

!

incrementalStcPath 

    "return the path to the stc command for incremental method compilation, 

     or nil if not found."

    |f cmd|

    (cmd := parserFlags stcPath) isEmptyOrNil ifTrue:[

        (f := self class stcPathOf:'stc') notNil ifTrue:[

            cmd := f

        ] ifFalse:[

            cmd := self class stcPathOf:'demostc'

        ]

    ].

    (cmd notNil and:[cmd includes:Character space]) ifTrue:[

        cmd := '"' , cmd , '"'.

    ].

    ^ cmd

    "Created: 13.9.1995 / 14:36:36 / claus"

    "Modified: 13.9.1995 / 15:15:04 / claus"

!

originator:something

    originator := something.

!

parserFlags:something

    parserFlags := something.

!

stFileName:something

    stFileName := something.

! !

!STCCompilerInterface methodsFor:'machine code generation'!

compileToMachineCode:aString forClass:aClass selector:selector inCategory:categoryArg 

                             notifying:requestorArg install:install skipIfSame:skipIfSame silent:silent

    "this is called to compile primitive code.

     This is EXPERIMENTAL and going to be changed to raise an error,

     an redefined in subclasses which can do it (either by direct compilation, or by calling

     the external stc do do it)."

    |handle oldMethod newMethod ok dllFileName|

    install ifFalse:[

        "/ cannot do it uninstalled. reason:

        "/ if it is loaded twice, the first version could be unloaded by

        "/ finalization, which would also unload the second version

        "/ (because the first unload would unload the second version too)

        ^ #CannotLoad

    ].

    parserFlags isNil ifTrue:[

        parserFlags := ParserFlags new

    ].

    parserFlags stcCompilation == #never ifTrue:[^ #CannotLoad].

    classToCompileFor := aClass.

    requestor := requestorArg.

    methodCategory := categoryArg.

    self ensureModuleDirectoryExists.

    self ensureExternalToolsArePresent ifFalse:[^ #CannotLoad].

    theNonMetaclassToCompileFor := classToCompileFor theNonMetaclass.

    self ensureSuperClassesAreLoadedOf:theNonMetaclassToCompileFor.

    theNonMetaclassToCompileFor privateClassesSorted do:[:aPrivateClass |

        self ensureSuperClassesAreLoadedOf:aPrivateClass.

    ].

    (classToCompileFor isNil 

    or:[parserFlags allowExtensionsToPrivateClasses 

    or:[classToCompileFor owningClass isNil]]) ifTrue:[

        (requestor respondsTo:#packageToInstall) ifFalse:[

            package := Class packageQuerySignal query.

        ] ifTrue:[

            package := requestor packageToInstall

        ].

    ] ifFalse:[

        package := classToCompileFor owningClass package

    ].

    [

        self generateSTSource:aString.

        self setupCompilationCommandArguments.

        ok := self compileToC.

        ok ifFalse:[

            self reportCompilationErrorFor:stcPath.

            ^ #Error

        ].

        parserFlags stcKeepSIntermediate ifTrue:[ self compileToS ].

        "/ now compile to machine code

        ok := self compileToObj.

        ok ifFalse:[

            self reportCompilationErrorFor:ccPath.

            ^ #Error

        ].

        originator activityNotification:''.

        OperatingSystem removeFile:'errorOutput'.

        "

         if required, make a shared or otherwise loadable object file for it

        "

        originator activityNotification:'linking'.

        dllFileName := ObjectFileLoader createLoadableObjectFor:(oFileName asFilename withoutSuffix name).

        dllFileName isNil ifTrue:[

            "/ something went wrong

            originator parseError:('link error: ' , ObjectFileLoader lastError) position:1.

            ^ #CannotLoad

        ].

        dllFileName asFilename exists ifFalse:[

            originator parseError:'link failed - cannot create machine code' position:1.

            ^ #CannotLoad

        ].

        oldMethod := classToCompileFor compiledMethodAt:selector.

        oldMethod notNil ifTrue:[package := oldMethod package].

        install ifTrue:[

            (Smalltalk

                    changeRequest:#methodInClass

                    with:(Array with:classToCompileFor with:selector with:oldMethod)) ifFalse:[

                ^ #CannotLoad

            ].

        ].

        "

         load the method objectfile

        "

        originator activityNotification:'loading'.

        handle := ObjectFileLoader loadMethodObjectFile:dllFileName.

        handle isNil ifTrue:[

            OperatingSystem removeFile:dllFileName.

            "catch, so that #CannotLoad processing is done"

            ParseError catch:[

                originator parseError:'dynamic load of machine code failed' position:1.

            ].

            ^ #CannotLoad

        ].

        "

         did it work ?

        "

        newMethod := classToCompileFor compiledMethodAt:selector.

        "/ if install is false, we have to undo the install (which is always done, when loading machine code)

        install ifFalse:[

            oldMethod isNil ifTrue:[

                classToCompileFor removeSelector:selector

            ] ifFalse:[

                newMethod setPackage:oldMethod package.

                classToCompileFor addSelector:selector withMethod:oldMethod.

                oldMethod setPackage:package.

            ]

        ].

        newMethod notNil ifTrue:[

            handle method ~~ newMethod ifTrue:[

                'Compiler [warning]: loaded method installed itself in another class' errorPrintCR.

            ].

            newMethod source:aString string.

            newMethod setPackage:package.

"/            Project notNil ifTrue:[

"/                newMethod package:(Project currentPackageName)

"/            ].

    "/        classToCompileFor updateRevisionString.

            install ifTrue:[

                classToCompileFor addChangeRecordForMethod:newMethod fromOld:oldMethod.

                "/ kludge-sigh: must send change messages manually here (stc-loaded code does not do it)

                "/ see addMethod:... in ClassDescription

                classToCompileFor changed:#methodDictionary with:(Array with:selector with:oldMethod).

                Smalltalk changed:#methodInClass with:(Array with:classToCompileFor with:selector with:oldMethod).

            ] ifFalse:[

                oldMethod := nil.

            ].

            silent ifFalse:[

                Transcript showCR:('    compiled: ', aClass name,' ',selector,' - machine code')

            ].

            ObjectMemory flushCaches.

            handle method:newMethod.

            "/ check for obsolete compiled method code and unload the

            "/ corresponding ObjectFileHandle.

            "/ The old method with its source code is usually kept in the method history.

            "/ and will be recompiled on an undo

            ObjectFileLoader loadedObjectHandlesDo:[:anotherHandle |

                anotherHandle isMethodHandle ifTrue:[

                    anotherHandle method == oldMethod ifTrue:[

                        "break association betwen old method, code and handle"

                        anotherHandle removeConnectedObjects.

                    ].

                    anotherHandle isObsolete ifTrue:[

                        anotherHandle unload.

                        anotherHandle removeUnusedObjectFile.

                    ].

                ].

            ].

            ^ newMethod.

        ].

        "/ OperatingSystem removeFile:moduleFileName.

        originator parseError:'dynamic load failed' position:1.

        ^ #CannotLoad

    ] ensure:[

        parserFlags stcKeepSTIntermediate ifTrue:[

            Transcript showCR:'keeping st file: ', stFileName asFilename pathName

        ] ifFalse:[

            OperatingSystem removeFile:stFileName.

            OperatingSystem removeFile:'errorOutput'.

        ].

        parserFlags stcKeepCIntermediate == true ifTrue:[

            Transcript showCR:'keeping c file: ', cFileName asFilename pathName

        ] ifFalse:[

            (cFileName notNil and:[cFileName asFilename exists]) ifTrue:[cFileName asFilename delete].

        ].

        parserFlags stcKeepOIntermediate == true ifTrue:[

            Transcript showCR:'keeping o file: ', oFileName asFilename pathName

        ] ifFalse:[

            (oFileName notNil and:[oFileName asFilename exists]) ifTrue:[oFileName asFilename delete].

        ].

        OperatingSystem isMSDOSlike ifTrue:[

"/            (mapFileName notNil and:[mapFileName asFilename exists]) ifTrue:[mapFileName asFilename delete].

"/            (libFileName notNil and:[libFileName asFilename exists]) ifTrue:[libFileName asFilename delete].

        ].

    ].

    "

     |m|

     Object subclass:#Test

            instanceVariableNames:''

            classVariableNames:''

            poolDictionaries:''

            category:'tests'.

     m := ByteCodeCompiler

            compile:'foo ^ ''hello'''

            forClass:Test

            inCategory:'tests'

            notifying:nil

            install:false

            skipIfSame:false.

     m inspect

    "

    "

     |m|

     Object subclass:#Test

            instanceVariableNames:''

            classVariableNames:''

            poolDictionaries:''

            category:'tests'.

     m := ByteCodeCompiler

            compileToMachineCode:'foo %{ RETURN (_MKSMALLINT(1)); %}'

            forClass:Test

            inCategory:'tests'

            notifying:nil

            install:false

            skipIfSame:false

            silent:false.

     m inspect

    "

    "Modified: / 14-09-1995 / 22:33:04 / claus"

    "Modified: / 19-03-1999 / 08:31:42 / stefan"

    "Modified: / 17-09-2011 / 10:39:25 / cg"

! !

!STCCompilerInterface methodsFor:'machine code generation-helpers'!

compileToC

    "compile st to C using stc"

    |command errorStream ok|

    command := (self possiblyQuotedPath:stcPath) , ' ' , stcFlags 

                ' -C ' , (self possiblyQuotedPath:stFileName asFilename pathName).

    errorStream := 'errorOutput' asFilename writeStream.

    Verbose == true ifTrue:[

        'executing: ' infoPrint. command infoPrintCR.

    ].

    originator activityNotification:'compiling (stc)'.

    ok := OperatingSystem 

                executeCommand:command 

                inputFrom:nil

                outputTo:errorStream

                errorTo:errorStream

                onError:[:stat| 

                            executionStatus := stat.

                            false

                        ].

    errorStream close.

    cFileName asFilename exists ifTrue:[

        ok ifFalse:[

            'Compiler [info]: oops - system says stc failed - but c-file is there ...' infoPrintCR.

            ok := true

        ]

    ] ifFalse:[

        ok ifTrue:[

            'Compiler [info]: oops - system says stc ok - but no c-file is there ...' infoPrintCR.

        ].

        ok := false

    ].

    ^ ok

    "Created: / 07-11-2006 / 12:11:24 / cg"

    "Modified: / 08-08-2011 / 22:12:01 / cg"

!

compileToExe

    "compile C to exe, using cc"

    |command errorStream ok|

    errorStream := 'errorOutput' asFilename newReadWriteStream.

    command := (self possiblyQuotedPath:ccPath) , ' ' , cFlags , ' -D__INCREMENTAL_COMPILE__ ' , (self possiblyQuotedPath:cFileName).

    Verbose == true ifTrue:[

        'executing: ' infoPrint. command infoPrintCR.

    ].

    originator activityNotification:'compiling (' , ccPath , ')'.

    ok := OperatingSystem 

                executeCommand:command 

                inputFrom:nil

                outputTo:errorStream

                errorTo:errorStream

                onError:[:stat| 

                            executionStatus := stat.

                            false

                ].

    ok ifFalse:[

        errorStream reset.

        errorStream copyToEndInto:Transcript.

    ].

    errorStream close.

    ^ ok

!

compileToObj

    "compile C to obj, using cc"

    errorStream := 'errorOutput' asFilename newReadWriteStream.

    ParserFlags useBorlandC ifTrue:[

        "Note: Windows/bcc32 does not understand a space between -o and filename"

        "/ cg: I guess, this does not work for visual-c

    ] ifFalse:[

    ].

    Verbose == true ifTrue:[

        'executing: ' infoPrint. command infoPrintCR.

    ].

    originator activityNotification:'compiling (' , ccPath , ')'.

    ok := OperatingSystem 

                executeCommand:command 

                inputFrom:nil

                outputTo:errorStream

                errorTo:errorStream

                onError:[:stat| 

                            executionStatus := stat.

                            false