Arjen Markus (3 january 2005) In december 2004 Gustav Ivanovic posted the code below in the Fortran and Tcl newsgroups:
Still, it makes clear that access to functions and routines in other languages than C is really easy.
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 {$varType == "a"} {
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 {$routineName}} {returnType {0}}} {
####################
# 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
# 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}
default { ;# if it is not integer or a real then it is a string
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}
}
eval [subst {ffidl::callout ::Fortran::ffidl-$routineName {$ffidlDecl} $retType [ffidl::symbol $DLLname $routineName]}]
# DEBUG
# puts [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" \}
# make that new command
eval $cmd
# DEBUG
# puts $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+"
}
# Run the test
test]