-- C761010.A
|
-- C761010.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 WHATSOVER, INCLUDING THE CONDITIONS OF THE
|
-- WARRANTY AS TO ANY MATTER WHATSOVER, 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 the requirements of the new 7.6(17.1/1) from Technical
|
-- Check the requirements of the new 7.6(17.1/1) from Technical
|
-- Corrigendum 1 (originally discussed as AI95-00083).
|
-- Corrigendum 1 (originally discussed as AI95-00083).
|
-- This new paragraph requires that the initialization of an object with
|
-- This new paragraph requires that the initialization of an object with
|
-- an aggregate does not involve calls to Adjust.
|
-- an aggregate does not involve calls to Adjust.
|
--
|
--
|
-- TEST DESCRIPTION
|
-- TEST DESCRIPTION
|
-- We include several cases of initialization:
|
-- We include several cases of initialization:
|
-- - Explicit initialization of an object declared by an
|
-- - Explicit initialization of an object declared by an
|
-- object declaration.
|
-- object declaration.
|
-- - Explicit initialization of a heap object.
|
-- - Explicit initialization of a heap object.
|
-- - Default initialization of a record component.
|
-- - Default initialization of a record component.
|
-- - Initialization of a formal parameter during a call.
|
-- - Initialization of a formal parameter during a call.
|
-- - Initialization of a formal parameter during a call with
|
-- - Initialization of a formal parameter during a call with
|
-- a defaulted parameter.
|
-- a defaulted parameter.
|
-- - Lots of nested records, arrays, and pointers.
|
-- - Lots of nested records, arrays, and pointers.
|
-- In this test, Initialize should never be called, because we
|
-- In this test, Initialize should never be called, because we
|
-- never declare a default-initialized controlled object (although
|
-- never declare a default-initialized controlled object (although
|
-- we do declare default-initialized records containing controlled
|
-- we do declare default-initialized records containing controlled
|
-- objects, with default expressions for the components).
|
-- objects, with default expressions for the components).
|
-- Adjust should never be called, because every initialization
|
-- Adjust should never be called, because every initialization
|
-- is via an aggregate. Finalize is called, because the objects
|
-- is via an aggregate. Finalize is called, because the objects
|
-- themselves need to be finalized.
|
-- themselves need to be finalized.
|
-- Thus, Initialize and Adjust call Failed.
|
-- Thus, Initialize and Adjust call Failed.
|
-- In some of the cases, these procedures will not yet be elaborated,
|
-- In some of the cases, these procedures will not yet be elaborated,
|
-- anyway.
|
-- anyway.
|
--
|
--
|
-- CHANGE HISTORY:
|
-- CHANGE HISTORY:
|
-- 29 JUN 1999 RAD Initial Version
|
-- 29 JUN 1999 RAD Initial Version
|
-- 23 SEP 1999 RLB Improved comments, renamed, issued.
|
-- 23 SEP 1999 RLB Improved comments, renamed, issued.
|
-- 10 APR 2000 RLB Corrected errors in comments and text, fixed
|
-- 10 APR 2000 RLB Corrected errors in comments and text, fixed
|
-- discriminant error. Fixed so that Report.Test
|
-- discriminant error. Fixed so that Report.Test
|
-- is called before any Report.Failed call. Added
|
-- is called before any Report.Failed call. Added
|
-- a marker so that the failed subtest can be
|
-- a marker so that the failed subtest can be
|
-- determined.
|
-- determined.
|
-- 26 APR 2000 RAD Try to defeat optimizations.
|
-- 26 APR 2000 RAD Try to defeat optimizations.
|
-- 04 AUG 2000 RLB Corrected error in Check_Equal.
|
-- 04 AUG 2000 RLB Corrected error in Check_Equal.
|
-- 18 AUG 2000 RLB Removed dubious main subprogram renames (see AI-172).
|
-- 18 AUG 2000 RLB Removed dubious main subprogram renames (see AI-172).
|
-- 19 JUL 2002 RLB Fixed to avoid calling comment after Report.Result.
|
-- 19 JUL 2002 RLB Fixed to avoid calling comment after Report.Result.
|
--
|
--
|
--!
|
--!
|
|
|
with Ada; use Ada;
|
with Ada; use Ada;
|
with Report; use Report; pragma Elaborate_All(Report);
|
with Report; use Report; pragma Elaborate_All(Report);
|
with Ada.Finalization;
|
with Ada.Finalization;
|
package C761010_1 is
|
package C761010_1 is
|
pragma Elaborate_Body;
|
pragma Elaborate_Body;
|
function Square(X: Integer) return Integer;
|
function Square(X: Integer) return Integer;
|
private
|
private
|
type TC_Control is new Ada.Finalization.Limited_Controlled with null record;
|
type TC_Control is new Ada.Finalization.Limited_Controlled with null record;
|
procedure Initialize (Object : in out TC_Control);
|
procedure Initialize (Object : in out TC_Control);
|
procedure Finalize (Object : in out TC_Control);
|
procedure Finalize (Object : in out TC_Control);
|
TC_Finalize_Called : Boolean := False;
|
TC_Finalize_Called : Boolean := False;
|
end C761010_1;
|
end C761010_1;
|
|
|
package body C761010_1 is
|
package body C761010_1 is
|
function Square(X: Integer) return Integer is
|
function Square(X: Integer) return Integer is
|
begin
|
begin
|
return X**2;
|
return X**2;
|
end Square;
|
end Square;
|
|
|
procedure Initialize (Object : in out TC_Control) is
|
procedure Initialize (Object : in out TC_Control) is
|
begin
|
begin
|
Test("C761010_1",
|
Test("C761010_1",
|
"Check that Adjust is not called"
|
"Check that Adjust is not called"
|
& " when aggregates are used to initialize objects");
|
& " when aggregates are used to initialize objects");
|
end Initialize;
|
end Initialize;
|
|
|
procedure Finalize (Object : in out TC_Control) is
|
procedure Finalize (Object : in out TC_Control) is
|
begin
|
begin
|
if not TC_Finalize_Called then
|
if not TC_Finalize_Called then
|
Failed("Var_Strings Finalize never called");
|
Failed("Var_Strings Finalize never called");
|
end if;
|
end if;
|
Result;
|
Result;
|
end Finalize;
|
end Finalize;
|
|
|
TC_Test : TC_Control; -- Starts test; finalization ends test.
|
TC_Test : TC_Control; -- Starts test; finalization ends test.
|
end C761010_1;
|
end C761010_1;
|
|
|
with Ada.Finalization;
|
with Ada.Finalization;
|
package C761010_1.Var_Strings is
|
package C761010_1.Var_Strings is
|
type Var_String(<>) is private;
|
type Var_String(<>) is private;
|
|
|
Some_String: constant Var_String;
|
Some_String: constant Var_String;
|
|
|
function "=" (X, Y: Var_String) return Boolean;
|
function "=" (X, Y: Var_String) return Boolean;
|
|
|
procedure Check_Equal(X, Y: Var_String);
|
procedure Check_Equal(X, Y: Var_String);
|
-- Calls to this are used to defeat optimizations
|
-- Calls to this are used to defeat optimizations
|
-- that might otherwise defeat the purpose of the
|
-- that might otherwise defeat the purpose of the
|
-- test. I'm talking about the optimization of removing
|
-- test. I'm talking about the optimization of removing
|
-- unused controlled objects.
|
-- unused controlled objects.
|
|
|
private
|
private
|
|
|
type String_Ptr is access constant String;
|
type String_Ptr is access constant String;
|
|
|
type Var_String(Length: Natural) is new Finalization.Controlled with
|
type Var_String(Length: Natural) is new Finalization.Controlled with
|
record
|
record
|
Comp_1: String_Ptr := new String'(2..Square(Length)-1 => 'x');
|
Comp_1: String_Ptr := new String'(2..Square(Length)-1 => 'x');
|
Comp_2: String_Ptr(1..Length) := null;
|
Comp_2: String_Ptr(1..Length) := null;
|
Comp_3: String(Length..Length) := (others => '.');
|
Comp_3: String(Length..Length) := (others => '.');
|
TC_Lab: Character := '1';
|
TC_Lab: Character := '1';
|
end record;
|
end record;
|
procedure Initialize(X: in out Var_String);
|
procedure Initialize(X: in out Var_String);
|
procedure Adjust(X: in out Var_String);
|
procedure Adjust(X: in out Var_String);
|
procedure Finalize(X: in out Var_String);
|
procedure Finalize(X: in out Var_String);
|
|
|
Some_String: constant Var_String
|
Some_String: constant Var_String
|
:= (Finalization.Controlled with Length => 1,
|
:= (Finalization.Controlled with Length => 1,
|
Comp_1 => null,
|
Comp_1 => null,
|
Comp_2 => null,
|
Comp_2 => null,
|
Comp_3 => "x",
|
Comp_3 => "x",
|
TC_Lab => 'A');
|
TC_Lab => 'A');
|
|
|
Another_String: constant Var_String
|
Another_String: constant Var_String
|
:= (Finalization.Controlled with Length => 10,
|
:= (Finalization.Controlled with Length => 10,
|
Comp_1 => Some_String.Comp_2,
|
Comp_1 => Some_String.Comp_2,
|
Comp_2 => new String'("1234567890"),
|
Comp_2 => new String'("1234567890"),
|
Comp_3 => "x",
|
Comp_3 => "x",
|
TC_Lab => 'B');
|
TC_Lab => 'B');
|
|
|
end C761010_1.Var_Strings;
|
end C761010_1.Var_Strings;
|
|
|
package C761010_1.Var_Strings.Types is
|
package C761010_1.Var_Strings.Types is
|
|
|
type Ptr is access all Var_String;
|
type Ptr is access all Var_String;
|
Ptr_Const: constant Ptr;
|
Ptr_Const: constant Ptr;
|
|
|
type Ptr_Arr is array(Positive range <>) of Ptr;
|
type Ptr_Arr is array(Positive range <>) of Ptr;
|
Ptr_Arr_Const: constant Ptr_Arr;
|
Ptr_Arr_Const: constant Ptr_Arr;
|
|
|
type Ptr_Rec(N_Strings: Natural) is
|
type Ptr_Rec(N_Strings: Natural) is
|
record
|
record
|
Ptrs: Ptr_Arr(1..N_Strings);
|
Ptrs: Ptr_Arr(1..N_Strings);
|
end record;
|
end record;
|
Ptr_Rec_Const: constant Ptr_Rec;
|
Ptr_Rec_Const: constant Ptr_Rec;
|
|
|
private
|
private
|
|
|
Ptr_Const: constant Ptr := new Var_String'
|
Ptr_Const: constant Ptr := new Var_String'
|
(Finalization.Controlled with
|
(Finalization.Controlled with
|
Length => 1,
|
Length => 1,
|
Comp_1 => null,
|
Comp_1 => null,
|
Comp_2 => null,
|
Comp_2 => null,
|
Comp_3 => (others => ' '),
|
Comp_3 => (others => ' '),
|
TC_Lab => 'C');
|
TC_Lab => 'C');
|
|
|
Ptr_Arr_Const: constant Ptr_Arr :=
|
Ptr_Arr_Const: constant Ptr_Arr :=
|
(1 => new Var_String'
|
(1 => new Var_String'
|
(Finalization.Controlled with
|
(Finalization.Controlled with
|
Length => 1,
|
Length => 1,
|
Comp_1 => new String'("abcdefghij"),
|
Comp_1 => new String'("abcdefghij"),
|
Comp_2 => null,
|
Comp_2 => null,
|
Comp_3 => (2..2 => ' '),
|
Comp_3 => (2..2 => ' '),
|
TC_Lab => 'D'));
|
TC_Lab => 'D'));
|
|
|
Ptr_Rec_Var: Ptr_Rec :=
|
Ptr_Rec_Var: Ptr_Rec :=
|
(3,
|
(3,
|
(1..2 => null,
|
(1..2 => null,
|
3 => new Var_String'
|
3 => new Var_String'
|
(Finalization.Controlled with
|
(Finalization.Controlled with
|
Length => 2,
|
Length => 2,
|
Comp_1 => new String'("abcdefghij"),
|
Comp_1 => new String'("abcdefghij"),
|
Comp_2 => null,
|
Comp_2 => null,
|
Comp_3 => (2..2 => ' '),
|
Comp_3 => (2..2 => ' '),
|
TC_Lab => 'E')));
|
TC_Lab => 'E')));
|
|
|
Ptr_Rec_Const: constant Ptr_Rec :=
|
Ptr_Rec_Const: constant Ptr_Rec :=
|
(3,
|
(3,
|
(1..2 => null,
|
(1..2 => null,
|
3 => new Var_String'
|
3 => new Var_String'
|
(Finalization.Controlled with
|
(Finalization.Controlled with
|
Length => 2,
|
Length => 2,
|
Comp_1 => new String'("abcdefghij"),
|
Comp_1 => new String'("abcdefghij"),
|
Comp_2 => null,
|
Comp_2 => null,
|
Comp_3 => (2..2 => ' '),
|
Comp_3 => (2..2 => ' '),
|
TC_Lab => 'F')));
|
TC_Lab => 'F')));
|
|
|
type Arr is array(Positive range <>) of Var_String(Length => 2);
|
type Arr is array(Positive range <>) of Var_String(Length => 2);
|
|
|
Arr_Var: Arr :=
|
Arr_Var: Arr :=
|
(1 => (Finalization.Controlled with
|
(1 => (Finalization.Controlled with
|
Length => 2,
|
Length => 2,
|
Comp_1 => new String'("abcdefghij"),
|
Comp_1 => new String'("abcdefghij"),
|
Comp_2 => null,
|
Comp_2 => null,
|
Comp_3 => (2..2 => ' '),
|
Comp_3 => (2..2 => ' '),
|
TC_Lab => 'G'));
|
TC_Lab => 'G'));
|
|
|
type Rec(N_Strings: Natural) is
|
type Rec(N_Strings: Natural) is
|
record
|
record
|
Ptrs: Ptr_Rec(N_Strings);
|
Ptrs: Ptr_Rec(N_Strings);
|
Strings: Arr(1..N_Strings) :=
|
Strings: Arr(1..N_Strings) :=
|
(others =>
|
(others =>
|
(Finalization.Controlled with
|
(Finalization.Controlled with
|
Length => 2,
|
Length => 2,
|
Comp_1 => new String'("abcdefghij"),
|
Comp_1 => new String'("abcdefghij"),
|
Comp_2 => null,
|
Comp_2 => null,
|
Comp_3 => (2..2 => ' '),
|
Comp_3 => (2..2 => ' '),
|
TC_Lab => 'H'));
|
TC_Lab => 'H'));
|
end record;
|
end record;
|
|
|
Default_Init_Rec_Var: Rec(N_Strings => 10);
|
Default_Init_Rec_Var: Rec(N_Strings => 10);
|
Empty_Default_Init_Rec_Var: Rec(N_Strings => 0);
|
Empty_Default_Init_Rec_Var: Rec(N_Strings => 0);
|
|
|
Rec_Var: Rec(N_Strings => 2) :=
|
Rec_Var: Rec(N_Strings => 2) :=
|
(N_Strings => 2,
|
(N_Strings => 2,
|
Ptrs =>
|
Ptrs =>
|
(2,
|
(2,
|
(1..1 => null,
|
(1..1 => null,
|
2 => new Var_String'
|
2 => new Var_String'
|
(Finalization.Controlled with
|
(Finalization.Controlled with
|
Length => 2,
|
Length => 2,
|
Comp_1 => new String'("abcdefghij"),
|
Comp_1 => new String'("abcdefghij"),
|
Comp_2 => null,
|
Comp_2 => null,
|
Comp_3 => (2..2 => ' '),
|
Comp_3 => (2..2 => ' '),
|
TC_Lab => 'J'))),
|
TC_Lab => 'J'))),
|
Strings =>
|
Strings =>
|
(1 =>
|
(1 =>
|
(Finalization.Controlled with
|
(Finalization.Controlled with
|
Length => 2,
|
Length => 2,
|
Comp_1 => new String'("abcdefghij"),
|
Comp_1 => new String'("abcdefghij"),
|
Comp_2 => null,
|
Comp_2 => null,
|
Comp_3 => (2..2 => ' '),
|
Comp_3 => (2..2 => ' '),
|
TC_Lab => 'K'),
|
TC_Lab => 'K'),
|
others =>
|
others =>
|
(Finalization.Controlled with
|
(Finalization.Controlled with
|
Length => 2,
|
Length => 2,
|
Comp_1 => new String'("abcdefghij"),
|
Comp_1 => new String'("abcdefghij"),
|
Comp_2 => null,
|
Comp_2 => null,
|
Comp_3 => (2..2 => ' '),
|
Comp_3 => (2..2 => ' '),
|
TC_Lab => 'L')));
|
TC_Lab => 'L')));
|
|
|
procedure Check_Equal(X, Y: Rec);
|
procedure Check_Equal(X, Y: Rec);
|
|
|
end C761010_1.Var_Strings.Types;
|
end C761010_1.Var_Strings.Types;
|
|
|
package body C761010_1.Var_Strings.Types is
|
package body C761010_1.Var_Strings.Types is
|
|
|
-- Check that parameter passing doesn't create new objects,
|
-- Check that parameter passing doesn't create new objects,
|
-- and therefore doesn't need extra Adjusts or Finalizes.
|
-- and therefore doesn't need extra Adjusts or Finalizes.
|
|
|
procedure Check_Equal(X, Y: Rec) is
|
procedure Check_Equal(X, Y: Rec) is
|
-- We assume that the arguments should be equal.
|
-- We assume that the arguments should be equal.
|
-- But we cannot assume that pointer values are the same.
|
-- But we cannot assume that pointer values are the same.
|
begin
|
begin
|
if X.N_Strings /= Y.N_Strings then
|
if X.N_Strings /= Y.N_Strings then
|
Failed("Records should be equal (1)");
|
Failed("Records should be equal (1)");
|
else
|
else
|
for I in 1 .. X.N_Strings loop
|
for I in 1 .. X.N_Strings loop
|
if X.Ptrs.Ptrs(I) /= Y.Ptrs.Ptrs(I) then
|
if X.Ptrs.Ptrs(I) /= Y.Ptrs.Ptrs(I) then
|
if X.Ptrs.Ptrs(I) = null or else
|
if X.Ptrs.Ptrs(I) = null or else
|
Y.Ptrs.Ptrs(I) = null or else
|
Y.Ptrs.Ptrs(I) = null or else
|
X.Ptrs.Ptrs(I).all /= Y.Ptrs.Ptrs(I).all then
|
X.Ptrs.Ptrs(I).all /= Y.Ptrs.Ptrs(I).all then
|
Failed("Records should be equal (2)");
|
Failed("Records should be equal (2)");
|
end if;
|
end if;
|
end if;
|
end if;
|
if X.Strings(I) /= Y.Strings(I) then
|
if X.Strings(I) /= Y.Strings(I) then
|
Failed("Records should be equal (3)");
|
Failed("Records should be equal (3)");
|
end if;
|
end if;
|
end loop;
|
end loop;
|
end if;
|
end if;
|
end Check_Equal;
|
end Check_Equal;
|
|
|
procedure My_Check_Equal
|
procedure My_Check_Equal
|
(X: Rec := Rec_Var;
|
(X: Rec := Rec_Var;
|
Y: Rec :=
|
Y: Rec :=
|
(N_Strings => 2,
|
(N_Strings => 2,
|
Ptrs =>
|
Ptrs =>
|
(2,
|
(2,
|
(1..1 => null,
|
(1..1 => null,
|
2 => new Var_String'
|
2 => new Var_String'
|
(Finalization.Controlled with
|
(Finalization.Controlled with
|
Length => 2,
|
Length => 2,
|
Comp_1 => new String'("abcdefghij"),
|
Comp_1 => new String'("abcdefghij"),
|
Comp_2 => null,
|
Comp_2 => null,
|
Comp_3 => (2..2 => ' '),
|
Comp_3 => (2..2 => ' '),
|
TC_Lab => 'M'))),
|
TC_Lab => 'M'))),
|
Strings =>
|
Strings =>
|
(1 =>
|
(1 =>
|
(Finalization.Controlled with
|
(Finalization.Controlled with
|
Length => 2,
|
Length => 2,
|
Comp_1 => new String'("abcdefghij"),
|
Comp_1 => new String'("abcdefghij"),
|
Comp_2 => null,
|
Comp_2 => null,
|
Comp_3 => (2..2 => ' '),
|
Comp_3 => (2..2 => ' '),
|
TC_Lab => 'N'),
|
TC_Lab => 'N'),
|
others =>
|
others =>
|
(Finalization.Controlled with
|
(Finalization.Controlled with
|
Length => 2,
|
Length => 2,
|
Comp_1 => new String'("abcdefghij"),
|
Comp_1 => new String'("abcdefghij"),
|
Comp_2 => null,
|
Comp_2 => null,
|
Comp_3 => (2..2 => ' '),
|
Comp_3 => (2..2 => ' '),
|
TC_Lab => 'O'))))
|
TC_Lab => 'O'))))
|
renames Check_Equal;
|
renames Check_Equal;
|
begin
|
begin
|
|
|
My_Check_Equal;
|
My_Check_Equal;
|
|
|
Check_Equal(Rec_Var,
|
Check_Equal(Rec_Var,
|
(N_Strings => 2,
|
(N_Strings => 2,
|
Ptrs =>
|
Ptrs =>
|
(2,
|
(2,
|
(1..1 => null,
|
(1..1 => null,
|
2 => new Var_String'
|
2 => new Var_String'
|
(Finalization.Controlled with
|
(Finalization.Controlled with
|
Length => 2,
|
Length => 2,
|
Comp_1 => new String'("abcdefghij"),
|
Comp_1 => new String'("abcdefghij"),
|
Comp_2 => null,
|
Comp_2 => null,
|
Comp_3 => (2..2 => ' '),
|
Comp_3 => (2..2 => ' '),
|
TC_Lab => 'P'))),
|
TC_Lab => 'P'))),
|
Strings =>
|
Strings =>
|
(1 =>
|
(1 =>
|
(Finalization.Controlled with
|
(Finalization.Controlled with
|
Length => 2,
|
Length => 2,
|
Comp_1 => new String'("abcdefghij"),
|
Comp_1 => new String'("abcdefghij"),
|
Comp_2 => null,
|
Comp_2 => null,
|
Comp_3 => (2..2 => ' '),
|
Comp_3 => (2..2 => ' '),
|
TC_Lab => 'Q'),
|
TC_Lab => 'Q'),
|
others =>
|
others =>
|
(Finalization.Controlled with
|
(Finalization.Controlled with
|
Length => 2,
|
Length => 2,
|
Comp_1 => new String'("abcdefghij"),
|
Comp_1 => new String'("abcdefghij"),
|
Comp_2 => null,
|
Comp_2 => null,
|
Comp_3 => (2..2 => ' '),
|
Comp_3 => (2..2 => ' '),
|
TC_Lab => 'R'))));
|
TC_Lab => 'R'))));
|
|
|
-- Use the objects to avoid optimizations.
|
-- Use the objects to avoid optimizations.
|
|
|
Check_Equal(Ptr_Const.all, Ptr_Const.all);
|
Check_Equal(Ptr_Const.all, Ptr_Const.all);
|
Check_Equal(Ptr_Arr_Const(1).all, Ptr_Arr_Const(1).all);
|
Check_Equal(Ptr_Arr_Const(1).all, Ptr_Arr_Const(1).all);
|
Check_Equal(Ptr_Rec_Const.Ptrs(Ptr_Rec_Const.N_Strings).all,
|
Check_Equal(Ptr_Rec_Const.Ptrs(Ptr_Rec_Const.N_Strings).all,
|
Ptr_Rec_Const.Ptrs(Ptr_Rec_Const.N_Strings).all);
|
Ptr_Rec_Const.Ptrs(Ptr_Rec_Const.N_Strings).all);
|
Check_Equal(Ptr_Rec_Var.Ptrs(Ptr_Rec_Var.N_Strings).all,
|
Check_Equal(Ptr_Rec_Var.Ptrs(Ptr_Rec_Var.N_Strings).all,
|
Ptr_Rec_Var.Ptrs(Ptr_Rec_Var.N_Strings).all);
|
Ptr_Rec_Var.Ptrs(Ptr_Rec_Var.N_Strings).all);
|
|
|
if Report.Equal (3, 2) then
|
if Report.Equal (3, 2) then
|
-- Can't get here.
|
-- Can't get here.
|
Check_Equal (Arr_Var(1), Default_Init_Rec_Var.Strings(1));
|
Check_Equal (Arr_Var(1), Default_Init_Rec_Var.Strings(1));
|
Check_Equal (Arr_Var(1), Empty_Default_Init_Rec_Var.Strings(1));
|
Check_Equal (Arr_Var(1), Empty_Default_Init_Rec_Var.Strings(1));
|
end if;
|
end if;
|
|
|
end C761010_1.Var_Strings.Types;
|
end C761010_1.Var_Strings.Types;
|
|
|
with C761010_1.Var_Strings;
|
with C761010_1.Var_Strings;
|
with C761010_1.Var_Strings.Types;
|
with C761010_1.Var_Strings.Types;
|
procedure C761010_1.Main is
|
procedure C761010_1.Main is
|
begin
|
begin
|
-- Report.Test is called by the elaboration of C761010_1, and
|
-- Report.Test is called by the elaboration of C761010_1, and
|
-- Report.Result is called by the finalization of C761010_1.
|
-- Report.Result is called by the finalization of C761010_1.
|
-- This will happen before any objects are created, and after any
|
-- This will happen before any objects are created, and after any
|
-- are finalized.
|
-- are finalized.
|
null;
|
null;
|
end C761010_1.Main;
|
end C761010_1.Main;
|
|
|
with C761010_1.Main;
|
with C761010_1.Main;
|
procedure C761010 is
|
procedure C761010 is
|
begin
|
begin
|
C761010_1.Main;
|
C761010_1.Main;
|
end C761010;
|
end C761010;
|
|
|
package body C761010_1.Var_Strings is
|
package body C761010_1.Var_Strings is
|
|
|
Some_Error: exception;
|
Some_Error: exception;
|
|
|
procedure Initialize(X: in out Var_String) is
|
procedure Initialize(X: in out Var_String) is
|
begin
|
begin
|
Failed("Initialize should never be called");
|
Failed("Initialize should never be called");
|
raise Some_Error;
|
raise Some_Error;
|
end Initialize;
|
end Initialize;
|
|
|
procedure Adjust(X: in out Var_String) is
|
procedure Adjust(X: in out Var_String) is
|
begin
|
begin
|
Failed("Adjust should never be called - case " & X.TC_Lab);
|
Failed("Adjust should never be called - case " & X.TC_Lab);
|
raise Some_Error;
|
raise Some_Error;
|
end Adjust;
|
end Adjust;
|
|
|
procedure Finalize(X: in out Var_String) is
|
procedure Finalize(X: in out Var_String) is
|
begin
|
begin
|
Comment("Finalize called - case " & X.TC_Lab);
|
Comment("Finalize called - case " & X.TC_Lab);
|
C761010_1.TC_Finalize_Called := True;
|
C761010_1.TC_Finalize_Called := True;
|
end Finalize;
|
end Finalize;
|
|
|
function "=" (X, Y: Var_String) return Boolean is
|
function "=" (X, Y: Var_String) return Boolean is
|
-- Don't check the TC_Lab component, but do check the contents of the
|
-- Don't check the TC_Lab component, but do check the contents of the
|
-- access values.
|
-- access values.
|
begin
|
begin
|
if X.Length /= Y.Length then
|
if X.Length /= Y.Length then
|
return False;
|
return False;
|
end if;
|
end if;
|
if X.Comp_3 /= Y.Comp_3 then
|
if X.Comp_3 /= Y.Comp_3 then
|
return False;
|
return False;
|
end if;
|
end if;
|
if X.Comp_1 /= Y.Comp_1 then
|
if X.Comp_1 /= Y.Comp_1 then
|
-- Still OK if the values are the same.
|
-- Still OK if the values are the same.
|
if X.Comp_1 = null or else
|
if X.Comp_1 = null or else
|
Y.Comp_1 = null or else
|
Y.Comp_1 = null or else
|
X.Comp_1.all /= Y.Comp_1.all then
|
X.Comp_1.all /= Y.Comp_1.all then
|
return False;
|
return False;
|
--else OK.
|
--else OK.
|
end if;
|
end if;
|
end if;
|
end if;
|
if X.Comp_2 /= Y.Comp_2 then
|
if X.Comp_2 /= Y.Comp_2 then
|
-- Still OK if the values are the same.
|
-- Still OK if the values are the same.
|
if X.Comp_2 = null or else
|
if X.Comp_2 = null or else
|
Y.Comp_2 = null or else
|
Y.Comp_2 = null or else
|
X.Comp_2.all /= Y.Comp_2.all then
|
X.Comp_2.all /= Y.Comp_2.all then
|
return False;
|
return False;
|
end if;
|
end if;
|
end if;
|
end if;
|
return True;
|
return True;
|
end "=";
|
end "=";
|
|
|
procedure Check_Equal(X, Y: Var_String) is
|
procedure Check_Equal(X, Y: Var_String) is
|
begin
|
begin
|
if X /= Y then
|
if X /= Y then
|
Failed("Check_Equal of Var_String");
|
Failed("Check_Equal of Var_String");
|
end if;
|
end if;
|
end Check_Equal;
|
end Check_Equal;
|
|
|
begin
|
begin
|
Check_Equal(Another_String, Another_String);
|
Check_Equal(Another_String, Another_String);
|
end C761010_1.Var_Strings;
|
end C761010_1.Var_Strings;
|
|
|