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;