aboutsummaryrefslogtreecommitdiff
path: root/gcc/testsuite/ada/acats/tests/c7/c761011.a
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c7/c761011.a')
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c761011.a410
1 files changed, 0 insertions, 410 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c7/c761011.a b/gcc/testsuite/ada/acats/tests/c7/c761011.a
deleted file mode 100644
index 1d447c755a9..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c761011.a
+++ /dev/null
@@ -1,410 +0,0 @@
--- C761011.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 if a Finalize propagates an exception, other Finalizes due
--- to be performed are performed.
--- Case 1: A Finalize invoked due to the end of execution of
--- a master. (Defect Report 8652/0023, as reflected in Technical
--- Corrigendum 1).
--- Case 2: A Finalize invoked due to finalization of an anonymous
--- object. (Defect Report 8652/0023, as reflected in Technical
--- Corrigendum 1).
--- Case 3: A Finalize invoked due to the transfer of control
--- due to an exit statement.
--- Case 4: A Finalize invoked due to the transfer of control
--- due to a goto statement.
--- Case 5: A Finalize invoked due to the transfer of control
--- due to a return statement.
--- Case 6: A Finalize invoked due to the transfer of control
--- due to raises an exception.
---
---
--- CHANGE HISTORY:
--- 29 JAN 2001 PHL Initial version
--- 15 MAR 2001 RLB Readied for release; added optimization blockers.
--- Added test cases for paragraphs 18 and 19 of the
--- standard (the previous tests were withdrawn).
---
---!
-with Ada.Finalization;
-use Ada.Finalization;
-package C761011_0 is
-
- type Ctrl (D : Boolean) is new Ada.Finalization.Controlled with
- record
- Finalized : Boolean := False;
- case D is
- when False =>
- C1 : Integer;
- when True =>
- C2 : Float;
- end case;
- end record;
-
- function Create (Id : Integer) return Ctrl;
- procedure Finalize (Obj : in out Ctrl);
- function Was_Finalized (Id : Integer) return Boolean;
- procedure Use_It (Obj : in Ctrl);
- -- Use Obj to prevent optimization.
-
-end C761011_0;
-
-with Report;
-use Report;
-package body C761011_0 is
-
- User_Error : exception;
-
- Finalize_Called : array (0 .. 50) of Boolean := (others => False);
-
- function Create (Id : Integer) return Ctrl is
- Obj : Ctrl (Boolean'Val (Id mod Ident_Int (2)));
- begin
- case Obj.D is
- when False =>
- Obj.C1 := Ident_Int (Id);
- when True =>
- Obj.C2 := Float (Ident_Int (Id + Ident_Int (Id)));
- end case;
- return Obj;
- end Create;
-
- procedure Finalize (Obj : in out Ctrl) is
- begin
- if not Obj.Finalized then
- Obj.Finalized := True;
- if Obj.D then
- if Integer (Obj.C2 / 2.0) mod Ident_Int (10) =
- Ident_Int (3) then
- raise User_Error;
- else
- Finalize_Called (Integer (Obj.C2) / 2) := True;
- end if;
- else
- if Obj.C1 mod Ident_Int (10) = Ident_Int (0) then
- raise Tasking_Error;
- else
- Finalize_Called (Obj.C1) := True;
- end if;
- end if;
- end if;
- end Finalize;
-
- function Was_Finalized (Id : Integer) return Boolean is
- begin
- return Finalize_Called (Ident_Int (Id));
- end Was_Finalized;
-
- procedure Use_It (Obj : in Ctrl) is
- -- Use Obj to prevent optimization.
- begin
- case Obj.D is
- when True =>
- if not Equal (Boolean'Pos(Obj.Finalized),
- Boolean'Pos(Obj.Finalized)) then
- Failed ("Identity check - 1");
- end if;
- when False =>
- if not Equal (Obj.C1, Obj.C1) then
- Failed ("Identity check - 2");
- end if;
- end case;
- end Use_It;
-
-end C761011_0;
-
-with Ada.Exceptions;
-use Ada.Exceptions;
-with Ada.Finalization;
-with C761011_0;
-use C761011_0;
-with Report;
-use Report;
-procedure C761011 is
-begin
- Test
- ("C761011",
- " Check that if a finalize propagates an exception, other finalizes " &
- "due to be performed are performed");
-
- Normal: -- Case 1
- begin
- declare
- Obj1 : Ctrl := Create (Ident_Int (1));
- Obj2 : constant Ctrl := (Ada.Finalization.Controlled with
- D => False,
- Finalized => Ident_Bool (False),
- C1 => Ident_Int (2));
- Obj3 : Ctrl :=
- (Ada.Finalization.Controlled with
- D => True,
- Finalized => Ident_Bool (False),
- C2 => 2.0 * Float (Ident_Int
- (3))); -- Finalization: User_Error
- Obj4 : Ctrl := Create (Ident_Int (4));
- begin
- Comment ("Finalization of normal object");
- Use_It (Obj1); -- Prevent optimization of Objects.
- Use_It (Obj2); -- (Critical if AI-147 is adopted.)
- Use_It (Obj3);
- Use_It (Obj4);
- end;
- Failed ("No exception raised by finalization of normal object");
- exception
- when Program_Error =>
- if not Was_Finalized (Ident_Int (1)) or
- not Was_Finalized (Ident_Int (2)) or
- not Was_Finalized (Ident_Int (4)) then
- Failed ("Missing finalizations - 1");
- end if;
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Message (E) & " - 1");
- end Normal;
-
- Anon: -- Case 2
- begin
- declare
- Obj1 : Ctrl := (Ada.Finalization.Controlled with
- D => True,
- Finalized => Ident_Bool (False),
- C2 => 2.0 * Float (Ident_Int (5)));
- Obj2 : constant Ctrl := (Ada.Finalization.Controlled with
- D => False,
- Finalized => Ident_Bool (False),
- C1 => Ident_Int (6));
- Obj3 : Ctrl := (Ada.Finalization.Controlled with
- D => True,
- Finalized => Ident_Bool (False),
- C2 => 2.0 * Float (Ident_Int (7)));
- Obj4 : Ctrl := Create (Ident_Int (8));
- begin
- Comment ("Finalization of anonymous object");
-
- -- The finalization of the anonymous object below will raise
- -- Tasking_Error.
- if Create (Ident_Int (10)).C1 /= Ident_Int (10) then
- Failed ("Incorrect construction of an anonymous object");
- end if;
- Failed ("Anonymous object not finalized at the end of the " &
- "enclosing statement");
- Use_It (Obj1); -- Prevent optimization of Objects.
- Use_It (Obj2); -- (Critical if AI-147 is adopted.)
- Use_It (Obj3);
- Use_It (Obj4);
- end;
- Failed ("No exception raised by finalization of an anonymous " &
- "object of a function");
- exception
- when Program_Error =>
- if not Was_Finalized (Ident_Int (5)) or
- not Was_Finalized (Ident_Int (6)) or
- not Was_Finalized (Ident_Int (7)) or
- not Was_Finalized (Ident_Int (8)) then
- Failed ("Missing finalizations - 2");
- end if;
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Message (E) & " - 2");
- end Anon;
-
- An_Exit: -- Case 3
- begin
- for Counter in 1 .. 4 loop
- declare
- Obj1 : Ctrl := Create (Ident_Int (11));
- Obj2 : constant Ctrl := (Ada.Finalization.Controlled with
- D => False,
- Finalized => Ident_Bool (False),
- C1 => Ident_Int (12));
- Obj3 : Ctrl :=
- (Ada.Finalization.Controlled with
- D => True,
- Finalized => Ident_Bool (False),
- C2 => 2.0 * Float (
- Ident_Int(13))); -- Finalization: User_Error
- Obj4 : Ctrl := Create (Ident_Int (14));
- begin
- Comment ("Finalization because of exit of loop");
-
- Use_It (Obj1); -- Prevent optimization of Objects.
- Use_It (Obj2); -- (Critical if AI-147 is adopted.)
- Use_It (Obj3);
- Use_It (Obj4);
-
- exit when not Ident_Bool (Obj2.D);
-
- Failed ("Exit not taken");
- end;
- end loop;
- Failed ("No exception raised by finalization on exit");
- exception
- when Program_Error =>
- if not Was_Finalized (Ident_Int (11)) or
- not Was_Finalized (Ident_Int (12)) or
- not Was_Finalized (Ident_Int (14)) then
- Failed ("Missing finalizations - 3");
- end if;
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Message (E) & " - 3");
- end An_Exit;
-
- A_Goto: -- Case 4
- begin
- declare
- Obj1 : Ctrl := Create (Ident_Int (15));
- Obj2 : constant Ctrl := (Ada.Finalization.Controlled with
- D => False,
- Finalized => Ident_Bool (False),
- C1 => Ident_Int (0));
- -- Finalization: Tasking_Error
- Obj3 : Ctrl := Create (Ident_Int (16));
- Obj4 : Ctrl := (Ada.Finalization.Controlled with
- D => True,
- Finalized => Ident_Bool (False),
- C2 => 2.0 * Float (Ident_Int (17)));
- begin
- Comment ("Finalization because of goto statement");
-
- Use_It (Obj1); -- Prevent optimization of Objects.
- Use_It (Obj2); -- (Critical if AI-147 is adopted.)
- Use_It (Obj3);
- Use_It (Obj4);
-
- if Ident_Bool (Obj4.D) then
- goto Continue;
- end if;
-
- Failed ("Goto not taken");
- end;
- <<Continue>>
- Failed ("No exception raised by finalization on goto");
- exception
- when Program_Error =>
- if not Was_Finalized (Ident_Int (15)) or
- not Was_Finalized (Ident_Int (16)) or
- not Was_Finalized (Ident_Int (17)) then
- Failed ("Missing finalizations - 4");
- end if;
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Message (E) & " - 4");
- end A_Goto;
-
- A_Return: -- Case 5
- declare
- procedure Do_Something is
- Obj1 : Ctrl := Create (Ident_Int (18));
- Obj2 : Ctrl := (Ada.Finalization.Controlled with
- D => True,
- Finalized => Ident_Bool (False),
- C2 => 2.0 * Float (Ident_Int (19)));
- Obj3 : constant Ctrl := (Ada.Finalization.Controlled with
- D => False,
- Finalized => Ident_Bool (False),
- C1 => Ident_Int (20));
- -- Finalization: Tasking_Error
- begin
- Comment ("Finalization because of return statement");
-
- Use_It (Obj1); -- Prevent optimization of Objects.
- Use_It (Obj2); -- (Critical if AI-147 is adopted.)
- Use_It (Obj3);
-
- if not Ident_Bool (Obj3.D) then
- return;
- end if;
-
- Failed ("Return not taken");
- end Do_Something;
- begin
- Do_Something;
- Failed ("No exception raised by finalization on return statement");
- exception
- when Program_Error =>
- if not Was_Finalized (Ident_Int (18)) or
- not Was_Finalized (Ident_Int (19)) then
- Failed ("Missing finalizations - 5");
- end if;
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Message (E) & " - 5");
- end A_Return;
-
- Except: -- Case 6
- declare
- Funky_Error : exception;
-
- procedure Do_Something is
- Obj1 : Ctrl :=
- (Ada.Finalization.Controlled with
- D => True,
- Finalized => Ident_Bool (False),
- C2 => 2.0 * Float (
- Ident_Int(23))); -- Finalization: User_Error
- Obj2 : Ctrl := Create (Ident_Int (24));
- Obj3 : Ctrl := Create (Ident_Int (25));
- Obj4 : constant Ctrl := (Ada.Finalization.Controlled with
- D => False,
- Finalized => Ident_Bool (False),
- C1 => Ident_Int (26));
- begin
- Comment ("Finalization because of exception propagation");
-
- Use_It (Obj1); -- Prevent optimization of Objects.
- Use_It (Obj2); -- (Critical if AI-147 is adopted.)
- Use_It (Obj3);
- Use_It (Obj4);
-
- if not Ident_Bool (Obj4.D) then
- raise Funky_Error;
- end if;
-
- Failed ("Exception not raised");
- end Do_Something;
- begin
- Do_Something;
- Failed ("No exception raised by finalization on exception " &
- "propagation");
- exception
- when Program_Error =>
- if not Was_Finalized (Ident_Int (24)) or
- not Was_Finalized (Ident_Int (25)) or
- not Was_Finalized (Ident_Int (26)) then
- Failed ("Missing finalizations - 6");
- end if;
- when Funky_Error =>
- Failed ("Wrong exception propagated");
- -- Should be Program_Error (7.6.1(19)).
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Message (E) & " - 6");
- end Except;
-
- Result;
-end C761011;
-
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-08 20:39:33 +0000