-- C761012.A
|
-- C761012.A
|
--
|
--
|
-- Grant of Unlimited Rights
|
-- Grant of Unlimited Rights
|
--
|
--
|
-- The Ada Conformity Assessment Authority (ACAA) holds unlimited
|
-- The Ada Conformity Assessment Authority (ACAA) holds unlimited
|
-- rights in the software and documentation contained herein. Unlimited
|
-- rights in the software and documentation contained herein. Unlimited
|
-- rights are the same as those granted by the U.S. Government for older
|
-- 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
|
-- 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
|
-- 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
|
-- intends to confer upon all recipients unlimited rights equal to those
|
-- held by the ACAA. These rights include rights to use, duplicate,
|
-- held by the ACAA. These rights include rights to use, duplicate,
|
-- release or disclose the released technical data and computer software
|
-- release or disclose the released technical data and computer software
|
-- in whole or in part, in any manner and for any purpose whatsoever, and
|
-- in whole or in part, in any manner and for any purpose whatsoever, and
|
-- to have or permit others to do so.
|
-- to have or permit others to do so.
|
--
|
--
|
-- DISCLAIMER
|
-- DISCLAIMER
|
--
|
--
|
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
|
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
|
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
|
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
|
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
|
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
|
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
|
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
|
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
|
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
|
-- PARTICULAR PURPOSE OF SAID MATERIAL.
|
-- PARTICULAR PURPOSE OF SAID MATERIAL.
|
--*
|
--*
|
--
|
--
|
-- OBJECTIVE:
|
-- OBJECTIVE:
|
-- Check that an anonymous object is finalized with its enclosing master if
|
-- Check that an anonymous object is finalized with its enclosing master if
|
-- a transfer of control or exception occurs prior to performing its normal
|
-- a transfer of control or exception occurs prior to performing its normal
|
-- finalization. (Defect Report 8652/0023, as reflected in
|
-- finalization. (Defect Report 8652/0023, as reflected in
|
-- Technical Corrigendum 1, RM95 7.6.1(13.1/1)).
|
-- Technical Corrigendum 1, RM95 7.6.1(13.1/1)).
|
--
|
--
|
-- CHANGE HISTORY:
|
-- CHANGE HISTORY:
|
-- 29 JAN 2001 PHL Initial version.
|
-- 29 JAN 2001 PHL Initial version.
|
-- 5 DEC 2001 RLB Reformatted for ACATS.
|
-- 5 DEC 2001 RLB Reformatted for ACATS.
|
--
|
--
|
--!
|
--!
|
with Ada.Finalization;
|
with Ada.Finalization;
|
use Ada.Finalization;
|
use Ada.Finalization;
|
package C761012_0 is
|
package C761012_0 is
|
|
|
type Ctrl (D : Boolean) is new Controlled with
|
type Ctrl (D : Boolean) is new Controlled with
|
record
|
record
|
case D is
|
case D is
|
when False =>
|
when False =>
|
C1 : Integer;
|
C1 : Integer;
|
when True =>
|
when True =>
|
C2 : Float;
|
C2 : Float;
|
end case;
|
end case;
|
end record;
|
end record;
|
|
|
function Create return Ctrl;
|
function Create return Ctrl;
|
procedure Finalize (Obj : in out Ctrl);
|
procedure Finalize (Obj : in out Ctrl);
|
function Finalize_Was_Called return Boolean;
|
function Finalize_Was_Called return Boolean;
|
|
|
end C761012_0;
|
end C761012_0;
|
|
|
with Report;
|
with Report;
|
use Report;
|
use Report;
|
package body C761012_0 is
|
package body C761012_0 is
|
|
|
Finalization_Flag : Boolean := False;
|
Finalization_Flag : Boolean := False;
|
|
|
function Create return Ctrl is
|
function Create return Ctrl is
|
Obj : Ctrl (Ident_Bool (True));
|
Obj : Ctrl (Ident_Bool (True));
|
begin
|
begin
|
Obj.C2 := 3.0;
|
Obj.C2 := 3.0;
|
return Obj;
|
return Obj;
|
end Create;
|
end Create;
|
|
|
procedure Finalize (Obj : in out Ctrl) is
|
procedure Finalize (Obj : in out Ctrl) is
|
begin
|
begin
|
Finalization_Flag := True;
|
Finalization_Flag := True;
|
end Finalize;
|
end Finalize;
|
|
|
function Finalize_Was_Called return Boolean is
|
function Finalize_Was_Called return Boolean is
|
begin
|
begin
|
if Finalization_Flag then
|
if Finalization_Flag then
|
Finalization_Flag := False;
|
Finalization_Flag := False;
|
return True;
|
return True;
|
else
|
else
|
return False;
|
return False;
|
end if;
|
end if;
|
end Finalize_Was_Called;
|
end Finalize_Was_Called;
|
|
|
end C761012_0;
|
end C761012_0;
|
|
|
with Ada.Exceptions;
|
with Ada.Exceptions;
|
use Ada.Exceptions;
|
use Ada.Exceptions;
|
with C761012_0;
|
with C761012_0;
|
use C761012_0;
|
use C761012_0;
|
with Report;
|
with Report;
|
use Report;
|
use Report;
|
procedure C761012 is
|
procedure C761012 is
|
begin
|
begin
|
Test ("C761012",
|
Test ("C761012",
|
"Check that an anonymous object is finalized with its enclosing " &
|
"Check that an anonymous object is finalized with its enclosing " &
|
"master if a transfer of control or exception occurs prior to " &
|
"master if a transfer of control or exception occurs prior to " &
|
"performing its normal finalization");
|
"performing its normal finalization");
|
|
|
Excep:
|
Excep:
|
begin
|
begin
|
|
|
declare
|
declare
|
I : Integer := Create.C1; -- Raises Constraint_Error
|
I : Integer := Create.C1; -- Raises Constraint_Error
|
begin
|
begin
|
Failed
|
Failed
|
("Improper component selection did not raise Constraint_Error, I =" &
|
("Improper component selection did not raise Constraint_Error, I =" &
|
Integer'Image (I));
|
Integer'Image (I));
|
exception
|
exception
|
when Constraint_Error =>
|
when Constraint_Error =>
|
Failed ("Constraint_Error caught by the wrong handler");
|
Failed ("Constraint_Error caught by the wrong handler");
|
end;
|
end;
|
|
|
Failed ("Transfer of control did not happen correctly");
|
Failed ("Transfer of control did not happen correctly");
|
|
|
exception
|
exception
|
when Constraint_Error =>
|
when Constraint_Error =>
|
if not Finalize_Was_Called then
|
if not Finalize_Was_Called then
|
Failed ("Finalize wasn't called when the master was left " &
|
Failed ("Finalize wasn't called when the master was left " &
|
"- Constraint_Error");
|
"- Constraint_Error");
|
end if;
|
end if;
|
when E: others =>
|
when E: others =>
|
Failed ("Exception " & Exception_Name (E) &
|
Failed ("Exception " & Exception_Name (E) &
|
" raised - " & Exception_Information (E));
|
" raised - " & Exception_Information (E));
|
end Excep;
|
end Excep;
|
|
|
Transfer:
|
Transfer:
|
declare
|
declare
|
Finalize_Was_Called_Before_Leaving_Exit : Boolean;
|
Finalize_Was_Called_Before_Leaving_Exit : Boolean;
|
begin
|
begin
|
|
|
begin
|
begin
|
loop
|
loop
|
exit when Create.C2 = 3.0;
|
exit when Create.C2 = 3.0;
|
end loop;
|
end loop;
|
Finalize_Was_Called_Before_Leaving_Exit := Finalize_Was_Called;
|
Finalize_Was_Called_Before_Leaving_Exit := Finalize_Was_Called;
|
if Finalize_Was_Called_Before_Leaving_Exit then
|
if Finalize_Was_Called_Before_Leaving_Exit then
|
Comment ("Finalize called before the transfer of control");
|
Comment ("Finalize called before the transfer of control");
|
end if;
|
end if;
|
end;
|
end;
|
|
|
if not Finalize_Was_Called and then
|
if not Finalize_Was_Called and then
|
not Finalize_Was_Called_Before_Leaving_Exit then
|
not Finalize_Was_Called_Before_Leaving_Exit then
|
Failed ("Finalize wasn't called when the master was left " &
|
Failed ("Finalize wasn't called when the master was left " &
|
"- transfer of control");
|
"- transfer of control");
|
end if;
|
end if;
|
end Transfer;
|
end Transfer;
|
|
|
Result;
|
Result;
|
end C761012;
|
end C761012;
|
|
|
|
|