| -- 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; |
