Updated 2011-07-04 17:23:54 by RLE

Arjen Markus (3 january 2005) 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.
    # gustav_ivanovic@yahoo.com
    ###############################################################

    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: Ffidl