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