[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 " 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 ---- [[ [Category Foreign Interfaces] | [Category Language] ]]