Below is a simple example:
- Tcl asks for a string and puts it to an executable program written in Fortran.
- This program reads the string and writes it out, until the string is "q", then it exits.
- At this moment, Tcl must exit too.
The Tcl code:
global inout
set inout [open "|copy_inp" "w+"]
fconfigure $inout -buffering none
puts "Input:"
fileevent $inout readable {
gets $::inout copied
puts $copied
if { [eof $inout] } { close $inout; set forever 1 }
}
fileevent stdin readable {
gets stdin line
puts $::inout $line
puts "Input:"
}
vwait foreverThe Fortran code:
! copy_inp.f90 --
! Copy stdin to stdout - IPC test
!
program copy_inp
! Compaq Visual Fortran requires:
! use dflib
character(len=60) :: string
do
read(*,*) string
write(*,*) 'Copied: ', string
call flush( 6 )
! On SGI use:
! call flush( 101 )
if ( string .eq. 'q' ) stop
enddo
end programNotes:- Standard output is usually unit 6, but on SGI it is unit 101
- As FLUSH() is non-standard, you may need to add a USE statement, or link with a special library
See also: open, exec, Inventory of IPC methods
[Peter Këmpf] I needed to make Tcl work together with Fortran without having a C compiler at hand, and Arjen was so kind to supply me with an object file which just needs to be linked to a Ftcl interface and the Fortran stuff. To show how it works I have put together an example:This has been compiled using Compaq Visual Fortran 6.5 on Windows, and I had no other compiler to test it with, so all the rest just refers to CVF. Normally I work with Macs as they are much more fun to program, but this had to be don on Windoze. Hated it!!!First, create a new Workspace for a Dynamic Link Library, name it as you want and specify an empty DLL application on the next page. Click Finish.Next, load the two source files "Ftcl_mod.f90" and "ftcl_exm.f90" (listing to be found below) by right- clicking the folder icon "Source Files" and selecting "Add files to folder". If you don't see it first, click on the "+" sign below the workspace icon in the workspace file view.Then, add the object file "Ftcl_c.obj" by selecting Project/Add to Project. Do the same for the Tcl stubs library "tcl83stubs.lib" (in the lib subfolder of your Tcl folder). Then, go to Project/Settings, select the Link tab and check "Link incrementally".Now build the DLL. Depending on whether you specified a Debug or a Release version, the DLL is now in an appropriately named subfolder. To make it easier for Tcl to find it, just drag it over to your Tcl/bin directory and add the Tcl script "Caesar.tcl" (also listed below) to that folder as well. Make sure that you use your workspace name when you call your DLL from Tcl! For this, open the file "Caesar.tcl" and put your workspace name where it now says "Test" in the line {load Test.dll ftcl}.Now fire up "wish83" and select the script "Caesar.tcl" via the File/Source menu in the console. What happens next should be quite obvious: Either it works, or you blame me for anything that went wrong ...You can reach me at [1] for further questioning and to get the object file. In the meantime I try to figure out how to upload binary stuff to the wiki.Allright now, first the (lengthy) Fortran interface file Ftcl_mod.f90:
! DOC
!
! ftcl_mod.f90 - module for interacting with Tcl/Tk
!
! Copyright (C) 1999 Arjen Markus
!
! Arjen Markus
!
!
! General information:
! This module contains routines to interface with Tcl/Tk as
! described in the documentation (ftcl.html).
! Note that some interfaces are merely a front-end for the
! actual C routines.
!
! ENDDOC
!
! --------------------------------------------------------------------
! Module: FTCL
! Author: Arjen Markus
! Purpose: Interaction with Tcl/Tk
! Context: Used by application programs
! Summary:
! Defines interfaces and some actual routines for
! interacting with Tcl/Tk.
! Note:
! We have not included the INTENT attributes for those
! routines that are implemented in C
! --------------------------------------------------------------------
!
module FTCL
implicit none
!
! All public interfaces are defined after this:
!
public
!
! Interface for the generic ftcl_get() routines
!
interface ftcl_get
subroutine ftcl_get_int( varname, int_value )
CHARACTER*(*) varname
INTEGER int_value
end subroutine ftcl_get_int
subroutine ftcl_get_real( varname, real_value )
CHARACTER*(*) varname
REAL real_value
end subroutine ftcl_get_real
subroutine ftcl_get_log( varname, log_value )
CHARACTER*(*) varname
LOGICAL log_value
end subroutine ftcl_get_log
subroutine ftcl_get_double( varname, double_value )
CHARACTER*(*) varname
DOUBLE PRECISION double_value
end subroutine ftcl_get_double
subroutine ftcl_get_string( varname, string )
CHARACTER*(*) varname
CHARACTER*(*) string
end subroutine ftcl_get_string
module procedure ftcl_get_int_array
module procedure ftcl_get_real_array
end interface
!
! Interface for the generic ftcl_put() routines
!
interface ftcl_put
subroutine ftcl_put_int( varname, int_value )
CHARACTER*(*) varname
INTEGER int_value
end subroutine ftcl_put_int
subroutine ftcl_put_real( varname, real_value )
CHARACTER*(*) varname
REAL real_value
end subroutine ftcl_put_real
subroutine ftcl_put_double( varname, double_value )
CHARACTER*(*) varname
DOUBLE PRECISION double_value
end subroutine ftcl_put_double
subroutine ftcl_put_log( varname, log_value )
CHARACTER*(*) varname
LOGICAL log_value
end subroutine ftcl_put_log
subroutine ftcl_put_string( varname, string )
CHARACTER*(*) varname
CHARACTER*(*) string
end subroutine ftcl_put_string
module procedure ftcl_put_int_array
module procedure ftcl_put_real_array
end interface
!
! Interface for the ftcl_script() routine
! (The result, if any, is copied into the "ftcl_result" variable)
!
interface
subroutine ftcl_script( script )
CHARACTER*(*) script
end subroutine ftcl_script
end interface
!
! All private variables are defined here
!
contains
!
! Administrative routines - for C interface
!
subroutine ftcl_init_log( true_value, false_value )
LOGICAL true_value
LOGICAL false_value
true_value = .true.
false_value = .false.
return
end subroutine ftcl_init_log
!
! Subroutines for transferring an entire array
!
subroutine ftcl_get_int_array( varname, int_array )
CHARACTER*(*) :: varname
INTEGER, dimension(:) :: int_array
integer :: idx
integer :: no_elems
character(len=5) :: elid
character(len=40) :: element
no_elems = size( int_array )
do idx = 1,no_elems
write( elid, '(i5)' ) idx
element = trim( varname ) // '(' // trim( elid ) // ')'
call ftcl_get( element, int_array(idx) )
enddo
end subroutine ftcl_get_int_array
subroutine ftcl_get_real_array( varname, real_array )
CHARACTER*(*) :: varname
REAL, dimension(:) :: real_array
integer :: idx
integer :: no_elems
character(len=5) :: elid
character(len=40) :: element
no_elems = size( real_array )
do idx = 1,no_elems
write( elid, '(i5)' ) idx
element = trim( varname ) // '(' // trim( elid ) // ')'
call ftcl_get( element, real_array(idx) )
enddo
end subroutine ftcl_get_real_array
subroutine ftcl_put_int_array( varname, int_array )
CHARACTER*(*) :: varname
INTEGER, dimension(:) :: int_array
integer :: idx
integer :: no_elems
character(len=5) :: elid
character(len=40) :: element
no_elems = size( int_array )
do idx = 1,no_elems
write( elid, '(i5)' ) idx
element = trim( varname ) // '(' // trim( elid ) // ')'
call ftcl_put( element, int_array(idx) )
enddo
end subroutine ftcl_put_int_array
subroutine ftcl_put_real_array( varname, real_array )
CHARACTER*(*) :: varname
REAL, dimension(:) :: real_array
integer :: idx
integer :: no_elems
character(len=5) :: elid
character(len=40) :: element
no_elems = size( real_array )
do idx = 1,no_elems
write( elid, '(i5)' ) idx
element = trim( varname ) // '(' // trim( elid ) // ')'
call ftcl_put( element, real_array(idx) )
enddo
end subroutine ftcl_put_real_array
end module FTCL
! -------------------------------------------------------------------------
! Routines outside the module:
! Administrative routines - for C interface
! -------------------------------------------------------------------------
!
subroutine ftcl_init_log( true_value, false_value )
LOGICAL true_value
LOGICAL false_value
true_value = .true.
false_value = .false.
return
end subroutine ftcl_init_log
!Now the Fortran interface (which is called ftcl_exm.f90):
! DOC
!
! ftcl_exm.f - example of usage of FTCL
!
! Copyright (C) 1999 Arjen Markus
!
! Arjen Markus
!
!
! General information:
! This file contains a sample implementation of FTCL's ftcl_exec
! routine as described in the documentation (ftcl.html).
! It is used for demonstration and testing purposes.
!
! ENDDOC
! --------------------------------------------------------------------
! Routine: ftcl_exec
! Author: Arjen Markus, adapted for CAESAR by Peter Kmpf
! Purpose: Provide services to Tcl/Tk
! Context: Used by ftn_exec() in the C library for FTCL
! Summary:
! Determine which service to call and call its routine.
! Note:
! We have not included the INTENT attributes for those
! routines that are implemented in C
! --------------------------------------------------------------------
!
subroutine ftcl_exec (service, noargs, ierror)
USE FTCL
implicit none
character*(*) service
integer noargs, Laenge, Shift
integer ierror
character*256 Input
character*256 Output
ierror = 0
!
! Activate the subroutine specified by service
!
IF (TRIM(service) .EQ. 'CAESAR') THEN
CALL ftcl_get_int ('Verschiebung', Shift)
CALL ftcl_get_string ('Eingabe', Input)
Laenge = LEN(TRIM(Input))
!
CALL CAESAR (Shift, Laenge, Input, Output)
!
CALL ftcl_put_string ('Ausgabe', Output)
!
ELSE
ierror = 1
END IF
return
end
!
!***********************************************************************
!
SUBROUTINE CAESAR (Shift, Length, Input, Output)
!
! Simple encryption by letter-shifting (G. J. Caesar)
!
! Author : Peter Kmpf
! Last change: 24-03-2003
!
IMPLICIT NONE
!
INTEGER :: I, ASCII
INTEGER, INTENT(IN) :: Shift
INTEGER, INTENT(INOUT) :: Length
CHARACTER(LEN=256), INTENT(IN) :: Input
CHARACTER(LEN=256), INTENT(OUT) :: Output
!
IF (Length .GT. 256) THEN
Output = 'Only < 256 letters allowed!'
Length = 27
ELSE
DO I = 1,Length
ASCII = ICHAR(Input(I:I))
IF (ASCII .LE. 64) THEN
Output(I:I) = Input(I:I)
ELSE IF (ASCII .LE. 90) THEN
IF ((ASCII + Shift) .GT. 90) ASCII = ASCII - 26
IF ((ASCII + Shift) .LT. 65) ASCII = ASCII + 26
Output(I:I) = CHAR (ASCII + Shift)
ELSE IF (ASCII .LE. 122) THEN
IF ((ASCII + Shift) .GT. 122) ASCII = ASCII - 26
IF ((ASCII + Shift) .LT. 97) ASCII = ASCII + 26
Output(I:I) = CHAR (ASCII + Shift)
ELSE
Output(I:I) = Input(I:I)
END IF
END DO
END IF
!
RETURN
END SUBROUTINE CAESARAnd now the fun part - I mean the Tcl GUI to it all. If you haven't noticed yet -- I just enjoyed to have Fortran manipulate strings for a Tcl routine. As you can see in the interface definitions above, you can transfer any data type (well, excluding COMPLEX, since this is no generic type in C). with Ftcl.
#################################
# Visual Tcl v1.20 Project
#
#################################
# GLOBAL VARIABLES
#
global widget
global inout
global tcl_platform
switch $tcl_platform(platform) {
unix {}
macintosh {load Caesar.shlb Caesar}
windows {load Test.dll ftcl}
}
#
proc {main} {argc argv} {
}
#################################
# VTCL GENERATED GUI PROCEDURES
#
proc vTclWindow. {base} {
if {$base == ""} {
set base .
}
wm focusmodel $base passive
wm geometry $base 1x1+25+65
wm maxsize $base 817 594
wm minsize $base 1 1
wm overrideredirect $base 0
wm resizable $base 1 1
wm withdraw $base
wm title $base "Wish"
}
proc {Window} {args} {
global vTcl
set cmd [lindex $args 0]
set name [lindex $args 1]
set newname [lindex $args 2]
set rest [lrange $args 3 end]
if {$name == "" || $cmd == ""} {return}
if {$newname == ""} {
set newname $name
}
set exists [winfo exists $newname]
switch $cmd {
show {
if {$exists == "1" && $name != "."} {wm deiconify $name; return}
if {[info procs vTclWindow(pre)$name] != ""} {
eval "vTclWindow(pre)$name $newname $rest"
}
if {[info procs vTclWindow$name] != ""} {
eval "vTclWindow$name $newname $rest"
}
if {[info procs vTclWindow(post)$name] != ""} {
eval "vTclWindow(post)$name $newname $rest"
}
}
hide { if $exists {wm withdraw $newname; return} }
iconify { if $exists {wm iconify $newname; return} }
destroy { if $exists {destroy $newname; return} }
}
}
#################################
# USER DEFINED PROCEDURES
#
proc vTclWindow.dialog {base} {
global Verschiebung
global Eingabe
global Ausgabe
#
if {$base == ""} {
set base .dialog
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
###################
# CREATING WIDGETS
###################
toplevel $base -class Toplevel \
-relief groove
wm focusmodel $base passive
wm geometry $base 417x282+101+123
wm maxsize $base 817 594
wm minsize $base 1 1
wm overrideredirect $base 0
wm resizable $base 1 1
wm deiconify $base
wm title $base "Caesar"
set Verschiebung 1
#
frame $base.eingabe \
-borderwidth 1 -height 30 -relief ridge -width 30
entry $base.eingabe.03 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-140-*-*-*-*-*-* \
-textvariable Eingabe -justify center -width 8 -state normal
label $base.lab1 \
-borderwidth 1 -text {Text to be (de/en)coded:}
scale $base.schieber \
-variable Verschiebung -from -26.0 -to 26.0 -digits 0 \
-label {Shift by} -length 104 -showvalue 1 \
-tickinterval 13.0 -orient horizontal
label $base.lab3 \
-borderwidth 1 -text letters
button $base.okBut -command {Kodiere; update} \
-text "Do it!" -default active
frame $base.ausgabe \
-borderwidth 1 -height 30 -relief ridge -width 30
entry $base.ausgabe.03 \
-font -Adobe-Helvetica-Medium-R-Normal-*-*-140-*-*-*-*-*-* \
-textvariable Ausgabe -justify center -width 8 -state disabled
bind $base <Return> {Kodiere; update}
###################
# SETTING GEOMETRY
###################
place $base.eingabe \
-x 5 -y 45 -width 408 -height 36 -anchor nw
grid columnconf $base.eingabe 0 -weight 1
grid rowconf $base.eingabe 0 -weight 1
grid $base.eingabe.03 \
-in .dialog.eingabe -column 0 -row 0 -columnspan 1 -rowspan 1 \
-sticky nesw
place $base.lab1 \
-x 10 -y 20 -width 211 -height 19 -anchor nw -bordermode ignore
place $base.schieber \
-x 30 -y 85 -width 357 -height 129 -bordermode ignore
place $base.lab3 \
-x 30 -y 165 -width 91 -height 19 -anchor nw -bordermode ignore
place $base.okBut \
-x 320 -y 166 -width 73 -height 29 -anchor nw -bordermode ignore
place $base.ausgabe \
-x 5 -y 215 -width 408 -height 36 -anchor nw
grid columnconf $base.ausgabe 0 -weight 1
grid rowconf $base.ausgabe 0 -weight 1
grid $base.ausgabe.03 \
-in .dialog.ausgabe -column 0 -row 0 -columnspan 1 -rowspan 1 \
-sticky nesw
}
proc Kodiere {} {
global Eingabe
global Ausgabe
global Verschiebung
#
set Ausgabe leer
puts stdout "Shift $Eingabe by $Verschiebung letters"
ftn_exec CAESAR
puts stdout "Result: $Ausgabe"
}
Window show .
Window show .dialog
main $argc $argv