"

 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'

	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'!

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.

! !

!STCCompilerInterface methodsFor:'machine code generation'!

compileToMachineCode:aString forClass:aClass selector:selector inCategory:cat 

                             notifying:requestor 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.

     For a description of the arguments, see compile:forClass....."

    |stFileName stream handle stcFlags cFlags def

     command oFileName cFileName

     initName oldMethod newMethod ok status className sep class stcPath ccPath 

     errorStream errorMessages eMsg moduleFileName 

     mapFileName libFileName pkg libDir incDir incDirArg|

    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

    ].

    self ensureModuleDirectoryExists.

    ObjectFileLoader isNil ifTrue:[^ #CannotLoad].

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

    (stcPath := self incrementalStcPath) isNil ifTrue:[

        originator parseError:'no stc compiler available - cannot create machine code' position:1.

        ^ #CannotLoad

    ].

    (ccPath := parserFlags ccPath) isNil ifTrue:[

        originator parseError:'no cc compiler available - cannot create machine code' position:1.

        ^ #CannotLoad

    ].

    (ObjectFileLoader notNil and:[ObjectFileLoader canLoadObjectFiles]) ifFalse:[

        originator parseError:'no dynamic loader configured - cannot create machine code' position:1.

        ^ #CannotLoad

    ].

    class := aClass theNonMetaclass.

    self ensureSuperClassesAreLoadedOf:class.

    class privateClassesSorted do:[:aPrivateClass |

        self ensureSuperClassesAreLoadedOf:aPrivateClass.

    ].

    "/ generate a unique name, consisting of my processID and a sequence number

    "/ the processId is added to allow filein of modules from different

    "/ lifes

    SequenceNumber := (SequenceNumber ? 0) + 1.

    initName := 'm_' , OperatingSystem getProcessId printString, '_' , SequenceNumber printString.

    stFileName := (Filename currentDirectory construct:(initName , '.st')) name. 

    [

        stream := stFileName asFilename writeStream.

    ] on:FileStream openErrorSignal do:[:ex|

        originator parseError:'cannot create temporary sourcefile for compilation'.

        ^ #CannotLoad

    ].

    [

        |definedClasses|

        definedClasses := IdentitySet new.

        sep := stream class chunkSeparator.

        Class fileOutNameSpaceQuerySignal answer:true

        do:[

            self 

                fileOutAllDefinitionsOf:class 

                to:stream 

                rememberIn:definedClasses.

            class privateClassesSorted do:[:aPrivateClass |

                self 

                    fileOutAllDefinitionsOf:aPrivateClass 

                    to:stream 

                    rememberIn:definedClasses.

            ].

            class fileOutPrimitiveDefinitionsOn:stream.

        ].

        (aClass isNil or:[parserFlags allowExtensionsToPrivateClasses or:[aClass owningClass isNil]]) ifTrue:[

            (requestor respondsTo:#packageToInstall) ifFalse:[

                pkg := Class packageQuerySignal query.

            ] ifTrue:[

                pkg := requestor packageToInstall

            ].

        ] ifFalse:[

            pkg := aClass owningClass package

        ].

false ifTrue:[

        stream cr.

        stream nextPutLine:'"{ Package: ''' , pkg , ''' }"'.

        stream cr.

].

        stream nextPut:sep.

        className := class name.

        stream nextPutAll:className.

        aClass isMeta ifTrue:[

            stream nextPutAll:' class'.

        ].

        stream nextPutAll:' methodsFor:'''; nextPutAll:cat; nextPutAll:''''.

        stream nextPut:sep; cr.

        stream nextPutLine:'"{ Line: 0 }"'; 

               nextChunkPut:aString;

               space; nextPut:sep.

        stream close.

        "

         call stc to compile it

        "

        oFileName := stFileName asFilename withoutSuffix name , (ObjectFileLoader objectFileExtension).

        cFileName := (stFileName asFilename withSuffix:'c') name. 

        mapFileName := (stFileName asFilename withSuffix:'map') name. 

        libFileName := (stFileName asFilename withSuffix:'lib') name. 

        oFileName asFilename delete.

        cFileName asFilename delete.

        "/ stcFlags := '-commonSymbols +sharedLibCode +newIncremental -E:errorOutput -N' , initName .

        stcFlags := '+newIncremental -E:errorOutput -N' , initName .

        cFlags := OperatingSystem getOSDefine.

        cFlags isNil ifTrue:[

            cFlags := ''

        ].

        (def := OperatingSystem getCPUDefine) notNil ifTrue:[

            cFlags := cFlags , ' ' , def

        ].

        parserFlags stcCompilationDefines notNil ifTrue:[

            cFlags := cFlags , ' ' , parserFlags stcCompilationDefines

        ].

        parserFlags stcCompilationIncludes notNil ifTrue:[

            stcFlags := parserFlags stcCompilationIncludes , ' ' , stcFlags.

            cFlags := cFlags , ' ' , parserFlags stcCompilationIncludes.

            "/ if STX_LIBDIR is defined, and not in passed argument,

            "/ add it here.

            libDir := OperatingSystem getEnvironment:'STX_LIBDIR'.

            (libDir notNil and:[libDir asFilename exists]) ifTrue:[

                incDir := libDir asFilename construct:'include'.

                incDir exists ifTrue:[

                    incDirArg := '-I' , incDir pathName.

                    (parserFlags stcCompilationIncludes asCollectionOfWords includes:incDirArg) ifFalse:[

                        stcFlags := stcFlags , ' ' , incDirArg.

                        cFlags := cFlags , ' ' , incDirArg.

                    ]

                ]

            ].

        ].

        parserFlags stcCompilationOptions notNil ifTrue:[

            stcFlags := parserFlags stcCompilationOptions , ' ' , stcFlags

        ].

        parserFlags ccCompilationOptions notNil ifTrue:[

            cFlags := cFlags , ' ' , parserFlags ccCompilationOptions

        ].

        command := stcPath , ' ' , stcFlags , ' -C ' , stFileName.

        Verbose == true ifTrue:[

            'executing: ' infoPrint. command infoPrintCR.

        ].

        errorStream := 'errorOutput' asFilename writeStream.

        originator activityNotification:'compiling (stc)'.

        ok := OperatingSystem 

                    executeCommand:command 

                    inputFrom:nil

                    outputTo:errorStream

                    errorTo:errorStream

                    onError:[:stat| 

                                status := stat.

                                false

                            ].

        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 ifTrue:[

            "/ now compile to machine code

            command := ccPath , ' ' , cFlags , ' -D__INCREMENTAL_COMPILE__ -c ' , cFileName.

            Verbose == true ifTrue:[

                'executing: ' infoPrint. command infoPrintCR.

            ].

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

            ok := OperatingSystem 

                        executeCommand:command 

                        inputFrom:nil

                        outputTo:errorStream

                        errorTo:errorStream

                        onError:[:stat| 

                                    status := stat.

                                    false

                                ].

            oFileName asFilename exists ifTrue:[

                ok ifFalse:[

                    'Compiler [info]: system says compile failed - but o-file is there ...' infoPrintCR.

                    ok := true

                ]

            ] ifFalse:[

                ok ifTrue:[

                    'Compiler [info]: system says compile ok - but no o-file is there ...' infoPrintCR.

                ].

                ok := false

            ].

        ].

        ok ifFalse:[

            (status notNil and:[status couldNotExecute]) ifTrue:[

                eMsg := 'oops, no STC - cannot create machine code'

            ] ifFalse:[

                errorMessages := 'errorOutput' asFilename contents.

                errorMessages notNil ifTrue:[

                    errorMessages size > 20 ifTrue:[

errorMessages := errorMessages select:[:line | line asLowercase startsWith:'error'].

errorMessages size > 20 ifTrue:[

                        errorMessages := (errorMessages copyTo:20) copyWith:'... more messages skipped'

].

                    ].

"/                    errorMessages := errorMessages collect:[:line |

"/                        (line startsWith:(stFileName , ':')) ifTrue:[

"/                            'Line: ' , (line copyFrom:(stFileName size + 2))

"/                        ] ifFalse:[

"/                            line

"/                        ]

"/                      ].

                    errorMessages := errorMessages asString

                ].

                errorMessages isNil ifTrue:[

                    errorMessages := ''

                ].

                errorMessages isEmpty ifTrue:[

                    eMsg := 'STC / CC error during compilation:\\unspecified error' withCRs

                ] ifFalse:[

                    eMsg := 'STC / CC error during compilation:\\'withCRs,errorMessages

                ].

                "/ eMsg := eMsg withCRs

            ].

            originator activityNotification:'compilation failed'.

            originator parseError:eMsg position:1.

            originator activityNotification:''.

            ^ #Error

        ].

        originator activityNotification:''.

        OperatingSystem removeFile:'errorOutput'.

        "

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

        "

        originator activityNotification:'linking'.

        oFileName := ObjectFileLoader createLoadableObjectFor:initName.

        oFileName isNil ifTrue:[

            "/ something went wrong

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

            ^ #CannotLoad

        ].

        oFileName asFilename exists ifFalse:[

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

            ^ #CannotLoad

        ].

        "

         move it into the modules directory

        "

        moduleFileName := (parserFlags stcModulePath asFilename construct:(initName , '.' , (oFileName asFilename suffix))) name.

        oFileName asFilename moveTo:moduleFileName.

        (moduleFileName asFilename exists 

        and:[moduleFileName asFilename isReadable]) ifFalse:[

            originator parseError:'link failed - cannot move shared library module to ''modules'' directory' position:1.

            ^ #CannotLoad

        ].

        oldMethod := aClass compiledMethodAt:selector.

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

        "

         load the method objectfile

        "

        originator activityNotification:'loading'.

        handle := ObjectFileLoader loadMethodObjectFile:moduleFileName.

        handle isNil ifTrue:[

            OperatingSystem removeFile:moduleFileName.

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

            ^ #CannotLoad

        ].

        "

         did it work ?

        "

        newMethod := aClass 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:[

                aClass removeSelector:selector

            ] ifFalse:[

                newMethod setPackage:oldMethod package.

                aClass addSelector:selector withMethod:oldMethod.

                oldMethod setPackage:pkg.

            ]

        ].

        newMethod notNil ifTrue:[

            handle method ~~ newMethod ifTrue:[

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

            ].

            newMethod source:aString string.

            newMethod setPackage:pkg.

"/            Project notNil ifTrue:[

"/                newMethod package:(Project currentPackageName)

"/            ].

    "/        aClass updateRevisionString.

            install ifTrue:[

                aClass addChangeRecordForMethod:newMethod fromOld:oldMethod.

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

                "/ see addMethod:... in ClassDescription

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

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

            ].

            (silent or:[Smalltalk silentLoading == true]) ifFalse:[

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

            ].

            ObjectMemory flushCaches.

            handle method:newMethod.

            "/ check for obsolete loaded objects and unload them

            ObjectFileLoader loadedObjectHandlesDo:[:anotherHandle |

                anotherHandle isMethodHandle ifTrue:[

                    anotherHandle method isNil ifTrue:[

                        ObjectFileLoader unloadObjectFile:anotherHandle pathName.

                        OperatingSystem removeFile:anotherHandle pathName.

                    ]

                ]

            ].

            ^ newMethod.

        ].

        OperatingSystem removeFile:moduleFileName.

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

        ^ #CannotLoad

    ] ensure:[

        parserFlags stcKeepSTIntermediate ifFalse:[

            OperatingSystem removeFile:stFileName.

            OperatingSystem removeFile:'errorOutput'.

        ].

        parserFlags stcKeepOIntermediate == true ifFalse:[

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

        ].

        parserFlags stcKeepCIntermediate == true ifFalse:[

            (cFileName notNil and:[cFileName asFilename exists]) ifTrue:[cFileName 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].

        ].