------------------------->  GNU Sather - sourcefile  <-------------------------
-- Copyright (C) 199x by International Computer Science Institute            --
-- This file is part of the GNU Sather library. It is free software; you may --
-- redistribute  and/or modify it under the terms of the GNU Library General --
-- Public  License (LGPL)  as published  by the  Free  Software  Foundation; --
-- either version 2 of the license, or (at your option) any later version.   --
-- This  library  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/LGPL 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>  <--------------

class TEST_YIELD is -- TEST_PROTECT is
   include R_TEST;

   private test_lock(l:$LOCK):BOOL is
      r:BOOL;
      par
	 fork
	    lock when l then r:=true;
	    else r:=false;
	    end;
         end;
      end;
      return r;
   end;

   shared alck:ARRAY{$LOCK};

   next_cl is
      lock alck[here] then
	 if here=0 then raise 99; else next_cl@(here+1)%clusters; end;
      end;
   end;
    
   iter!(once l:$LOCK) is
      lock l then
         yield;
      end;
   end;

   riter1!(once i:INT) is
      loop
	 lock alck[i] then
	    if i/=alck.size-1 then
	       riter2!(i+1);
	    end;
	    yield;
	 end;
      end;
   end;

   riter2!(once i:INT) is
      lock alck[i] then
	 loop
	    if i/=alck.size-1 then
	       riter1!(i+1);
	    end;
	    yield;
	 end;
      end;
   end;

   main is
      class_name("PROTECT");
      oblig::=0;
      protect
         protect
	    protect
	       protect
	          protect
		     raise 3;
		  when INT then
		     test("first protect",exception,3);
		     oblig:=oblig+1;
		  end;
		  oblig:=oblig+1;
		  raise 2;
	       when FLT then 
		  test("FLT protect",false,true);
	       end;
	       test("FLT protect",false,true);
	    when $OB then raise exception
	    end;
	 when INT then
	    test("middle protect",exception,2);
	    oblig:=oblig+1;
	    raise 1;
	 else
	    test("middle protect",false,true);
	 end;
	 test("middle protect",false,true);
      when INT then
	 test("last protect",exception,1);
	 SYS::defer;
	 oblig:=oblig+1;
      else
      	 test("last protect",false,true);
      end;
      test("oblig",oblig,4);
      finish;

      class_name("PROTECT AND LOCK");
      oblig:=0;
      m::=#MUTEX;
      n::=#GATE;
      protect
	 lock n then
	    protect
	       protect
		  protect
		     lock m then 
			protect
			   raise 3;
			when INT then
			   test("first protect",exception,3);
			   test("first protect lock m",test_lock(m),false);
			   oblig:=oblig+1;
			end;
			oblig:=oblig+1;
			raise 2;
		     end;
		  when FLT then 
		     test("FLT protect",false,true);
		  end;
		  test("FLT protect",false,true);
	       when $OB then raise exception
	       end;
	    when INT then
	       test("middle protect",exception,2);
	       test("middle protect lock m",test_lock(m),true);
	       test("middle protect lock n",test_lock(n),false);
	       oblig:=oblig+1;
	       raise 1;
	    else
	       test("middle protect",false,true);
	    end;
	    test("middle protect",false,true);
         end;
      when INT then
	 test("last protect",exception,1);
	 test("last protect lock n",test_lock(n),true);
	 oblig:=oblig+1;
      else
      	 test("last protect",false,true);
      end;
      test("oblig",oblig,4);

      protect
	 alck:=#(clusters);
	 loop alck.set!(#MUTEX); end;
	 -- make life more interesting: 
	 if clusters>1 then alck[0]:=alck[1]; end;
	 next_cl@1%clusters;
      when INT then
         test("remote exec raise",exception,99);
	 t1::=#ARRAY{BOOL}(clusters);
	 t2::=#ARRAY{BOOL}(clusters);
	 loop t1.set!(true);t2.set!(test_lock(alck.elt!)); end;
	 test("remote exec locks",t2.str,t1.str);
      else
         test("remote exec",false,true);
      end; 
      finish;

      class_name("YIELDS IN LOCK");
      ll::=#MUTEX;
      loop
      	 test("ll 1",test_lock(ll),true);
	 iter!(ll);
      	 test("ll 2",test_lock(ll),false);
	 break!;
      end;   
      test("ll 3",test_lock(ll),true);
      alck:=#ARRAY{$LOCK}(10);
      loop alck.set!(#MUTEX); end;
      -- add some spice (multiple locks)
      alck[4]:=alck[2];
      alck[5]:=alck[3];
      t1::=#ARRAY{BOOL}(10);
      t2::=#ARRAY{BOOL}(10);
      loop t1.set!(true);t2.set!(test_lock(alck.elt!)); end;
      test("recursive 1",t2.str,t1.str);
      loop
         riter1!(0);
	 loop t1.set!(false);t2.set!(test_lock(alck.elt!)); end;
	 test("recursive 2",t2.str,t1.str);
	 break!;
      end;
      loop t1.set!(true);t2.set!(test_lock(alck.elt!)); end;
      test("recursive 3",t2.str,t1.str);

      loop
      	 iter!(alck[0]);
	 test("parallel 1",test_lock(alck[0]).str+","+test_lock(alck[1])+","+test_lock(alck[2]),
	 	"false,true,true");
      	 iter!(alck[1]);
	 test("parallel 2",test_lock(alck[0]).str+","+test_lock(alck[1])+","+test_lock(alck[2]),
	 	"false,false,true");
      	 iter!(alck[2]);
	 test("parallel 3",test_lock(alck[0]).str+","+test_lock(alck[1])+","+test_lock(alck[2]),
	 	"false,false,false");
	 break!;
      end;
      test("parallel 4",test_lock(alck[0]).str+","+test_lock(alck[1])+","+test_lock(alck[2]),
	 	"true,true,true");
         
      finish;
   end;
    
end; -- class TEST_PROTECT

-- vim:sw=3:nosmartindent
