2
# Fortran version of Critcl
4
package provide critclf 0.1
6
package require wrapfort
8
namespace eval critcl {
13
namespace export fproc
15
variable fsrc ;# File with Fortran source code
17
variable ftype ;# Fortran types
18
set ftype(integer) "integer :: VNAME"
19
set ftype(integer-array) "integer :: size__VNAME; integer, dimension(SIZE) :: VNAME"
20
set ftype(real) "real(kind=kind(1.0d0)) :: VNAME"
21
set ftype(real-array) "integer :: size__VNAME; real, dimension(SIZE) :: VNAME"
22
set ftype(double) "real(kind=kind(1.0d0)) :: VNAME"
23
set ftype(double-array) "integer :: size__VNAME; real(kind=kind(1.0d0)), dimension(SIZE) :: VNAME"
26
# Private namespaces for convenience:
27
# - Store the configuration parameters
28
# - Re-read the configuration file
31
variable fconfigvars {fcompile fversion finclude flink foutput
32
foptimize fextra_cflags}
33
set configvars [concat $configvars $fconfigvars]
35
namespace eval c [list
36
foreach var $v::fconfigvars {
40
readconfig $configfile
44
# Femit, Femitln, Cmdemit --
45
# Store Fortran and C code in a private variable for later reference
48
# s Fragment of Fortran code to be stored
53
proc ::critcl::Femit {s} {
54
append v::fcode($v::curr) $s
57
proc ::critcl::Femitln {{s ""}} {
61
proc ::critcl::Cmdemit {s} {
62
append v::cmdcode($v::curr) $s
67
# Register the new command for later use
70
# name Name of the new command
71
# args Argument list and body
76
proc ::critcl::Fdefine {name args} {
77
set v::curr [md5_hex "$name $args"]
78
set file [file normalize [info script]]
80
set ns [uplevel 2 namespace current]
81
if {$ns == "::"} { set ns "" } else { append ns :: }
83
set ::auto_index($ns$name) [list [namespace current]::fbuild $file]
85
lappend v::code($file,list) $name $v::curr
91
# Generate a fragment of C to call the Fortran routine
94
# name Name of the Fortran subroutine
95
# carguments List of arguments (already in C form)
101
# Will probably need to be revised
103
proc ::critcl::FortCall {name carguments} {
105
return " $name\( [join $carguments ,] );"
111
# Generate a proper Fortran declaration
114
# type Type of the variable
115
# vname Name of the variable
116
# data Additional information
119
# Fortran declaration
121
proc ::critcl::FortDeclaration {type vname data} {
124
if { [string match "*-array" $type] } {
125
set size [string map {"size(" "size__" ")" ""} [lindex $data 1]]
126
return [string map [list VNAME $vname SIZE $size] $ftype($type)]
128
return [string map [list VNAME $vname] $ftype($type)]
134
# Generate the Tcl/C wrapper for a command written in Fortran
137
# name Name of the Fortran subroutine and Tcl command
138
# arguments Description of the arguments
139
# body Body of the Fortran subroutine
145
# This relies for the most part on Wrapfort for the actual
146
# generation of the source code
148
proc ::critcl::fproc {name arguments body} {
150
::Wrapfort::incritcl 1
152
Fdefine $name $arguments $body
154
Femit "subroutine $name\( &\n "
160
foreach {type vname data} $arguments {
161
set role [lindex $data 0]
167
lappend fdecls [FortDeclaration $type $vname $data]
168
if { ! [string match "*-array" $type] } {
169
lappend farglist $vname
170
lappend carglist "&$vname"
172
lappend farglist "$vname, size__$vname"
173
lappend carglist "$vname, &size__$vname"
174
set carguments [concat $carguments "integer size__$vname {assign size($vname)}"]
178
if { $type == "external" } {
179
lappend farglist $vname
180
lappend carglist "$vname"
184
Femitln "[join $farglist ",&\n "])"
185
Femitln " [join $fdecls "\n "]"
186
Femitln $body ;# TODO: use statements
187
Femitln "end subroutine $name"
189
::Wrapfort::fproc $name $name \
190
[concat $arguments $carguments code [list {Call the routine}] \
191
[list [FortCall $name $carglist]]]
193
::Wrapfort::incritcl 0
198
# Generate the C wrapper for a Tcl command to be called as an
199
# external function in Fortran
202
# name Name of the Fortran interface
203
# arguments Description of the arguments and the surrounding code
209
# This relies for the most part on Wrapfort for the actual
210
# generation of the source code
212
proc ::critcl::fexternal {name arguments} {
214
::Wrapfort::incritcl 1
215
::Wrapfort::fexternal $name $arguments
216
::Wrapfort::incritcl 0
222
# Compile the generated Fortran code
225
# file Name of the Fortran source file
226
# src Complete source code
228
# obj Name of the object file
233
proc ::critcl::fcompile {file src fopts lfd obj} {
235
set cmdline "$c::fcompile $fopts"
237
append cmdline " [subst $c::foutput] $src"
238
if {$v::options(language) != ""} {
239
# Allow the compiler to determine the type of file
240
# otherwise it will try to compile the libs
241
append cmdline " -x none"
243
if {!$option::debug_symbols} {
244
append cmdline " $c::foptimize"
248
interp transfer {} $lfd $run
250
interp eval $run "exec $cmdline 2>@ $lfd"
251
interp transfer $run $lfd {}
252
if {!$v::options(keepsrc) && $src ne $file} { file delete $src }
253
puts $lfd "$obj: [file size $obj] bytes"
256
interp transfer $run $lfd {}
257
puts $lfd "ERROR while compiling code in $file:"
268
# file Name of the library
269
# load When completed, load the library (or not)
270
# prefix Prefix for the name of the library
271
# silent Suppress error message (or not)
276
proc ::critcl::fbuild {{file ""} {load 1} {prefix {}} {silent ""}} {
279
set file [file normalize [info script]]
284
# each unique set of cmds is compiled into a separate extension
286
set digest [md5_hex "$file $v::code($file,list)"]
289
set cache [file normalize $cache]
291
set base [file join $cache ${v::prefix}_$digest]
294
# the compiled library will be saved for permanent use if the outdir
295
# option is set (in which case rebuilds will no longer be automatic)
296
if {$v::options(outdir) != ""} {
297
set odir [file join [file dirname $file] $v::options(outdir)]
298
set oroot [file root [file tail $file]]
299
set libfile [file normalize [file join $odir $oroot]]
302
# get the settings for this file into local variables
303
foreach x {hdrs srcs libs init ext} {
304
set $x [append v::code($file,$x) ""] ;# make sure it exists
307
# modify the output file name if debugging symbols are requested
308
if {$option::debug_symbols} {
312
# choose distinct suffix so switching between them causes a rebuild
313
switch -- $v::options(combine) {
315
dynamic { append libfile _pic$c::object }
316
static { append libfile _stub$c::object }
317
standalone { append libfile $c::object }
320
# the init proc name takes a capitalized prefix from the package name
321
set ininame stdin ;# in case it's called interactively
322
regexp {^\w+} [file tail $file] ininame
324
set ininame [string totitle $ininame]
326
set pkgname "${prefix}_$pkgname"
327
set ininame "${prefix}_$ininame"
330
# the shared library we hope to produce
331
set target $base$c::sharedlibext
332
if {$v::options(force) || ![file exists $target]} {
335
set log [file join $cache [pid].log]
336
set lfd [open $log w]
337
puts $lfd "\n[clock format [clock seconds]] - $file"
339
::Wrapfort::incritcl 1
340
::Wrapfort::fsource $pkgname $base.c
341
::Wrapfort::incritcl 0
342
set ffile [open ${base}_f.f90 w]
343
set cmdfile [open $::Wrapfort::tclfname w]
344
set fd [open ${base}.c w]
347
puts $fd "/* Generated by critcl on [clock format [clock seconds]]
351
foreach {name digest} $v::code($file,list) {
352
if {[info exists v::code($digest)]} {
353
puts $fd $v::code($digest)
355
if {[info exists v::fcode($digest)]} {
356
puts $ffile $v::fcode($digest)
358
if {[info exists v::cmdcode($digest)]} {
359
puts $cmdfile $v::cmdcode($digest)
367
if {$v::options(language) != ""} {
368
lappend fopts -x $v::options(language)
370
if {$v::options(I) != ""} {
371
lappend copts $c::include$v:::options(I)
373
lappend copts $c::include$cache
376
if {$v::options(language) != ""} {
377
lappend fopts -x $v::options(language)
379
if {$v::options(I) != ""} {
380
lappend fopts $c::finclude$v:::options(I)
382
lappend fopts $c::finclude$cache
385
if {[string index $x 0] == "-"} {
388
set copy [file join $cache [file tail $x]]
395
fcompile $file ${base}_f.f90 $fopts $lfd $libfile
396
append copts " $c::fextra_cflags"
398
set c::compile "gcc -c -fPIC"
400
set c::threadflags ""
401
set c::output "-o \$outfile"
403
set c::link_release ""
405
set copts " $c::fextra_cflags"
406
file copy -force [file join $::Wrapfort::wrapdir "wrapfort_lib.c"] [file dirname $base]
407
compile $file $::Wrapfort::pkgfname $copts $lfd ${base}_c$c::object
408
lappend v::objs ${base}_c$c::object
410
if { !$v::options(keepsrc) } {
411
# file delete $::Wrapfort::tclfname -- AM: this does not work yet!
412
# the file remains open somewhere?
413
# file delete $base.c
417
set tail [file tail $src]
418
set srcbase [file rootname [file tail $src]]
419
if {[file dirname $base] ne [file dirname $src]} {
420
set srcbase [file tail [file dirname $src]]_$srcbase
422
set obj [file join [file normalize $cache] ${srcbase}$c::object]
423
compile $src $src $copts $lfd $obj
426
if {($load || $link) && !$v::failed} {
427
set cmdline $c::flink
428
if {[llength $v::preload]} {
429
append cmdline " $c::link_preload"
432
if {[string length [set ldout [subst $c::ldoutput]]] == 0} {
433
set ldout [subst $c::output]
435
if {$option::debug_symbols} {
436
append cmdline " $c::link_debug $ldout"
438
append cmdline " $c::strip $c::link_release $ldout"
440
if {[string match "win32-*-cl" [Platform]]} {
441
regsub -all -- {-l(\S+)} $libs {\1.lib} libs
443
append cmdline " $libfile "
444
#AM if {[string match "win32-*-cl" [Platform]]} {
445
# set f [open [set rsp [file join $cache link.fil]] w]
446
# puts $f [join $v::objs \n]
448
# append cmdline @$rsp
450
append cmdline [join [lsort -unique $v::objs]]
452
append cmdline " $libs $v::ldflags"
453
puts $lfd "\n$cmdline"
455
interp transfer {} $lfd $run
457
interp eval $run "exec $cmdline 2>@ $lfd"
458
interp transfer $run $lfd {}
459
puts $lfd "$target: [file size $target] bytes"
461
interp transfer $run $lfd {}
462
puts $lfd "ERROR while linking $target:"
465
if {!$v::failed && [llength $v::preload]} {
466
# compile preload if necessary
467
set outfile [file join [file dirname $base] \
468
preload$c::sharedlibext]
469
if {![file readable $outfile]} {
470
set src [file join $v::cache preload.c]
471
set obj [file join $v::cache preload.o]
472
compile $src $src $copts $lfd $obj
473
set cmdline "$c::link $obj $c::strip [subst $c::output]"
474
puts $lfd "\n$cmdline"
475
interp transfer {} $lfd $run
477
interp eval $run "exec $cmdline 2>@ $lfd"
478
interp transfer $run $lfd {}
479
puts $lfd "$outfile: [file size $target] bytes"
481
interp transfer $run $lfd {}
482
puts $lfd "ERROR while linking $outfile:"
493
file delete -force $log
494
# append to critcl log
495
set log [file join $cache $v::prefix.log]
496
set lfd [open $log a]
499
foreach x $copies { file delete $x }
505
puts stderr "critcl build failed ($file)"
508
load $target $ininame
511
foreach {name digest} $v::code($file,list) {
512
if {$name != "" && [info exists v::code($digest)]} {
513
unset v::code($digest)
516
foreach x {hdrs srcs init} {
517
array unset v::code $file,$x
520
return [list $target $ininame]
522
return [list $libfile $ininame]
added
removed
lib/critclf/critclf.tcl
