Updated 2014-11-08 18:59:12 by NF

Arjen Markus 2005-01-03: In december 2004 Gustav Ivanovic posted the code below in the Fortran and Tcl newsgroups:

  • It allows you to create a new command that calls Fortran routines stored in a dynamic link library (or a shared object for that matter)
  • It has a few platform-dependencies that are not yet "ironed" out and the Tcl code can be improved in a few places (personally, I avoid subst in favour of list and string map

Still, it makes clear that access to functions and routines in other languages than C is really easy.

Gustav Ivanovic: I add "c" type argument and a test with Win32 APIs.
namespace eval Fortran {

    ##############################################################
    # Provide simplified declarations to call fortran routines in
    # a DLL built using Compaq Visual Fortran
    # Please use as you wish, but there is no guarantee whatsoever.
    #
    # Please report bugs. Thank you.
    # [email protected]
    ###############################################################

    catch {package require Ffidl}
    
    proc Binarize {varType args} {
        foreach var $args {
            upvar $var x
            if [regexp {[ac]} $varType] {
                set x [binary format a* $x]
            } else  {
                set x [binary format $varType[llength $x] $x]
            }
        }
    };#End proc Binarize
    
    proc deBinarize {varType args} {
        foreach var $args {
            upvar $var x
            switch $varType {
                i {binary scan $x i[expr {[string length $x]/4}] x}
                f {binary scan $x f[expr {[string length $x]/4}] x}
                d {binary scan $x d[expr {[string length $x]/8}] x}
                default {binary scan $x a* x}
            }
        }
    };#End proc deBinarize
    
    proc declareRoutine {DLLname routineName argDef {tclName {}} {returnType {}}} {
        ####################
        # usage:
        #      Fortran::declareRoutine dllName routineName argDef tclName returnType
        # e.g  Fortran::declareRoutine FtnTcl.dll scalarproduct {f f i} SCAPROD f
        ##########################
        # argument definition is
        #   a or A string of charaters (add hidden length argument)
        #   c or C string of charaters (without the hidden length argument)
        #   I or i integer or array of integers
        #   F or f or R or r real or array of reals
        #   D or d double precision or array of double precision reals
        #
        # if no tclName specified, a command routineName is created.
        # However, I recommend to specify a tclName
        # Example
        # a.  Fortran::declareRoutine FtnTcl.dll doublevectorsum {D D D i}
        #       a new command named doublevectorsum is created
        # b.  Fortran::declareRoutine FtnTcl.dll doublevectorsum {D D D i} doublSum
        #        a new command named doublSum is created
        ##########################
        
        if {$tclName == {}} {
            set tclName $routineName
        }
        
        set ffidlDecl {}
        set argTypeList {}
        set argList {}
        set argCount 0
        
        # store argument type as a list
        foreach i $argDef {
            lappend argList arg$argCount
            lappend ffidlDecl pointer-var
            set varType [string index $i 0]
            switch -regexp $varType {
                [iI] {lappend argTypeList i}
                [rRfF] {lappend argTypeList f}
                [dD] {lappend argTypeList d}
                [cC] {lappend argTypeList c}
                default { ;# if it is not integer or a real then it is a string
                    # append hidden length argument
                    lappend ffidlDecl int
                    lappend argTypeList a
                }
            }
            incr argCount
        }
        
        # define return value type. Only void, integer, real and double
        set retType [string index $returnType 0]
        switch -regexp $retType {
            [iI] {set retType int}
            [rRfF] {set retType float}
            [dD] {set retType double}
            default {set retType void}
        }
        
        # DEBUG
        # puts [subst {ffidl::callout ::Fortran::ffidl-$routineName {$ffidlDecl} $retType [ffidl::symbol $DLLname $routineName]}]
        eval [subst {ffidl::callout ::Fortran::ffidl-$routineName {$ffidlDecl} $retType [ffidl::symbol $DLLname $routineName]}]
        
        # Define a procedure that Binarizes, call the entry in the DLL and deBinarizes (stored in cmd and to be eval'ed)
        set cmd {}
        append cmd {proc ::} $tclName " \{$argList\} \{"
        for  {set i 0} {$i < $argCount} {incr i} {
            append cmd "\n    upvar \$[lindex $argList $i] x$i"
        }
        for  {set i 0} {$i < $argCount} {incr i} {
            append cmd "\n    ::Fortran::Binarize [lindex $argTypeList $i] x$i"
        }
        set ffidlArgs {}
        for  {set i 0} {$i < $argCount} {incr i} {
            append ffidlArgs " x$i"
            if {[lindex $argTypeList $i] == "a"} {
                append ffidlArgs { [string length $} "x$i" {]}
            }
        }
        append cmd "\n    set retval \[ ::Fortran::ffidl-$routineName $ffidlArgs \]"
        for  {set i 0} {$i < $argCount} {incr i} {
            append cmd "\n    ::Fortran::deBinarize [lindex $argTypeList $i] x$i"
        }
        append cmd "\n    return \$retval\n" \}
        # DEBUG
        # puts $cmd
        # make that new command
        eval $cmd
    };#End proc declareRoutine
    
};#End namespace Fortran

proc test {} {
    load ffidl05
    
    # Declare all routines
    ####################
    # usage
    #      Fortran::declareRoutine dllName routineName argDef tclName returnType
    # e.g  Fortran::declareRoutine FtnTcl.dll scalarproduct {f f i} SCAPROD f
    ####################
    
    Fortran::declareRoutine FtnTcl.dll string a STRING
    # in the above example
    # if no tclName is specified, then it creates confusion with "string"
    
    Fortran::declareRoutine FtnTcl.dll realvector f
    Fortran::declareRoutine FtnTcl.dll integervector i
    Fortran::declareRoutine FtnTcl.dll scalarproduct {f f i} SCAPROD f
    # we defined a new name and the return value type as a real
    
    Fortran::declareRoutine FtnTcl.dll doublevectorsum {d d d i}

    # Use of the declared functions starts here
    puts "Test 1"
    set a {1 2 3}
    puts "a was $a"
    integervector a
    puts "a is now "
    puts $a
    puts "\n\nTest 2"
    set a {1 2 3}
    set b {10 20 30}
    set c {0 0 0}
    set l 3
    puts "a is $a"
    puts "b is $b"
    puts "c is $c"
    doublevectorsum a b c l
    puts "after"
    puts "a is now $a"
    puts "b is now $b"
    puts "c is now $c"
    
    puts "\n\nTest 3 scalar product <a,b>"
    puts [SCAPROD a b l]
    
    puts "a is +$a+"
    STRING a
    puts "a is now +$a+"
    set l 32


    # Testing Windows API
    Fortran::declareRoutine advapi32.dll GetUserNameA {c i} GetUserNameA-TCL
    Fortran::declareRoutine kernel32.dll GetComputerNameA {c i} GetComputerNameA-TCL
    
    set a [string repeat + 64]
    GetUserNameA-TCL a l
    puts " User Name is $a"
    GetComputerNameA-TCL a l
    puts " Computer Name is $a"
}

# Run the test
test

This is the corresponding fortran code (to be compiled with Compaq Visual Fortran)
MODULE tcl


CONTAINS


  SUBROUTINE doublevector(vector)
    !DEC$ ATTRIBUTES DLLEXPORT, ALIAS: 'doublevector' ::doublevector
    DOUBLE PRECISION , DIMENSION(*) :: vector
    vector(3)=3333.
  END SUBROUTINE doublevector

  SUBROUTINE realvector(vector)
    !DEC$ ATTRIBUTES DLLEXPORT, ALIAS: 'realvector' ::realvector
    REAL , DIMENSION(*) :: vector
    vector(2)=2222.
  END SUBROUTINE realvector


  SUBROUTINE integervector(vector)
    !DEC$ ATTRIBUTES DLLEXPORT, ALIAS: 'integervector' ::integervector
    INTEGER , DIMENSION(*) :: vector
    vector(1)=1111
  END SUBROUTINE integervector


  SUBROUTINE string(line)
    !DEC$ ATTRIBUTES DLLEXPORT, ALIAS: 'string'::string
    CHARACTER(LEN=*) :: line
    line='QWERTY'
  END SUBROUTINE string

  FUNCTION scalarproduct(x,y,n) RESULT (z)
    !DEC$ ATTRIBUTES DLLEXPORT, ALIAS: 'scalarproduct'::scalarproduct
        INTEGER ::n
    REAL, DIMENSION(n) :: x, y
        REAL :: z
    z=sum(x*y)
  END FUNCTION scalarproduct

  SUBROUTINE doublevectorsum(x,y,z,n)
    !DEC$ ATTRIBUTES DLLEXPORT, ALIAS: 'doublevectorsum'::doublevectorsum
        INTEGER ::n
    DOUBLE PRECISION, DIMENSION(n) :: x, y, z
        z=x+y
  END SUBROUTINE doublevectorsum

END MODULE tcl

See Also  edit

Ffidl
Fortran DLLs called from Tcl (via Gustav Ivanovic's code / Ffidl), comp.lang.tcl, 2014-11-03
Provides some tips on how to use this code with other flavours for Fortran.

[NF] - 2014-11-06 22:09:05

Gustav Ivanovic's code can work with the GNU Fortran compiler (gfortran), on both Windows and Linux, with some minor modifications on the Fortran side and in Gustav's code.

Part of the problem with is that gfortran doesn't support the ALIAS attribute in the compiler directives, such that you can't set a name that you want for the function in the DLL. By default, it has extra underscores added, and if the procedure is in a module, there are additional things like "mod" and the module name. These problems can be overcome by compiling with flags to remove the underscores, not having the functions in a module, and using a GCC compiler directive that includes STDCALL.

The resulting tcl.f90 file should thus look as follows:
SUBROUTINE doublevector(vector)
  !GCC$ ATTRIBUTES STDCALL :: doublevector
  DOUBLE PRECISION , DIMENSION(*) :: vector
  vector(3)=3333.
END SUBROUTINE doublevector

SUBROUTINE realvector(vector)
  !GCC$ ATTRIBUTES STDCALL :: realvector
  REAL , DIMENSION(*) :: vector
  vector(2)=2222.
END SUBROUTINE realvector

SUBROUTINE integervector(vector)
  !GCC$ ATTRIBUTES STDCALL :: integervector
  INTEGER , DIMENSION(*) :: vector
  vector(1)=1111
END SUBROUTINE integervector

SUBROUTINE string(line)
  !GCC$ ATTRIBUTES STDCALL :: string
  CHARACTER(LEN=*) :: line
  line='QWERTY'
END SUBROUTINE string

FUNCTION scalarproduct(x,y,n) RESULT (z)
  !GCC$ ATTRIBUTES STDCALL :: scalarproduct
  INTEGER ::n
  REAL, DIMENSION(n) :: x, y
  REAL :: z
  z=sum(x*y)
END FUNCTION scalarproduct

SUBROUTINE doublevectorsum(x,y,z,n)
  !GCC$ ATTRIBUTES STDCALL :: doublevectorsum
  INTEGER ::n
  DOUBLE PRECISION, DIMENSION(n) :: x, y, z
  z=x+y
END SUBROUTINE doublevectorsum

And then compile as follows:
gfortran -c -fno-underscoring tcl.f90 -o tcl.o 
gfortran -shared -mrtd -fno-underscoring -"Wl,--kill-at" -static-libgfortran -static-libgcc tcl.o -o FtnTcl.dll 

The "static" flags are to make the DLL work on systems where gfortran hasn't been installed separately. Other flags (e.g. optimisation options) should also be added, as required.

Then, in order to run this (with tclkit, anyway), place the Tcl file containing Gustav's code and example (I've called it gustavscode.tcl) in the same directory as the tclkit executable, along with Ffidl06.dll. (Or whichever version of Ffidl you are using. Make sure that the "load Ffidl05" in Gustav's code is changed to the name corresponding to the Ffidl DLL you have, so, in my case, "load Ffidl06".) So with the tclkit executable, your Tcl file, FtnTcl.dll, and Ffidl06.dll in the same folder, run "tclkit gustavscode.tcl" in a Command Prompt or similar.

To get this working in Linux, first build the Ffidl shared library from source (unless you can find a Linux binary on the net; I couldn't). The only "tricky" bit about this is that you need the Tcl source code as well. First, navigate to "/path/to/tcl/source/code/unix" (note the unix bit), and run "./configure". This will generate tclConfig.sh. Now navigate back to "/path/to/ffidl/source/code" and run "./configure --with-tcl=/path/to/tcl/source/code/unix", then run "make". This will generate libFfidl0.6.so. (Make sure that the path to the Ffidl source doesn't have any spaces in it, or else the "make" will fail.)

Compile the Fortran code as follows (note the subtle difference in making the shared library compared to the Windows DLL):
gfortran -c -fno-underscoring tcl.f90 -o tcl.o
gfortran -shared -fPIC -fno-underscoring -static-libgfortran -static-libgcc tcl.o -o FtnTcl.so

Modify Gustav's Tcl code to say "load ./libFfidl0.6.so" instead of "load Ffidl05" (ensuring that load corresponds to whatever your Ffidl shared library is called). Finally, put the tclkit binary, FtnTcl.so, Gustav's Tcl file, and libFfidl0.6.so in the same directory, and run "./tclkit gustavscode.tcl".