------------------------->  GNU Sather - sourcefile  <-------------------------
-- Copyright (C) 1996 by International Computer Science Institute            --
-- This file is part of the GNU Sather package. It is free software; you may --
-- redistribute  and/or modify it under the terms of the  GNU General Public --
-- License (GPL)  as  published  by the  Free  Software  Foundation;  either --
-- version 2 of the license, or (at your option) any later version.          --
-- This  program  is distributed  in the  hope that it will  be  useful, but --
-- WITHOUT ANY WARRANTY without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See Doc/GPL for more details.        --
-- The license text is also available from:  Free Software Foundation, Inc., --
-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA                     --
-------------->  Please email comments to <bug-sather@gnu.org>  <--------------

-- test-fortran.sa: Test external fortran interface
-- Author: Boris Vaysman
-- Date:   6/30/96

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 F_ARRAY tests
      farr1:F_ARRAY{F_DOUBLE};
      farr1_str:FSTR;
      arr_size:INT := 10;
      farr1:=#(arr_size);
      loop 
	 ind:INT:=0.upto!(arr_size-1);
	 farr1[ind] := #(ind.fltd);
      end;
	 
      loop
	 ind:INT:=0.upto!(arr_size-1);
	 farr1_str := farr1_str + farr1[ind].str;
      end;
      test("F_ARRAY{F_DOUBLE}: aget, aset", farr1_str, "0123456789");      

      farr2:F_ARRAY{F_INTEGER};
      farr2_str:FSTR;
      farr2:=#(arr_size);
      loop 
	 ind:INT:=0.upto!(arr_size-1);
	 farr2[ind] := #(ind);
      end;
	 
      loop
	 ind:INT:=0.upto!(arr_size-1);
	 farr2_str := farr2_str + farr2[ind].str;
      end;
      test("F_ARRAY{F_INTEGER}: aget, aset", farr2_str, "0123456789");      
     
      v1:VEC;
      v1:=#(10);
      vstr:FSTR;
      fv1:F_ARRAY{F_REAL};
		  
      loop
	 ind:INT:=0.upto!(9);
	 v1[ind] := ind.flt;
      end;
      fv1 := #(v1);
      
      loop
	 ind:INT:= 0.upto!(9);
	 vstr := vstr + fv1[ind].str;
      end;
      test("F_ARRAY::create(VEC)", vstr, "0123456789");

      vd:VECD;
      vd:=#(10);
      vdstr:FSTR;
      fvd:F_ARRAY{F_DOUBLE};
		  
      loop
	 ind:INT:=0.upto!(9);
	 vd[ind] := ind.fltd;
      end;
      fvd := #(vd);
      
      loop
	 ind:INT:= 0.upto!(9);
	 vdstr := vdstr + fvd[ind].str;
      end;
      test("F_ARRAY::create(VECD)", vdstr, "0123456789");
      
      -- 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");                  
      
      iii := TEST_F_ROUT::test3(1,2);
      test("TEST_F_ROUT::test3", 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 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;
   
   test3(a:INT,b:INT):INT is
      frout:F_ROUT{F_INTEGER,F_INTEGER,F_INTEGER} := 
	    #F_ROUT(TEST_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;   
   
   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;

