diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c7/c761010.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c7/c761010.a | 447 |
1 files changed, 0 insertions, 447 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c7/c761010.a b/gcc/testsuite/ada/acats/tests/c7/c761010.a deleted file mode 100644 index 7784c6da517..00000000000 --- a/gcc/testsuite/ada/acats/tests/c7/c761010.a +++ /dev/null @@ -1,447 +0,0 @@ --- 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; |