URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c7/] [c760010.a] - Rev 154
Go to most recent revision | Compare with Previous | Blame | View Log
-- C760010.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that explicit calls to Initialize, Adjust and Finalize
-- procedures that raise exceptions propagate the exception raised,
-- not Program_Error. Check this for both a user defined exception
-- and a language defined exception. Check that implicit calls to
-- initialize procedures that raise an exception propagate the
-- exception raised, not Program_Error;
--
-- Check that the utilization of a controlled type as the actual for
-- a generic formal tagged private parameter supports the correct
-- behavior in the instantiated software.
--
-- TEST DESCRIPTION:
-- Declares a generic package instantiated to check that controlled
-- types are not impacted by the "generic boundary."
-- This instance is then used to perform the tests of various calls to
-- the procedures. After each operation in the main program that should
-- cause implicit calls where an exception is raised, the program handles
-- Program_Error. After each explicit call, the program handles the
-- Expected_Error. Handlers for the opposite exception are provided to
-- catch the obvious failure modes. The predefined exception
-- Tasking_Error is used to be certain that some other reason has not
-- raised a predefined exception.
--
--
-- DATA STRUCTURES
--
-- C760010_1.Simple_Control is derived from
-- Ada.Finalization.Controlled
--
-- C760010_2.Embedded_Derived is derived from C760010_1.Simple_Control
-- by way of generic instantiation
--
--
-- CHANGE HISTORY:
-- 01 MAY 95 SAIC Initial version
-- 23 APR 96 SAIC Fix visibility problem for 2.1
-- 14 NOV 96 SAIC Revisit for 2.1 release
-- 26 JUN 98 EDS Added pragma Elaborate_Body to
-- package C760010_0.Check_Formal_Tagged
-- to avoid possible instantiation error
--!
---------------------------------------------------------------- C760010_0
package C760010_0 is
User_Defined_Exception : exception;
type Actions is ( No_Action,
Init_Raise_User_Defined, Init_Raise_Standard,
Adj_Raise_User_Defined, Adj_Raise_Standard,
Fin_Raise_User_Defined, Fin_Raise_Standard );
Action : Actions := No_Action;
function Unique return Natural;
end C760010_0;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
package body C760010_0 is
Value : Natural := 101;
function Unique return Natural is
begin
Value := Value +1;
return Value;
end Unique;
end C760010_0;
---------------------------------------------------------------- C760010_0
------------------------------------------------------ Check_Formal_Tagged
generic
type Formal_Tagged is tagged private;
package C760010_0.Check_Formal_Tagged is
pragma Elaborate_Body;
type Embedded_Derived is new Formal_Tagged with record
TC_Meaningless_Value : Natural := Unique;
end record;
procedure Initialize( ED: in out Embedded_Derived );
procedure Adjust ( ED: in out Embedded_Derived );
procedure Finalize ( ED: in out Embedded_Derived );
end C760010_0.Check_Formal_Tagged;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
with Report;
package body C760010_0.Check_Formal_Tagged is
procedure Initialize( ED: in out Embedded_Derived ) is
begin
ED.TC_Meaningless_Value := Unique;
case Action is
when Init_Raise_User_Defined => raise User_Defined_Exception;
when Init_Raise_Standard => raise Tasking_Error;
when others => null;
end case;
end Initialize;
procedure Adjust ( ED: in out Embedded_Derived ) is
begin
ED.TC_Meaningless_Value := Unique;
case Action is
when Adj_Raise_User_Defined => raise User_Defined_Exception;
when Adj_Raise_Standard => raise Tasking_Error;
when others => null;
end case;
end Adjust;
procedure Finalize ( ED: in out Embedded_Derived ) is
begin
ED.TC_Meaningless_Value := Unique;
case Action is
when Fin_Raise_User_Defined => raise User_Defined_Exception;
when Fin_Raise_Standard => raise Tasking_Error;
when others => null;
end case;
end Finalize;
end C760010_0.Check_Formal_Tagged;
---------------------------------------------------------------- C760010_1
with Ada.Finalization;
package C760010_1 is
procedure Check_Counters(Init,Adj,Fin : Natural; Message: String);
procedure Reset_Counters;
type Simple_Control is new Ada.Finalization.Controlled with record
Item: Integer;
end record;
procedure Initialize( AV: in out Simple_Control );
procedure Adjust ( AV: in out Simple_Control );
procedure Finalize ( AV: in out Simple_Control );
end C760010_1;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
with Report;
package body C760010_1 is
Initialize_Called : Natural;
Adjust_Called : Natural;
Finalize_Called : Natural;
procedure Check_Counters(Init,Adj,Fin : Natural; Message: String) is
begin
if Init /= Initialize_Called then
Report.Failed("Initialize mismatch " & Message);
end if;
if Adj /= Adjust_Called then
Report.Failed("Adjust mismatch " & Message);
end if;
if Fin /= Finalize_Called then
Report.Failed("Finalize mismatch " & Message);
end if;
end Check_Counters;
procedure Reset_Counters is
begin
Initialize_Called := 0;
Adjust_Called := 0;
Finalize_Called := 0;
end Reset_Counters;
procedure Initialize( AV: in out Simple_Control ) is
begin
Initialize_Called := Initialize_Called +1;
AV.Item := 0;
end Initialize;
procedure Adjust ( AV: in out Simple_Control ) is
begin
Adjust_Called := Adjust_Called +1;
AV.Item := AV.Item +1;
end Adjust;
procedure Finalize ( AV: in out Simple_Control ) is
begin
Finalize_Called := Finalize_Called +1;
AV.Item := AV.Item +1;
end Finalize;
end C760010_1;
---------------------------------------------------------------- C760010_2
with C760010_0.Check_Formal_Tagged;
with C760010_1;
package C760010_2 is
new C760010_0.Check_Formal_Tagged(C760010_1.Simple_Control);
---------------------------------------------------------------------------
with Report;
with C760010_0;
with C760010_1;
with C760010_2;
procedure C760010 is
use type C760010_0.Actions;
procedure Case_Failure(Message: String) is
begin
Report.Failed(Message & " for case "
& C760010_0.Actions'Image(C760010_0.Action) );
end Case_Failure;
procedure Check_Implicit_Initialize is
Item : C760010_2.Embedded_Derived; -- exception here propagates to
Gadget : C760010_2.Embedded_Derived; -- caller
begin
if C760010_0.Action
in C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard
then
Case_Failure("Anticipated exception at implicit init");
end if;
begin
Item := Gadget; -- exception here handled locally
if C760010_0.Action in C760010_0.Adj_Raise_User_Defined
.. C760010_0.Fin_Raise_Standard then
Case_Failure ("Anticipated exception at assignment");
end if;
exception
when Program_Error =>
if C760010_0.Action not in C760010_0.Adj_Raise_User_Defined
.. C760010_0.Fin_Raise_Standard then
Report.Failed("Program_Error in Check_Implicit_Initialize");
end if;
when Tasking_Error =>
Report.Failed("Tasking_Error in Check_Implicit_Initialize");
when C760010_0.User_Defined_Exception =>
Report.Failed("User_Error in Check_Implicit_Initialize");
when others =>
Report.Failed("Wrong exception Check_Implicit_Initialize");
end;
end Check_Implicit_Initialize;
---------------------------------------------------------------------------
Global_Item : C760010_2.Embedded_Derived;
---------------------------------------------------------------------------
procedure Check_Explicit_Initialize is
begin
begin
C760010_2.Initialize( Global_Item );
if C760010_0.Action
in C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard
then
Case_Failure("Anticipated exception at explicit init");
end if;
exception
when Program_Error =>
Report.Failed("Program_Error in Check_Explicit_Initialize");
when Tasking_Error =>
if C760010_0.Action /= C760010_0.Init_Raise_Standard then
Report.Failed("Tasking_Error in Check_Explicit_Initialize");
end if;
when C760010_0.User_Defined_Exception =>
if C760010_0.Action /= C760010_0.Init_Raise_User_Defined then
Report.Failed("User_Error in Check_Explicit_Initialize");
end if;
when others =>
Report.Failed("Wrong exception in Check_Explicit_Initialize");
end;
end Check_Explicit_Initialize;
---------------------------------------------------------------------------
procedure Check_Explicit_Adjust is
begin
begin
C760010_2.Adjust( Global_Item );
if C760010_0.Action
in C760010_0.Adj_Raise_User_Defined..C760010_0.Adj_Raise_Standard
then
Case_Failure("Anticipated exception at explicit Adjust");
end if;
exception
when Program_Error =>
Report.Failed("Program_Error in Check_Explicit_Adjust");
when Tasking_Error =>
if C760010_0.Action /= C760010_0.Adj_Raise_Standard then
Report.Failed("Tasking_Error in Check_Explicit_Adjust");
end if;
when C760010_0.User_Defined_Exception =>
if C760010_0.Action /= C760010_0.Adj_Raise_User_Defined then
Report.Failed("User_Error in Check_Explicit_Adjust");
end if;
when others =>
Report.Failed("Wrong exception in Check_Explicit_Adjust");
end;
end Check_Explicit_Adjust;
---------------------------------------------------------------------------
procedure Check_Explicit_Finalize is
begin
begin
C760010_2.Finalize( Global_Item );
if C760010_0.Action
in C760010_0.Fin_Raise_User_Defined..C760010_0.Fin_Raise_Standard
then
Case_Failure("Anticipated exception at explicit Finalize");
end if;
exception
when Program_Error =>
Report.Failed("Program_Error in Check_Explicit_Finalize");
when Tasking_Error =>
if C760010_0.Action /= C760010_0.Fin_Raise_Standard then
Report.Failed("Tasking_Error in Check_Explicit_Finalize");
end if;
when C760010_0.User_Defined_Exception =>
if C760010_0.Action /= C760010_0.Fin_Raise_User_Defined then
Report.Failed("User_Error in Check_Explicit_Finalize");
end if;
when others =>
Report.Failed("Wrong exception in Check_Explicit_Finalize");
end;
end Check_Explicit_Finalize;
---------------------------------------------------------------------------
begin -- Main test procedure.
Report.Test ("C760010", "Check that explicit calls to finalization " &
"procedures that raise exceptions propagate " &
"the exception raised. Check the utilization " &
"of a controlled type as the actual for a " &
"generic formal tagged private parameter" );
for Act in C760010_0.Actions loop
C760010_1.Reset_Counters;
C760010_0.Action := Act;
begin
Check_Implicit_Initialize;
if Act in
C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard then
Case_Failure("No exception at Check_Implicit_Initialize");
end if;
exception
when Tasking_Error =>
if Act /= C760010_0.Init_Raise_Standard then
Case_Failure("Tasking_Error at Check_Implicit_Initialize");
end if;
when C760010_0.User_Defined_Exception =>
if Act /= C760010_0.Init_Raise_User_Defined then
Case_Failure("User_Error at Check_Implicit_Initialize");
end if;
when Program_Error =>
-- If finalize raises an exception, all other object are finalized
-- first and Program_Error is raised upon leaving the master scope.
-- 7.6.1:14
if Act not in C760010_0.Fin_Raise_User_Defined..
C760010_0.Fin_Raise_Standard then
Case_Failure("Program_Error at Check_Implicit_Initialize");
end if;
when others =>
Case_Failure("Wrong exception at Check_Implicit_Initialize");
end;
Check_Explicit_Initialize;
Check_Explicit_Adjust;
Check_Explicit_Finalize;
C760010_1.Check_Counters(0,0,0, C760010_0.Actions'Image(Act));
end loop;
-- Set to No_Action to avoid exception in finalizing Global_Item
C760010_0.Action := C760010_0.No_Action;
Report.Result;
end C760010;
Go to most recent revision | Compare with Previous | Blame | View Log