- 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]
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
testThis 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 tclSee also: Ffidl