test-fortran.sa
Generated by gen_html_sa_files from ICSI. Contact gomes@icsi.berkeley.edu for details
---------------------------> Sather 1.1 source file <-----------------------
---
-- test-fortran.sa: Test external fortran interface
-- Copyright (C) 1996, International Computer Science Institute
--
-- COPYRIGHT NOTICE: This code is provided WITHOUT ANY WARRANTY
-- and is subject to the terms of the SATHER LIBRARY GENERAL PUBLIC
-- LICENSE contained in the file: Sather/Doc/License of the
-- Sather distribution. The license is also available from ICSI,
-- 1947 Center St., Suite 600, Berkeley CA 94704, USA.
-- Author: Boris Vaysman
-- Date: 6/30/96
class TEST_FORTRAN
class TEST_FORTRAN is
-- Test external fortran interface
include TEST;
-- test F_CHARACTER type
main is
class_name("TEST_FORTRAN");
c,c1,c2:F_CHARACTER;
-- test basic library stuff for F_CHARACTER
c1:=#('a'); c2:=#('a');
test("F_CHARACTER::is_eq", c1.is_eq(c2), "true");
c2:=#('b');
test("F_CHARACTER::is_lt", c1.is_lt(c2), "true");
-- test functions
test("TEST_F_CHARACTER::char_function",
TEST_F_CHARACTER::char_function.str, "A");
test("TEST_F_CHARACTER::char_function_char",
TEST_F_CHARACTER::char_function_char(#('A')).str, "B");
c := #('B');
c := TEST_F_CHARACTER::char_function_char(c);
test("TEST_F_CHARACTER::char_function_char", c.str, "C");
test("TEST_F_CHARACTER::char_function_char_char",
TEST_F_CHARACTER::char_function_char_char(#('A'),#('C')).str, "B");
-- test subroutines
TEST_F_CHARACTER::subroutine_out_char(out c);
test("TEST_F_CHARACTER::subroutine_out_char", c.str, "D");
c:=#('D');
TEST_F_CHARACTER::subroutine_inout_char(inout c);
test("TEST_F_CHARACTER::subroutine_inout_char", c.str, "E");
TEST_F_CHARACTER::subroutine_char_char_out_char(#('A'), #('C'), out c);
test("TEST_F_CHARACTER::subroutine_char_char_out_char", c.str, "B");
c1:= #('A');
c2:= #('B');
TEST_F_CHARACTER::subroutine_inout_char_inout_char(inout c1, inout c2);
test("TEST_F_CHARACTER::subroutine_iout_char_inout_char",c1.str+c2.str,"BA");
-- test F_STRING
fs:F_STRING:=#(4);
TEST_F_STRING::subroutine_char_arr(fs);
test("TEST_F_STRING::subroutine_char_arr", fs.str, "XXXX");
as:F_STRING:=#("AAA");
TEST_F_STRING::subroutine_char_arr_char_arr(as,fs);
test("TEST_F_STRING::subroutine_char_arr_char_arr", fs.str, "AAA ");
fs := #("BBBB");
TEST_F_STRING::subroutine_char_arr_char_arr(fs,as);
test("TEST_F_STRING::subroutine_char_arr_char_arr", as.str, "BBB");
as := #("AAA");
fs := #("FFFF");
TEST_F_STRING::subroutine_char_arr_char_3(as,fs);
test("TEST_F_STRING::subroutine_char_arr_char_3", fs.str, "AAAF");
as := #("AAA");
fs := #("FFFF");
TEST_F_STRING::subroutine_char_3_char_3(as,fs);
test("TEST_F_STRING::subroutine_char_3_char_3", fs.str, "AAAF");
as := TEST_F_STRING::char_arr_function;
test("TEST_F_STRING::char_arr_function", as.str.head(4), "XXXX");
as := #("AAA");
fs := #("FFFF");
as := TEST_F_STRING::char_arr_function_char_arr(fs);
test("TEST_F_STRING::char_arr_function_char_arr", as.str.head(4), "FFFF");
-- integer tests
i,j,k:F_INTEGER;
-- test basic library stuff
i:=#(1); j:=#(2);
test("F_INTEGER::plus", i+j, "3");
test("F_INTEGER::minus", i-j, "-1");
test("F_INTEGER::is_eq", i=j, "false");
test("F_INTEGER::is_lt", i<j, "true");
-- external interface stuff
i := TEST_F_INTEGER::f_int_function;
test("TEST_F_INTEGER::f_int_function", i.str, "99");
j:=#(100);
i := TEST_F_INTEGER::f_int_function_f_int(j);
test("TEST_F_INTEGER::f_int_function_f_int", i.str, "100");
i := #(1); j :=#(2);
k := TEST_F_INTEGER::f_int_function_f_int_f_int(i,j);
test("TEST_F_INTEGER::f_int_function_f_int_f_int", k.str, "3");
k := TEST_F_INTEGER::int_func_inout_int_inout_int(inout i,inout j);
test("TEST_F_INTEGER::int_func_inout_int_inout_int",
k.str+i.str+j.str, "321");
i:=#(1); j:=#(2);
TEST_F_INTEGER::sub_inout_int_inout_int(inout i, inout j);
test("TEST_F_INTEGER::sub_inout_int_inout_int", i.str+j.str, "21");
TEST_F_INTEGER::sub_int_int_out_int(i, j, out k);
test("TEST_F_INTEGER::sub_int_int_out_int", k.str, "3");
-- real tests
ri,rj,rk:F_REAL;
-- simple library tests
ri := #(1.0);
rj := #(2.0);
test("F_REAL::plus", ri+rj, "3");
test("F_REAL::minus", ri-rj, "-1");
test("F_REAL::times", rj*rj, "4");
test("F_REAL::is_eq", ri=rj, "false");
test("F_REAL::is_lt", rj<ri, "false");
test("F_REAL::is_lt", ri<rj, "true");
ri := TEST_F_REAL::f_real_function;
test("TEST_F_REAL::f_real_function", ri.str, "99.5");
rj:=#(100.1);
ri := TEST_F_REAL::f_real_function_f_real(rj);
test("TEST_F_REAL::f_real_function_f_real", ri.str, "100.1");
ri := #(1.5); rj :=#(2.5);
rk := TEST_F_REAL::f_real_function_f_real_f_real(ri,rj);
test("TEST_F_REAL::f_real_function_f_real_f_real", rk.str, "4");
rk := TEST_F_REAL::real_func_inout_real_inout_real(inout ri,inout rj);
test("TEST_F_REAL::real_func_inout_real_inout_real",
rk.str+ri.str+rj.str, "42.51.5");
ri:=#(1.0); rj:=#(2.0);
TEST_F_REAL::sub_inout_real_inout_real(inout ri, inout rj);
test("TEST_F_REAL::sub_inout_real_inout_real", ri.str+rj.str, "21");
TEST_F_REAL::sub_real_real_out_real(ri, rj, out rk);
test("TEST_F_REAL::sub_real_real_out_real", rk.str, "3");
-- double precision tests
di,dj,dk:F_DOUBLE;
di := #(1.0d);
dj := #(2.0d);
test("F_DOUBLE::plus", di+dj, "3");
test("F_DOUBLE::minus", di-dj, "-1");
test("F_DOUBLE::times", dj*dj, "4");
test("F_DOUBLE::is_eq", di=dj, "false");
test("F_DOUBLE::is_lt", di<dj, "true");
di := TEST_F_DOUBLE::f_d_function;
test("TEST_F_DOUBLE::f_d_function", di.str, "99.5");
dj:=#(100.1d);
di := TEST_F_DOUBLE::f_d_function_f_d(dj);
test("TEST_F_DOUBLE::f_d_function_f_d", di.str, "100.1");
di := #(1.5d); dj :=#(2.5d);
dk := TEST_F_DOUBLE::f_d_function_f_d_f_d(di,dj);
test("TEST_F_DOUBLE::f_d_function_f_d_f_d", dk.str, "4");
dk := TEST_F_DOUBLE::f_d_func_inout_f_d_inout_f_d(inout di,inout dj);
test("TEST_F_DOUBLE::f_d_func_inout_f_d_inout_f_d",
dk.str+di.str+dj.str, "42.51.5");
di:=#(1.0d); dj:=#(2.0d);
TEST_F_DOUBLE::sub_inout_f_d_inout_f_d(inout di, inout dj);
test("TEST_F_DOUBLE::sub_inout_f_d_inout_f_d", di.str+dj.str, "21");
TEST_F_DOUBLE::sub_f_d_f_d_out_f_d(di, dj, out dk);
test("TEST_F_DOUBLE::sub_f_d_f_d_out_f_d", dk.str, "3");
-- logical tests
li,lj,lk:F_LOGICAL;
-- simple library tests
li := #(true); lj := #(false);
test("F_LOGICAL::not", ~li, "false");
test("F_LOGICAL::f_or", li.f_or(lj), "true");
test("F_LOGICAL::f_and", li.f_and(lj), "false");
test("F_LOGICAL::is_eq", li=lj, "false");
li := #(true);
#OUT + "LI: " + li.str + "\n";
li := TEST_F_LOGICAL::f_l_function;
test("TEST_F_LOGICAL::f_l_function", li.str, "true");
lj:=#(false);
li := TEST_F_LOGICAL::f_l_function_f_l(lj);
test("TEST_F_LOGICAL::f_l_function_f_l", li.str, "false");
li := #(true); lj :=#(false);
lk := TEST_F_LOGICAL::f_l_function_f_l_f_l(li,lj);
test("TEST_F_LOGICAL::f_l_function_f_l_f_l", lk.str, "true");
lk := TEST_F_LOGICAL::f_l_func_inout_f_l_inout_f_l(inout li,inout lj);
test("TEST_F_LOGICAL::f_l_func_inout_f_l_inout_f_l",
lk.str+" "+li.str+" "+lj.str, "true false true");
li:=#(true); lj:=#(false);
TEST_F_LOGICAL::sub_inout_f_l_inout_f_l(inout li, inout lj);
test("TEST_F_LOGICAL::sub_inout_f_l_inout_f_l", li.str+" "+lj.str,
"false true");
TEST_F_LOGICAL::sub_f_l_f_l_out_f_l(li, lj, out lk);
test("TEST_F_LOGICAL::sub_f_l_f_l_out_f_l", lk.str, "false");
-- complex tests
ci,cj,ck:F_COMPLEX;
--simple library tests
ci := #(1.0,2.0);
cj := #(3.0,4.0);
test("F_COMPLEX::plus", ci+cj, "4+6i");
test("F_COMPLEX::minus", ci-cj, "-2-2i");
test("F_COMPLEX::is_eq", ci=cj, "false");
-- external interface
ci := TEST_F_COMPLEX::f_c_function;
test("TEST_F_COMPLEX::f_c_function", ci.str, "99.5+99.5i");
h::=#CPX(100.1,200.2);
cj:=#(h);
ci := TEST_F_COMPLEX::f_c_function_f_c(cj);
test("TEST_F_COMPLEX::f_c_function_f_c", ci.str, "100.1+200.2i");
si ::= #CPX(1.0,1.0); sj ::= #CPX(2.0,2.0);
ci := #(si); cj :=#(sj);
ck := TEST_F_COMPLEX::f_c_function_f_c_f_c(ci,cj);
test("TEST_F_COMPLEX::f_c_function_f_c_f_c", ck.str, "3+3i");
ck := TEST_F_COMPLEX::f_c_func_inout_f_c_inout_f_c(inout ci,inout cj);
test("TEST_F_COMPLEX::f_c_func_inout_f_c_inout_f_c",
ck.str+" "+ci.str+" "+cj.str, "3+3i 2+2i 1+1i");
ci:=#(si); cj:=#(sj);
TEST_F_COMPLEX::sub_inout_f_c_inout_f_c(inout ci, inout cj);
test("TEST_F_COMPLEX::sub_inout_f_c_inout_f_c", ci.str+" "+cj.str,
"2+2i 1+1i");
TEST_F_COMPLEX::sub_f_c_f_c_out_f_c(ci, cj, out ck);
test("TEST_F_COMPLEX::sub_f_c_f_c_out_f_c", ck.str, "3+3i");
-- double precision complex tests
dci,dcj,dck:F_DOUBLE_COMPLEX;
-- simple library tests
dci := #(1.0d,2.0d);
dcj := #(3.0d,4.0d);
test("F_DOUBLE_COMPLEX::plus", dci+dcj, "4+6i");
test("F_DOUBLE_COMPLEX::minus", dci-dcj, "-2-2i");
test("F_DOUBLE_COMPLEX::is_eq", dci=dcj, "false");
-- external interface checks
dci := TEST_F_DOUBLE_COMPLEX::f_dc_function;
test("TEST_F_DOUBLE_COMPLEX::f_dc_function", dci.str, "99.5+99.5i");
hd::=#CPXD(100.1d,200.2d);
dcj:=#(hd);
dci := TEST_F_DOUBLE_COMPLEX::f_dc_function_f_dc(dcj);
test("TEST_F_DOUBLE_COMPLEX::f_dc_function_f_dc", dci.str, "100.1+200.2i");
i_cpxd ::= #CPXD(1.0d,1.0d); j_cpxd ::= #CPXD(2.0d,2.0d);
dci := #(i_cpxd); dcj :=#(j_cpxd);
dck := TEST_F_DOUBLE_COMPLEX::f_dc_function_f_dc_f_dc(dci,dcj);
test("TEST_F_DOUBLE_COMPLEX::f_dc_function_f_dc_f_dc", dck.str, "3+3i");
dck := TEST_F_DOUBLE_COMPLEX::f_dc_func_inout_f_dc_inout_f_dc(inout dci,inout dcj);
test("TEST_F_DOUBLE_COMPLEX::f_dc_func_inout_f_dc_inout_f_dc",
dck.str+" "+dci.str+" "+dcj.str, "3+3i 2+2i 1+1i");
dci:=#(i_cpxd); dcj:=#(j_cpxd);
TEST_F_DOUBLE_COMPLEX::sub_inout_f_dc_inout_f_dc(inout dci, inout dcj);
test("TEST_F_DOUBLE_COMPLEX::sub_inout_f_dc_inout_f_dc", dci.str+" "+dcj.str,
"2+2i 1+1i");
TEST_F_DOUBLE_COMPLEX::sub_f_dc_f_dc_out_f_dc(dci, dcj, out dck);
test("TEST_F_DOUBLE_COMPLEX::sub_f_dc_f_dc_out_f_dc", dck.str, "3+3i");
--------------- Exception handling/alternate returns ----------------
handler1,handler2: F_HANDLER;
helper::=#EXCEPTION_HANDLERS;
handler1 := #(bind(helper.h(1)));
handler2 := #(bind(helper.h(2)));
-- simple test: pass handlers to the FORTRAN calls and see if they are
-- invoked as necessary
TEST_F_EXCEPTIONS::may_trigger_exceptions(#(0),handler1,handler2);
test("TEST_F_EXCEPTIONS: simple test 0",
EXCEPTION_HANDLERS::emessage, "no exception");
TEST_F_EXCEPTIONS::may_trigger_exceptions(#(1),handler1,handler2);
test("TEST_F_EXCEPTIONS: simple test 1",
EXCEPTION_HANDLERS::emessage, "Sather handler for fortran exceptions #1");
TEST_F_EXCEPTIONS::may_trigger_exceptions(#(2),handler1,handler2);
test("TEST_F_EXCEPTIONS: simple test 2",
EXCEPTION_HANDLERS::emessage, "Sather handler for fortran exceptions #2");
-- now try something more sophisticated. Sather exception handlers
-- that catch exceptions raised by fortran redirect them to be caught
-- by the regular Sather protect mechanism.
redirect_handler1,redirect_handler2:F_HANDLER;
redirect_handler1 := #(bind(helper.r_h(1)));
redirect_handler2 := #(bind(helper.r_h(2)));
estr:STR:="no exception";
caught_str:STR:="\n\t... caught by protect";
-- Redirection Test 0
protect
TEST_F_EXCEPTIONS::may_trigger_exceptions(#(0),redirect_handler1,redirect_handler2);
when STR then
estr := exception + caught_str;
end;
test("TEST_F_EXCEPTIONS: redirection test 0", estr, "no exception");
-- Redirection Test 1
protect
TEST_F_EXCEPTIONS::may_trigger_exceptions(#(1),redirect_handler1,redirect_handler2);
when STR then
estr := exception + caught_str;
end;
test("TEST_F_EXCEPTIONS: redirection test 1", estr,
"FORTRAN->Sather exception redirected by handler #1"+caught_str);
-- Redirection Test 2
protect
TEST_F_EXCEPTIONS::may_trigger_exceptions(#(2),redirect_handler1,redirect_handler2);
when STR then
estr := exception + caught_str;
end;
test("TEST_F_EXCEPTIONS: redirection test 2", estr,
"FORTRAN->Sather exception redirected by handler #2"+caught_str);
-- Test some simple BLA routines
sa,sb,sc:ARRAY2{FLTD};
fa,fb,fc:F_ARRAY2{F_DOUBLE};
sa := #(2,2);
sb := #(2,2);
sc := #(2,2);
sa[0,0] := 1.0d; sa[0,1] := 2.0d;
sa[1,0] := 2.0d; sa[1,1] := 1.0d;
sb[0,0] := 2.0d; sb[0,1] := 0.0d;
sb[1,0] := 0.0d; sb[1,1] := 2.0d;
fa := #(sa);
fb := #(sb);
fc := #(sc);
dim:F_INTEGER:=#(2);
TEST_BLAS::dgemm(#('N'),#('N'),dim,dim,dim,#(1.0d),fa,dim,fb,dim,#(0.0d),fc,dim);
blas_res:STR;
loop
ind1::=0.upto!(sc.size1-1);
blas_res := blas_res+"[";
loop
ind2::=0.upto!(sc.size2-1);
if ind2/=0 then blas_res := blas_res+" "; end;
blas_res := blas_res + sc[ind1,ind2]
end;
blas_res := blas_res+"]";
end;
test("TEST_BLAS:dgemm", blas_res, "[2 4][4 2]");
-- test Fortran->Sather interface
i:=#(1); j:=#(2); k:=#(0);
TEST_CALLBACKS::sub_callback1(i,j,out k);
test("TEST_CALLBACKS::sub_callback1", k, "3");
ri:=#(1.0); rj := #(2.0);
TEST_CALLBACKS::sub_callback2(ri,rj,out rk);
test("TEST_CALLBACKS::sub_callback2", rk, "3");
TEST_CALLBACKS::sub_callback3(inout i, inout j);
test("TEST_CALLBACKS::sub_callback3", i.str+" "+j.str, "2 1");
di := #(1.0d); dj := #(2.0d);
TEST_CALLBACKS::sub_callback4(inout di, inout dj);
test("TEST_CALLBACKS::sub_callback4",di.str+" " +dj.str, "2 1");
ci :=#(0.0,0.0);
TEST_CALLBACKS::sub_callback5(inout ci);
test("TEST_CALLBACKS::sub_callback5", ci.str, "1+2i");
dci := #(0.0d, 0.0d);
TEST_CALLBACKS::sub_callback6(inout dci);
test("TEST_CALLBACKS::sub_callback6", dci.str, "1+2i");
fch:F_CHARACTER:=#('*');
fch := TEST_CALLBACKS::func_callback1;
test("TEST_CALLBACKS::func_callback1", fch.str, "A");
fstr:F_STRING:=#("****");
fstr := TEST_CALLBACKS::func_callback2;
test("TEST_CALLBACKS::func_callback2", fstr.str.head(4), "AAAA");
iii:INT := TEST_F_ROUT::test1(1,2);
test("TEST_F_ROUT::tes1", iii.str, "3");
iii := TEST_F_ROUT::test2(1,2);
test("TEST_F_ROUT::test2", iii.str, "3");
-------- Sather style calls to features with Sather arguments ---------
iii:=TEST_SATHER_CALLS::foo1(1,#(2));
test("TEST_SATHER_CALLS::foo1", iii.str, "3");
TEST_SATHER_CALLS::bar1(1,#F_INTEGER(9),out iii);
test("TEST_SATHER_CALLS::bar1", iii.str, "10");
sf:FLT;
sf := TEST_SATHER_CALLS::foo2(1.0,#(2.0));
test("TEST_SATHER_CALLS::foo2", sf.str, "3");
TEST_SATHER_CALLS::bar2(1.0,#F_REAL(9.0),out sf);
test("TEST_SATHER_CALLS::bar2", sf.str, "10");
-- these two are calls to routines defined in Sather, but they use
-- the Fortran calling convention
i:=TEST_SATHER_CALLS::f_add1(#(10),#(5));
test("TEST_SATHER_CALLS::f_add1", i.str, "15");
TEST_SATHER_CALLS::f_add2(#(10),#(20),out i);
test("TEST_SATHER_CALLS::f_add2", i.str, "30");
end;
end;
external FORTRAN class TEST_F_CHARACTER is
-- tests for F_CHARACTER (treated as immutable in Sather)
char_function:F_CHARACTER;
char_function_char(x:F_CHARACTER):F_CHARACTER;
char_function_char_char(x:F_CHARACTER,y:F_CHARACTER):F_CHARACTER;
subroutine_out_char(out x:F_CHARACTER);
subroutine_inout_char(inout x:F_CHARACTER);
subroutine_char_char_out_char(X:F_CHARACTER,y:F_CHARACTER,out res:F_CHARACTER);
subroutine_inout_char_inout_char(inout x:F_CHARACTER,inout y:F_CHARACTER);
end;
external FORTRAN class TEST_F_STRING is
-- test F_STRING (roughly equivalent to dynamic CHARACTER*(*) arrays
subroutine_char_arr_char_arr(x:F_STRING,y:F_STRING);
subroutine_char_arr(x:F_STRING);
subroutine_char_arr_char_3(x:F_STRING,y:F_STRING);
subroutine_char_3_char_3(x:F_STRING,y:F_STRING);
char_arr_function:F_STRING;
char_arr_function_char_arr(x:F_STRING):F_STRING;
end;
external FORTRAN class TEST_F_INTEGER is
f_int_function:F_INTEGER;
f_int_function_f_int(x:F_INTEGER):F_INTEGER;
f_int_function_f_int_f_int(x,y:F_INTEGER):F_INTEGER;
int_func_inout_int_inout_int(inout x:F_INTEGER, inout y:F_INTEGER):F_INTEGER;
sub_inout_int_inout_int(inout x,inout y:F_INTEGER);
sub_int_int_out_int(x,y:F_INTEGER, out z:F_INTEGER);
end;
external FORTRAN class TEST_F_REAL is
f_real_function:F_REAL;
f_real_function_f_real(x:F_REAL):F_REAL;
f_real_function_f_real_f_real(x,y:F_REAL):F_REAL;
real_func_inout_real_inout_real(inout x:F_REAL, inout y:F_REAL):F_REAL;
sub_inout_real_inout_real(inout x,inout y:F_REAL);
sub_real_real_out_real(x,y:F_REAL, out z:F_REAL);
end;
external FORTRAN class TEST_F_DOUBLE is
f_d_function:F_DOUBLE;
f_d_function_f_d(x:F_DOUBLE):F_DOUBLE;
f_d_function_f_d_f_d(x,y:F_DOUBLE):F_DOUBLE;
f_d_func_inout_f_d_inout_f_d(inout x:F_DOUBLE, inout y:F_DOUBLE):F_DOUBLE;
sub_inout_f_d_inout_f_d(inout x,inout y:F_DOUBLE);
sub_f_d_f_d_out_f_d(x,y:F_DOUBLE, out z:F_DOUBLE);
end;
external FORTRAN class TEST_F_LOGICAL is
f_l_function:F_LOGICAL;
f_l_function_f_l(x:F_LOGICAL):F_LOGICAL;
f_l_function_f_l_f_l(x,y:F_LOGICAL):F_LOGICAL;
f_l_func_inout_f_l_inout_f_l(inout x:F_LOGICAL, inout y:F_LOGICAL):F_LOGICAL;
sub_inout_f_l_inout_f_l(inout x,inout y:F_LOGICAL);
sub_f_l_f_l_out_f_l(x,y:F_LOGICAL, out z:F_LOGICAL);
end;
external FORTRAN class TEST_F_COMPLEX is
f_c_function:F_COMPLEX;
f_c_function_f_c(x:F_COMPLEX):F_COMPLEX;
f_c_function_f_c_f_c(x,y:F_COMPLEX):F_COMPLEX;
f_c_func_inout_f_c_inout_f_c(inout x:F_COMPLEX, inout y:F_COMPLEX):F_COMPLEX;
sub_inout_f_c_inout_f_c(inout x,inout y:F_COMPLEX);
sub_f_c_f_c_out_f_c(x,y:F_COMPLEX, out z:F_COMPLEX);
end;
external FORTRAN class TEST_F_DOUBLE_COMPLEX is
f_dc_function:F_DOUBLE_COMPLEX;
f_dc_function_f_dc(x:F_DOUBLE_COMPLEX):F_DOUBLE_COMPLEX;
f_dc_function_f_dc_f_dc(x,y:F_DOUBLE_COMPLEX):F_DOUBLE_COMPLEX;
f_dc_func_inout_f_dc_inout_f_dc(inout x:F_DOUBLE_COMPLEX, inout y:F_DOUBLE_COMPLEX):F_DOUBLE_COMPLEX;
sub_inout_f_dc_inout_f_dc(inout x,inout y:F_DOUBLE_COMPLEX);
sub_f_dc_f_dc_out_f_dc(x,y:F_DOUBLE_COMPLEX, out z:F_DOUBLE_COMPLEX);
end;
external FORTRAN class TEST_F_EXCEPTIONS is
may_trigger_exceptions(i:F_INTEGER, handler1:F_HANDLER, handler2:F_HANDLER);
end;
class EXCEPTION_HANDLERS
class EXCEPTION_HANDLERS is
shared emessage:STR := "no exception";
create:SAME is
return new;
end;
h(i:INT) is
emessage := "Sather handler for fortran exceptions #"+ i.str;
end;
r_h(i:INT) is
raise "FORTRAN->Sather exception redirected by handler #"+i.str;
end;
end;
external FORTRAN class TEST_BLAS is
dgemm(transa:F_CHARACTER, transb:F_CHARACTER, m,n,k:F_INTEGER,
alpha:F_DOUBLE, a:F_ARRAY2{F_DOUBLE}, lda:F_INTEGER,
b:F_ARRAY2{F_DOUBLE}, ldb:F_INTEGER,beta:F_DOUBLE,
C:F_ARRAY2{F_DOUBLE},ldc:F_INTEGER);
end;
external FORTRAN class TEST_CALLBACKS is
sub_callback1(i:F_INTEGER,j:F_INTEGER,out k:F_INTEGER);
sather_add1(i,j:F_INTEGER):F_INTEGER is
return i+j;
end;
sub_callback2(ri:F_REAL,rj:F_REAL,out rk:F_REAL);
sather_add2(i,j:F_REAL):F_REAL is
return i+j;
end;
sub_callback3(inout i:F_INTEGER, inout j:F_INTEGER);
sather_swap3(i:F_INTEGER, j:F_INTEGER) is
t::=i;
i := j;
j := t;
end;
sub_callback4(inout i:F_DOUBLE, inout j:F_DOUBLE);
sather_swap4(i:F_DOUBLE, j:F_DOUBLE) is
t::=i;
i := j;
j := t;
end;
sub_callback5(inout i:F_COMPLEX);
sather_return_complex(cp:F_COMPLEX):F_COMPLEX is
return #F_COMPLEX(cp.re+#F_REAL(1.0), cp.im+#F_REAL(2.0));
end;
sub_callback6(inout i:F_DOUBLE_COMPLEX);
sather_return_double_complex(dcp:F_DOUBLE_COMPLEX):F_DOUBLE_COMPLEX is
return #F_DOUBLE_COMPLEX(dcp.re+#F_DOUBLE(1.0d), dcp.im+#F_DOUBLE(2.0d));
end;
func_callback1:F_CHARACTER;
sather_return_char:F_CHARACTER is
return #F_CHARACTER('A');
end;
func_callback2:F_STRING;
sather_return_char4:F_STRING is
return #F_STRING("AAAA");
end;
end;
external FORTRAN class TEST_F_ROUT is
plus(a:F_INTEGER, b:F_INTEGER,sum:F_INTEGER) is
sum := a+b;
end;
test1(a:INT,b:INT):INT is
frout:F_ROUT{F_INTEGER,F_INTEGER,F_INTEGER} := #F_ROUT(plus(_,_,_));
frout1:F_ROUT{F_INTEGER,F_INTEGER,F_INTEGER};
frout1 := frout;
tmp::=func_test_f_rout(frout1, #(a),#(b));
return tmp.int;
end;
test2(a:INT,b:INT):INT is
frout:F_ROUT{F_INTEGER,F_INTEGER,F_INTEGER} := #F_ROUT(plus(_,_,_));
frout1:F_ROUT{F_INTEGER,F_INTEGER,F_INTEGER};
frout1 := frout;
sum:F_INTEGER;
sub_test_f_rout(frout1, #(a),#(b),out sum);
return sum.int;
end;
func_test_f_rout(func:F_ROUT{F_INTEGER,F_INTEGER,F_INTEGER},
a:F_INTEGER,
b:F_INTEGER):F_INTEGER;
sub_test_f_rout(func:F_ROUT{F_INTEGER,F_INTEGER,F_INTEGER},
a:F_INTEGER,
b:F_INTEGER,
out sum:F_INTEGER);
end;
external FORTRAN class TEST_SATHER_CALLS is
-- this tests Sather style calls to features with Sather arguments
-- in the external Fortran classes
foo1(i:INT, fi:F_INTEGER):INT is
return i+fi.int;
end;
bar1(i:INT,fi:F_INTEGER,out res:INT) is
res := i + fi.int;
end;
foo2(f:FLT, ff:F_REAL):FLT is
return f+ff.flt;
end;
bar2(f:FLT,ff:F_REAL,out res:FLT) is
res := f + ff.flt;
end;
f_add1(i:F_INTEGER, j:F_INTEGER):F_INTEGER is
return i+j;
end;
f_add2(i:F_INTEGER, j:F_INTEGER, out res:F_INTEGER) is
res := i+j;
end;
end;