-- C760011.A
|
-- C760011.A
|
--
|
--
|
-- Grant of Unlimited Rights
|
-- Grant of Unlimited Rights
|
--
|
--
|
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
|
-- 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
|
-- 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 in the software and documentation contained herein.
|
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
|
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
|
-- this public release, the Government intends to confer upon all
|
-- this public release, the Government intends to confer upon all
|
-- recipients unlimited rights equal to those held by the Government.
|
-- recipients unlimited rights equal to those held by the Government.
|
-- These rights include rights to use, duplicate, release or disclose the
|
-- These rights include rights to use, duplicate, release or disclose the
|
-- released technical data and computer software in whole or in part, in
|
-- 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
|
-- any manner and for any purpose whatsoever, and to have or permit others
|
-- to do so.
|
-- 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 the anonymous objects of a controlled type associated with
|
-- Check that the anonymous objects of a controlled type associated with
|
-- function results and aggregates are finalized no later than the
|
-- function results and aggregates are finalized no later than the
|
-- end of the innermost enclosing declarative_item or statement. Also
|
-- end of the innermost enclosing declarative_item or statement. Also
|
-- check this for function calls and aggregates of a noncontrolled type
|
-- check this for function calls and aggregates of a noncontrolled type
|
-- with controlled components.
|
-- with controlled components.
|
--
|
--
|
-- TEST DESCRIPTION:
|
-- TEST DESCRIPTION:
|
-- This test defines a controlled type with a discriminant, the
|
-- This test defines a controlled type with a discriminant, the
|
-- discriminant is use as an index into a global table to indicate that
|
-- discriminant is use as an index into a global table to indicate that
|
-- the object has been finalized. The controlled type is used as the
|
-- the object has been finalized. The controlled type is used as the
|
-- component of a non-controlled type, and the non-controlled type is
|
-- component of a non-controlled type, and the non-controlled type is
|
-- used for the same set of tests. Following is a table of the tests
|
-- used for the same set of tests. Following is a table of the tests
|
-- performed and their associated tag character.
|
-- performed and their associated tag character.
|
--
|
--
|
-- 7.6(21) allows for the optimizations that remove these temporary
|
-- 7.6(21) allows for the optimizations that remove these temporary
|
-- objects from ever existing. As such this test checks that in the
|
-- objects from ever existing. As such this test checks that in the
|
-- case the object was initialized (the only access we have to
|
-- case the object was initialized (the only access we have to
|
-- determining if it ever existed) it must subsequently be finalized.
|
-- determining if it ever existed) it must subsequently be finalized.
|
--
|
--
|
-- CASE TABLE:
|
-- CASE TABLE:
|
-- A - aggregate test, controlled
|
-- A - aggregate test, controlled
|
-- B - aggregate test, controlled
|
-- B - aggregate test, controlled
|
-- C - aggregate test, non_controlled
|
-- C - aggregate test, non_controlled
|
-- D - function test, controlled
|
-- D - function test, controlled
|
-- E - function test, non_controlled
|
-- E - function test, non_controlled
|
-- F - formal parameter function test, controlled
|
-- F - formal parameter function test, controlled
|
-- G - formal parameter aggregate test, controlled
|
-- G - formal parameter aggregate test, controlled
|
-- H - formal parameter function test, non_controlled
|
-- H - formal parameter function test, non_controlled
|
-- I - formal parameter aggregate test, non_controlled
|
-- I - formal parameter aggregate test, non_controlled
|
--
|
--
|
-- X - scratch object, not consequential to the objective
|
-- X - scratch object, not consequential to the objective
|
-- Y - scratch object, not consequential to the objective
|
-- Y - scratch object, not consequential to the objective
|
-- Z - scratch object, not consequential to the objective
|
-- Z - scratch object, not consequential to the objective
|
--
|
--
|
--
|
--
|
-- CHANGE HISTORY:
|
-- CHANGE HISTORY:
|
-- 22 MAY 95 SAIC Initial version
|
-- 22 MAY 95 SAIC Initial version
|
-- 24 APR 96 SAIC Minor doc fixes, visibility patch
|
-- 24 APR 96 SAIC Minor doc fixes, visibility patch
|
-- 14 NOV 96 SAIC Revised for release 2.1
|
-- 14 NOV 96 SAIC Revised for release 2.1
|
--
|
--
|
--!
|
--!
|
|
|
------------------------------------------------------------------- C760011_0
|
------------------------------------------------------------------- C760011_0
|
|
|
with Ada.Finalization;
|
with Ada.Finalization;
|
package C760011_0 is
|
package C760011_0 is
|
type Tracking_Array is array(Character range 'A'..'Z') of Boolean;
|
type Tracking_Array is array(Character range 'A'..'Z') of Boolean;
|
|
|
Initialized : Tracking_Array := (others => False);
|
Initialized : Tracking_Array := (others => False);
|
Finalized : Tracking_Array := (others => False);
|
Finalized : Tracking_Array := (others => False);
|
|
|
type Controlled_Type(Tag : Character) is
|
type Controlled_Type(Tag : Character) is
|
new Ada.Finalization.Controlled with record
|
new Ada.Finalization.Controlled with record
|
TC_Component : String(1..4) := "ACVC";
|
TC_Component : String(1..4) := "ACVC";
|
end record;
|
end record;
|
procedure Initialize( It: in out Controlled_Type );
|
procedure Initialize( It: in out Controlled_Type );
|
procedure Finalize ( It: in out Controlled_Type );
|
procedure Finalize ( It: in out Controlled_Type );
|
function Create(With_Tag: Character) return Controlled_Type;
|
function Create(With_Tag: Character) return Controlled_Type;
|
|
|
type Non_Controlled(Tag : Character := 'Y') is record
|
type Non_Controlled(Tag : Character := 'Y') is record
|
Controlled_Component : Controlled_Type(Tag);
|
Controlled_Component : Controlled_Type(Tag);
|
end record;
|
end record;
|
procedure Initialize( It: in out Non_Controlled );
|
procedure Initialize( It: in out Non_Controlled );
|
procedure Finalize ( It: in out Non_Controlled );
|
procedure Finalize ( It: in out Non_Controlled );
|
function Create(With_Tag: Character) return Non_Controlled;
|
function Create(With_Tag: Character) return Non_Controlled;
|
|
|
Under_Debug : constant Boolean := False; -- construction lines
|
Under_Debug : constant Boolean := False; -- construction lines
|
|
|
end C760011_0;
|
end C760011_0;
|
|
|
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
|
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
|
|
|
with Report;
|
with Report;
|
package body C760011_0 is
|
package body C760011_0 is
|
|
|
procedure Initialize( It: in out Controlled_Type ) is
|
procedure Initialize( It: in out Controlled_Type ) is
|
begin
|
begin
|
It.TC_Component := (others => It.Tag);
|
It.TC_Component := (others => It.Tag);
|
if It.Tag in Tracking_Array'Range then
|
if It.Tag in Tracking_Array'Range then
|
Initialized(It.Tag) := True;
|
Initialized(It.Tag) := True;
|
end if;
|
end if;
|
if Under_Debug then
|
if Under_Debug then
|
Report.Comment("Initializing Tag: " & It.Tag );
|
Report.Comment("Initializing Tag: " & It.Tag );
|
end if;
|
end if;
|
end Initialize;
|
end Initialize;
|
|
|
procedure Finalize( It: in out Controlled_Type ) is
|
procedure Finalize( It: in out Controlled_Type ) is
|
begin
|
begin
|
if Under_Debug then
|
if Under_Debug then
|
Report.Comment("Finalizing for Tag: " & It.Tag );
|
Report.Comment("Finalizing for Tag: " & It.Tag );
|
end if;
|
end if;
|
if It.Tag in Finalized'Range then
|
if It.Tag in Finalized'Range then
|
Finalized(It.Tag) := True;
|
Finalized(It.Tag) := True;
|
end if;
|
end if;
|
end Finalize;
|
end Finalize;
|
|
|
function Create(With_Tag: Character) return Controlled_Type is
|
function Create(With_Tag: Character) return Controlled_Type is
|
begin
|
begin
|
return Controlled_Type'(Ada.Finalization.Controlled
|
return Controlled_Type'(Ada.Finalization.Controlled
|
with Tag => With_Tag,
|
with Tag => With_Tag,
|
TC_Component => "*CON" );
|
TC_Component => "*CON" );
|
end Create;
|
end Create;
|
|
|
procedure Initialize( It: in out Non_Controlled ) is
|
procedure Initialize( It: in out Non_Controlled ) is
|
begin
|
begin
|
Report.Failed("Called Initialize for Non_Controlled");
|
Report.Failed("Called Initialize for Non_Controlled");
|
end Initialize;
|
end Initialize;
|
|
|
procedure Finalize( It: in out Non_Controlled ) is
|
procedure Finalize( It: in out Non_Controlled ) is
|
begin
|
begin
|
Report.Failed("Called Finalize for Non_Controlled");
|
Report.Failed("Called Finalize for Non_Controlled");
|
end Finalize;
|
end Finalize;
|
|
|
function Create(With_Tag: Character) return Non_Controlled is
|
function Create(With_Tag: Character) return Non_Controlled is
|
begin
|
begin
|
return Non_Controlled'(Tag => With_Tag, Controlled_Component => (
|
return Non_Controlled'(Tag => With_Tag, Controlled_Component => (
|
Ada.Finalization.Controlled
|
Ada.Finalization.Controlled
|
with Tag => With_Tag,
|
with Tag => With_Tag,
|
TC_Component => "#NON" ) );
|
TC_Component => "#NON" ) );
|
end Create;
|
end Create;
|
|
|
end C760011_0;
|
end C760011_0;
|
|
|
--------------------------------------------------------------------- C760011
|
--------------------------------------------------------------------- C760011
|
|
|
with Report;
|
with Report;
|
with TCTouch;
|
with TCTouch;
|
with C760011_0;
|
with C760011_0;
|
with Ada.Finalization; -- needed to be able to create extension aggregates
|
with Ada.Finalization; -- needed to be able to create extension aggregates
|
procedure C760011 is
|
procedure C760011 is
|
|
|
use type C760011_0.Controlled_Type;
|
use type C760011_0.Controlled_Type;
|
use type C760011_0.Controlled_Type'Class;
|
use type C760011_0.Controlled_Type'Class;
|
use type C760011_0.Non_Controlled;
|
use type C760011_0.Non_Controlled;
|
|
|
subtype AFC is Ada.Finalization.Controlled;
|
subtype AFC is Ada.Finalization.Controlled;
|
|
|
procedure Check_Result( Tag : Character; Message : String ) is
|
procedure Check_Result( Tag : Character; Message : String ) is
|
-- make allowance for 7.6(21) optimizations
|
-- make allowance for 7.6(21) optimizations
|
begin
|
begin
|
if C760011_0.Initialized(Tag) then
|
if C760011_0.Initialized(Tag) then
|
TCTouch.Assert(C760011_0.Finalized(Tag),Message);
|
TCTouch.Assert(C760011_0.Finalized(Tag),Message);
|
elsif C760011_0.Under_Debug then
|
elsif C760011_0.Under_Debug then
|
Report.Comment("Optimized away: " & Tag );
|
Report.Comment("Optimized away: " & Tag );
|
end if;
|
end if;
|
end Check_Result;
|
end Check_Result;
|
|
|
procedure Subtest_1 is
|
procedure Subtest_1 is
|
|
|
|
|
procedure Subtest_1_Local_1 is
|
procedure Subtest_1_Local_1 is
|
An_Object : C760011_0.Controlled_Type'Class
|
An_Object : C760011_0.Controlled_Type'Class
|
:= C760011_0.Controlled_Type'(AFC with 'X', "ONE*");
|
:= C760011_0.Controlled_Type'(AFC with 'X', "ONE*");
|
-- initialize An_Object
|
-- initialize An_Object
|
begin
|
begin
|
if C760011_0.Controlled_Type(An_Object)
|
if C760011_0.Controlled_Type(An_Object)
|
= C760011_0.Controlled_Type'(AFC with 'A', "ONE*") then
|
= C760011_0.Controlled_Type'(AFC with 'A', "ONE*") then
|
Report.Failed("Comparison bad"); -- A = X !!!
|
Report.Failed("Comparison bad"); -- A = X !!!
|
end if;
|
end if;
|
end Subtest_1_Local_1;
|
end Subtest_1_Local_1;
|
-- An_Object must be Finalized by this point.
|
-- An_Object must be Finalized by this point.
|
|
|
procedure Subtest_1_Local_2 is
|
procedure Subtest_1_Local_2 is
|
An_Object : C760011_0.Controlled_Type('B');
|
An_Object : C760011_0.Controlled_Type('B');
|
begin
|
begin
|
An_Object := (AFC with 'B', "TWO!" );
|
An_Object := (AFC with 'B', "TWO!" );
|
if Report.Ident_Char(An_Object.Tag) /= 'B' then
|
if Report.Ident_Char(An_Object.Tag) /= 'B' then
|
Report.Failed("Subtest_1_Local_2 Optimization Foil: Bad Data!");
|
Report.Failed("Subtest_1_Local_2 Optimization Foil: Bad Data!");
|
end if;
|
end if;
|
exception
|
exception
|
when others => Report.Failed("Bad controlled assignment");
|
when others => Report.Failed("Bad controlled assignment");
|
end Subtest_1_Local_2;
|
end Subtest_1_Local_2;
|
-- An_Object must be Finalized by this point.
|
-- An_Object must be Finalized by this point.
|
|
|
procedure Subtest_1_Local_3 is
|
procedure Subtest_1_Local_3 is
|
An_Object : C760011_0.Non_Controlled('C');
|
An_Object : C760011_0.Non_Controlled('C');
|
begin
|
begin
|
TCTouch.Assert_Not(C760011_0.Finalized('C'),
|
TCTouch.Assert_Not(C760011_0.Finalized('C'),
|
"Non_Controlled declaration C");
|
"Non_Controlled declaration C");
|
An_Object := C760011_0.Non_Controlled'('C', Controlled_Component
|
An_Object := C760011_0.Non_Controlled'('C', Controlled_Component
|
=> (AFC with 'C', "TEE!"));
|
=> (AFC with 'C', "TEE!"));
|
if Report.Ident_Char(An_Object.Tag) /= 'C' then
|
if Report.Ident_Char(An_Object.Tag) /= 'C' then
|
Report.Failed("Subtest_1_Local_3 Optimization Foil: Bad Data!");
|
Report.Failed("Subtest_1_Local_3 Optimization Foil: Bad Data!");
|
end if;
|
end if;
|
end Subtest_1_Local_3;
|
end Subtest_1_Local_3;
|
-- Only controlled components of An_Object must be finalized; it is an
|
-- Only controlled components of An_Object must be finalized; it is an
|
-- error to call Finalize for An_Object
|
-- error to call Finalize for An_Object
|
|
|
begin
|
begin
|
Subtest_1_Local_1;
|
Subtest_1_Local_1;
|
Check_Result( 'A', "Aggregate in subprogram 1" );
|
Check_Result( 'A', "Aggregate in subprogram 1" );
|
|
|
Subtest_1_Local_2;
|
Subtest_1_Local_2;
|
Check_Result( 'B', "Aggregate in subprogram 2" );
|
Check_Result( 'B', "Aggregate in subprogram 2" );
|
|
|
Subtest_1_Local_3;
|
Subtest_1_Local_3;
|
Check_Result( 'C', "Embedded aggregate in subprogram 3" );
|
Check_Result( 'C', "Embedded aggregate in subprogram 3" );
|
end Subtest_1;
|
end Subtest_1;
|
|
|
|
|
procedure Subtest_2 is
|
procedure Subtest_2 is
|
-- using 'Z' for both evades order issues
|
-- using 'Z' for both evades order issues
|
Con_Object : C760011_0.Controlled_Type('Z');
|
Con_Object : C760011_0.Controlled_Type('Z');
|
Non_Object : C760011_0.Non_Controlled('Z');
|
Non_Object : C760011_0.Non_Controlled('Z');
|
begin
|
begin
|
if Report.Ident_Bool( Con_Object = C760011_0.Create('D') ) then
|
if Report.Ident_Bool( Con_Object = C760011_0.Create('D') ) then
|
Report.Failed("Con_Object catastrophe");
|
Report.Failed("Con_Object catastrophe");
|
end if;
|
end if;
|
-- Controlled function result should be finalized by now
|
-- Controlled function result should be finalized by now
|
Check_Result( 'D', "Function Result" );
|
Check_Result( 'D', "Function Result" );
|
|
|
if Report.Ident_Bool( Non_Object = C760011_0.Create('E') ) then
|
if Report.Ident_Bool( Non_Object = C760011_0.Create('E') ) then
|
Report.Failed("Non_Object catastrophe");
|
Report.Failed("Non_Object catastrophe");
|
end if;
|
end if;
|
-- Controlled component of function result should be finalized by now
|
-- Controlled component of function result should be finalized by now
|
Check_Result( 'E', "Function Result" );
|
Check_Result( 'E', "Function Result" );
|
end Subtest_2;
|
end Subtest_2;
|
|
|
|
|
procedure Subtest_3(Con : in C760011_0.Controlled_Type) is
|
procedure Subtest_3(Con : in C760011_0.Controlled_Type) is
|
begin
|
begin
|
if Con.Tag not in 'F'..'G' then
|
if Con.Tag not in 'F'..'G' then
|
Report.Failed("Bad value passed to subtest 3 " & Con.Tag & ' '
|
Report.Failed("Bad value passed to subtest 3 " & Con.Tag & ' '
|
& Report.Ident_Str(Con.TC_Component));
|
& Report.Ident_Str(Con.TC_Component));
|
end if;
|
end if;
|
end Subtest_3;
|
end Subtest_3;
|
|
|
|
|
procedure Subtest_4(Non : in C760011_0.Non_Controlled) is
|
procedure Subtest_4(Non : in C760011_0.Non_Controlled) is
|
begin
|
begin
|
if Non.Tag not in 'H'..'I' then
|
if Non.Tag not in 'H'..'I' then
|
Report.Failed("Bad value passed to subtest 4 "
|
Report.Failed("Bad value passed to subtest 4 "
|
& Non.Tag & ' '
|
& Non.Tag & ' '
|
& Report.Ident_Str(Non.Controlled_Component.TC_Component));
|
& Report.Ident_Str(Non.Controlled_Component.TC_Component));
|
end if;
|
end if;
|
end Subtest_4;
|
end Subtest_4;
|
|
|
|
|
begin -- Main test procedure.
|
begin -- Main test procedure.
|
|
|
Report.Test ("C760011", "Check that anonymous objects of controlled " &
|
Report.Test ("C760011", "Check that anonymous objects of controlled " &
|
"types or types containing controlled types " &
|
"types or types containing controlled types " &
|
"are finalized no later than the end of the " &
|
"are finalized no later than the end of the " &
|
"innermost enclosing declarative_item or " &
|
"innermost enclosing declarative_item or " &
|
"statement" );
|
"statement" );
|
|
|
Subtest_1;
|
Subtest_1;
|
|
|
Subtest_2;
|
Subtest_2;
|
|
|
Subtest_3(C760011_0.Create('F'));
|
Subtest_3(C760011_0.Create('F'));
|
Check_Result( 'F', "Function as formal F" );
|
Check_Result( 'F', "Function as formal F" );
|
|
|
Subtest_3(C760011_0.Controlled_Type'(AFC with 'G',"GIGI"));
|
Subtest_3(C760011_0.Controlled_Type'(AFC with 'G',"GIGI"));
|
Check_Result( 'G', "Aggregate as formal G" );
|
Check_Result( 'G', "Aggregate as formal G" );
|
|
|
Subtest_4(C760011_0.Create('H'));
|
Subtest_4(C760011_0.Create('H'));
|
Check_Result( 'H', "Function as formal H" );
|
Check_Result( 'H', "Function as formal H" );
|
|
|
Subtest_4(C760011_0.Non_Controlled'('I', (AFC with 'I',"IAGO")));
|
Subtest_4(C760011_0.Non_Controlled'('I', (AFC with 'I',"IAGO")));
|
Check_Result( 'I', "Aggregate as formal I" );
|
Check_Result( 'I', "Aggregate as formal I" );
|
|
|
Report.Result;
|
Report.Result;
|
|
|
end C760011;
|
end C760011;
|
|
|
