gcc/testsuite/ada/acats/tests/c7/c761010.a

   1 -- C761010.A
   2 --
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     The Ada Conformity Assessment Authority (ACAA) holds unlimited
   6 --     rights in the software and documentation contained herein. Unlimited
   7 --     rights are the same as those granted by the U.S. Government for older
   8 --     parts of the Ada Conformity Assessment Test Suite, and are defined
   9 --     in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
  10 --     intends to confer upon all recipients unlimited rights equal to those
  11 --     held by the ACAA. These rights include rights to use, duplicate,
  12 --     release or disclose the released technical data and computer software
  13 --     in whole or in part, in any manner and for any purpose whatsoever, and
  14 --     to have or permit others to do so.
  15 --
  16 --                                    DISCLAIMER
  17 --
  18 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  19 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  20 --     WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE
  21 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  22 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  23 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  24 --*
  25 --
  26 -- OBJECTIVE
  27 --     Check the requirements of the new 7.6(17.1/1) from Technical
  28 --     Corrigendum 1 (originally discussed as AI95-00083).
  29 --     This new paragraph requires that the initialization of an object with
  30 --     an aggregate does not involve calls to Adjust.
  31 --
  32 -- TEST DESCRIPTION
  33 --     We include several cases of initialization:
  34 --        - Explicit initialization of an object declared by an
  35 --          object declaration.
  36 --        - Explicit initialization of a heap object.
  37 --        - Default initialization of a record component.
  38 --        - Initialization of a formal parameter during a call.
  39 --        - Initialization of a formal parameter during a call with
  40 --          a defaulted parameter.
  41 --        - Lots of nested records, arrays, and pointers.
  42 --     In this test, Initialize should never be called, because we
  43 --     never declare a default-initialized controlled object (although
  44 --     we do declare default-initialized records containing controlled
  45 --     objects, with default expressions for the components).
  46 --     Adjust should never be called, because every initialization
  47 --     is via an aggregate.  Finalize is called, because the objects
  48 --     themselves need to be finalized.
  49 --     Thus, Initialize and Adjust call Failed.
  50 --     In some of the cases, these procedures will not yet be elaborated,
  51 --     anyway.
  52 --
  53 -- CHANGE HISTORY:
  54 --      29 JUN 1999   RAD   Initial Version
  55 --      23 SEP 1999   RLB   Improved comments, renamed, issued.
  56 --      10 APR 2000   RLB   Corrected errors in comments and text, fixed
  57 --                          discriminant error. Fixed so that Report.Test
  58 --                          is called before any Report.Failed call. Added
  59 --                          a marker so that the failed subtest can be
  60 --                          determined.
  61 --      26 APR 2000   RAD   Try to defeat optimizations.
  62 --      04 AUG 2000   RLB   Corrected error in Check_Equal.
  63 --      18 AUG 2000   RLB   Removed dubious main subprogram renames (see AI-172).
  64 --      19 JUL 2002   RLB   Fixed to avoid calling comment after Report.Result.
  65 --
  66 --!
  67
  68 with Ada; use Ada;
  69 with Report; use Report; pragma Elaborate_All(Report);
  70 with Ada.Finalization;
  71 package C761010_1 is
  72     pragma Elaborate_Body;
  73     function Square(X: Integer) return Integer;
  74 private
  75     type TC_Control is new Ada.Finalization.Limited_Controlled with null record;
  76     procedure Initialize (Object : in out TC_Control);
  77     procedure Finalize (Object : in out TC_Control);
  78     TC_Finalize_Called : Boolean := False;
  79 end C761010_1;
  80
  81 package body C761010_1 is
  82     function Square(X: Integer) return Integer is
  83     begin
  84         return X**2;
  85     end Square;
  86
  87     procedure Initialize (Object : in out TC_Control) is
  88     begin
  89         Test("C761010_1",
  90              "Check that Adjust is not called"
  91               & " when aggregates are used to initialize objects");
  92     end Initialize;
  93
  94     procedure Finalize (Object : in out TC_Control) is
  95     begin
  96         if not TC_Finalize_Called then
  97             Failed("Var_Strings Finalize never called");
  98         end if;
  99         Result;
 100     end Finalize;
 101
 102     TC_Test : TC_Control; -- Starts test; finalization ends test.
 103 end C761010_1;
 104
 105 with Ada.Finalization;
 106 package C761010_1.Var_Strings is
 107     type Var_String(<>) is private;
 108
 109     Some_String: constant Var_String;
 110
 111     function "=" (X, Y: Var_String) return Boolean;
 112
 113     procedure Check_Equal(X, Y: Var_String);
 114         -- Calls to this are used to defeat optimizations
 115         -- that might otherwise defeat the purpose of the
 116         -- test.  I'm talking about the optimization of removing
 117         -- unused controlled objects.
 118
 119 private
 120
 121     type String_Ptr is access constant String;
 122
 123     type Var_String(Length: Natural) is new Finalization.Controlled with
 124         record
 125             Comp_1: String_Ptr := new String'(2..Square(Length)-1 => 'x');
 126             Comp_2: String_Ptr(1..Length) := null;
 127             Comp_3: String(Length..Length) := (others => '.');
 128             TC_Lab: Character := '1';
 129         end record;
 130     procedure Initialize(X: in out Var_String);
 131     procedure Adjust(X: in out Var_String);
 132     procedure Finalize(X: in out Var_String);
 133
 134     Some_String: constant Var_String
 135       := (Finalization.Controlled with Length => 1,
 136           Comp_1 => null,
 137           Comp_2 => null,
 138           Comp_3 => "x",
 139           TC_Lab => 'A');
 140
 141     Another_String: constant Var_String
 142       := (Finalization.Controlled with Length => 10,
 143           Comp_1 => Some_String.Comp_2,
 144           Comp_2 => new String'("1234567890"),
 145           Comp_3 => "x",
 146           TC_Lab => 'B');
 147
 148 end C761010_1.Var_Strings;
 149
 150 package C761010_1.Var_Strings.Types is
 151
 152     type Ptr is access all Var_String;
 153     Ptr_Const: constant Ptr;
 154
 155     type Ptr_Arr is array(Positive range <>) of Ptr;
 156     Ptr_Arr_Const: constant Ptr_Arr;
 157
 158     type Ptr_Rec(N_Strings: Natural) is
 159         record
 160             Ptrs: Ptr_Arr(1..N_Strings);
 161         end record;
 162     Ptr_Rec_Const: constant Ptr_Rec;
 163
 164 private
 165
 166     Ptr_Const: constant Ptr := new Var_String'
 167       (Finalization.Controlled with
 168        Length => 1,
 169        Comp_1 => null,
 170        Comp_2 => null,
 171        Comp_3 => (others => ' '),
 172        TC_Lab => 'C');
 173
 174     Ptr_Arr_Const: constant Ptr_Arr :=
 175       (1 => new Var_String'
 176        (Finalization.Controlled with
 177         Length => 1,
 178         Comp_1 => new String'("abcdefghij"),
 179         Comp_2 => null,
 180         Comp_3 => (2..2 => ' '),
 181         TC_Lab => 'D'));
 182
 183     Ptr_Rec_Var: Ptr_Rec :=
 184       (3,
 185        (1..2 => null,
 186         3 => new Var_String'
 187         (Finalization.Controlled with
 188          Length => 2,
 189          Comp_1 => new String'("abcdefghij"),
 190          Comp_2 => null,
 191          Comp_3 => (2..2 => ' '),
 192          TC_Lab => 'E')));
 193
 194     Ptr_Rec_Const: constant Ptr_Rec :=
 195       (3,
 196        (1..2 => null,
 197         3 => new Var_String'
 198         (Finalization.Controlled with
 199          Length => 2,
 200          Comp_1 => new String'("abcdefghij"),
 201          Comp_2 => null,
 202          Comp_3 => (2..2 => ' '),
 203          TC_Lab => 'F')));
 204
 205     type Arr is array(Positive range <>) of Var_String(Length => 2);
 206
 207     Arr_Var: Arr :=
 208       (1 => (Finalization.Controlled with
 209          Length => 2,
 210          Comp_1 => new String'("abcdefghij"),
 211          Comp_2 => null,
 212          Comp_3 => (2..2 => ' '),
 213          TC_Lab => 'G'));
 214
 215     type Rec(N_Strings: Natural) is
 216         record
 217             Ptrs: Ptr_Rec(N_Strings);
 218             Strings: Arr(1..N_Strings) :=
 219               (others =>
 220                  (Finalization.Controlled with
 221                   Length => 2,
 222                   Comp_1 => new String'("abcdefghij"),
 223                   Comp_2 => null,
 224                   Comp_3 => (2..2 => ' '),
 225                   TC_Lab => 'H'));
 226         end record;
 227
 228     Default_Init_Rec_Var: Rec(N_Strings => 10);
 229     Empty_Default_Init_Rec_Var: Rec(N_Strings => 0);
 230
 231     Rec_Var: Rec(N_Strings => 2) :=
 232       (N_Strings => 2,
 233        Ptrs =>
 234          (2,
 235           (1..1 => null,
 236            2 => new Var_String'
 237            (Finalization.Controlled with
 238             Length => 2,
 239             Comp_1 => new String'("abcdefghij"),
 240             Comp_2 => null,
 241             Comp_3 => (2..2 => ' '),
 242             TC_Lab => 'J'))),
 243        Strings =>
 244          (1 =>
 245             (Finalization.Controlled with
 246              Length => 2,
 247              Comp_1 => new String'("abcdefghij"),
 248              Comp_2 => null,
 249              Comp_3 => (2..2 => ' '),
 250              TC_Lab => 'K'),
 251           others =>
 252             (Finalization.Controlled with
 253              Length => 2,
 254              Comp_1 => new String'("abcdefghij"),
 255              Comp_2 => null,
 256              Comp_3 => (2..2 => ' '),
 257              TC_Lab => 'L')));
 258
 259     procedure Check_Equal(X, Y: Rec);
 260
 261 end C761010_1.Var_Strings.Types;
 262
 263 package body C761010_1.Var_Strings.Types is
 264
 265     -- Check that parameter passing doesn't create new objects,
 266     -- and therefore doesn't need extra Adjusts or Finalizes.
 267
 268     procedure Check_Equal(X, Y: Rec) is
 269         -- We assume that the arguments should be equal.
 270         -- But we cannot assume that pointer values are the same.
 271     begin
 272         if X.N_Strings /= Y.N_Strings then
 273             Failed("Records should be equal (1)");
 274         else
 275             for I in 1 .. X.N_Strings loop
 276                 if X.Ptrs.Ptrs(I) /= Y.Ptrs.Ptrs(I) then
 277                     if X.Ptrs.Ptrs(I) = null or else
 278                        Y.Ptrs.Ptrs(I) = null or else
 279                        X.Ptrs.Ptrs(I).all /= Y.Ptrs.Ptrs(I).all then
 280                        Failed("Records should be equal (2)");
 281                     end if;
 282                 end if;
 283                 if X.Strings(I) /= Y.Strings(I) then
 284                     Failed("Records should be equal (3)");
 285                 end if;
 286             end loop;
 287         end if;
 288     end Check_Equal;
 289
 290     procedure My_Check_Equal
 291               (X: Rec := Rec_Var;
 292                Y: Rec :=
 293       (N_Strings => 2,
 294        Ptrs =>
 295          (2,
 296           (1..1 => null,
 297            2 => new Var_String'
 298            (Finalization.Controlled with
 299             Length => 2,
 300             Comp_1 => new String'("abcdefghij"),
 301             Comp_2 => null,
 302             Comp_3 => (2..2 => ' '),
 303             TC_Lab => 'M'))),
 304        Strings =>
 305          (1 =>
 306             (Finalization.Controlled with
 307              Length => 2,
 308              Comp_1 => new String'("abcdefghij"),
 309              Comp_2 => null,
 310              Comp_3 => (2..2 => ' '),
 311              TC_Lab => 'N'),
 312           others =>
 313             (Finalization.Controlled with
 314              Length => 2,
 315              Comp_1 => new String'("abcdefghij"),
 316              Comp_2 => null,
 317              Comp_3 => (2..2 => ' '),
 318              TC_Lab => 'O'))))
 319               renames Check_Equal;
 320 begin
 321
 322     My_Check_Equal;
 323
 324     Check_Equal(Rec_Var,
 325       (N_Strings => 2,
 326        Ptrs =>
 327          (2,
 328           (1..1 => null,
 329            2 => new Var_String'
 330            (Finalization.Controlled with
 331             Length => 2,
 332             Comp_1 => new String'("abcdefghij"),
 333             Comp_2 => null,
 334             Comp_3 => (2..2 => ' '),
 335             TC_Lab => 'P'))),
 336        Strings =>
 337          (1 =>
 338             (Finalization.Controlled with
 339              Length => 2,
 340              Comp_1 => new String'("abcdefghij"),
 341              Comp_2 => null,
 342              Comp_3 => (2..2 => ' '),
 343              TC_Lab => 'Q'),
 344           others =>
 345             (Finalization.Controlled with
 346              Length => 2,
 347              Comp_1 => new String'("abcdefghij"),
 348              Comp_2 => null,
 349              Comp_3 => (2..2 => ' '),
 350              TC_Lab => 'R'))));
 351
 352     -- Use the objects to avoid optimizations.
 353
 354     Check_Equal(Ptr_Const.all, Ptr_Const.all);
 355     Check_Equal(Ptr_Arr_Const(1).all, Ptr_Arr_Const(1).all);
 356     Check_Equal(Ptr_Rec_Const.Ptrs(Ptr_Rec_Const.N_Strings).all,
 357                 Ptr_Rec_Const.Ptrs(Ptr_Rec_Const.N_Strings).all);
 358     Check_Equal(Ptr_Rec_Var.Ptrs(Ptr_Rec_Var.N_Strings).all,
 359                 Ptr_Rec_Var.Ptrs(Ptr_Rec_Var.N_Strings).all);
 360
 361     if Report.Equal (3, 2) then
 362        -- Can't get here.
 363        Check_Equal (Arr_Var(1), Default_Init_Rec_Var.Strings(1));
 364        Check_Equal (Arr_Var(1), Empty_Default_Init_Rec_Var.Strings(1));
 365     end if;
 366
 367 end C761010_1.Var_Strings.Types;
 368
 369 with C761010_1.Var_Strings;
 370 with C761010_1.Var_Strings.Types;
 371 procedure C761010_1.Main is
 372 begin
 373     -- Report.Test is called by the elaboration of C761010_1, and
 374     -- Report.Result is called by the finalization of C761010_1.
 375     -- This will happen before any objects are created, and after any
 376     -- are finalized.
 377     null;
 378 end C761010_1.Main;
 379
 380 with C761010_1.Main;
 381 procedure C761010 is
 382 begin
 383     C761010_1.Main;
 384 end C761010;
 385
 386 package body C761010_1.Var_Strings is
 387
 388     Some_Error: exception;
 389
 390     procedure Initialize(X: in out Var_String) is
 391     begin
 392         Failed("Initialize should never be called");
 393         raise Some_Error;
 394     end Initialize;
 395
 396     procedure Adjust(X: in out Var_String) is
 397     begin
 398         Failed("Adjust should never be called - case " & X.TC_Lab);
 399         raise Some_Error;
 400     end Adjust;
 401
 402     procedure Finalize(X: in out Var_String) is
 403     begin
 404         Comment("Finalize called - case " & X.TC_Lab);
 405         C761010_1.TC_Finalize_Called := True;
 406     end Finalize;
 407
 408     function "=" (X, Y: Var_String) return Boolean is
 409         -- Don't check the TC_Lab component, but do check the contents of the
 410         -- access values.
 411     begin
 412         if X.Length /= Y.Length then
 413             return False;
 414         end if;
 415         if X.Comp_3 /= Y.Comp_3 then
 416             return False;
 417         end if;
 418         if X.Comp_1 /= Y.Comp_1 then
 419             -- Still OK if the values are the same.
 420             if X.Comp_1 = null or else
 421                Y.Comp_1 = null or else
 422                X.Comp_1.all /= Y.Comp_1.all then
 423                return False;
 424             --else OK.
 425             end if;
 426         end if;
 427         if X.Comp_2 /= Y.Comp_2 then
 428             -- Still OK if the values are the same.
 429             if X.Comp_2 = null or else
 430                Y.Comp_2 = null or else
 431                X.Comp_2.all /= Y.Comp_2.all then
 432                return False;
 433             end if;
 434         end if;
 435         return True;
 436     end "=";
 437
 438     procedure Check_Equal(X, Y: Var_String) is
 439     begin
 440         if X /= Y then
 441             Failed("Check_Equal of Var_String");
 442         end if;
 443     end Check_Equal;
 444
 445 begin
 446     Check_Equal(Another_String, Another_String);
 447 end C761010_1.Var_Strings;